l-system.red

Red [
	Author: "Toomas Vooglaid"
	Date: 25-9-2017
	Description: {Experiments with L-System}
]
ctx: context [
	scale: origin: length: len: angle: width: delta-width: times-length: delta-length: delta-angle: aliasing?: stack: commands: none
	defaults: [
		scale 	2.0
		origin 	300x500
		length 	0x100
		len 	100
		angle 	90;22.5;45;
		width 	1
		delta-width 	1
		times-length 	2
		delta-length 	0x10
		delta-angle 	15
		aliasing? yes
	]
	drawing: [
		#"U" [line 0x0 (length) translate (length)]
		#"L" [line 0x0 (length) translate (length)]
		#"M" [translate (length)]
		#"l" ['line (length)]
		#"h" ['hline (len)]
		#"v" ['vline (len)]
		#"m" ['move (length)]
		#"+" [rotate (negate angle)]
		#"-" [rotate (angle)]
		#"|" [rotate 180]
		#"&" [swap next find drawing #"+" next find drawing #"-"]
		;#"[" []
		;#"]" []
		#"#" [line-width (width: width + delta-width)]
		#"!" [line-width (width: width - delta-width)]
		#"@" [circle 0x0 (width)]
		;#"{" []
		;#"}" []
		#">" [length: length * times-length len: len * times-length]
		#"<" [length: length / times-length len: len / times-length]
		#"(" [angle: angle - delta-angle]
		#")" [angle: angle + delta-angle]
		#"´" [length: length + delta-length len: len + delta-length]
		#"`" [length: length - delta-length len: len - delta-length]
	]
	set 'l-system func [str iter /with opts /local word value scl1 scl2 cmd][
		stack: copy [] commands: copy []
		foreach [word value] self/defaults [self/:word: value]
		put drawing #"+" [rotate (negate angle)]
		put drawing #"-" [rotate (angle)]
		
		if with [foreach [word value] opts [self/:word: value]]
		length: either iter > 0 [length / (2 * iter)][length]
		if iter > 0 [
			str: loop iter [
				str: rejoin parse/case str compose [
					collect some [
						set elem skip 
						if (find extract language 2 elem) 
							keep (select language elem) 
					| 	keep skip
					]
		]	]	]
		;probe str
		parse str [some [
			set symb skip [
				if (find [#"<" #">" #"&" #"(" #")" #"´" #"`"] symb) (do select drawing symb)
			|	if (find [#"[" #"{"] symb) (insert/only stack commands commands: copy []) 
			|	if (find [#"]" #"}"] symb) (
					commands: either empty? commands [
						take stack
					][
						switch symb [
							#"]" [append append/only append take stack 'push copy commands [pen black]]
							#"}" [append/only append take stack 'shape head insert copy commands [move 0x0]]
						]
					]
				)
			|	(append commands compose/deep either cmd: select drawing symb [cmd][[]])
			]
		]]
		;probe commands
		scl1: scl2: either iter > 0 [scale / iter][scale]
		view/no-wait compose/deep [
			image 700x600 
			draw [
				anti-alias (aliasing?) 
				;line-width (width)
				matrix [(scl1) 0 0 (negate scl2) (origin/x) (origin/y)]
				(commands)
			]
		]
	]
]
comment {
; Blocky 1
language: [#"L" "L+L-L-LL+L+L-L"]
l-system/with "L+L+L+L" iter: 3 opts: [angle 90 length 0x100 scale 1.0 origin 200x450]
;-----------
; Blocky 2
language: [#"L" "LL+L-L+L+LL"] ; FF-F+F-F-FF
l-system/with "L+L+L+L" iter: 4 opts: [angle 90 length 100x0 scale 2.0 origin 200x300]
;-----------
; Weed 1
language: [
	#"L" "LL"
	#"X" "L-[[X]+X]+L[+LX]-X" ;F-[[X]+X]+F[+FX]-X
]
l-system/with "X" iter: 6 opts: [angle 22.5 length 30x100 scale 2.0 origin 300x570]
; Weed in wind
language: [
	#"L" "LL"
	#"X" "L-[[X]-X]+L[-LX]-X" ;F-[[X]+X]+F[+FX]-X
]
l-system/with "&X" iter: 6 opts: [angle 22.5 length 30x100 scale 2.0 origin 300x570]
;-----------
; Weed 3
language: [
	#"U" "L[+U]-U"
	#"L" "LL"
]
l-system/with "U" 7 opts: [angle 45 length 0x100 scale 3.0 origin 350x580]
;-----------
; Spiral
language: [#"L" "L+U" #"U" "´L+U"] l-system/with "L" 5 [origin 350x300 scale 4.0]
;-----------
; Koch curve
language: [#"L" "L-L+L+L-L"] l-system/with "+L" 3 [angle 90 origin 150x380]
;-----------
; Sierpinski
language: [#"L" "L-U+L+U-L" #"U" "UU"] 
l-system/with "L-U-U" 6 [length 100x0 angle 120 origin 50x580 scale 6.0]
}