META DISCUSSION:
Are the maintainers of McCLIM OK with me rooting around in the code for graph formatting? I readily confess I'm not a serious graphics hacker, but I need to debug a lot of code that uses DAGs, and I'd like to see this pushed along... Does anyone have the time and patience to give patches like this a cursory once-over and either hurl abuse or commit them?
NOTES ON CODE:
I have had a first shot at making a graph layout method for DAGs. This is a little brittle, but since if you try to format-graph-from-roots with :dag as the :graph-type, it will just crash McCLIM, maybe that's not too bad ;-)
Rather than trying to build a new graph layout method ab initio, I have simply adapted Gilbert's original code. As far as I could tell, when laying out one level of the graph, Gilbert's code would look ahead, and try to allocate space for the next layer. My code keeps that structure, but just lets nodes go to the first place where the fit, rather than thinking hard about who their "tree parent" should be.
Ugliness:
1. Interested code readers will see some ugliness in the handling of the DUPLICATE-TEST and DUPLICATE-KEY arguments to FORMAT-GRAPH-FROM-ROOTS. For some reason, these are pulled out of the argument list and thrown away rather than being given as initargs to the GRAPH-OUTPUT-RECORD that's created by FORMAT-GRAPH-FROM-ROOTS. I'm not sure why this was done.
Since I'm ignorant about this code, instead of arrogating it to myself to add them to the STANDARD-GRAPH-OUTPUT-RECORD, I simply added DUPLICATE-TEST and DUPLICATE-KEY slots to the DAG-GRAPH-OUTPUT-RECORD type. Unless someone can see a reason why not, though, I would argue for pushing them up to STANDARD-GRAPH-OUTPUT-RECORD. (Or possibly doing a minor refactoring that would split STANDARD-GRAPH-OUTPUT-RECORD into TREE-GRAPH-OUTPUT-RECORD and NON-TREE-GRAPH-OUTPUT record, only the latter being allowed to have DUPLICATE-TEST and DUPLICATE-KEY.)
Because I didn't want to muck with the current graph-output-record classes, I ended up with some ugliness in FORMAT-GRAPH-FROM-ROOTS argument handling. This could easily be removed, if the above change is accepted.
2. Per my earlier email, I arrogated it to myself to limit the set of permissible values for the duplicate-test keyword arg of FORMAT-GRAPH-FROM-ROOTS. I think that this is reasonable, but it arguably violates the CLIM spec. On the other hand, I think that McCLIM already does this --- there are some comments by GB to that effect at the head of hte file...
3. There's a little oddity in Gilbert's code where he seems to take a vector data structure and wham it into a list in order to be able to use MAP over it. I'm inclined to whack it into an array loop, but if someone thinks that would be really wrong, I'd like to hear.
Cheers, Robert
Patch file:
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 18 Jul 2005 22:41:54 -0000 @@ -164,7 +164,11 @@ (defun format-graph-from-roots (root-obj (find-graph-type graph-type) nil :hash-table (make-hash-table :test duplicate-test) - graph-options)))) + (append + (when (and (eq graph-type :dag) merge-duplicates) + (list :duplicate-test duplicate-test + :duplicate-key duplicate-key)) + 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) @@ -210,7 +214,17 @@ (defclass tree-graph-output-record (stan ())
(defclass dag-graph-output-record (standard-graph-output-record) - ()) + ((duplicate-key + :initarg :duplicate-key + :reader duplicate-key + ) + (duplicate-test + :initarg :duplicate-test + :reader duplicate-test + :documentation "The DUPLICATE-TEST of a DAG-GRAPH-OUTPUT-RECORD +should be one of the :TEST values acceptable to MAKE-HASH-TABLE." + ) + ))
(defclass digraph-graph-output-record (standard-graph-output-record) ()) @@ -300,6 +314,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 +325,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 +386,126 @@ (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 + duplicate-key + 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 (duplicate-test graph-output-record))) + (parent-hash (make-hash-table :test (duplicate-test graph-output-record)))) + (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) + ;; the following is possibly unnecessary --- it + ;; would only be a win if the key-value is + ;; expensive to compute. [2005/07/18:rpg] + (let ((key-value (funcall duplicate-key node))) + (unless (gethash key-value visited) + (setf (gethash key-value visited) depth) + (when parent + (setf (gethash key-value 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)