proto-arrows.red

Red [
	Needs: View
	Author: "Toomas Vooglaid"
	Date: 2018-01-07
	Purpose: {Experimenting with arrowheads}
]
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 [
		box [
			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 [cent/x]
	]
]
arrow: function [start end face][
	s: start/offset + (start/size / 2) - face/offset
	e: end/offset + (end/size / 2) - face/offset
	ang: angle s e
	dims: e - s
	in-s: round/to inner start ang 1
	in-e: round/to inner end ang 1
	len: (sqrt (power dims/x 2) + (power dims/y 2)) - in-s - in-e
	len: as-pair len 0
	compose/deep [
		translate (s) 
		rotate (ang) 
		translate (as-pair in-s 0)
		shape [move 0x0 'line 10x-5 'move 0x10 'line -10x-5]
		shape [move (len) 'line -10x-5 'move 0x10 'line 10x-5]
		line 0x0 (len) 
	]
]
lay: layout compose/only [
	size 300x200
	at 125x80 b: box 70x40 loose draw [
		fill-pen brick box 0x0 69x39
	] with [extra: 'box] 
	at 10x10 c: box 40x40 loose draw [
		fill-pen mint ellipse 0x0 39x39
	] with [extra: 'circle]
]
clear-reactions
insert lay/pane layout/only [
	at 0x0 box react [
		face/offset: as-pair 
			min b/offset/x c/offset/x  
			min b/offset/y c/offset/y
		face/size: subtract as-pair 
			max b/offset/x + b/size/x c/offset/x + c/size/x
			max b/offset/y + b/size/y c/offset/y + c/size/y
			face/offset
		face/draw: arrow c b face
	]
]
view/tight lay