[mcclim-devel] New version of :dag graph-formatting patch
Robert P. Goldman
rpgoldman at sift.info
Tue Jul 26 02:40:15 UTC 2005
This new version provides a layout-graph-nodes method for the :dag
graph type. It also makes the code conform better to the
specification of :duplicate-test and :duplicate-key argument handling
in the CLIM spec.
I would be very grateful if people would play with my dag formatting,
but realize that it's a long shot if anyone else needs it right now[1],
since it only handles merge-duplicates for the acyclic case. Maybe
I'll tackle :digraph if I can get this working and accepted!
But even if you don't need the :dag graph type, I'd be grateful if you
were to test the code to make sure it doesn't break any of your
existing uses of the tree type, and I know there must be SOME people
using that...
Cheers,
R
Footnotes:
[1] Although I think if you were to browse a CLOS inheritance
hierarchy, you might want to be able to merge duplicates, and I think
that would have to be acyclic...
Index: graph-formatting.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/graph-formatting.lisp,v
retrieving revision 1.15
diff -u -F^(def -r1.15 graph-formatting.lisp
--- graph-formatting.lisp 13 May 2005 03:00:25 -0000 1.15
+++ graph-formatting.lisp 26 Jul 2005 02:34:20 -0000
@@ -163,8 +163,10 @@ (defun format-graph-from-roots (root-obj
#'cont
(find-graph-type graph-type)
nil
- :hash-table (make-hash-table :test duplicate-test)
- graph-options))))
+ ;; moved to local variable... [2005/07/25:rpg]
+ ;; :hash-table (make-hash-table :test duplicate-test)
+ graph-options
+ ))))
(setf (output-record-position graph-output-record)
(values cursor-old-x cursor-old-y))
(with-output-recording-options (stream :draw t :record nil)
@@ -182,35 +184,40 @@ (defun format-graph-from-root (root &res
(defclass standard-graph-output-record (graph-output-record
standard-sequence-output-record)
- ((orientation
- :initarg :orientation
- :initform :horizontal)
- (center-nodes
- :initarg :center-nodes
- :initform nil)
- (cutoff-depth
- :initarg :cutoff-depth
- :initform nil)
- (merge-duplicates
- :initarg :merge-duplicates
- :initform nil)
- (generation-separation
- :initarg :generation-separation
- :initform '(4 :character))
- (within-generation-separation
- :initarg :within-generation-separation
- :initform '(1/2 :line))
- (hash-table
- :initarg :hash-table
- :initform nil)
- (root-nodes
- :accessor graph-root-nodes) ))
+ ((orientation
+ :initarg :orientation
+ :initform :horizontal)
+ (center-nodes
+ :initarg :center-nodes
+ :initform nil)
+ (cutoff-depth
+ :initarg :cutoff-depth
+ :initform nil)
+ (merge-duplicates
+ :initarg :merge-duplicates
+ :initform nil)
+ (generation-separation
+ :initarg :generation-separation
+ :initform '(4 :character))
+ (within-generation-separation
+ :initarg :within-generation-separation
+ :initform '(1/2 :line))
+ ;; removed HASH-TABLE slot and stuffed it into
+ ;; GENERATE-GRAPH-NODES method definition [2005/07/25:rpg]
+ (root-nodes
+ :accessor graph-root-nodes)
+ ))
(defclass tree-graph-output-record (standard-graph-output-record)
- ())
+ ())
+
+(defmethod initialize-instance :after ((obj tree-graph-output-record) &key merge-duplicates)
+ (when merge-duplicates
+ (error "Cannot use a TREE layout for graphs while merging duplicates.")))
(defclass dag-graph-output-record (standard-graph-output-record)
- ())
+ (
+ ))
(defclass digraph-graph-output-record (standard-graph-output-record)
())
@@ -242,41 +249,57 @@ (defmethod generate-graph-nodes ((graph-
stream root-objects
object-printer inferior-producer
&key duplicate-key duplicate-test)
- (declare (ignore duplicate-test))
- (with-slots (cutoff-depth merge-duplicates hash-table) graph-output-record
- (labels
- ((traverse-objects (node objects depth)
- (unless (and cutoff-depth (>= depth cutoff-depth))
- (remove nil
- (map 'list
- (lambda (child)
- (let* ((key (funcall duplicate-key child))
- (child-node (and merge-duplicates
- (gethash key hash-table))))
- (cond (child-node
- (when node
- (push node (graph-node-parents child-node)))
- child-node)
- (t
- (let ((child-node
- (with-output-to-output-record
- (stream 'standard-graph-node-output-record new-node
- :object child)
- (funcall object-printer child stream))))
- (when merge-duplicates
- (setf (gethash key hash-table) child-node))
- (when node
- (push node (graph-node-parents child-node)))
- (setf (graph-node-children child-node)
- (traverse-objects child-node
- (funcall inferior-producer child)
- (+ depth 1)))
- child-node)))))
- objects)))))
- ;;
- (setf (graph-root-nodes graph-output-record)
- (traverse-objects nil root-objects 0))
- (values))))
+ (with-slots (cutoff-depth merge-duplicates) graph-output-record
+ (let* ((hash-table (when (and merge-duplicates (member duplicate-test (list #'eq #'eql #'equal #'equalp)))
+ (make-hash-table :test duplicate-test)))
+ node-list
+ (hashed hash-table))
+ (labels
+ ((previous-node (obj)
+ ;; is there a previous node for obj? if so, return it.
+ (when merge-duplicates
+ (if hashed
+ (locally (declare (type hash-table hash-table))
+ (gethash obj hash-table))
+ (cdr (assoc obj node-list :test duplicate-test)))))
+ ((setf previous-node) (val obj)
+ (if hashed
+ (locally (declare (type hash-table hash-table))
+ (setf (gethash obj hash-table) val))
+ (setf node-list (push (cons obj val) node-list))))
+ (traverse-objects (node objects depth)
+ (unless (and cutoff-depth (>= depth cutoff-depth))
+ (remove nil
+ (map 'list
+ (lambda (child)
+ (let* ((key (funcall duplicate-key child))
+ (child-node (previous-node key)))
+ (cond (child-node
+ (when node
+ (push node (graph-node-parents child-node)))
+ child-node)
+ (t
+ (let ((child-node
+ (with-output-to-output-record
+ (stream 'standard-graph-node-output-record new-node
+ :object child)
+ (funcall object-printer child stream))))
+ (when merge-duplicates
+ (setf (previous-node key) child-node)
+ ;; (setf (gethash key hash-table) child-node)
+ )
+ (when node
+ (push node (graph-node-parents child-node)))
+ (setf (graph-node-children child-node)
+ (traverse-objects child-node
+ (funcall inferior-producer child)
+ (+ depth 1)))
+ child-node)))))
+ objects)))))
+ ;;
+ (setf (graph-root-nodes graph-output-record)
+ (traverse-objects nil root-objects 0))
+ (values)))))
(defun traverse-graph-nodes (graph continuation)
;; continuation: node x children x cont -> some value
@@ -300,6 +323,8 @@ (defmethod layout-graph-nodes ((graph-ou
(:horizontal :vertical)
(:vertical :horizontal))))
(generation-separation (parse-space stream generation-separation orientation)))
+ ;; generation sizes is an adjustable array that tracks the major
+ ;; dimension of each of the generations [2005/07/18:rpg]
(let ((generation-sizes (make-array 10 :adjustable t :initial-element 0)))
(labels ((node-major-dimension (node)
(if (eq orientation :vertical)
@@ -309,6 +334,9 @@ (defmethod layout-graph-nodes ((graph-ou
(if (eq orientation :vertical)
(bounding-rectangle-width node)
(bounding-rectangle-height node)))
+ ;; WALK returns a node minor dimension for the node,
+ ;; AFAICT, allowing space for that node's children
+ ;; along the minor dimension. [2005/07/18:rpg]
(walk (node depth)
(unless (graph-node-minor-size node)
(when (>= depth (length generation-sizes))
@@ -367,6 +395,121 @@ (defmethod layout-graph-nodes ((graph-ou
(unless (null rest)
(incf v within-generation-separation)))
(graph-root-nodes graph-output-record)))))))))))
+
+
+(defmethod layout-graph-nodes ((graph-output-record dag-graph-output-record)
+ stream arc-drawer arc-drawing-options)
+ "This is a first shot at a DAG layout. First does a TOPO sort that associates
+each node with a depth, then lays out by depth. Tries to reuse a maximum of the
+tree graph layout code.
+PRECONDITION: This code assumes that we have generated only nodes up to the
+cutoff-depth. GENERATE-GRAPH-NODES seems to obey this precondition."
+ (declare (ignore arc-drawer arc-drawing-options))
+ (with-slots (orientation center-nodes generation-separation within-generation-separation root-nodes
+ merge-duplicates) graph-output-record
+ ;; this code is snarly enough, handling merge-duplicates. If
+ ;; you're not merging duplicates, you're out of luck, at least for
+ ;; now... [2005/07/18:rpg]
+ (unless merge-duplicates
+ (cerror "Set to T and continue?" "DAG graph-layout type only supports merge-duplicates to be T")
+ (setf merge-duplicates t))
+
+ (check-type orientation (member :horizontal :vertical)) ;xxx move to init.-inst.
+
+ ;; here major dimension is the dimension in which we grow the
+ ;; tree.
+ (let ((within-generation-separation (parse-space stream within-generation-separation
+ (case orientation
+ (:horizontal :vertical)
+ (:vertical :horizontal))))
+ (generation-separation (parse-space stream generation-separation orientation)))
+ ;; generation sizes is an adjustable array that tracks the major
+ ;; dimension of each of the generations [2005/07/18:rpg]
+ (let ((generation-sizes (make-array 10 :adjustable t :initial-element 0))
+ (visited (make-hash-table :test #'eq))
+ (parent-hash (make-hash-table :test #'eq)))
+ (labels ((node-major-dimension (node)
+ (if (eq orientation :vertical)
+ (bounding-rectangle-height node)
+ (bounding-rectangle-width node)))
+ (node-minor-dimension (node)
+ (if (eq orientation :vertical)
+ (bounding-rectangle-width node)
+ (bounding-rectangle-height node)))
+ ;; WALK returns a node minor dimension for the node,
+ ;; AFAICT, allowing space for that node's children
+ ;; along the minor dimension. [2005/07/18:rpg]
+ (walk (node depth &optional parent)
+ (unless (gethash node visited)
+ (setf (gethash node visited) depth)
+ (when parent
+ (setf (gethash node parent-hash) parent))
+ (unless (graph-node-minor-size node)
+ (when (>= depth (length generation-sizes))
+ (setf generation-sizes (adjust-array generation-sizes (ceiling (* depth 1.2))
+ :initial-element 0)))
+ (setf (aref generation-sizes depth)
+ (max (aref generation-sizes depth) (node-major-dimension node)))
+ (setf (graph-node-minor-size node) 0)
+ (max (node-minor-dimension node)
+ (setf (graph-node-minor-size node)
+ (let ((sum 0) (n 0))
+ (map nil (lambda (child)
+ (let ((x (walk child (+ depth 1) node)))
+ (when x
+ (incf sum x)
+ (incf n))))
+ (graph-node-children node))
+ (+ sum
+ (* (max 0 (- n 1)) within-generation-separation)))))))))
+ (map nil #'(lambda (x) (walk x 0)) root-nodes)
+ (let ((hash (make-hash-table :test #'eq)))
+ (labels ((foo (node majors u0 v0)
+ (cond ((gethash node hash)
+ v0)
+ (t
+ (setf (gethash node hash) t)
+ (let ((d (- (node-minor-dimension node)
+ (graph-node-minor-size node))))
+ (let ((v (+ v0 (/ (min 0 d) -2))))
+ (setf (output-record-position node)
+ (if (eq orientation :vertical)
+ (transform-position (medium-transformation stream) v u0)
+ (transform-position (medium-transformation stream) u0 v)))
+ (add-output-record node graph-output-record))
+ ;;
+ (let ((u (+ u0 (car majors)))
+ (v (+ v0 (max 0 (/ d 2))))
+ (firstp t))
+ (map nil (lambda (q)
+ (unless (gethash q hash)
+ (if firstp
+ (setf firstp nil)
+ (incf v within-generation-separation))
+ (setf v (foo q (cdr majors)
+ u v))))
+ ;; when computing the sizes, to
+ ;; make the tree-style layout
+ ;; work, we have to have each
+ ;; node have a unique
+ ;; parent. [2005/07/18:rpg]
+ (remove-if-not #'(lambda (x) (eq (gethash x parent-hash) node))
+ (graph-node-children node))))
+ ;;
+ (+ v0 (max (node-minor-dimension node)
+ (graph-node-minor-size node))))))))
+ ;;
+ (let ((majors (mapcar (lambda (x) (+ x generation-separation))
+ (coerce generation-sizes 'list))))
+ (let ((u (+ 0 (car majors)))
+ (v 0))
+ (maplist (lambda (rest)
+ (setf v (foo (car rest) majors u v))
+ (unless (null rest)
+ (incf v within-generation-separation)))
+ (graph-root-nodes graph-output-record)))))))))))
+
+
#+ignore
(defmethod layout-graph-edges ((graph-output-record standard-graph-output-record)
More information about the mcclim-devel
mailing list