[mcclim-cvs] CVS mcclim
crhodes
crhodes at common-lisp.net
Mon Apr 10 09:48:40 UTC 2006
Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv20167
Modified Files:
graph-formatting.lisp mcclim.asd
Log Message:
Andy Hefner's code for keeping track of graph edges, and demo code for
draggable graphs. I've been running with this for about a year now, and
I'm bored of having to snip it out of diffs all the time.
(Also add the drag-and-drop-translator demo to demodemo)
--- /project/mcclim/cvsroot/mcclim/graph-formatting.lisp 2006/03/10 21:58:13 1.17
+++ /project/mcclim/cvsroot/mcclim/graph-formatting.lisp 2006/04/10 09:48:40 1.18
@@ -3,7 +3,7 @@
;;; Title: Graph Formatting
;;; Created: 2002-08-13
;;; License: LGPL (See file COPYING for details).
-;;; $Id: graph-formatting.lisp,v 1.17 2006/03/10 21:58:13 tmoore Exp $
+;;; $Id: graph-formatting.lisp,v 1.18 2006/04/10 09:48:40 crhodes Exp $
;;; ---------------------------------------------------------------------------
;;; (c) copyright 2002 by Gilbert Baumann
@@ -240,6 +240,8 @@
:initarg :graph-children
:initform nil
:accessor graph-node-children)
+ (edges-from :initform (make-hash-table))
+ (edges-to :initform (make-hash-table))
(object
:initarg :object
:reader graph-node-object)
@@ -405,6 +407,15 @@
(incf v within-generation-separation)))
(graph-root-nodes graph-output-record)))))))))))
+;;;; Edges
+
+(defclass standard-edge-output-record (standard-sequence-output-record)
+ ((stream)
+ (arc-drawer)
+ (arc-drawing-options)
+ (from-node :initarg :from-node)
+ (to-node :initarg :to-node)))
+
(defmethod layout-graph-nodes ((graph-output-record dag-graph-output-record)
stream arc-drawer arc-drawing-options)
@@ -526,7 +537,7 @@
(with-slots (root-nodes orientation) graph-output-record
(let ((hash (make-hash-table)))
(labels ((walk (node)
- (unless (gethash node hash)
+ (unless (gethash node hash)
(setf (gethash node hash) t)
(dolist (k (graph-node-children node))
(with-bounding-rectangle* (x1 y1 x2 y2) node
@@ -551,6 +562,55 @@
(walk k)))))
(map nil #'walk root-nodes)))))
+(defun layout-edges (graph node stream arc-drawer arc-drawing-options)
+ (dolist (k (graph-node-children node))
+ (layout-edge graph node k stream arc-drawer arc-drawing-options)))
+
+(defun ensure-edge-record (graph major-node minor-node)
+ (let ((edges-from (slot-value major-node 'edges-from))
+ (edges-to (slot-value minor-node 'edges-to)))
+ (assert (eq (gethash minor-node edges-from)
+ (gethash major-node edges-to)))
+ (or (gethash minor-node edges-from)
+ (let ((record (make-instance 'standard-edge-output-record
+ :from-node major-node :to-node minor-node)))
+ (setf (gethash minor-node edges-from) record
+ (gethash major-node edges-to) record)
+ (add-output-record record graph)
+ record))))
+
+(defun layout-edge-1 (graph major-node minor-node)
+ (let ((edge-record (ensure-edge-record graph major-node minor-node)))
+ (with-slots (stream arc-drawer arc-drawing-options) edge-record
+ (with-bounding-rectangle* (x1 y1 x2 y2) major-node
+ (with-bounding-rectangle* (u1 v1 u2 v2) minor-node
+ (clear-output-record edge-record) ;;; FIXME: repaint?
+ (letf (((stream-current-output-record stream) edge-record))
+ (ecase (slot-value graph 'orientation)
+ ((:horizontal)
+ (multiple-value-bind (from to) (if (< x1 u1)
+ (values x2 u1)
+ (values x1 u2))
+ (apply arc-drawer stream major-node minor-node
+ from (/ (+ y1 y2) 2)
+ to (/ (+ v1 v2) 2)
+ arc-drawing-options)))
+ ((:vertical)
+ (multiple-value-bind (from to) (if (< y1 v1)
+ (values y2 v1)
+ (values y1 v2))
+ (apply arc-drawer stream major-node minor-node
+ (/ (+ x1 x2) 2) from
+ (/ (+ u1 u2) 2) to
+ arc-drawing-options))))))))))
+
+(defun layout-edge (graph major-node minor-node stream arc-drawer arc-drawing-options)
+ (let ((edge-record (ensure-edge-record graph major-node minor-node)))
+ (setf (slot-value edge-record 'stream) stream
+ (slot-value edge-record 'arc-drawer) arc-drawer
+ (slot-value edge-record 'arc-drawing-options) arc-drawing-options)
+ (layout-edge-1 graph major-node minor-node)))
+
(defmethod layout-graph-edges ((graph standard-graph-output-record)
stream arc-drawer arc-drawing-options)
(with-slots (orientation) graph
@@ -562,26 +622,7 @@
(traverse-graph-nodes graph
(lambda (node children continuation)
(unless (eq node graph)
- (dolist (k children)
- (with-bounding-rectangle* (x1 y1 x2 y2) node
- (with-bounding-rectangle* (u1 v1 u2 v2) k
- (ecase orientation
- ((:horizontal)
- (multiple-value-bind (from to) (if (< x1 u1)
- (values x2 u1)
- (values x1 u2))
- (apply arc-drawer stream node k
- from (/ (+ y1 y2) 2)
- to (/ (+ v1 v2) 2)
- arc-drawing-options)))
- ((:vertical)
- (multiple-value-bind (from to) (if (< y1 v1)
- (values y2 v1)
- (values y1 v2))
- (apply arc-drawer stream node k
- (/ (+ x1 x2) 2) from
- (/ (+ u1 u2) 2) to
- arc-drawing-options))))))))
+ (layout-edges graph node stream arc-drawer arc-drawing-options))
(map nil continuation children))))))
(defmethod layout-graph-edges :around ((graph-output-record tree-graph-output-record)
--- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/29 10:43:37 1.16
+++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/04/10 09:48:40 1.17
@@ -315,7 +315,8 @@
#+clx (:file "gadget-test")
(:file "accepting-values")
(:file "method-browser")
- (:file "dragndrop-translator")))
+ (:file "dragndrop-translator")
+ (:file "draggable-graph")))
(:module "Goatee"
:components
((:file "goatee-test")))))
More information about the Mcclim-cvs
mailing list