Toy diagramming tool

diagram.red

Red [
	Author: "Toomas Vooglaid"
	Started: 2018-05-17
]
context [
	pan: dat: typ: category: cat: cats: sers: num: y-unit: x-unit: x-unit2: x-scale: y-scale: n: sum: swapped: transp: none
	series: make block! 30
	categories: make block! 30
	numbers: make block! 150
	dia-type: "bar"
	_max: func [blk /local m][m: pick [0 0x0] number? blk/1 forall blk [m: max m blk/1] m]
	_max2: func [blk1 blk2][forall blk1 [blk1/1: max blk1/1 get blk2/(index? blk1)]]
	_sum: func [blk /local m][m: pick [0 0x0] number? blk/1 forall blk [m: m + blk/1] m]
	_sum2: func [blk1 blk2][forall blk1 [blk1/1: blk1/1 + get blk2/(index? blk1)]]
	dummy-text: make face! [type: 'text]
	colors: reduce [brick water gold leaf papaya mint wheat rebolor sky sienna brown yellow forest aqua red green blue crimson khaki teal]
	forall colors [colors/1: as-rgba colors/1/1 colors/1/2 colors/1/3 0]
	make-x-scale: has [x-dim size][
		clear y-scale/pane
		clear x-scale/pane
		cats: pick reduce [series categories] swapped/data
		sers: pick reduce [categories series] swapped/data
		unless 0 = length? cats [
			x-dim: either horizontal/data [
				bac/draw/3/y - bac/draw/2/y - 10
			][
				bac/draw/4/x - bac/draw/3/x - 10
			]
			x-unit: x-dim / (length? cats)
			unless pair? numbers/1 [
				either horizontal/data [
					y-scale/pane: layout/only collect [
						keep compose [style t: text left (as-pair y-scale/size/x 24)]
						forall cats [
							dummy-text/text: form cats/1 
							size: size-text dummy-text
							keep reduce [
								'at as-pair 0 (index? cats) * x-unit - (x-unit / 2)  ;y-scale/size/x - size/x ;- (size/y / 2)
								't dummy-text/text
							]
						]
					]
				][
					x-scale/pane: layout/only collect [
						keep compose [style t: text (as-pair x-unit 24)]
						forall cats [
							dummy-text/text: form cats/1 
							size: size-text dummy-text
							keep reduce [
								'at as-pair (index? cats) * x-unit - (x-unit / 2) - (size/x / 2) 0 
								't dummy-text/text
							]
						]
					]
				]
			]
		]
	]
	make-y-scale: has [upp y-dim x-dim][
		case [
			stacked/data [  
				cols: collect [repeat i length? cats [keep to-word rejoin ["_" i]]]
				acc: collect [loop length? cols [keep either pair? numbers/1 [0x0][0]]]
				foreach (cols) numbers [_sum2 acc cols]
				upp: _max acc
			]
			true	[upp: _max numbers	sum: _sum numbers]
		]
		y-dim: either horizontal/data [
			bac/draw/4/x - bac/draw/3/x - 10
		][
			bac/draw/3/y - bac/draw/2/y - 10
		]
		y-unit: 1.0 * y-dim / either number? upp [upp][upp/y]
		if pair? numbers/1 [
			x-dim: either horizontal/data [
				bac/draw/3/y - bac/draw/2/y - 10
			][
				bac/draw/4/x - bac/draw/3/x - 10
			]
			x-unit2: 1.0 * x-dim / upp/x
		]
		;probe reduce [x-dim y-dim x-unit2 y-unit]
		;clng: to-integer round/ceiling upp
		;lclng: length? form clng
		;probe flr: load rejoin ["1" form append/dup copy "" #"0" lclng - 1]
	]
	make-diagram: has [s s1 s2 t t1 t2 pair1 pair2 idx lcategories lseries lc lc0 inumbers i j][
		lcategories: length? cats
		lseries: length? sers
		lc: lc0: negate 1.0 * lseries / 2 + .5
		case [
			horizontal/data [dia/draw/2/4: 1 dia/draw/2/6: 10]
			true [dia/draw/2/4: -1 dia/draw/2/6: dia/size/y]
		]
		switch dia-type [
			"line" or "spline" [
				collect/into [
					keep [line-width 2]
					forall numbers [
						inumbers: index? numbers
						if (idx: inumbers - 1 % lcategories + 1) = 1 [
							keep compose [pen (colors/(inumbers - 1 / lcategories + 1)) (to-word dia-type)]
						]
						keep reduce [
							either pair? numbers/1 [
								either horizontal/data [
									as-pair y-unit * numbers/1/2 x-unit2 * numbers/1/1
								][
									as-pair x-unit2 * numbers/1/1 y-unit * numbers/1/2
								]
							][
								either horizontal/data [
									as-pair y-unit * numbers/1 idx * x-unit - (x-unit / 2) 
								][
									as-pair idx * x-unit - (x-unit / 2) y-unit * numbers/1
								]
							]
						]
					]
				] clear at dia/draw 3
			]
			"bar" [
				collect/into [
					i: 0 t2: 0
					if horizontal/data and pair? numbers/1 [dia/draw/2/4: -1 dia/draw/2/6: dia/size/y]
					forall numbers [
						inumbers: index? numbers
						if 1 = (idx: inumbers - 1 % lcategories + 1) [
							lc: lc0 t2: 0
							j: (30 * lc: lc + (i: i + 1))
							keep reduce ['fill-pen colors/(inumbers - 1 / lcategories + 1)]
						]
						either pair? numbers/1 [
							either horizontal/data [
								keep reduce ['box 0x0 as-pair y-unit * numbers/1/2 x-unit2 * numbers/1/1]
							][
								keep reduce ['box 0x0 as-pair x-unit2 * numbers/1/1 y-unit * numbers/1/2]
							]
						][
							either stacked/data [
								probe "stacked"
								s: idx * x-unit - (x-unit / 2)
								s1: s - 10 s2: s + 10
								t1: t2
								t: y-unit * numbers/1
								t2: t2 + t
								x1: s1 y1: t1 x2: s2 y2: t2
							][
								probe "ordinary"
								s: idx * x-unit - (x-unit / 2) + j
								s1: s - 10 s2: s + 10
								t: y-unit * numbers/1
								x1: s1 y1: 0 x2: s2 y2: t
							]
							either horizontal/data [
								pair1: as-pair y1 x1 pair2: as-pair y2 x2 
								;keep reduce ['box as-pair 0 s1 as-pair t s2]
							][
								probe pair1: as-pair x1 y1 probe pair2: as-pair x2 y2 
								;keep reduce ['box as-pair s1 0 as-pair s2 t]
							]
							keep reduce ['box pair1 pair2]
							;either horizontal/data [
							;	keep reduce ['box as-pair 0 (s: idx * x-unit - (x-unit / 2) + j) - 10 as-pair y-unit * numbers/1 s + 10]
							;][
							;	keep reduce ['box as-pair (s: idx * x-unit - (x-unit / 2) + j) - 10 0 as-pair s + 10 y-unit * numbers/1]
							;]
						]
					]
				] clear at dia/draw 3
			]
			"box" [
				collect/into [
					i: 0
					if horizontal/data and pair? numbers/1 [dia/draw/2/4: -1 dia/draw/2/6: dia/size/y]
					forall numbers [
						inumbers: index? numbers
						if 1 = (idx: inumbers - 1 % lcategories + 1) [
							lc: lc0
							j: (30 * lc: lc + (i: i + 1))
							keep reduce ['fill-pen colors/(inumbers - 1 / lcategories + 1)]
						]
						either pair? numbers/1 [
							either horizontal/data [
								keep reduce ['box 0x0 as-pair y-unit * numbers/1/2 x-unit2 * numbers/1/1]
							][
								keep reduce ['box 0x0 as-pair x-unit2 * numbers/1/1 y-unit * numbers/1/2]
							]
						][
							either horizontal/data [
								keep reduce ['box as-pair 0 (s: idx * x-unit - (x-unit / 2) + j) - 10 as-pair y-unit * numbers/1 s + 10]
							][
								keep reduce ['box as-pair (s: idx * x-unit - (x-unit / 2) + j) - 10 0 as-pair s + 10 y-unit * numbers/1]
							]
						]
					]
				] clear at dia/draw 3
			]
			"pie" [
				coef: 360.0 / sum
				start: 90
				cent: dia/size / 2
				radius: min cent/x cent/y
				collect/into [
					forall numbers [
						inumbers: index? numbers
						degrees: negate round/to numbers/1 * coef 1
						keep reduce [
							'fill-pen colors/:inumbers
							'arc cent as-pair radius radius start degrees 'closed
						]
						start: start + degrees
					]
				] clear at dia/draw 3
			]
			"points" [
				collect/into [
					forall numbers [
						inumbers: index? numbers
						if (idx: inumbers - 1 % lcategories + 1) = 1 [
							keep compose [pen (colors/(inumbers - 1 / lcategories + 1))]
						]
						either pair? numbers/1 [
							either horizontal/data [
								keep reduce ['circle as-pair y-unit * numbers/1/2 x-unit2 * numbers/1/1 1]
							][
								keep reduce ['circle as-pair x-unit2 * numbers/1/1 y-unit * numbers/1/2 1]
							]
						][
							either horizontal/data [
								keep reduce ['circle as-pair y-unit * numbers/1 idx * x-unit - (x-unit / 2) 1]
							][
								keep reduce ['circle as-pair idx * x-unit - (x-unit / 2) y-unit * numbers/1 1]
							]
						]
					]
				] clear at dia/draw 3
			]
			"radar" [
				collect/into [
					forall numbers [
						inumbers: index? numbers
						if (idx: inumbers - 1 % lcategories + 1) = 1 [
							keep compose [pen (colors/(inumbers - 1 / lcategories + 1))]
						]
						either pair? numbers/1 [
							keep reduce []
						][
							
						]
					]
				] clear at dia/draw 3
			]
		]
		probe dia/draw
	]
	rule: [
		[	set series block! set categories block! set numbers block! ;()
		|	(series: make block! 30) 
			set categories block! 
			set numbers block! 
			(repeat n (length? numbers) / (length? categories) [append series n])
		|	(clear categories clear series clear numbers) 
			some [
				set cat [all-word! | any-string! | char! | date! | time!] 
				[
					set num [number! | pair!] (append categories cat append numbers num)
				|	set num block! (append series cat append/only numbers num)
				]
			] (if empty? series [repeat n (length? numbers) / (length? categories) [append series n]])
		|	(clear numbers) 
			some [
				set num [number! | pair!] (append numbers num append categories length? numbers)
			] (repeat n (length? numbers) / (length? categories) [append series n])
		] 	(make-x-scale make-y-scale make-diagram)
	]
	win: layout [;/options
		title "Diagram"
		size 600x500
		group-box "Type" [
			style typ: radio 60x23 [
				dia-type: face/text unless empty? dat/text [
					make-x-scale make-y-scale make-diagram 
					do-actor transp event 'change
				]
			]
			typ "Points" typ "Line" typ "Spline" typ "Area" typ "Bar" data true typ "Box" ;typ "pie" typ "radar"
		] 
		group-box "Transparent:" [
			transp: slider 100x24 data 0.0 [
				f: dia/draw while [f: find next f tuple!][f/1/4: round/to 255 * transp/data 1]
			]
		]
		;group-box "Direction" [vertical: radio "Vertical" data true horizontal: radio "Horizontal"]
		;group-box "Form" [rec: radio "Rectangular" data true circ: radio "Circular"] 
		return
		text "Data:" 
		style chk: check [
			make-x-scale make-y-scale make-diagram 
			do-actor transp event 'change
		]
		swapped: chk "Swapped"
		horizontal: chk "Horizontal"
		radial: chk "Radial"
		stacked: chk "Stacked"
		shw: button "Show" [
			either empty? dat/text [
				cause-error 'user 'message ["Nothing to show!"]
			][
				parse load dat/text rule 
				do-actor transp event 'change
			]
		] return
		dat: area 580x50 focus
		return
		pan: panel 580x352 [
			origin 0x0 space 0x0
			at 50x310 x-scale: panel 480x30 []
			at 10x50 y-scale: panel 50x250 []
			at 50x50 dia: base snow 480x250 draw [matrix [1 0 0 -1 0 250]]
			at 0x0 bac: box 580x352 draw [
				line 50x50 50x300 520x300 shape [
					move 45x55 line 50x50 55x55 move 45x45
				] shape [
					move 515x295 line 520x300 515x305 move 515x295
				]
			]
		]
		do [shw/offset/x: 528];append pan/pane layout/only arrows 
	]
comment {
	[
		actors: object [
			on-resizing: func [face event][
				pan/size: bac/size: win/size - pan/offset - 10
				dia/size: bac/size - dia/offset - 59x52
				unless horizontal/data [dia/draw/2/6: dia/size/y]
				dat/size/x: win/size/x - 20
				shw/offset/x: win/size/x - shw/size/x - 10
				bac/draw/3/y: bac/draw/4/y: bac/draw/8/4/y: bac/size/y - 52
				bac/draw/4/x: bac/draw/8/4/x: bac/size/x - 60
				bac/draw/8/2: bac/draw/8/7: bac/size - 65x57
				bac/draw/8/5: bac/size - 65x47
				x-scale/offset/y: bac/draw/3/y + 10
				x-scale/size/x: pan/size/x - 50
				y-scale/size/y: pan/size/y - y-scale/offset/y - 52
				make-x-scale make-y-scale make-diagram
				do-actor transp event 'change
			]
		]
	]
}
	view win ;/flags[resize] 
]
comment {
	(<series-block> <categories-block> <numbers-block>
	| <categories-block> <numbers-block>
	| (<series-name> <numbers-block>)+
	| (<category-name> <number>)+
	| <number>+)
	
	<series-block>: [<series-name>+]
	<series-name>: (all-word! | any-string! | char! | date! | time!)
	<categories-block>: [<category-name>+]
	<category-name>: (all-word! | any-string! | char! | date! | time!)
	<numbers-block>: [<number>+]
	<number>: (integer! | float! | percent! | pair!)
	
	; Examples of data
	[a b c][83x31 12x42 77x11 36x51 3x7 40x6]
}

Unfinished and buggy

Examples of data:

10 20 15 43 22

[a b c d e][10 20 15 43 22]

[one two three four][a b c][1 2 3 4 5 6 7 8 9 10 11 12]