;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; Base: 10 -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The Garnet User Interface Development Environment. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This code was written as part of the Garnet project at ;;; ;;; Carnegie Mellon University, and has been placed in the public ;;; ;;; domain. If you are using this code or any part of Garnet, ;;; ;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; aggregraphs.lisp ;;; ;;; Written by A. Bryan Loyall ;;; Winter 1990-1991 #| ====================================================================== Change log: 6/01/93 Andrew Mickish - Added some macros 4/15/92 Martin Sjolin - Add #-cmu flags before :rehash-size 2.0 03/25/92 Andrew Mickish - Get-Values ---> G-Value 12/13/91 Dario Giuse - Removed (declare (ignore dummy)) from :add-node of aggregraph. 11/27/91 Andrew Mickish - Added args parameter to initialize method so that an aggregraph can be a part of an aggregadget 4/01/91 Bryan Loyall - Added cache for :add-node method to make multiple node additions to the same set of parents and children faster. 4/01/91 Bryan Loyall - Changed find-good-y-near-desired-y to avoid spaces above the :top of the graph 3/13/91 Andrew Mickish - Added lines to :add-node that will put the new node in the hash table in :source->graph-node-table 3/12/91 Andrew Mickish - :x-dist-between-nodes ==> :h-spacing, :y-dist-between-nodes ==> :v-spacing 3/11/91 Andrew Mickish - Merged into Opal/Aggregadgets format 3/09/91 Bryan Loyall - Created ====================================================================== |# ;; requires the file "rectangle-conflict-object.lisp" to be loaded. (in-package "OPAL") (eval-when (eval load compile) (export '(AGGREGRAPH AGGREGRAPH-NODE-PROTOTYPE AGGREGRAPH-LINK-PROTOTYPE LAYOUT-TREE)) (export '(source-to-graph-node remove-root make-root add-node layout-graph))) (defmacro Source-To-Graph-Node (graph source) `(let ((the-graph ,graph)) (kr-send the-graph :source-to-graph-node the-graph ,source))) (defmacro Remove-Root (graph root) `(let ((the-graph ,graph)) (kr-send the-graph :remove-root the-graph ,root))) (defmacro Make-Root (graph root) `(let ((the-graph ,graph)) (kr-send the-graph :make-root the-graph ,root))) (defmacro Add-Node (graph node parents children) `(let ((the-graph ,graph)) (kr-send the-graph :add-node the-graph ,node ,parents ,children))) (defmacro Layout-Graph (graph) `(let ((the-graph ,graph)) (kr-send the-graph :layout-graph the-graph))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; default node prototype ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; displays the provided string (possibly multiple lines) in a white ;; filled roundtangle. ;; ;; requires: ;; - the user provided :info-function (in aggregraph object) must ;; return a string. (kr:create-instance 'aggregraph-node-prototype opal:aggregadget ;; necessary slots for an aggregraph node prototype. (:left 0) (:top 0) (:info "") ;; string to be displayed. returned by :info-function ;; in aggregraph object (:source-node nil) (:links-to-me nil) (:links-from-me nil) ;; internal bookkeeping for default layout function (:layout-info-appears-in-top-sortp nil) (:layout-info-left-setp nil) (:layout-info-top-setp nil) ;; graphics (:parts `((:box ,opal:roundtangle (:filling-style ,opal:white-fill) (:top ,(kr:o-formula (kr:gvl :parent :top))) (:left ,(kr:o-formula (kr:gvl :parent :left))) (:width ,(kr:o-formula (+ (kr:gvl :parent :text-al :width) 8))) (:height ,(kr:o-formula (+ (kr:gvl :parent :text-al :height) 8))) (:radius 5)) (:text-al ,opal:multi-text (:left ,(kr:o-formula (+ (kr:gvl :parent :left) 4))) (:top ,(kr:o-formula (+ (kr:gvl :parent :top) 4))) (:string ,(kr:o-formula (kr:gvl :parent :info))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; default link prototype ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; displays a line from the center of the right edge of the :from ;; object to the center of the left edge of the :to object (so it is ;; well suited to a left to right layout of a tree or dag.) (kr:create-instance 'aggregraph-link-prototype opal:line ;; necessary slots for an aggregraph node prototype. (:from nil) (:to nil) ;; graphics (:x1 (kr:o-formula (+ (kr:gvl :from :left) (kr:gvl :from :width)))) (:y1 (kr:o-formula (+ (kr:gvl :from :top) (floor (kr:gvl :from :height) 2)))) (:x2 (kr:o-formula (kr:gvl :to :left))) (:y2 (kr:o-formula (+ (kr:gvl :to :top) (floor (kr:gvl :to :height) 2))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; helping function for ;; layout-tree function ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; this function returns an ordered list of the graphics nodes. It ;; orders them in an "pre-order traversal" manner from the roots: ;; - for a tree it will return exactly the pre-order traversal of ;; the tree. ;; - for a dag or graph it will do the same thing with the following ;; interpretation: ;; - nodes are only included in the list the first time they are ;; encoutered. ;; nodes which can not be reached by a pre-order traversal of ;; the graph from the root (i.e. nodes which can not be ;; reached by traversing the child pointers from the roots) ;; are added at the appropriate places. (defun top-sort (graph roots) (labels ((top-sort-node (node) (cond ((kr:g-value node :layout-info-appears-in-top-sortp) nil) (t (kr:s-value node :layout-info-appears-in-top-sortp t) (let* ((children-links (kr:g-value node :links-from-me)) (children (mapcar #'(lambda (link) (kr:g-value link :to)) children-links)) (top-sorted-children (map-reduce #'append #'top-sort-node children)) (parent-links (kr:g-value node :links-to-me)) (parents (mapcar #'(lambda (link) (kr:g-value link :from)) parent-links)) (top-sorted-parents (map-reduce #'append #'top-sort-node parents))) (append top-sorted-parents (cons node top-sorted-children))))))) (let* ((sort-list (map-reduce #'append #'top-sort-node roots)) (all-nodes (g-value (kr:g-value graph :nodes) :components)) (sort-list-for-nodes-not-reachable-from-roots (map-reduce #'append #'top-sort-node all-nodes)) (total-sort-list (append sort-list sort-list-for-nodes-not-reachable-from-roots))) (values total-sort-list (reverse total-sort-list))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; default layout function ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; This function places the nodes of graph. It works for arbitrary ;; graphs, but only creates pleasing layouts for trees. (It works for ;; arbitrary graphs by effectively ignoring all but a subset of the links ;; which makes the graph a tree.) ;; ;; Requires: ;; - the slots :layout-info-appears-in-top-sortp, :layout-info-left-setp, ;; and :layout-info-right-setp in the node prototype must not be set by ;; the user, (and so they have the default value of nil.) ;; [The aggregraph object requires that no slot whose name begins with ;; ":layout-info" be set by anything other than the layout function.] (defun layout-tree (graph) ;; reset bookkeeping information (opal:do-components (kr:g-value graph :nodes) #'(lambda (n) (kr:s-value n :layout-info-appears-in-top-sortp nil) (kr:s-value n :layout-info-left-setp nil) (kr:s-value n :layout-info-top-setp nil))) (kr:s-value graph :layout-info-rect-conflict-object (make-rectangle-conflict-object)) (multiple-value-bind (parent-child-top-sort child-parent-top-sort) (top-sort graph (kr:g-value graph :graph-roots)) ;; compute :left value for each node ; (format t "~&computing :left value for each node") (dolist (node parent-child-top-sort) ; (format t "~&:left for node: ~A" (kr:g-value node :info)) (let* ((parent-links (kr:g-value node :links-to-me)) (parents (mapcar #'(lambda (link) (kr:g-value link :from)) parent-links)) (parents-with-left-set (remove-if #'(lambda (node) (not (kr:g-value node :layout-info-left-setp))) parents))) (if (not (null parents-with-left-set)) (kr:s-value node :left (+ (map-reduce #'max #'(lambda (parent) (+ (kr:g-value parent :left) (kr:g-value parent :width))) parents-with-left-set) (kr:g-value graph :h-spacing))) (kr:s-value node :left (kr:g-value graph :left))) (kr:s-value node :layout-info-left-setp t))) ;; compute :top value for each node ;; for each node from the children to the root give nodes with ;; (effectively) no children the next available space. If (some of)a ;; node's children have already been given a y-value, then center the ;; node over those children. (let ((current-y (kr:g-value graph :top))) ;; next place to put ;; node if no other info ; (format t "~&computing :top value for each node") (dolist (node child-parent-top-sort) ; (format t "~&:top for node: ~A" (kr:g-value node :info)) (let* ((children-links (kr:g-value node :links-from-me)) (children (mapcar #'(lambda (link) (kr:g-value link :to)) children-links)) (children-with-top-set (remove-if #'(lambda (node) (not (kr:g-value node :layout-info-top-setp))) children))) (cond ;; if there are (effectively) no children for this node then just ;; give it the next available y position and update the next ;; available y position. ((null children-with-top-set) (let ((top (find-good-y-near-desired-y graph node current-y))) ;; update the current-y to be the position under this ;; node. (Will work well for trees because ;; find-good-y-near-desired-y will just place the node ;; at current-y. This means that the leaves are just ;; placed one right after another. It may or may not ;; work well for dags and graphs.) (setf current-y (+ current-y (kr:g-value node :height) (kr:g-value graph :v-spacing))) (kr:s-value node :top top))) ;; otherwise center the node over it's (effective) children (t (let ((total-centers 0)) (dolist (child children-with-top-set) (setf total-centers (+ total-centers (kr:g-value child :top) (floor (kr:g-value child :height) 2)))) (let ((desired-y (- (floor total-centers (length children-with-top-set)) (floor (kr:g-value node :height) 2)))) (kr:s-value node :top (find-good-y-near-desired-y graph node desired-y)))))) (kr:s-value node :layout-info-top-setp t))))) ;; initialize the cache for use with the :add-node method. (see the ;; comment by the :layout-info-add-node-cache slot.) (kr:s-value graph :layout-info-add-node-cache ;; if no parents and no children, :left is :left of the ;; graph and only try to add things from the top of the ;; graph down starting at :top = :top of the graph. (vector nil nil (kr:g-value graph :left) nil (kr:g-value graph :top) :high))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; aggregraph object ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; definition of aggregraph object (kr:create-instance 'aggregraph opal:aggregadget ;; must be specified in created instance to actually create graph (:source-roots nil) (:children-function nil) (:info-function nil) ;; customizable slots (:left 0) (:top 0) (:parent-function nil) (:add-back-pointer-to-nodes-function nil) (:node-prototype aggregraph-node-prototype) (:link-prototype aggregraph-link-prototype) (:node-prototype-selector-function nil) (:link-prototype-selector-function nil) ;(:interactors nil) ;; inherited from aggregadget (:h-spacing 20) (:v-spacing 5) (:test-to-distinguish-source-nodes #'eql) ;; methods (can be overridden) (:layout-graph #'layout-tree) (:delete-link #'(lambda (graph link) (let ((parent (kr:g-value link :from)) (child (kr:g-value link :to))) ;; remove me from :links-{to/from}-me lists (kr:s-value parent :links-from-me (remove link (kr:g-value parent :links-from-me))) (kr:s-value child :links-to-me (remove link (kr:g-value child :links-to-me))) ;; delete any image links (mapc #'(lambda (image-graph image-link) (kr:kr-send image-graph :primitive-delete-link image-graph image-link)) (kr:g-value graph :image-graphs) (kr:g-value link :image-links)) ;; now delete it (opal:remove-component (kr:g-value graph :links) link) (opal:destroy link)))) (:delete-node #'(lambda (graph node) ;; destroy the links to and from the node (dolist (link (kr:g-value node :links-to-me)) (kr:kr-send graph :delete-link graph link)) (dolist (link (kr:g-value node :links-from-me)) (kr:kr-send graph :delete-link graph link)) ;; now take it off of the root lists if is a root (when (member node (kr:g-value graph :graph-roots)) (kr:s-value graph :source-roots (remove (kr:g-value node :source-node) (kr:g-value graph :source-roots))) (kr:s-value graph :graph-roots (remove node (kr:g-value graph :graph-roots)))) ;; remove it from the rectangle-conflict-object ;; to mark the space as free again. (remove-node-from-conflict-object graph node) ;; remove it from the source->graph-node-table (remhash (kr:g-value node :source-node) (kr:g-value graph :source->graph-node-table)) ;; delete any image nodes (mapc #'(lambda (image-graph image-node) (kr:kr-send image-graph :primitive-delete-node image-graph image-node)) (kr:g-value graph :image-graphs) (kr:g-value node :image-nodes)) ;; now delete it (opal:remove-component (kr:g-value graph :nodes) node) (opal:destroy node))) (:add-node #'(lambda (graph source-node parent-g-nodes children-g-nodes) (let ((node (make-graph-node source-node graph))) (opal:add-component (kr:g-value graph :nodes) node) ;; add links from parents to node (dolist (parent parent-g-nodes) (kr:kr-send graph :add-link graph parent node)) ;; add links from node to children (dolist (child children-g-nodes) (kr:kr-send graph :add-link graph node child)) ;; add node to hash table (setf (gethash source-node (g-value graph :source->graph-node-table)) node) ;; position node ;; check the cache first (let* ((cache (kr:g-value graph :layout-info-add-node-cache)) (cache-parents (svref cache 0)) (cache-children (svref cache 1))) (cond ;; if a cache hit, then use the value ((and (equal cache-parents parent-g-nodes) (equal cache-children children-g-nodes)) (let* ((cache-left-val (svref cache 2)) (cache-low-val (svref cache 3)) (cache-high-val (svref cache 4)) (cache-val-to-use (svref cache 5)) (desired-top (if (eq cache-val-to-use :low) cache-low-val cache-high-val)) top) (s-value node :left cache-left-val) (setf top (find-good-y-near-desired-y graph node desired-top)) (s-value node :top top) ;; update values in the cache (cond ((eq cache-val-to-use :low) (if (<= top cache-low-val) (setf (svref cache 3) (- top (floor (kr:g-value graph :v-spacing) 2.01))) ;; otherwise only search below from ;; now on (signal that you are at the top) (setf (svref cache 3) nil)) ;; search below next time (setf (svref cache 5) :high)) (t (if (>= top cache-high-val) (setf (svref cache 4) (+ top (kr:g-value node :height) (floor (kr:g-value graph :v-spacing) 2.01)))) (if cache-low-val ;; not at the top ;; then search above next time (setf (svref cache 5) :low)))))) (t ;; if not a cache hit, then compute the ;; position normally (let* (;; first compute left ;; based on children (right+space (and children-g-nodes (map-reduce #'min #'(lambda (c) (kr:g-value c :left)) children-g-nodes))) (cleft (and right+space (- right+space (kr:g-value node :width) (kr:g-value graph :h-spacing)))) ;; based on parents (pleft (and parent-g-nodes (+ (map-reduce #'max #'(lambda (p) (+ (kr:g-value p :left) (kr:g-value p :width))) parent-g-nodes) (kr:g-value graph :h-spacing)))) ;; total = ;; 0, if no parents or children ;; pleft or cleft if other is nil ;; average otherwise (left (cond ((and (null pleft) (null cleft)) 0) ((null pleft) cleft) ((null cleft) pleft) (t (floor (+ pleft cleft) 2)))) ;; next compute top. average over centers of ;; both parents and children (total-centers 0)) (dolist (p parent-g-nodes) (setf total-centers (+ total-centers (kr:g-value p :top) (floor (kr:g-value p :height) 2)))) (dolist (c children-g-nodes) (setf total-centers (+ total-centers (kr:g-value c :top) (floor (kr:g-value c :height) 2)))) (let ((top (if (and (null parent-g-nodes) (null children-g-nodes)) 0 (- (floor total-centers (+ (length children-g-nodes) (length parent-g-nodes))) (floor (kr:g-value node :height) 2))))) ;; now set the values (kr:s-value node :left left) (kr:s-value node :top (find-good-y-near-desired-y graph node top)) ;; cache these values: (let ((cache (kr:g-value graph :layout-info-add-node-cache)) (actual-top (kr:g-value node :top))) (setf (svref cache 0) parent-g-nodes) (setf (svref cache 1) children-g-nodes) (setf (svref cache 2) left) (cond ((<= actual-top top) (setf (svref cache 3) (- actual-top (kr:g-value node :height) (floor (kr:g-value graph :v-spacing) 2.01))) (setf (svref cache 4) (+ top (kr:g-value node :height) (floor (kr:g-value graph :v-spacing) 2.01))) (setf (svref cache 5) :high)) (t (setf (svref cache 3) (- top (kr:g-value node :height) (floor (kr:g-value graph :v-spacing) 2.01))) (setf (svref cache 4) (+ actual-top (kr:g-value node :height) (floor (kr:g-value graph :v-spacing) 2.01))) (setf (svref cache 5) :low))) )))))) ;; add node to any image graphs (mapc #'(lambda (image-graph) (kr:kr-send image-graph :primitive-add-node image-graph node)) (kr:g-value graph :image-graphs)) ))) (:add-link #'(lambda (graph from to) (let ((link (make-graph-link from to graph))) (opal:add-component (kr:g-value graph :links) link) (push link (kr:g-value from :links-from-me)) (push link (kr:g-value to :links-to-me)) ;; add link to any image graphs (mapc #'(lambda (image-graph) (kr:kr-send image-graph :primitive-add-link image-graph link)) (kr:g-value graph :image-graphs)) ))) (:make-root #'(lambda (graph node) (when (not (member node (kr:g-value graph :graph-roots))) (push node (kr:g-value graph :graph-roots)) (push (kr:g-value node :source-node) (kr:g-value graph :source-roots))))) (:remove-root #'(lambda (graph node) (setf (kr:g-value graph :graph-roots) (remove node (kr:g-value graph :graph-roots))) (setf (kr:g-value graph :source-roots) (remove (kr:g-value node :source-node) (kr:g-value graph :source-roots))))) (:source-to-graph-node #'(lambda (graph source-node) (gethash source-node (kr:g-value graph :source->graph-node-table)))) (:find-link #'(lambda (graph from to) (declare (ignore graph)) (intersection (kr:g-value from :links-from-me) (kr:g-value to :links-to-me) :test #'eq))) ;; read-only slots (:nodes nil) ; set by initialize (:links nil) ; set by initialize (:graph-roots nil) ;; internal slots (not guaranteed to maintain names or implementation) (:internal-parent-function (kr:o-formula (or (kr:gvl :parent-function) #'(lambda (source-node depth) (declare (ignore source-node depth)) nil)))) ;; make an initial rectangle conflict object that always says there ;; is no conflict. This allows people to write new layout ;; functions without redefining the methods. The methods will work ;; if they do this, but perhaps not as nicely as if they redefine ;; them to do the appropriate bookkeeping for their layout. (:layout-info-rect-conflict-object #'(lambda (&rest args) (declare (ignore args)) NIL)) ;; initialized by :layout-function, and set and used by :add-node ;; method. Contains a vector of six elements: a parent list, a ;; children list, the :left position for a node inserted with those ;; parents and children, the next low :top value to try, the next ;; high :top value to try, and whether to try the low value or the ;; high value next (:low or :high). (:layout-info-add-node-cache nil) (:source->graph-node-table nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; :initialize method ;; for aggregraph ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; function to set up all internal structure for the aggregraph object, ;; including making and placing the graphical nodes and links. (kr:define-method :initialize aggregraph (self) (kr:call-prototype-method self) (when (and (kr:g-value self :source-roots) (kr:g-value self :children-function) (kr:g-value self :info-function)) (let ((node-agg (kr:create-instance nil opal:aggregate)) (link-agg (kr:create-instance nil opal:aggregate))) ;; need to test that :source-roots, :children-function, and ;; :info-function contain reasonable values (kr:s-value self :nodes node-agg) (kr:s-value self :links link-agg) (opal:add-components self link-agg node-agg)) (kr:s-value self :source->graph-node-table (make-hash-table :test (kr:g-value self :test-to-distinguish-source-nodes) :size 50 #-cmu :rehash-size #-cmu 2.0)) ;; test that if multiple prototypes are included that a selector ;; function has been provided (let ((node-prototype (kr:g-value self :node-prototype)) (link-prototype (kr:g-value self :link-prototype))) (when (and (listp node-prototype) (not (functionp-and-not-null (kr:g-value self :node-prototype-selector-function)))) (format t "~&Error in aggregraph: :node-prototype is a list but no selector function was") (format t "~& provided in slot :node-prototype-selector-function.") (format t "~& First one in the list will be used.") (kr:s-value self :node-prototype-selector-function #'(lambda (node l) (declare (ignore node)) (car l)))) (when (and (listp link-prototype) (not (functionp-and-not-null (kr:g-value self :link-prototype-selector-function)))) (format t "~&Error in aggregraph: :link-prototype is a list but no selector function was") (format t "~& provided in slot :link-prototype-selector-function.") (format t "~& First one in the list will be used.") (kr:s-value self :link-prototype-selector-function #'(lambda (from to l) (declare (ignore from to)) (car l))))) ;; create nodes and links (create-aggregraph-nodes-and-links self) ;; layout graph (place nodes) (kr:kr-send self :layout-graph self))) (defun make-graph-node (source-node graph) (let* ((prototype-arg (kr:g-value graph :node-prototype)) (prototype (cond ;; if the user gave a list of prototypes then choose one ((listp prototype-arg) (let ((selector-f (kr:g-value graph :node-prototype-selector-function))) (funcall selector-f source-node prototype-arg))) (t prototype-arg))) (graph-node (kr:create-instance nil prototype (:info (funcall (kr:g-value graph :info-function) source-node)) (:source-node source-node) (:links-to-me '()) (:links-from-me '()))) (back-pointer-fun (kr:g-value graph :add-back-pointer-to-nodes-function))) (when back-pointer-fun (funcall back-pointer-fun source-node graph-node)) graph-node)) (defun make-graph-link (from to graph) (let* ((prototype-arg (kr:g-value graph :link-prototype)) (prototype (cond ;; if the user gave a list of prototypes then choose one ((listp prototype-arg) (let ((selector-f (kr:g-value graph :link-prototype-selector-function))) (funcall selector-f from to prototype-arg))) (t prototype-arg)))) (kr:create-instance nil prototype (:from from) (:to to)))) ;; walks the source graph with :source-roots and :children-function, ;; creating graph nodes from :node-prototype and :info-function. It places ;; these graph nodes in the hash table :source->graph-node-table indexed by ;; the source nodes. ;; values used in aggregraph: ;; :source-roots ;; :children-function ;; :info-function ;; :node-prototype ;; values set in aggregraph: ;; :graph-roots ;; values changed in aggregraph: ;; :source->graph-node-table ;; values set in nodes: ;; :info ;; :source-node ;; :links-to-me ;; :links-from-me (defun create-nodes-and-links-from-root (root graph depth hash-table) (labels ((link-together (from-node to-node) (if (member-if #'(lambda (link) (eq (kr:g-value link :to) to-node)) (kr:g-value from-node :links-from-me)) nil (let ((link (make-graph-link from-node to-node graph))) (opal:add-component (kr:g-value graph :links) link) (push link (kr:g-value from-node :links-from-me)) (push link (kr:g-value to-node :links-to-me)))))) (let ((graph-node (gethash root hash-table))) (if graph-node graph-node (let ((graph-node (make-graph-node root graph))) (setf (gethash root hash-table) graph-node) (opal:add-component (kr:g-value graph :nodes) graph-node) (let* ((source-children (funcall (kr:g-value graph :children-function) root depth)) (source-parents (funcall (kr:g-value graph :internal-parent-function) root depth)) (graph-children (mapcar #'(lambda (n) (create-nodes-and-links-from-root n graph (+ depth 1) hash-table)) source-children)) (graph-parents (mapcar #'(lambda (n) (create-nodes-and-links-from-root n graph (+ depth 1) hash-table)) source-parents))) (dolist (child graph-children) (link-together graph-node child)) (dolist (parent graph-parents) (link-together parent graph-node))) graph-node))))) (defun create-aggregraph-nodes-and-links (graph) (let ((hash-table (kr:g-value graph :source->graph-node-table))) (kr:s-value graph :graph-roots (mapcar #'(lambda (n) (create-nodes-and-links-from-root n graph 0 hash-table)) (kr:g-value graph :source-roots))))) ;;; Support functions for layout and general placement of nodes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; find-free-space ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; This function takes a rectangle-conflict-object and a rectangle ;; (x1, x2, y1, y2). It returns a position where the given rectangle ;; will not overlap with any previous rectangles placed in ;; rectangle-conflict-object. (The position is given by specifying a ;; new (x1,y1).) The returned position will be the closest possible ;; to the initial initial position (given by (x1,y1)) by varying only ;; along the y axis and not going above 'top'. (defun find-free-space (rect-conf-obj x1 x2 y1 y2 top) (let ((conflicting-rect (funcall rect-conf-obj x1 x2 y1 y2 nil))) (if conflicting-rect (let ((lowy (caddr conflicting-rect)) (highy (cadddr conflicting-rect)) (ysize (- y2 y1))) (find-space-by-varying-y rect-conf-obj x1 x2 lowy highy ysize top)) (values x1 y1)))) ;; one way to implement find-free-space (defun find-space-by-varying-y (rect-conf-obj x1 x2 lowy highy ysize top) (let ((below-highy (+ highy 1)) (above-lowy (and lowy (- lowy 1)))) ;; try below highy (let ((conf (funcall rect-conf-obj x1 x2 below-highy (+ below-highy ysize) nil))) (cond ;; if no conflict then put it there ((not conf) (values x1 below-highy)) ;; if a conflict and not at the top then try above lowy ((and above-lowy (>= (- above-lowy ysize) top)) (let ((conf2 (funcall rect-conf-obj x1 x2 (- above-lowy ysize) above-lowy nil))) (if conf2 ;; try further out from conflicting rectangles (find-space-by-varying-y rect-conf-obj x1 x2 (caddr conf2) (cadddr conf) ysize top) ;; use above lowy (values x1 (- above-lowy ysize))))) ;; otherwise try further below conflicting rectangle (t (find-space-by-varying-y rect-conf-obj x1 x2 nil (cadddr conf) ysize top)) )))) (defun find-good-y-near-desired-y (graph node desired-y) ;; finds a free space for the node near the desired-y position and ;; updates the :layout-info-rect-conflict-object with the knowledge ;; that a node was placed there. Returns the y position of the good ;; place. (let* ((rect-conf-obj (kr:g-value graph :layout-info-rect-conflict-object)) ;; get node's rectangle (node-x1 (kr:g-value node :left)) (node-x2 (+ node-x1 (kr:g-value node :width))) (node-y1 desired-y) (node-y2 (+ desired-y (kr:g-value node :height))) ;; 2.01 is used to avoid conflicts when nodes are exactly the ;; correct distance apart. May cause nodes to be one pixel ;; closer together than desired. (x-between (floor (kr:g-value graph :h-spacing) 2.01)) (y-between (floor (kr:g-value graph :v-spacing) 2.01)) ;; rectangle of influence (x1 (- node-x1 x-between)) (x2 (+ node-x2 x-between)) (y1 (- node-y1 y-between)) (y2 (+ node-y2 y-between))) (multiple-value-bind (left top) (find-free-space rect-conf-obj x1 x2 y1 y2 (kr:g-value graph :top)) (declare (ignore left)) (+ top y-between)))) (defun remove-node-from-conflict-object (graph node) ;; removes a node from the rectangle-conflict-object so that the ;; space it occupied can be used again. (let* ((rect-conf-obj (kr:g-value graph :layout-info-rect-conflict-object)) ;; get node's rectangle (node-x1 (kr:g-value node :left)) (node-x2 (+ node-x1 (kr:g-value node :width))) (node-y1 (kr:g-value node :top)) (node-y2 (+ node-y1 (kr:g-value node :height))) ;; find node's rectangle of influence in exactly the same ;; manner as was stored by find-good-y-near-desired-y. (x-between (floor (kr:g-value graph :h-spacing) 2.01)) (y-between (floor (kr:g-value graph :v-spacing) 2.01)) ;; rectangle of influence (x1 (- node-x1 x-between)) (x2 (+ node-x2 x-between)) (y1 (- node-y1 y-between)) (y2 (+ node-y2 y-between))) ;; now delete rectangle of influence (funcall rect-conf-obj x1 x2 y1 y2 'delete))) ;;;;;;;;;;;;;;;; ;; map-reduce ;;;;;;;;;;;;;;;; ;; this function has exactly the same functionality as ;; (reduce reduce-f (mapcar map-f list)) without doing the ;; intermediate consing of that form. (defun map-reduce (reduce-f map-f list) (labels ((map-reduce (first rest) (cond ((null rest) (funcall map-f first)) (t (funcall reduce-f (funcall map-f first) (map-reduce (car rest) (cdr rest))))))) (cond ((null list) '()) (t (map-reduce (car list) (cdr list)))))) (defun functionp-and-not-null (f) (and f (functionp f)))