Toy graph DSL

graph.red

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]]
```

}
]

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]]