diff --git a/clim/graph-formatting.lisp b/clim/graph-formatting.lisp index 7932f30b46fa6099f6162b871977b7b59b2ff522..2c58ad9e1566cc74f5931b891418a3487b62c64e 100644 --- a/clim/graph-formatting.lisp +++ b/clim/graph-formatting.lisp @@ -1,11 +1,79 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- - +;; Allegro Common Lisp +;; -[Thu Nov 19 18:52:10 1992 by smh]- +;; +;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. +;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved. +;; +;; The software, data and information contained herein are proprietary +;; to, and comprise valuable trade secrets of, Franz, Inc. They are +;; given in confidence by Franz, Inc. pursuant to a written license +;; agreement, and may be stored and used only in accordance with the terms +;; of such license. +;; +;; Restricted Rights Legend +;; ------------------------ +;; Use, duplication, and disclosure of the software, data and information +;; contained herein by any agency, department or entity of the U.S. +;; Government are subject to restrictions of Restricted Rights for +;; Commercial Software developed at private expense as specified in FAR +;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as +;; applicable. +;; ;; $fiHeader: graph-formatting.lisp,v 1.18 92/11/06 18:59:45 cer Exp $ -(In-package :clim-internals) "Copyright (c) 1990, 1991, 1992 Symbolics Inc. All rights reserved." + +(In-package :clim-internals) + +#| + +This file is smh's quick hacked version for improved digraph layout. + +The basic strategy is that each node appearing more than once in the +graph is reliably assigned the maximum generation (ply) to which it +belongs, instead of depending on which occurence was encountered +first. Then `filler' output records are inserted to fill in missing +generations in any link. These fillers then participate in regular +node layout. This results in some unnecessarily squiggley lines, but +generally the behavior is reasonable. + +In graphs where a node with large "depth" is adjacent to a small depth +node with large fanout connections there is still the possibly that a +connector will overwrite a node. This could be fixed with one of +several strategies: Pad the short node's depth somehow, which moves a +lot of complexity onto the arc-drawing functions; or add a whole +generation of additional filler nodes, which would be laid out to +constrain the set of children of each parent to lie within that +parents breadth. I'd draw a picture of it weren't so tedious... + +The unnecessary squiggles could be fixed without too much work by +postprocessing the links, successively moving filler nodes when there +is room to line them up with one of it's connections in the adjacent +generation. + +Useful rfe: Enforce some limit on the maximum absolute value slope on +a connection. Extra inter-generation spacing would be adde to limit +the slope, since high-slope lines are the most visually confusion, +especially when many occur together. + +As an additional hack, the digraph grapher handles circularities by +creating a pair of `offpage' connectors. This isn't as elegant as +plotting circular paths backwards, but the current hack results in a +clear visual diagram with little effort. The new +offpage-connector-out-printer and offpage-connector-in-printer args to +format-graph-from-roots are something of a crock -- perhaps we can +avoid documenting them until better treatment of cyclic graphs is +devised. BTW, before this hack, a circular graph with no roots (i.e. +all nodes have at least one parent) would blow the stack, so don't +undertake a more ambitious fix for circular graphs without accounting +for this case. + +|# + + (defvar *graph-type-record-type-alist* nil) (defmacro define-graph-type (graph-type class) @@ -116,7 +184,7 @@ ;; The basic graph node output record class (defclass standard-graph-node-output-record (standard-sequence-output-record graph-node-output-record) - ((generation :accessor node-generation :initform 0) + ((generation :accessor graph-node-generation :initform 0) ;; The output records corresponding to this node's parents and children (node-children :accessor graph-node-children :initform nil) (node-parents :accessor graph-node-parents :initform nil)) @@ -175,7 +243,15 @@ *default-generation-separation*) (within-generation-separation *default-within-generation-separation*) - (move-cursor t)) + (move-cursor t) + ;; These `offpage' connector print functions + ;; should receive more useful id in addition + ;; to an identification number, such as the + ;; from and to nodes. + (offpage-connector-out-printer + #'(lambda (s n) (format s ">~d" n))) + (offpage-connector-in-printer + #'(lambda (s n) (format s "~d>" n)))) (declare (dynamic-extent object-printer inferior-producer)) (check-type cutoff-depth (or null integer)) (check-type generation-separation real) @@ -205,14 +281,17 @@ :within-generation-separation (coordinate within-generation-separation) :hash-table hash-table) - (generate-graph-nodes graph-record stream - root-objects object-printer inferior-producer - :duplicate-key duplicate-key - :duplicate-test duplicate-test) + (generate-graph-nodes + graph-record stream + root-objects object-printer inferior-producer + :duplicate-key duplicate-key + :duplicate-test duplicate-test + :offpage-connector-out-printer offpage-connector-out-printer + :offpage-connector-in-printer offpage-connector-in-printer) graph-record)))))) (unwind-protect (progn - (layout-graph-nodes graph-record stream) + (layout-graph-nodes graph-record stream arc-drawer arc-drawing-options) (layout-graph-edges graph-record stream arc-drawer arc-drawing-options)) ;; We're going to free the hash table as we exit, so make sure ;; there are no pointers to it @@ -269,8 +348,12 @@ (defmethod generate-graph-nodes ((graph tree-graph-output-record) stream root-objects object-printer inferior-producer - &key duplicate-key duplicate-test) - (declare (ignore duplicate-key duplicate-test)) + &key duplicate-key duplicate-test + offpage-connector-out-printer + offpage-connector-in-printer) + (declare (ignore duplicate-key duplicate-test + offpage-connector-out-printer + offpage-connector-in-printer)) (let ((cutoff-depth (slot-value graph 'cutoff-depth))) (labels ((format-node (object &optional (depth 1)) (when (and cutoff-depth (> depth cutoff-depth)) @@ -290,12 +373,13 @@ (dolist (child (graph-node-children this-node)) (setf (graph-node-parents child) (list this-node))) this-node)))) - (setf (graph-root-nodes graph) + (setf (graph-root-nodes graph) (map 'list #'format-node root-objects)))) graph) -(defmethod layout-graph-nodes ((graph tree-graph-output-record) stream) - (declare (ignore stream)) +(defmethod layout-graph-nodes ((graph tree-graph-output-record) + stream arc-drawer arc-drawing-options) + (declare (ignore stream arc-drawer arc-drawing-options)) (with-slots (root-nodes orientation center-nodes generation-separation within-generation-separation) graph (let ((start-x (coordinate 0)) @@ -414,71 +498,115 @@ ((n-generations :initform 0))) ;; For now, treat digraphs and DAGs the same way... +;; +;; With smh's hacks, cyclic digraphs get converted to dags automatically +;; with the insertion of `offpage' connectors. +;; This should be conditionalized, with options for also trying to thread +;; the cycle path neatly backwards -- but it's too tricky for right now. +;; Contact me for my thoughts on the matter. 19Nov92 -smh + (define-graph-type :directed-graph directed-graph-output-record) (define-graph-type :digraph directed-graph-output-record) (define-graph-type :directed-acyclic-graph directed-graph-output-record) (define-graph-type :dag directed-graph-output-record) -(defmethod generate-graph-nodes ((graph directed-graph-output-record) stream +;; These implement the dummy nodes inserted when an arc must span +;; more than one generation. +(defclass graph-node-filler-output-record (standard-graph-node-output-record) ()) +(defclass graph-node-filler-output-record-1 (standard-graph-node-output-record) ()) + +;; These implement the `offpage' connectors for cyclic graphs. +(defclass graph-node-connector-output-record + (standard-graph-node-output-record) + ((id :accessor connector-id :initarg :connector-id))) +(defclass graph-node-connector-in-output-record (graph-node-connector-output-record) ()) +(defclass graph-node-connector-out-output-record (graph-node-connector-output-record) ()) + +(defmethod generate-graph-nodes ((graph directed-graph-output-record) + stream root-objects object-printer inferior-producer - &key duplicate-key duplicate-test) + &key duplicate-key duplicate-test + offpage-connector-out-printer + offpage-connector-in-printer) (declare (dynamic-extent object-printer inferior-producer)) (declare (ignore duplicate-test)) (let ((hash-table (slot-value graph 'hash-table)) (cutoff-depth (slot-value graph 'cutoff-depth)) - (n-generations 0)) + (root-nodes '()) + (connectors-in '())) (labels ((inferior-mapper (function node) (map nil function (funcall inferior-producer node))) (new-node-function (parent-object parent-record child-object) (let ((child-record - (with-stream-cursor-position-saved (stream) - (with-new-output-record (stream 'standard-graph-node-output-record) - (funcall object-printer child-object stream))))) + (with-stream-cursor-position-saved (stream) + (with-new-output-record + (stream 'standard-graph-node-output-record) + (funcall object-printer child-object stream))))) + ;; This guarantees that the next phase will have at least one node + ;; from which to start. Otherwise the entire graph gets lost. + ;; If the first node isn't really a root, it will be deleted from + ;; the set of roots when the cycle is detected. + (when (null root-nodes) + (push child-record root-nodes)) (old-node-function parent-object parent-record child-object child-record))) (old-node-function (parent-object parent-record child-object child-record) (declare (ignore parent-object child-object)) - (let ((old-generation (node-generation child-record))) - ;; Set the generation of this node to 1 greater than the parent, - ;; and keep track of the highest generation encountered. - (maxf n-generations - (maxf (node-generation child-record) - (if parent-record - (1+ (node-generation parent-record)) - 0))) - ;; If the child-record got its generation adjusted, then we must - ;; adjust the generation-number of already-processed children, - ;; and their children, etc. - (unless (eql (node-generation child-record) old-generation) - (increment-generation child-record))) ;; Preserve the ordering of the nodes + ;; Generation numbers are now computed later -smh. (when parent-record (unless (member parent-record (graph-node-parents child-record)) (setf (graph-node-parents child-record) - (nconc (graph-node-parents child-record) - (list parent-record)))) + (nconc (graph-node-parents child-record) + (list parent-record)))) (unless (member child-record (graph-node-children parent-record)) (setf (graph-node-children parent-record) - (nconc (graph-node-children parent-record) - (list child-record))))) - child-record) - (increment-generation (record) - (let ((new-generation (1+ (node-generation record)))) - (dolist (child (graph-node-children record)) - ;; Remember which generation the child belonged to. - (let ((old-generation (node-generation child))) - (maxf n-generations - (maxf (node-generation child) - new-generation)) - ;; If it has changed, fix up the next generation recursively. - (unless (eql (node-generation child) old-generation) - (increment-generation child))))))) - (declare (dynamic-extent #'inferior-mapper #'increment-generation - #'new-node-function #'old-node-function)) + (nconc (graph-node-children parent-record) + (list child-record))))) + child-record)) + (declare (dynamic-extent #'inferior-mapper #'new-node-function #'old-node-function)) (traverse-graph root-objects #'inferior-mapper hash-table duplicate-key #'new-node-function #'old-node-function - cutoff-depth) - (setf (slot-value graph 'n-generations) n-generations)) + cutoff-depth)) + (map-node-table #'(lambda (key node) + (declare (ignore key)) + (when (and (typep node 'graph-node-output-record) + (null (graph-node-parents node))) + (pushnew node root-nodes))) + hash-table) + (labels ((break-cycles (node &optional path) + (do ((c (graph-node-children node) (cdr c))) + ((null c)) + (let ((child (car c))) + (if (member child path) + (let* ((id (connector-id + (or (find child connectors-in + :key #'(lambda (x) + (car (graph-node-children x)))) + (let* ((id (1+ (length connectors-in))) + (rec (with-new-output-record + (stream + 'graph-node-connector-in-output-record + nil :connector-id id) + (funcall offpage-connector-in-printer + stream id)))) + (push rec connectors-in) + (setf (graph-node-children rec) (list child)) + ;; What about ordering? + (push rec (graph-node-parents child)) + (setf root-nodes (delete child root-nodes)) + rec))))) + (setf (car c) + (with-new-output-record + (stream 'graph-node-connector-out-output-record nil + :connector-id id) + (funcall offpage-connector-out-printer stream id)))) + (break-cycles child (cons node path))))))) + (declare (dynamic-extent #'break-cycles)) + (map nil #'break-cycles (copy-list root-nodes))) + (setf (slot-value graph 'root-nodes) (nconc (nreverse connectors-in) + (nreverse root-nodes))) + #+never (let ((root-nodes nil)) (flet ((find-roots (key node) (declare (ignore key)) @@ -488,8 +616,47 @@ (declare (dynamic-extent #'find-roots)) (map-node-table #'find-roots hash-table)) (setf (graph-root-nodes graph) (nreverse root-nodes)))) + (compute-graph-effective-generations graph) + (add-graph-filler-output-records graph stream) graph) +(defmethod compute-graph-effective-generations ((graph directed-graph-output-record)) + (with-slots (n-generations root-nodes) graph + (labels ((traverse (node ply) + (with-slots (generation) node + (maxf generation ply) + (let ((children (graph-node-children node)) + (gen1 (1+ generation))) + (if children ;Save time -- do one or the other. + (dolist (child children) + (traverse child gen1)) + (maxf n-generations generation)))))) + (dolist (root root-nodes) + (traverse root 0))))) + +(defmethod add-graph-filler-output-records ((graph directed-graph-output-record) stream) + (with-slots (root-nodes) graph + (labels ((traverse (node) + (let* ((gen (graph-node-generation node)) + (gen1 (1+ gen)) + (children (graph-node-children node))) + (do ((c children (cdr c))) + ((null c)) + (let ((child (car c))) + (if (> (graph-node-generation child) gen1) + (progn + (let ((filler (with-new-output-record + (stream 'graph-node-filler-output-record) + nil))) + (setf (graph-node-children filler) (list child) + (graph-node-parents filler) (list node) + (car c) filler + (graph-node-generation filler) gen1) + (traverse filler))) + (traverse child))))))) + (dolist (root root-nodes) + (traverse root))))) + (defstruct (generation-descriptor (:conc-name generation-) (:type list)) generation ;generation number (breadth 0) ;sum of breadth of all nodes in this generation @@ -502,8 +669,8 @@ (edge-breadth-separation nil) ;margin whitespace (touched nil)) ;if T, use inner breadth separation -(defmethod layout-graph-nodes ((graph directed-graph-output-record) stream) - (declare (ignore stream)) +(defmethod layout-graph-nodes ((graph directed-graph-output-record) + stream arc-drawer arc-drawing-options) (with-slots (orientation center-nodes generation-separation within-generation-separation n-generations root-nodes hash-table) graph @@ -543,13 +710,45 @@ ;; Determine the breadth and depth of each generation (flet ((collect-node-size (p ph child-node) (declare (ignore p ph)) - (let ((descr (assoc (node-generation child-node) + (let ((descr (assoc (graph-node-generation child-node) generation-descriptors))) (incf (generation-size descr)) (incf (generation-breadth descr) (breadth child-node)) (maxf (generation-depth descr) (depth child-node))))) (declare (dynamic-extent #'collect-node-size)) (traverse #'collect-node-size)) + + ;; Replace all filler nodes, giving them the max depth in their generation. + (labels + ((replace-filler-nodes (parent) + (let ((children (graph-node-children parent))) + (do ((c children (cdr c))) + ((null c)) + (let ((node (car c))) + (when (typep node 'graph-node-filler-output-record) + (delete-output-record node graph) + (let* ((depth (generation-depth + (assoc (graph-node-generation node) + generation-descriptors))) + (new (with-output-to-output-record + (stream 'graph-node-filler-output-record-1) + (call-arc-drawer stream arc-drawer + ;;--- Should be from- and to-node + nil nil + parent 0 0 + node depth 0 + arc-drawing-options))) + (child (car (graph-node-children node)))) + (setf (graph-node-generation new) (graph-node-generation node) + (graph-node-children new) (graph-node-children node) + (graph-node-parents new) (graph-node-parents node) + (graph-node-parents child) (list new) + (car c) new) + (add-output-record new graph))))) + (map nil #'replace-filler-nodes children)))) + (declare (dynamic-extent #'replace-filler-nodes)) + (map nil #'replace-filler-nodes root-nodes)) + ;; Determine max-breadth and starting-depth (loop with depth-so-far = start-depth for descr in generation-descriptors do @@ -570,7 +769,7 @@ ;; Place nodes (flet ((place-node (p ph child-node) (declare (ignore p ph)) - (let ((descr (assoc (node-generation child-node) + (let ((descr (assoc (graph-node-generation child-node) generation-descriptors))) (incf (generation-breadth-so-far descr) (if (generation-touched descr) @@ -675,7 +874,7 @@ (funcall new-node-function parent-object parent-hashval object))) (setf (get-node-table (funcall key object) hash-table) object-hashval) (when max-depth (decf max-depth)) - (unless (eq max-depth 0) + (unless (eql max-depth 0) (flet ((traverse1 (child-object) (let ((child-key (funcall key child-object))) (multiple-value-bind (child-hashval found)