Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
C
clim-tos
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Container Registry
Model registry
Operate
Environments
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Alastair Bridgewater
clim-tos
Commits
ae8326c7
Commit
ae8326c7
authored
32 years ago
by
cer
Browse files
Options
Downloads
Patches
Plain Diff
Smh's modification to the graphing algorithm.
parent
bfdcc498
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
clim/graph-formatting.lisp
+257
-58
257 additions, 58 deletions
clim/graph-formatting.lisp
with
257 additions
and
58 deletions
clim/graph-formatting.lisp
+
257
−
58
View file @
ae8326c7
;;; -*- 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
(
eq
l
max-depth
0
)
(
flet
((
traverse1
(
child-object
)
(
let
((
child-key
(
funcall
key
child-object
)))
(
multiple-value-bind
(
child-hashval
found
)
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment