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)