Last active
July 11, 2018 02:22
-
-
Save toomasv/be38d5b451bc02da25e81a1cdba589fc to your computer and use it in GitHub Desktop.
Toy graph DSL
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Red [ | |
Author: "Toomas Vooglaid" | |
Date: 2017-12-31 | |
History: [ | |
2017-12-28 {First draft} | |
2018-01-20 {Added arrows, subtree moving, elementary interactive editing} | |
2018-01-24 {Edges formatting} | |
2018-02-01 {Added differnt edge-ends, layout orientations, improved options-handling} | |
2018-02-03 {Implemented stepped (orthogonal) edges, improved star layout} | |
2018-02-06 {Added directions `across` (default: perpendicular to the step-away direction) and `away` (in the step-away direction). | |
Added flows `center` (`c`, default: children centered to the parent), | |
`clockwise` (`cw`, children aligned clockwise to the parent) and `counter-clockwise` (`ccw`). | |
Also corrected `no-draw` presentation for presenting nodes as simple text} | |
] | |
Needs: View | |
Purpose: {Study of Red graph capabilities} | |
] | |
; Enable back-arrows (#"<" (60) -> #"˂" (706)) | |
either "<-" <> "˂-" [ | |
system/lexer/pre-load: func [src][replace/all src "<-" "˂-"] | |
do %graph.red | |
][ | |
;clear-reactions | |
glass: 254.254.254.254 | |
ctx: context [ | |
system/view/auto-sync?: no;yes; | |
ft: make font! [name: "Consolas" size: 12]; 6]; | |
_i: _j: sp: 0 | |
dsl: gr: none | |
before: copy [] | |
after: copy [] | |
middle: copy [] | |
middle-opts: copy [] | |
node-list: copy [] | |
level: 0 | |
level-graph-opts: none | |
level-edge-opts: none | |
space: 30x30 | |
drawing: 'down | |
flow: 'center | |
direction: 'across | |
grid: none | |
graph-options: [space drawing flow direction grid] | |
sub-options: copy [] | |
node-form: 'ellipse | |
node-color: 100.200.100 | |
node-size: 70x40 | |
node-corner: 0 | |
node-border-width: 1 | |
node-border-color: black | |
node-font: ft | |
node-no-draw: false | |
node-options: [ | |
node-form node-color node-size node-corner | |
node-border-width node-border-color | |
node-font node-no-draw | |
] | |
;show-edge: 'yes | |
edge-width: 1 | |
edge-pattern: 'line ;"-" | 'dashed "--" | 'dotted ".." | "-.-" | |
edge-path: 'straight ;'step | 'angle | 'curve | 'spline | |
edge-color: black | |
;edge-head: 'arrow ; ">" | "|>" | "o" | "<" | "|o" | |
edge-head: none | |
edge-head-border: 1 | |
edge-head-size: 10x10 | |
edge-head-size2: none | |
edge-head-color: white | |
edge-head-border-color: black | |
edge-tail: none | |
edge-tail-border: 1 | |
edge-tail-size: 10x10 | |
edge-tail-size2: none | |
edge-tail-color: white | |
edge-tail-border-color: black | |
edge-options: [ | |
edge-path edge-width edge-pattern edge-color edge-head edge-tail ;show-edge | |
edge-head-border edge-head-size edge-head-size2 edge-head-color edge-head-border-color | |
edge-tail-border edge-tail-size edge-tail-size2 edge-tail-color edge-tail-border-color | |
] | |
saved-graph-options: copy [] | |
saved-sub-options: copy [] | |
saved-node-options: copy [] | |
saved-edge-options: copy [] | |
save-options: does [ | |
;insert/only saved-graph-options probe reduce bind graph-options self | |
insert/only saved-sub-options reduce bind sub-options self | |
;probe node-options | |
insert/only saved-node-options reduce bind node-options self | |
;probe edge-options | |
insert/only saved-edge-options reduce bind edge-options self | |
] | |
restore-options: does [ | |
;set graph-options probe take saved-graph-options | |
set sub-options take saved-sub-options | |
set node-options take saved-node-options | |
set edge-options take saved-edge-options | |
] | |
move-to-top: func [face] [move find face/parent/pane face tail face/parent/pane] | |
panel?: false | |
repath: func [blk][to-path reduce blk] | |
bmax: func [block /local out][ ; pooleli? | |
out: 0 | |
forall block [out: max out block/1] | |
] | |
arrow-forms: ['- | |
| '-> | '-o | '-+ | '-< | '-n | |
| '˂- | 'o- | '+- | '>- | 'n- | |
| '˂-> | '<-o | '<-+ | '<-< | '<-n | |
| 'o-> | 'o-o | 'o-+ | 'o-< | 'o-n | |
| '+-> | '+-o | '+-+ | '+-< | '+-n | |
| '>-> | '>-o | '>-+ | '>-< | '>-n | |
| 'n-> | 'n-o | 'n-+ | 'n-< | 'n-n | |
] | |
edge-ends: [#"o" circle #"+" cross #"n" box]; #"x" 'asterisk or 'xcross? | |
tail-ends: append copy edge-ends [#"˂" arrow #">" crow] | |
head-ends: append copy edge-ends [#">" arrow #"<" crow] | |
node-forms: ['box | 'ellipse | 'circle | 'big-circle | 'square | 'big-square] | |
node-forms2: [box ellipse circle big-circle square big-square] | |
edge-paths: ['straight | 'step]; | 'angle | 'curve | 'spline] ; Maybe 'orto instead of 'step? | |
edge-forms: ['arrow | 'circle | 'box | 'cross | 'crow] | |
styles: ['bold | 'italic | 'underline | 'strike] | |
colors: [ | |
'Red | 'white | 'transparent | 'black | 'gray | 'aqua | 'beige | 'blue | |
| 'brick | 'brown | 'coal | 'coffee | 'crimson | 'cyan | 'forest | 'gold | |
| 'green | 'ivory | 'khaki | 'leaf | 'linen | 'magenta | 'maroon | 'mint | |
| 'navy | 'oldrab | 'olive | 'orange | 'papaya | 'pewter | 'pink | 'purple | |
| 'reblue | 'rebolor | 'sienna | 'silver | 'sky | 'snow | 'tanned | 'teal | |
| 'violet | 'water | 'wheat | 'yello | 'yellow | 'glass | |
] | |
font-fn: func [fnt][ | |
parse fnt [some [s: | |
[ string! (insert s to-set-word 'name) | |
| integer! (insert s to-set-word 'size); change next s 2 * second s) | |
| [logic! | 'ClearType] (insert s to-set-word 'anti-alias?) | |
| [block! | styles] (insert s to-set-word 'style) | |
| [tuple! | colors] (insert s to-set-word 'color) | |
] skip | |
]] | |
head fnt | |
] | |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
; Node and subgraph extra graph-related properties ; | |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
props: [ | |
self-ref?: none | |
level-index: none | |
children-groups: make block! 10 | |
edges: copy [] | |
type: none | |
label: none | |
parent: none | |
children: copy [] | |
root?: is [not parent] | |
root: is [ | |
either root? [self][ | |
first ancestors | |
] | |
] | |
external?: leaf?: does [empty? children] | |
internal?: branch?: does [not leaf?] | |
siblings: does [ | |
either root? [copy []] [ | |
exclude parent/extra/children [[self]] | |
] | |
] | |
ancestors: has [list ancestor][ | |
list: copy [] | |
ancestor: parent | |
while [ancestor][ | |
insert list ancestor | |
ancestor: ancestor/extra/parent | |
] copy list | |
] | |
;is [to-block do reduce [ | |
descendants: func [/into list /local child][ | |
list: any [list copy []] | |
if not empty? children [ | |
append list copy children | |
foreach child children [ | |
child/extra/descendants/into list | |
] | |
] copy list | |
] | |
degree: does [length? self/children] | |
depth: does [length? ancestors] | |
level: does [depth + 1] | |
count: func [what /condition cond /local n][ | |
either condition [ | |
n: 0 | |
forall what [if what/1/:cond [n: n + 1]] | |
n | |
][ | |
if word? what [length? self/(what)] | |
] | |
] | |
paths: func [/with out out2 /local child child2] compose/deep [ | |
out: any [out copy []] | |
out2: any [out2 copy []] | |
if not empty? children [ | |
append out to-word label | |
foreach child children [ | |
either empty? child/extra/children [ | |
append/only out2 append copy out child | |
][ | |
child/extra/paths/with copy out out2 | |
] | |
] | |
] | |
out2 | |
] | |
list-paths: has [labs x y labs2][ | |
labs: copy [] | |
foreach x copy paths [ | |
labs2: copy [] | |
foreach y x [append labs2 y/extra/label] | |
append/only labs labs2 | |
] | |
probe labs | |
] | |
heigth: func [/local h path][ | |
h: 0 | |
foreach path paths [ | |
h: max h (length? path) - 1 | |
] h | |
] | |
levels: has [list level child][ | |
list: copy [] level: copy [] | |
unless empty? children [ | |
append level children | |
] | |
until [ | |
append/only list copy level | |
clear level | |
foreach child last list [ | |
append level child/extra/children | |
] | |
empty? level | |
] | |
list | |
] | |
list-levels: has [labs x y labs2][ | |
labs: copy [] | |
foreach x levels [;probe length? x | |
labs2: copy [] | |
foreach y x [append labs2 y/extra/label] | |
append/only labs labs2 | |
] | |
probe labs | |
] | |
width: has [w level][ | |
w: 1 | |
foreach level levels [ | |
w: max w length? level | |
] | |
] | |
] | |
angle: function [start end][ | |
dims: end - start | |
ang: arcsine 1.0 * dims/y / (sqrt dims/x ** 2 + (dims/y ** 2)) | |
either 0 < dims/x [ang][180 - ang] | |
] | |
inner: function [face ang][ | |
cent: face/size / 2 | |
switch face/extra/type [ | |
box or square or big-square [ | |
cent-ang: angle 0x0 cent | |
either ((ang <= cent-ang) and (ang >= negate cent-ang)) or | |
((ang >= (180 - cent-ang)) and (ang <= (180 + cent-ang))) [ | |
x: cent/x | |
y: x * any [attempt [tangent ang] 10000] | |
][ | |
y: cent/y | |
x: y / any [attempt [tangent ang] 10000] | |
] | |
sqrt (x ** 2) + (y ** 2) | |
] | |
circle or big-circle [cent/x] | |
ellipse [ | |
x: to-integer (cent/x * cosine ang) | |
y: to-integer (cent/y * sine ang) | |
sqrt (x ** 2) + (y ** 2) | |
] | |
] | |
] | |
make-edge-decoration: function [edge-form form-size form-size2 edge-path][ | |
decoration: switch edge-form [ | |
arrow [ | |
compose [ | |
move 0x0 | |
'line (as-pair form-size/x form-size/y / 2) | |
(to-lit-word either form-size2 ['line]['move]) | |
(either form-size2 [as-pair negate form-size2 negate form-size/y / 2][as-pair 0 negate form-size/y]) | |
(either form-size2 [to-lit-word 'line][]) | |
(either form-size2 [as-pair form-size2 negate form-size/y / 2][]) | |
'line (as-pair negate form-size/x form-size/y / 2) | |
] | |
] | |
circle [ | |
form-size2: any [form-size2 0] | |
compose [ | |
move (as-pair negate form-size2 -1) | |
arc (as-pair negate form-size2 1) (form-size/1 / 2) (form-size/2 / 2) 0 sweep large | |
] | |
] | |
box [ | |
form-size2: any [form-size2 0] | |
compose [ | |
move (as-pair negate form-size2 form-size/y / 2) | |
'hline (form-size/x) 'vline (negate form-size/y) 'hline (negate form-size/x) | |
] | |
] | |
crow [ | |
compose [ | |
move (as-pair form-size/x 0) | |
'line (as-pair negate form-size/x form-size/y / 2) | |
(to-lit-word either form-size2 ['line]['move]) | |
(either form-size2 [as-pair form-size2 negate form-size/y / 2][as-pair 0 negate form-size/y]) | |
(either form-size2 [to-lit-word 'line][]) | |
(either form-size2 [as-pair negate form-size2 negate form-size/y / 2][]) | |
'line (as-pair form-size/x form-size/y / 2) | |
] | |
] | |
cross [ | |
form-size2: any [form-size2 1] | |
hop: either form-size2 > 1 [ | |
form-size/x / (form-size2 - 1) | |
][0] | |
out: copy [] | |
repeat i form-size2 [ | |
append out compose [ | |
move (as-pair i - 1 * hop + 3 form-size/y / 2) | |
'vline (negate form-size/y) | |
] | |
] | |
out | |
] | |
] | |
decoration | |
] | |
arrow: function [ | |
start end face edge opts | |
/local tail-form head-form;head-size2 tail-size2 | |
][ ;probe reduce [edge opts] | |
set edge-options opts | |
either start = end [ | |
s: e: start/offset + (start/size / 2) - face/offset | |
ang: -60 | |
in-s: to-integer inner start ang | |
in-e: to-integer inner end ang | |
][ | |
s: start/offset + (start/size / 2) - face/offset | |
e: end/offset + (end/size / 2) - face/offset | |
switch edge-path [ | |
straight [ | |
ang: angle s e | |
dims: e - s | |
in-s: to-integer inner start ang ; round/to .. 1 | |
in-e: to-integer inner end ang ; round/to .. 1 | |
len: (sqrt (power dims/x 2) + (power dims/y 2)) - in-s - in-e | |
len: as-pair len 0 | |
edge-line: compose [line 0x0 (len)] | |
] | |
step [ | |
;set graph-options end/extra/level-index | |
idx: end/extra/level-index | |
set self/graph-options pick select level-graph-opts idx/1 idx/2 | |
ang: select [down 90 right 0 up -90 left 180] drawing | |
ang2: select [down 0 right 90 up 0 left 90] drawing | |
dims: e - s | |
in-s: to-integer inner start ang ; round/to .. 1 | |
in-e: to-integer inner end either direction = 'across [ang][ang2] ; round/to .. 1 | |
;len: (sqrt (power dims/x 2) + (power dims/y - in-s - in-e 2)) | |
;len: as-pair len 0 | |
len: (as-pair dims/x dims/y - in-s - in-e) / 2 | |
edge-line: switch direction [ | |
across [ | |
switch drawing [ | |
down [compose [line 0x0 (as-pair 0 y: space/y / 2) (as-pair x: dims/x y) (as-pair x dims/y - (2 * in-e))]] | |
up [compose [line 0x0 (as-pair 0 y: 0 - (space/y / 2)) (as-pair x: dims/x y) (as-pair x dims/y + (2 * in-e))]] | |
right [compose [line 0x0 (as-pair x: space/x / 2 0) (as-pair x y: dims/y) (as-pair dims/x - (2 * in-e) y)]] | |
left [compose [line 0x0 (as-pair x: 0 - (space/x / 2) 0) (as-pair x y: dims/y) (as-pair dims/x + (2 * in-e) y)]] | |
] | |
] | |
away [ | |
switch flow [ | |
center [ | |
sign: either find [down right] drawing [:-][:+] | |
switch drawing [ | |
down or up [compose [ | |
line 0x0 (as-pair 0 y: dims/y sign (start/size/y / 2)) | |
(as-pair either 0 > dims/x [dims/x + (end/size/x / 2)][dims/x - (end/size/x / 2)] y) | |
]] | |
right or left [compose [ | |
line 0x0 (as-pair x: dims/x sign (start/size/x / 2) 0) | |
(as-pair x either 0 > dims/y [dims/y + (end/size/y / 2)][dims/y - (end/size/y / 2)]) | |
]] | |
] | |
] | |
clockwise [ | |
sign: either find [down right] drawing [:-][:+] | |
switch drawing [ | |
down or up [compose [ | |
line 0x0 (as-pair 0 y: dims/y sign (start/size/y / 2)) | |
(as-pair either 0 > dims/x [dims/x + (end/size/x / 2)][dims/x - (end/size/x / 2)] y) | |
]] | |
right or left [compose [ | |
line 0x0 (as-pair x: dims/x sign (start/size/x / 2) 0) | |
(as-pair x either 0 > dims/y [dims/y + (end/size/y / 2)][dims/y - (end/size/y / 2)]) | |
]] | |
] | |
] | |
counter-clockwise [ | |
sign: either find [down right] drawing [:-][:+] | |
switch drawing [ | |
down or up [compose [ | |
line 0x0 (as-pair 0 y: dims/y sign (start/size/y / 2)) | |
(as-pair either 0 > dims/x [dims/x + (end/size/x / 2)][dims/x - (end/size/x / 2)] y) | |
]] | |
right or left [compose [ | |
line 0x0 (as-pair x: dims/x sign (start/size/x / 2) 0) | |
(as-pair x either 0 > dims/y [dims/y + (end/size/y / 2)][dims/y - (end/size/y / 2)]) | |
]] | |
] | |
] | |
] | |
] | |
] | |
ang: 0 | |
] | |
] | |
] | |
;head-form: edge-head | |
;tail-form: edge-tail | |
;width: edge-width | |
;color: edge-color | |
;head-size: edge-head-size | |
;head-size2: edge-head-size2 | |
;tail-size: edge-tail-size | |
;tail-size2: edge-tail-size2 | |
head-border: any [edge-head-border edge-width] | |
tail-border: any [edge-tail-border edge-width] | |
head-color: any [edge-head-color edge-color] | |
tail-color: any [edge-tail-color edge-color] | |
head-border-color: any [edge-head-border-color edge-head-color] | |
tail-border-color: any [edge-tail-border-color tail-color] | |
if any [edge-tail tail?: find extract tail-ends 2 first edge][ | |
tail-form: any [edge-tail select tail-ends tail?/1] | |
tail-decoration: compose/deep [shape [ | |
pen (tail-border-color) line-width (tail-border) fill-pen (tail-color) | |
]] | |
append tail-decoration/2 make-edge-decoration tail-form edge-tail-size edge-tail-size2 edge-path | |
] | |
if any [edge-head head?: find extract head-ends 2 last edge][ | |
head-form: any [edge-head select head-ends head?/1] | |
head-decoration: compose/deep [shape [ | |
pen (head-border-color) line-width (head-border) fill-pen (head-color) | |
]] | |
append head-decoration/2 make-edge-decoration head-form edge-head-size edge-head-size2 edge-path | |
insert head-decoration either edge-path = 'straight [ | |
compose [ rotate 180 (len / 2)];(as-pair len/x / 2 0)] | |
][ | |
switch direction [ | |
across [ | |
switch drawing [ | |
down [compose [rotate 90 0x0 rotate 180 (as-pair dims/y - in-s - in-e / 2 0 - dims/x / 2)]] | |
up [compose [rotate -90 0x0 rotate 180 (as-pair 0 - dims/y - in-s - in-e / 2 dims/x / 2)]] | |
right [compose [ rotate 180 (as-pair dims/x - in-s - in-e / 2 dims/y / 2)]] | |
left [compose [rotate 180 0x0 rotate 180 (as-pair 0 - dims/x - in-s - in-e / 2 0 - dims/y / 2)]] | |
] | |
] | |
away [ | |
sign: either find [down right] drawing [:-][:+] | |
switch drawing [ | |
down or up [compose [ | |
translate (as-pair either 0 > dims/x [dims/x + (end/size/x / 2)][dims/x - (end/size/x / 2)] dims/y sign (start/size/y / 2)) | |
rotate (either 0 > dims/x [0][180]) 0x0 | |
]] | |
right or left [compose [ | |
translate (as-pair dims/x sign (start/size/x / 2) either 0 > dims/y [dims/y + (end/size/y / 2)][dims/y - (end/size/y / 2)]) | |
rotate (either 0 > dims/y [90][-90]) 0x0 | |
]] | |
] | |
] | |
] | |
] | |
] | |
either start = end [ | |
compose/deep [ | |
;translate (s) | |
;rotate (ang) | |
;translate (as-pair in-s 0) | |
pen (edge-color) line-width (edge-width) | |
circle (as-pair s/x s/y / 2) (space/y / 2) | |
;arc (as-pair 3 * s/x / 2 s/y) (as-pair s/x / 2 s/y / 2) -90 180 | |
;ellipse (as-pair s/x - (s/x / 2) s/y - start/size/x) (as-pair start/size/y start/size/x) | |
] | |
][ | |
compose/deep [ | |
translate (s) | |
rotate (ang) | |
translate (either edge-path = 'straight [as-pair in-s 0][ | |
switch drawing [ | |
down [as-pair 0 in-s] | |
up [as-pair 0 0 - in-s] | |
right [as-pair in-s 0] | |
left [as-pair 0 - in-s 0] | |
] | |
]) | |
pen (edge-color) line-width (edge-width) (edge-line);line 0x0 (len) | |
(either tail-form [tail-decoration][]) | |
(either head-form [head-decoration][]) | |
] | |
] | |
] | |
reposition: func [node diff /only /local n][ | |
unless only [ | |
node/offset/x: node/offset/x + diff | |
] | |
foreach n to-block node/extra/descendants [ | |
n/offset/x: n/offset/x + diff | |
] | |
] | |
adjust-offsets: function [_n1][ | |
;set graph-options _n1/extra/level-index | |
idx: _n1/extra/level-index | |
set self/graph-options pick select level-graph-opts idx/1 idx/2 | |
;if drawing = 'star [len: 2 * (sqrt (space/x ** 2) + (space/y ** 2))] | |
foreach _group extract/index _n1/extra/children-groups 2 2 [ | |
length: length? _group;_n1/extra/children | |
index: 0 | |
foreach _n2 _group [;_n1/extra/children [;probe reduce [_n2/extra/label _n2/extra/level-index] | |
;set graph-options _n2/extra/level-index | |
;probe _n2/extra/label | |
idx: _n2/extra/level-index | |
set self/graph-options pick select level-graph-opts idx/1 idx/2 | |
unless find [panel group-box] _n2/type [ | |
current: at _n2/draw (length? _n2/draw) - 1 | |
position: _n2/size - (size-text _n2) / 2 - 3x2 | |
change current position | |
] | |
reference: switch flow [ | |
center [length / 2 + 1] | |
clockwise [switch drawing [down [length] up [1] left [length] right [1]]] ;[length]; | |
counter-clockwise [switch drawing [down [1] up [length] left [1] right [length]]];[1]; | |
] | |
_n2/extra/parent: parent: _n1 | |
index: index + 1; | |
; If offset is preset by `at` use this value, otherwise compute it | |
either found: first find/tail _n2/options 'at-offset [ | |
; In star-drawing, at-x is angle and at-y is distance | |
either drawing = 'star [ | |
_n2/offset: as-pair | |
found/y * (cosine found/x) + _n1/offset/x | |
found/y * (sine found/x) + _n1/offset/y | |
][ | |
_n2/offset: found | |
] | |
][ ; Initial position for children from which to start calculations - step away from parent, center on parent | |
switch drawing [ | |
down [x: parent/offset/x + (parent/size/x / 2) y: parent/offset/y + parent/size/y + space/y] | |
up [x: parent/offset/x + (parent/size/x / 2) y: parent/offset/y - _n2/size/y - space/y] | |
right [x: parent/offset/x + parent/size/x + space/x y: parent/offset/y + (parent/size/y / 2)] | |
left [x: parent/offset/x - _n2/size/x - space/x y: parent/offset/y + (parent/size/y / 2)] | |
star [;probe reduce [_n2/extra/label parent/offset/x] | |
x: parent/offset/x + (parent/size/x / 2) | |
y: parent/offset/y + (parent/size/y / 2) | |
either parent/extra/root? [ | |
node-angle: -90 + to-integer (index - 1 * 360.0 / length) | |
][ | |
diff: parent/extra/parent/offset - parent/offset | |
atn: arctangent2 diff/y diff/x | |
angle: to-integer (180 / pi * atn) | |
node-angle: (angle + (index * 360 / (length + 1))) % 360 ; to-integer | |
] | |
in-s: to-integer inner _n1 node-angle | |
in-e: to-integer inner _n2 node-angle | |
len: in-s + in-e + space/y ;2 * (sqrt (space/x ** 2) + (space/y ** 2)) | |
x: len * (cosine node-angle) + x - (_n2/size/x / 2) | |
y: len * (sine node-angle) + y - (_n2/size/y / 2) | |
] | |
] | |
; Star already got positions | |
unless drawing = 'star [ | |
either direction = 'across [ | |
; First adjustment of positions | |
case [ | |
flow = 'center [ | |
either odd? length [ | |
switch drawing [ | |
down or up [x: x - (_group/:reference/size/x / 2)] | |
right or left [y: y - (_group/:reference/size/y / 2)] | |
] | |
gr?: :> | |
][ | |
switch drawing [ | |
down or up [x: x + (space/x / 2)] | |
right or left [y: y + (space/y / 2)] | |
] | |
gr?: :>= | |
] | |
] | |
'else [ | |
switch drawing [ | |
down or up [x: x - (_group/:reference/size/x / 2)] | |
right or left [y: y - (_group/:reference/size/y / 2)] | |
] | |
gr?: :> | |
] | |
] | |
; Initial position of specific node | |
case [ | |
index < reference [ | |
repeat j reference - index [;compose/deep | |
k: reference - j | |
;probe reduce ["<" index reference j k] | |
switch drawing [ | |
down or up [x: x - space/x - _group/:k/size/x] | |
right or left [y: y - space/y - _group/:k/size/y] | |
] | |
] | |
] | |
index gr? reference [ | |
repeat j index - reference [;compose/deep | |
k: reference + j - 1 | |
;probe reduce [">=" index reference j k] | |
switch drawing [ | |
down or up [x: x + space/x + _group/:k/size/x] | |
right or left [y: y + space/y + _group/:k/size/y] | |
] | |
] | |
] | |
] ;probe reduce [_n2/extra/label as-pair x y _n2/extra/parent/offset] | |
][ ; In case direction is 'away | |
; Set up two columns/rows | |
switch drawing [ | |
down or up [x1: x - space/x x2: x + space/x] | |
right or left [y1: y - space/y y2: y + space/y] | |
] | |
;coef: either flow = 'center [index - 1 / 2][index - 1] | |
switch flow [ | |
center [ | |
switch drawing [ | |
down or up [ | |
; x can be one of two columns | |
x: either o?: odd? index [x1 - _n2/size/x][x2] | |
; This is max-half-y-size of current row | |
y-max1: either o? [ | |
either index < length [ | |
;probe reduce [index index? find _group _n2] | |
(max _n2/size/y _group/(index + 1)/size/y) / 2 | |
][ | |
_n2/size/y / 2 | |
] | |
][ | |
(max _n2/size/y _group/(index - 1)/size/y) / 2 | |
] | |
if index > 2 [ | |
diff: pick [1 3] o? | |
; Highest y of previous row | |
y-min: min _group/(index - 2)/offset/y _group/(index - diff)/offset/y | |
] | |
] | |
right or left [ | |
; y can be one of two row | |
y: either o?: odd? index [y1 - _n2/size/y][y2] | |
; This is max-half-x-size of current column | |
x-max1: either o? [ | |
either index < length [ | |
;probe reduce [index index? find _group _n2] | |
(max _n2/size/x _group/(index + 1)/size/x) / 2 | |
][ | |
_n2/size/x / 2 | |
] | |
][ | |
(max _n2/size/x _group/(index - 1)/size/x) / 2 | |
] | |
if index > 2 [ | |
diff: pick [1 3] o? | |
; Highest x of previous column | |
x-min: min _group/(index - 2)/offset/x _group/(index - diff)/offset/x | |
] | |
] | |
] | |
if index > 2 [ | |
switch drawing [ | |
down [ | |
y-max2: (max _group/(index - 2)/size/y _group/(index - diff)/size/y) | |
y: y-min + y-max2 + space/y + y-max1 - (_n2/size/y / 2) | |
] | |
up [ | |
y: y-min - space/y - y-max1 - (_n2/size/y / 2) | |
] | |
right [ | |
x-max2: (max _group/(index - 2)/size/x _group/(index - diff)/size/x) | |
x: x-min + x-max2 + space/x + x-max1 - (_n2/size/x / 2) | |
] | |
left [ | |
x: x-min - space/x - x-max1 - (_n2/size/x / 2) | |
] | |
] | |
] | |
] | |
clockwise [ | |
switch drawing [ | |
down [x: x1 - _n2/size/x] | |
up [x: x2] | |
right [y: y2] | |
left [y: y1 - _n2/size/y] | |
] | |
if index > 1 [ | |
pre: _group/(index - 1) | |
switch drawing [ | |
down [y: pre/offset/y + space/y + pre/size/y] | |
up [y: pre/offset/y - space/y - (2 * _n2/size/y / 2)] | |
right [x: pre/offset/x + space/x + pre/size/x] | |
left [x: pre/offset/x - space/x - (2 * _n2/size/x / 2)] | |
] | |
] | |
] | |
counter-clockwise [ | |
switch drawing [ | |
down [x: x2] | |
up [x: x1 - _n2/size/x] | |
right [y: y1 - _n2/size/y] | |
left [y: y2] | |
] | |
if index > 1 [ | |
pre: _group/(index - 1) | |
switch drawing [ | |
down [y: pre/offset/y + space/y + pre/size/y] | |
up [y: pre/offset/y - space/y - (2 * _n2/size/y / 2)] | |
right [x: pre/offset/x + space/x + pre/size/x] | |
left [x: pre/offset/x - space/x - (2 * _n2/size/x / 2)] | |
] | |
] | |
] | |
] | |
] | |
; Readjust positions of overlapping nodes | |
if any [ | |
;_n2 = first parent/extra/children | |
_n2 = first _group | |
;_n2 = last parent/extra/children | |
_n2 = last _group | |
][ | |
my-ancs: to-block _n2/extra/ancestors | |
depth: to-integer _n2/extra/depth | |
root: _n2/extra/root | |
levels: to-block root/extra/levels | |
level: to-block levels/:depth | |
me: find level _n2 | |
if all [ | |
1 < index? me | |
][ | |
sib: first back me | |
;z: switch drawing [down or up ['x] right or left ['y]] | |
if sib/offset/x + sib/size/x > x [ | |
diff: sib/offset/x + sib/size/x + space/x - x / 2 | |
sib-ancs: to-block sib/extra/ancestors | |
forall my-ancs [ | |
i: index? my-ancs | |
unless same? my-ancs/1 sib-ancs/:i [ | |
reposition my-ancs/1 diff | |
ancs-level: levels/(-1 + index? my-ancs) | |
foreach anc copy/part ancs-level find ancs-level my-ancs/1 [ | |
reposition anc negate diff | |
] | |
x: x + diff | |
break | |
] | |
] | |
] | |
] | |
;comment [ | |
if all [ | |
(length? level) > index? me | |
par: select select sib: first next me 'extra 'parent | |
parent <> par | |
][ | |
if (x + _n2/size/x + space/x) > sib/offset/x [ | |
diff: x + _n2/size/x + space/x - sib/offset/x / 2 | |
sib-ancs: to-block sib/extra/ancestors | |
forall my-ancs [ | |
i: index? my-ancs | |
unless same? my-ancs/1 sib-ancs/:i [ | |
reposition my-ancs/1 negate diff | |
ancs-level: levels/(-1 + index? my-ancs) | |
foreach anc find/tail ancs-level my-ancs/1 [ | |
reposition anc diff | |
] | |
x: x - diff | |
break | |
] | |
] | |
] | |
] | |
;] | |
] | |
] | |
;probe reduce [_n2/extra/label as-pair x y _n2/extra/parent/offset] | |
_n2/offset: as-pair x y | |
] | |
] | |
] | |
] | |
draw-edge: function [_n2 _e opts same-node?][;probe _n2 | |
_2: get _n2 | |
either same-node? [ | |
append _2/parent/pane layout/only compose/deep/only [ | |
at 0x0 box | |
extra (to-map compose [head: (_2) tail: (_2)]) | |
on-create [ | |
append (repath [_n2 'extra 'edges]) face | |
] | |
react (copy/deep compose/deep [ | |
face/offset: (repath [_n2 'offset]) - space | |
face/size: 2 * space + (repath [_n2 'size]) | |
face/draw: arrow (_n2) (_n2) face (_e) [(opts)] | |
]) | |
] | |
][;probe reduce [_n2 _2/offset] | |
_1: _2/extra/parent | |
_n1: to-word _1/extra/label | |
;append _2/parent/pane layout/only compose/deep/only [ | |
insert _2/parent/pane layout/only compose/deep/only [ | |
at 0x0 box | |
extra (to-map compose [head: (_1) tail: (_2)]) | |
on-create [ | |
append (repath [_n1 'extra 'edges]) face | |
append (repath [_n2 'extra 'edges]) face | |
] | |
react (copy/deep compose/deep [ | |
face/offset: as-pair | |
min (repath [_n1 'offset 'x]) (repath [_n2 'offset 'x]) | |
min (repath [_n1 'offset 'y]) (repath [_n2 'offset 'y]) | |
face/size: subtract as-pair | |
max (repath [_n1 'offset 'x]) + (repath [_n1 'size 'x]) | |
(repath [_n2 'offset 'x]) + (repath [_n2 'size 'x]) | |
max (repath [_n1 'offset 'y]) + (repath [_n1 'size 'y]) | |
(repath [_n2 'offset 'y]) + (repath [_n2 'size 'y]) | |
face/offset | |
face/draw: arrow (_n1) (_n2) face (_e) [(opts)] | |
]) | |
] ;probe _n2 | |
] | |
;move at _2/parent/pane (length? _2/parent/pane) _2/parent/pane | |
] | |
add-sub: function [sub options lay live][ | |
;parse options [some [ | |
; | |
;]] | |
append lay compose/deep [ | |
(to-set-word sub-name: either sub = "sub" [append copy "sub" self/_j: self/_j + 1][to-string sub]) | |
subgraph with [ | |
text: (sub-name) | |
font: ft | |
extra: reactor! copy/deep props | |
extra/label: (sub-name) | |
] loose | |
[] | |
] | |
to-word sub-name | |
] | |
add-node: function [ | |
node options lay live | |
/local offset form size text fnt corner bdr pen-width pen-color fill-color node-name no-draw level-index | |
][ | |
self/_i: _i + 1 | |
node-name: either node?: node = 'node [to-word append copy "node" _i][node] | |
unless find node-list node-name [ | |
append node-list node-name | |
;;;;;;;;;;;;;;;;;;;;;;;; | |
; Prepare node options ; | |
;;;;;;;;;;;;;;;;;;;;;;;; | |
unless empty? options [ | |
parse options [some [ | |
'offset set offset pair! | |
| 'loop (self-ref?: true) | |
| set text string! | |
| set form node-forms | |
| set size pair! | |
| set no-draw 'no-draw | |
| 'border [ | |
set pen-color [tuple! | colors | 'off] | |
| set pen-width integer! | |
| into [some [ | |
set pen-color [tuple! | colors | 'off] | |
| set pen-width integer! | |
]] | |
] | |
| set fill-color [tuple! | colors | 'off] | |
| set corner integer! | |
| 'font [ | |
set fnt ['true | 'false | 'ClearType] ( | |
font: make font! font-fn compose [anti-alias?: (fnt)] | |
) | |
| set fnt word! (font: self/(fnt)) | |
| set fnt skip ( | |
unless block? fnt [fnt: to-block mold fnt] | |
font: make font! font-fn fnt | |
)] | |
| set level-index path! | |
]] | |
] | |
form: to-string any [form node-form] | |
form-type: to-lit-word form | |
form: to-word either big?: find/match form "big-" [big?][form] | |
size: any [size node-size] | |
corner: any [corner node-corner] | |
pen-width: any [pen-width node-border-width] | |
pen-color: any [pen-color node-border-color] | |
fill-color: any [fill-color node-color] | |
font: any [font node-font] | |
no-draw: any [no-draw node-no-draw] | |
if frm: find [circle square] form [ | |
mini: min size/x size/y | |
maxi: max size/x size/y | |
size: either big? [as-pair maxi maxi][as-pair mini mini] | |
form: select [circle ellipse square box] first frm | |
] | |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
; Append node to layout VID ; | |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
if offset [append either panel? [last lay][lay] reduce ['at offset]] | |
a: level-index/1 b: level-index/2 level-index: reduce [a b] | |
append either panel? [last lay][lay] compose/deep [ | |
(to-set-word node-name) | |
node | |
(size) | |
with [ | |
color: (either no-draw [any [fill-color node-color]][glass]) | |
font: (font) | |
text: (text: either text = "node" [to-string node-name][text]) | |
extra: make reactor! copy/deep props | |
extra/type: (form-type) | |
extra/label: (to-string node-name) | |
extra/level-index: [(level-index)] | |
draw: ( | |
either no-draw compose/deep [ | |
[[ | |
line-width (pen-width) | |
pen off ;(pen-color) | |
box (0x0 + (pen-width / 2)) | |
(size - (switch form [ | |
box [pen-width]; / 2] | |
ellipse [pen-width] | |
])) | |
(corner) | |
]] | |
] compose/deep [ | |
[[ | |
line-width (pen-width) | |
pen (pen-color) | |
fill-pen (fill-color) | |
(form) (0x0 + (pen-width / 2)) | |
(size - (switch form [ | |
box [pen-width]; / 2] | |
ellipse [pen-width] | |
])) | |
(either form = 'box [corner][]) | |
font (font) | |
text 15x10 (text) | |
]] | |
] | |
) | |
menu: [ | |
"Add child" add | |
;"Add sibling" | |
;"Edit" | |
"Delete" delete | |
] | |
actors: object [ | |
offs: copy [] | |
descs: copy [] | |
on-down: func [face event /local des][ | |
if event/ctrl? [ | |
clear offs | |
descs: to-block face/extra/descendants | |
foreach des descs [ | |
append offs des/offset - face/offset | |
] | |
] | |
'done | |
] | |
on-drag: func [face event /local des n][ | |
if event/ctrl? [ | |
n: 0 | |
foreach des descs [ | |
n: n + 1 | |
des/offset: face/offset + offs/:n | |
] | |
] | |
show face/parent ;[face face/extra/tail face/extra/head] | |
] | |
on-menu: func [ | |
face event | |
/local n list new idx bef my-ancs depth root levels level me sib diff sib-ancs ancs-level anc x y sib-x i | |
][ | |
switch event/picked [ | |
add [ | |
append face/parent/pane new: first layout/only | |
add-node 'node copy reduce ["node" to-path face/extra/level-index] copy [style node: box loose] 'live | |
append face/extra/children new | |
idx: either bef: find before to-word face/extra/label [ | |
index? bef | |
][ | |
append before to-word face/extra/label | |
append/only middle copy [] | |
append/only middle-opts copy [] | |
append/only after copy [] | |
1 | |
] | |
append pick middle idx to-word "->" | |
append/only pick middle-opts idx copy [] | |
append pick after idx to-word new/extra/label | |
;probe reduce [before middle middle-opts after] | |
adjust-offsets face level-graph-opts; need to add level-graph-opts | |
show face/parent | |
draw-edge to-word new/extra/label "->" copy [[]] false level-graph-opts ; lgo? | |
show face/parent | |
] | |
delete [ | |
all [ | |
n: find before to-word face/extra/label | |
foreach list [middle middle-opts after][remove at get list index? n] | |
remove n | |
] | |
forall after [ | |
all [ | |
n: find after/1 to-word face/extra/label | |
remove at middle/(index? after) index? n | |
remove at middle-opts/(index? after) index? n | |
remove n | |
] | |
] | |
unless empty? face/extra/edges [ | |
foreach edge face/extra/edges [ | |
remove find edge/extra/head/extra/edges edge | |
remove find edge/extra/tail/extra/edges edge | |
remove find edge/parent/pane edge | |
] | |
] | |
remove find face/parent/pane face | |
remove find node-list to-word face/extra/label | |
;probe reduce [before middle middle-opts after node-list] | |
show face/parent | |
] | |
] | |
] | |
] | |
] | |
(either no-draw [[do [put last self/pane 'size 10x10 + size-text last self/pane]]][]) | |
] | |
] | |
either live [lay][node-name] | |
] | |
;;;;;;;;;;;;;;;;; | |
; Main function ; | |
;;;;;;;;;;;;;;;;; | |
set 'graph function [spec [block!] /only /local font fnt node1 node2 edge bdr no-draw][ | |
clear-reactions | |
; Set up defaults node | |
clear middle | |
clear middle-opts | |
clear before | |
clear after | |
last-node: none | |
last-edge: none | |
level-edges: copy [] | |
level-edge-opts: make map! copy [] | |
graph-options: none | |
sub-options: none | |
node-options: none | |
edge-opts: none | |
bnode: copy [] | |
clear self/node-list | |
self/_i: self/_j: 0 | |
self/sp: 0 | |
self/level-graph-opts: make map! copy [] | |
self/space: 30x30 | |
self/drawing: 'down | |
self/flow: 'center | |
self/direction: 'across | |
self/grid: none | |
self/node-form: 'ellipse | |
self/node-color: 100.200.100 | |
self/node-size: 70x40 | |
self/node-corner: 0 | |
self/node-border-width: 1 | |
self/node-border-color: black | |
self/node-font: ft | |
self/node-no-draw: false | |
;self/show-edge: 'yes | |
self/edge-path: 'straight | |
self/edge-width: 1 | |
self/edge-pattern: 'line ; "-" | 'dashed "--" | 'dotted ".." | "-.-" | |
self/edge-color: black | |
self/edge-head: none ; ">" | "|>" | "o" | "<" | "|o" | |
self/edge-head-border: 1 | |
self/edge-head-size: 10x10 | |
self/edge-head-size2: none | |
self/edge-head-color: white | |
self/edge-head-border-color: black | |
self/edge-tail: none | |
self/edge-tail-border: 1 | |
self/edge-tail-size: 10x10 | |
self/edge-tail-size2: none | |
self/edge-tail-color: white | |
self/edge-tail-border-color: black | |
;;;;;;;;;;;;;;;;; | |
; Parsing rules ; | |
;;;;;;;;;;;;;;;;; | |
graph-defaults: [any [ | |
set space pair! | |
| set drawing ['down | 'up | 'left | 'right | 'star] | |
| 'tight (sp: 0) opt [set sp integer!] ( | |
self/space: switch drawing [down or up [as-pair sp space/y] right or left [as-pair space/x sp]] | |
) | |
| 'close (sp: 0) opt [set sp integer!] ( | |
;self/edge-head-color: self/edge-tail-color: self/edge-color: 'off | |
self/space: switch drawing [down or up [as-pair space/x sp] right or left [as-pair sp space/y]] | |
); self/edge off? | |
| [['c | 'center] (self/flow: 'center) | ['cw | 'clockwise] (self/flow: 'clockwise) | ['ccw | 'counter-clockwise] (self/flow: 'counter-clockwise)] | |
| set direction ['away | 'across] | |
]] | |
;end-form: ['arrow | 'closed-arrow | 'square | 'circle] | |
e-head: [ | |
set edge-head edge-forms | |
| set edge-head-border integer! | |
| set edge-head-size pair! opt [set edge-head-size2 integer!] | |
| set edge-head-color [tuple! | colors | 'off] | |
| 'border set edge-head-border-color [tuple! | colors | 'off] | |
] | |
e-tail: [ | |
set edge-tail edge-forms | |
| set edge-tail-border integer! | |
| set edge-tail-size pair! opt [set edge-tail-size2 integer!] | |
| set edge-tail-color [tuple! | colors | 'off] | |
| 'border set edge-tail-border-color [tuple! | colors | 'off] | |
] | |
;set show-edge ['yes | 'no] (probe show-edge) | |
edge-defaults: [some [ | |
set edge-path edge-paths | |
| set edge-width integer! | |
| set edge-color [tuple! | colors | 'off] | |
;| set edge-pattern | |
| 'head some e-head;[e-head | into [some [e-head]]] | |
| 'tail some e-tail;[e-tail | into [some [e-tail]]] | |
]] | |
sub-defaults: [] | |
node-defaults: [some [ | |
set node-form node-forms | |
| set node-no-draw 'no-draw | |
| 'border [ | |
set node-border-color [tuple! | colors | 'off] | |
| node-border-width integer! | |
| into [some [ | |
set node-border-color [tuple! | colors | 'off] | |
| node-border-width integer! | |
]] | |
] | |
| set node-color [tuple! | colors | 'off] | |
| set node-size pair! | |
| set node-corner integer! | |
| 'font [ | |
set fnt ['true | 'false | 'ClearType] ( | |
font: make font! font-fn compose [anti-alias?: (fnt)] | |
) | |
| set fnt word! (self/node-font: self/(fnt)) | |
| set fnt skip ( | |
unless block? fnt [fnt: to-block mold fnt] | |
self/node-font: make font! font-fn fnt | |
) | |
] | |
]] | |
defaults: [ | |
'nodes node-defaults ;into | |
| 'edges edge-defaults ;into | |
| 'subs sub-defaults ;into | |
] | |
graph-rule: [ | |
(self/level: level + 1) | |
opt [graph-defaults]; into | |
( | |
either level-graph-opts/:level [ | |
append/only level-graph-opts/:level reduce bind self/graph-options self | |
][ | |
level-graph-opts/:level: append/only copy [] reduce bind self/graph-options self | |
] | |
) | |
some [ | |
defaults | |
| '. | |
| some [(edge: none) | |
s: set edge arrow-forms ( ;=> <= <=> = --> <-- <--> -- ==> <== <==> == -< ->> -|o -|<; #"˂" = 706 | |
;probe s | |
;last-edge: edge | |
insert bnode last-node | |
unless find before last-node [ | |
append before last-node | |
append/only middle copy [] | |
append/only middle-opts copy [] | |
append/only after copy [] | |
] | |
) | |
opt [ | |
(edge-opts: none);(edge-opts: copy []) | |
set edge-opts into [[integer! | tuple! | colors | 'off | 'head | 'tail] to end] | |
] | |
any defaults | |
[ (sub?: false) | |
'sub (sub?: true clear sub-options subg2: copy "sub") | |
opt [set subg2 word!] | |
opt ['opts set sub-options block!] | |
set sub block! | |
| opt [(offset: none) 'at set offset pair!] | |
set node2 word! | |
(opt-text: none node-options: copy []) | |
opt [set opt-text string! | |
| set opt-text [binary! | integer!] | |
(opt-text: to-string to-char opt-text) | |
] | |
opt [set node-options block!] | |
| set node2 block! | |
]( | |
either sub? [ | |
append sub-options any [to-string subg2] | |
last-node: add-sub subg2 sub-options lay false | |
self/panel?: true | |
append after/(index? find before first bnode) last-node | |
append middle/(index? find before first bnode) any [edge last-edge] | |
append/only middle-opts/(index? find before first bnode) either edge-opts [ ; edge-opts | |
insert/only saved-edge-options reduce bind edge-options self | |
parse edge-opts edge-defaults | |
also reduce bind edge-options self set edge-options take saved-edge-options | |
][ | |
reduce bind edge-options self | |
] | |
save-options | |
parse sub graph-rule | |
restore-options | |
self/panel?: false | |
][ | |
either word? node2 [ | |
unless node2 = last-node [ | |
if find node-forms node2 [append node-options node2 node2: 'node] | |
append node-options any [opt-text to-string node2] | |
;append/only node-options to-path reduce ['level-graph-opts level length? level-graph-opts/:level] | |
append/only node-options to-path reduce [level length? level-graph-opts/:level] | |
if offset [append node-options reduce ['offset offset]] | |
last-node: add-node node2 node-options lay false | |
] ;probe last lay | |
append after/(index? find before first bnode) last-node | |
append middle/(index? find before first bnode) any [edge last-edge] | |
;probe node2 | |
append/only middle-opts/(index? find before first bnode) either edge-opts [ ; edge-opts | |
insert/only saved-edge-options reduce bind edge-options self | |
parse edge-opts edge-defaults | |
also reduce bind edge-options self set edge-options take saved-edge-options | |
][ | |
reduce bind edge-options self | |
] | |
][ | |
save-options | |
insert level-edges any [last-edge edge] | |
last-edge: edge | |
parse node2 graph-rule | |
;probe reduce edge-options | |
restore-options | |
last-edge: take level-edges | |
;probe reduce edge-options | |
] | |
] | |
remove bnode | |
) | |
] | |
| opt [(offset: none) 'at set offset pair!] | |
set node1 word! | |
(opt-text: none node-options: copy []) | |
opt [set opt-text string! | |
| set opt-text [binary! | integer!] | |
(opt-text: to-string to-char opt-text) | |
] | |
opt [set node-options block!] | |
( | |
if find node-forms node1 [append node-options node1 node1: 'node] | |
append node-options any [opt-text to-string node1] | |
;append/only node-options to-path reduce ['level-graph-opts level length? level-graph-opts/:level] | |
append/only node-options to-path reduce [level length? level-graph-opts/:level] | |
if offset [append node-options reduce ['offset offset]] | |
last-node: add-node node1 node-options lay false | |
unless any [empty? bnode panel?] [ | |
append after/(index? find before first bnode) last-node | |
append middle/(index? find before first bnode) any [edge last-edge] | |
;probe node1 | |
append/only middle-opts/(index? find before first bnode) either edge-opts [ ; edge-opts | |
insert/only saved-edge-options reduce bind edge-options self | |
parse edge-opts edge-defaults | |
also reduce bind edge-options self set edge-options take saved-edge-options | |
][ | |
reduce bind edge-options self | |
] | |
] | |
) | |
| ahead block! (save-options) into graph-rule (restore-options) | |
] | |
( | |
self/level: level - 1 | |
set self/graph-options either level-graph-opts/:level [last level-graph-opts/:level][copy []] | |
) | |
] | |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
; Initial layout VID with style definitions ; | |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
;either only [ | |
; lay: copy [] | |
; parse dsl/text graph-rule | |
; lay: layout/only lay | |
;][ | |
lay1: copy compose/deep [ | |
size 1130x620 | |
style node: box loose | |
style subgraph: group-box | |
;dsl: panel 200x600 [ | |
; space 0x0 origin 0x0 | |
; area 200x600 (mold spec) | |
;] | |
gr: panel 1110x600 ;900x600 | |
;draw [box 0x0 1109x599] ;899x599] | |
on-down [ | |
append face/pane new: first layout/only | |
add-node 'node copy ["node"] | |
copy [style node: box loose at event/offset] face/pane true | |
append before to-word new/extra/label | |
append/only middle copy [] | |
append/only middle-opts copy [] | |
append/only after copy [] | |
show face | |
] | |
[] | |
] | |
lay: last lay1 | |
; Build VID for nodes and subgraphs | |
parse spec graph-rule | |
;probe lay | |
;probe reduce [before middle middle-opts after] | |
; Build layout tree | |
lay: layout lay1 | |
;probe lay | |
;] | |
;comment { | |
;;;;;;;;;;;;;;;;;;;;;;; | |
; Adjust node offsets ; | |
;;;;;;;;;;;;;;;;;;;;;;; | |
_i: 0 | |
;probe level-graph-opts | |
foreach _n1 reduce before [ | |
_i: _i + 1 | |
current: at _n1/draw (length? _n1/draw) - 1 | |
position: _n1/size - (size-text _n1) / 2 - 3x2 | |
change current position | |
; Does it point to itself? | |
if aft: find after/:_i n1: to-word _n1/extra/label [ | |
_n1/extra/self-ref?: true | |
arr: take skip middle/:_i (index? aft) - 1 | |
apt: take skip middle-opts/:_i (index? aft) - 1 | |
remove aft | |
;probe reduce [middle middle-opts after] | |
draw-edge n1 form arr apt true | |
] | |
;comment { | |
_n1/extra/children: children: reduce after/:_i | |
forall children [ | |
either found: find/only/tail _n1/extra/children-groups _j: children/1/extra/level-index [ | |
append found/1 children/1 | |
][ | |
append _n1/extra/children-groups reduce [_j append copy [] children/1] | |
] | |
] | |
if _n1/extra/root? [ | |
_n1/offset: either found: first find/tail _n1/options 'at-offset [ | |
found | |
][ | |
;set self/graph-options _n1/extra/level-index | |
idx: _n1/extra/level-index | |
set self/graph-options pick select level-graph-opts idx/1 idx/2 | |
switch drawing [ | |
down [as-pair _n1/parent/size/x / 2 - (_n1/size/x / 2) space/y] | |
up [as-pair _n1/parent/size/x / 2 - (_n1/size/x / 2) _n1/parent/size/y - _n1/size/y - space/y] | |
right [as-pair space/x _n1/parent/size/y / 2 - (_n1/size/y / 2)] | |
left [as-pair _n1/parent/size/x - space/x - _n1/size/x _n1/parent/size/y / 2 - (_n1/size/y / 2)] | |
star [as-pair _n1/parent/size/x / 2 - (_n1/size/x / 2) _n1/parent/size/y / 2 - (_n1/size/y / 2)] | |
] | |
] | |
] ;probe _n1/extra/label | |
adjust-offsets _n1 ;level-graph-opts ;probe _n1/extra/label | |
;} | |
] | |
;} | |
;probe reduce [before middle middle-opts after] | |
;probe middle-opts | |
;comment { | |
;;;;;;;;;;;;;;;;;;;;;; | |
; Add reactive edges ; | |
;;;;;;;;;;;;;;;;;;;;;; | |
forall before [ | |
im: 0 | |
foreach _n2 after/(ib: index? before) [ | |
im: im + 1 | |
_e: form middle/:ib/:im | |
_e-opts: middle-opts/:ib/:im | |
;probe _n2 | |
;probe _e-opts | |
draw-edge _n2 _e _e-opts false | |
;probe _n2 | |
] | |
] | |
;} | |
;;;;;;;;;;; | |
; Show it ; | |
;;;;;;;;;;; | |
;comment { | |
either only [ | |
gr/pane: lay | |
][ | |
view/tight/flags lay [resize] ;/no-wait | |
;do-events | |
] | |
;} | |
] | |
] | |
; Examples | |
comment { | |
# Baby graph DSL | |
Still half-baked. First naive layouts. Unstable. | |
## Usage: | |
``` | |
do %graph.red | |
graph [n1 -> n2] | |
graph [n1 -> [n2 n3]] | |
; Anonymous node-names are incremented: | |
graph [node -> [node node -> [node node node]]] | |
``` | |
## Graph | |
1. Space: pair! | |
2. Drawing orientation: (down (default) | up | right | left | star) | |
3. Flow: (center | c | clockwise | cw | counter-clockwise | ccw) | |
4. Direction: (across (default) | away) | |
5. Subtree can be moved around with ctrl-drag. | |
6. Elementary interactive editing with right-click on node. (temporarily not working) | |
7. Several disconnected trees (forest) with different orientations | |
8. Several branches from the same node, e.g.: `graph [star [a -> [down b c]][a -> [up edges step d e]]]` | |
9. To close perpendiculr gap between children: 'tight (integer!)? e.g `´graph [tight a -> [b c]]` (optional integer! determines tightness) | |
10. To close distance to children: 'close (integer!)? e.g. `graph [close a -> [b c]]` (optional integer! determines closeness) | |
Examples | |
``` | |
graph [50x50 n1 -> [n2 n3 n4]] | |
graph [right edges head 10x10 0 tail 10x10 0 a -> [b c] [star nodes circle d - [e f g h o-> [k l] i]]] | |
``` | |
## Nodes | |
For general options (in scope of block) use e.g. `nodes blue circle` or `nodes font ["Arial" 12] 50x30 maroon box`). | |
To set options for individual node set options in block after node name, e.g. `n1 -> n2 [yellow circle]` | |
1. Initial position: at pair! (before node) | |
2. Form: (ellipse (default) | box | circle | square | big-circle | big-square) | |
3. Color: (<color-word> | tuple! | 'off) | |
4. Size: pair! | |
5. Border: | |
- width: border integer! | |
- color: border (<color-word> | tuple! | 'off) | |
- both together: border [(integer! | <color>)+] | |
6. Corner: integer! (for boxes and squares) | |
7. Text: <node-name> string! (or node-name itself, unless string! is "") | |
8. Font: font integer! | font (word! | tuple!) | font string! ;(`word!` refers to predefined font) | |
| font <style> (('italic | 'bold | 'underline | 'strike) : single or combinations in block) | |
| font [(any combination of mentioned attributes without set-words)] | |
9. If yo want only text as node, use 'no-draw, e.g `graph [a -> b [no-draw]]` or even `graph [nodes no-draw glass a -> b]` | |
Example: | |
``` | |
graph [nodes circle font ["Arial" 10 'bold gold] at 200x50 n1 -> [n2 n3 -> [nodes big-square 5 n4 n5] n6 "6" [brick] -> n7 "" [glass]]] | |
``` | |
## Edges | |
1. For edges you can use -> , <- , <-> or - | |
And now also any combination of `o`, `<`, `>`, `+` and `n` in any end: | |
- `o` circle | |
- `<` arrow or crow, depending on which end | |
- `>` same as previous | |
- `+` cross (bar) | |
- `n` box | |
2. Edge-line: | |
- color: <color-word> | tuple! | 'off | |
- width: integer! | |
- type: 'straight (default) | 'step | |
3. Head/Tail: (head | tail) + some of the following | |
- size: pair! (integer!)? (pair sets dimensions of plain arrowhead, optional integer adds possibilities for pattern; see examples below) | |
- color: (<color-word> | tuple! | 'off) | |
- border-width: integer! | |
- border-color: border (<color-word> | tuple! | 'off) | |
- several preceding attributes: [(<size> | <color> | <border-width> | <border-color>)+] | |
4. Size of head/tail: pair! (integer!)? | |
- `pair!` determines dimensions of the main part | |
- optional `integer!` is interpreted differntly for differnt decorations: | |
+ arrow/crow: determines the slant of the back part (0 - straight) | |
+ circle/box: determines translation of decoration on x-axis | |
+ cross: determines the number of bars | |
5. Form-of edge-line: | |
- straight: 'straight | |
- orthogonal: 'step | |
Default declarations can be separated from proper graph description by a dot if needed, e.g. `graph [away cw edges step nodes box . box -> [b c d]]` | |
Examples: | |
``` | |
graph [[ | |
n1 -> [head 20x10] n2 -> [head 20x10 0] n3 | |
n1 -> n4 -> [head 10x10 5] n5 | |
n1 -> [head 5x10] n6 -> [head 5x10 -5] n7 | |
][ | |
up edges head 10x10 0 tail 10x10 0 | |
a >- b o- c | |
a >- [tail glass 10x10 -7] d +- [tail 6x10 3] e | |
a <- f n- g | |
][ | |
star 20x20 | |
nodes circle edges head 4x4 black tail 3x3 snow | |
at 320x280 x n-o [square "y" z q w p] | |
][ | |
star 20x20 | |
nodes square edges head 6x6 3 black tail 6x6 3 snow | |
at 750x280 b1 >-> [b2 b3 b4 b5] | |
] | |
] | |
graph [edges brick head 20x10 0 gold tail 6x12 -6 sienna . n1 -> [n2 n3 <- n4]] | |
``` | |
} | |
] |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Baby graph DSL
Still half-baked. First naive layouts. Unstable.
Usage:
Graph
pair!
(down (default) | up | right | left | star)
(center | c | clockwise | cw | counter-clockwise | ccw)
(across (default) | away)
graph [star [a -> [down b c]][a -> [up edges step d e]]]
graph [tight a -> [b c]]
(optional integer! determines tightness)graph [close a -> [b c]]
(optional integer! determines closeness)Examples
Nodes
For general options (in scope of block) use e.g.
nodes blue circle
ornodes font ["Arial" 12] 50x30 maroon box
).To set options for individual node set options in block after node name, e.g.
n1 -> n2 [yellow circle]
at pair! (before node)
(ellipse (default) | box | circle | square | big-circle | big-square)
(<color-word> | tuple! | 'off)
pair!
border integer!
border (<color-word> | tuple! | 'off)
border [(integer! | <color>)+]
integer!
(for boxes and squares)<node-name> string!
(or node-name itself, unless string! is "")font integer! | font (word! | tuple!) | font string!
;(word!
refers to predefined font)| font <style> (('italic | 'bold | 'underline | 'strike)
: single or combinations in block)| font [(any combination of mentioned attributes without set-words)]
graph [a -> b [no-draw]]
or evengraph [nodes no-draw glass a -> b]
Example:
Edges
And now also any combination of
o
,<
,>
,+
andn
in any end:o
circle<
arrow or crow, depending on which end>
same as previous+
cross (bar)n
box<color-word> | tuple! | 'off
integer!
'straight (default) | 'step
(head | tail) +
some of the followingpair! (integer!)?
(pair sets dimensions of plain arrowhead, optional integer adds possibilities for pattern; see examples below)(<color-word> | tuple! | 'off)
integer!
border (<color-word> | tuple! | 'off)
[(<size> | <color> | <border-width> | <border-color>)+]
pair! (integer!)?
pair!
determines dimensions of the main partinteger!
is interpreted differntly for differnt decorations:'straight
'step
Default declarations can be separated from proper graph description by a dot if needed, e.g.
graph [away cw edges step nodes box . box -> [b c d]]
Examples: