Skip to content
Snippets Groups Projects
Commit ae8326c7 authored by cer's avatar cer
Browse files

Smh's modification to the graphing algorithm.

parent bfdcc498
No related branches found
No related tags found
No related merge requests found
;;; -*- 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)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment