svg2.r

REBOL []

src: read/string  %lizard.svg; %corner.svg ;

;** Stack operations
pile: tail reduce [copy [pen 0.0.0.255]]	;** by default, no pen color 
rollback: does [pile: back pile]
push: does [clear pile: change/only pile copy []]
pop: func ['v][rollback unless empty? pile/1 [append/only append new-line pile/0 true :v new-line pile/1 true]]
pop-flat: does [rollback out pile/1]
out: func [v][append pile/0 :v]

opacity: fill-opacity: stroke-opacity: stop-opacity: 1			;** full opacity by default

Box: copy [10000x10000 0x0]	;** bounding box used by gradients sometimes
digit: charset "0123456789"
num: [copy &num [opt #"-" some digit opt [#"." any digit] opt [#"e" [#"+" | #"-"] some digit]] (&num: to-decimal &num)]
out-num: [num (out &num)]
unit: [
	opt #"^"" num [
		  "pt"	(&unit: 1.25 * &num)
		| "pc"	(&unit: 15 * &num)
		| "mm"	(&unit: 3.543307 * &num)
		| "cm"	(&unit: 35.43307 * &num)
		| "in"	(&unit: 90 * &num)
		| "%"	(&unit: &num / 100)
		| opt "px" (&unit: &num)	
	] 
]
out-pair: [
	pair 
	(
		bound x y
		out as-pair 0.5 + x 0.5 + y
	)
]
bound: func [{Update the bounding box} x y][		
		box/1/x: min box/1/x x 
		box/2/x: max box/2/x x	
		box/1/y: min box/1/y y 
		box/2/y: max box/2/y y
]
pair: [unit (x: &unit) any [not unit skip] unit (y: &unit)]
_: charset " ^-^/"
__: [some _]

valid-tag: [
	#"<" here: copy tag [any [to [#">" | "=^""] not #">"  2 skip thru #"^""] to #">" ] skip 
	| here: (print ["--Can't load markup at" index? here "--Error:" copy/part here 1000])
	  #"<" any [to [#">" | "=^""] not #">" copy att [2 skip thru #"^""] (?? att) ] thru #">" 
	| (halt)
]

get-attribut: [
	#"^"" copy attribut to #"^"" skip
	| here: (print ["--Can't load the attribut at" index? here "--Error:" copy/part here 50] halt)
]

path: funco [tag /local path node][
	push
	Box: copy [10000x10000 0x0]	;** bounding box
	parse tag [thru " d=" get-attribut (d-block attribut)]
	path: new-line copy pile/0 true
	clear pile/0
	parse tag [thru " style=" get-attribut (style attribut)]
	out path
	pop push
]
cmd: charset [#"a" - #"z" #"A" - #"Z"]
d-block: funco [attribut][
	push
	parse/case attribut [
		some [
			  #"M" any _ (out 'move) out-pair
			| #"C" (out 'curve) some [any _ out-pair ]
			| #"S" (out 'curv) some [any _ out-pair]
			| #"Q" (out 'qcurve) some [any _ out-pair]
			| #"T" (out 'qcurv) some [any _ out-pair]
			| #"L" (out 'line ) some [any _ out-pair]
			| #"H" any _ (out 'hline) out-num
			| #"V" any _ (out 'vline) out-num
			| [#"Z" | #"z"] (out ['move 0x0]) ;** 'move 0x0
			| #"A" any _ out-shape-arc
			| not [cmd | unit] skip
			| not end error: to [#" " | end] (print ["-- Skipped d path:" mold head error] halt) skip 
		]
	]
	pop shape
]
out-shape-arc: use [rx ry large sweep angle][[
	pair (rx: x ry: y) __ unit (angle: &unit)
	__ unit (large: &unit) __ unit (sweep: &unit)
	(out 'arc)
	__ out-pair ;** end-point
	(
		out reduce [rx ry angle]
		if sweep = 1 [out 'sweep]
		if large = 1 [out 'large]
	)
]]
rgb: [#"#" copy &rgb [6 skip] if (attempt [&rgb: to-tuple debase/base &rgb 16])]
fill-url: [
	"url(#" copy url to #")" skip 
	(
		push xlink url rollback
		if all [object? pile/1/1 pile/1/1/id = 'gradient][grad-pen pile/1/1]
		clear pile
		recycle
	)
]
xlink: funco [url /local idx][
	either idx: select ids url [parse at src idx content true][print ["-- url:" url "not found"] false]
]

opacify: func [color [tuple!] factor][color/4: 1 - factor * 255 color]

style: funco [attribut /local savings][
	savings: reduce [opacity fill-opacity stroke-opacity stop-opacity]
	
	parse attribut [	;** At first, refresh all opacity attributes
		some [
			  "opacity:" num (opacity: &num)
			| "fill-opacity:" num (fill-opacity: &num)
			| "stroke-opacity:" num (stroke-opacity: &num)
			| "stop-opacity:" num (stop-opacity: &num)
			| thru #";"
		]
	]
	parse attribut [
		some [
			  "fill:none" (out [fill-pen #[none]])
			| "fill:" [rgb (out 'fill-pen out opacify &rgb (opacity * fill-opacity)) | fill-url]
			| "stroke:none" (out [pen 0.0.0.255])
			| "stroke:" rgb (out 'pen out opacify &rgb (opacity * stroke-opacity) )
			| "stroke-linejoin:miter" (out [line-join miter])
			| "stroke-linejoin:bevel" (out [line-join bevel])
			| "stroke-linejoin:round" (out [line-join round])
			| "stroke-linecap:butt" (out [line-cap butt])
			| "stroke-linecap:square" (out [line-cap square])
			| "stroke-linecap:round" (out [line-cap round])
			| "fill-rule:evenodd" (out [fill-rule even-odd])
			| "fill-rule:nonzero" (out [fill-rule non-zero])
			| "stroke-width:" unit (out 'line-width out max 0.01 &unit)
			| "stop-color:" rgb (out opacify &rgb (opacity * stop-opacity * fill-opacity) )
			| thru #";"
			;| not end copy error thru [#";" | end] (print ["-- Skipped style:" error])
		]
	]
	set [opacity fill-opacity stroke-opacity stop-opacity] savings
]
g-group: funco [tag][
	parse tag [
		thru " transform=" get-attribut (transform attribut) 
	]
]
rect: funco [tag /local x y width height rx ry][
	x: y: width: height: 0
	parse tag [thru " transform=" get-attribut (transform attribut)]
	parse tag [
		thru #" "
		some [
			  some [_ | #"^""]
			| "style=" get-attribut (style attribut)
			| "x=" unit (x: &unit)
			| "y=" unit (y: &unit)
			| "rx=" unit (rx: &unit)
			| "ry=" unit (ry: &unit)
			| "width=" unit (width: &unit)
			| "height=" unit (height: &unit)
			| not end copy error to [#" " | end] skip (print ["-- Skipped rect attribute:" error])
		]
	]
	out reduce ['box as-pair x y as-pair x + width y + height]
	if any [rx ry][out any [rx ry]]	;** corner radius
]
transform: funco [attribut][
	parse attribut [
		some [
			  __
			| matrix
			| translate
			| scale
			| not end copy error thru [#" " | end] (print ["-- Skipped transform:" error])
		]
	]
]
matrix: ["matrix(" (push) out-num 5 [#"," out-num] #")" (pop matrix)]
translate: ["translate(" (out 'translate) out-pair #")"]
scale: ["scale(" (out 'scale) out-num [#"," out-num | (out &num)] #")"]
xlink-href: funco [tag][
	parse tag [thru " xlink:href=^"#" copy url to #"^"" (push xlink url rollback) to end]
]
gradient: funco [tag /local grad][
	push
	out either xlink-href tag [pile/1/1][
		context [
			id: 'gradient
			type: 'linear
			mode: 'normal
			units: "objectBoundingBox" 
			cx: cy: 50%
			x1: y1: x2: y2: fx: fy: none
			r: 50%
			colors: copy []
			matrix: none	;for matrix transformations
		]
	]
	grad: pile/0/1
	parse tag [
		["linear" (grad/type: 'linear) | "radial" (grad/type: 'radial)]	"Gradient"
		any [
			some _
			| {spreadMethod="reflect"} (grad/mode: 'reflect)
			| {spreadMethod="repeat"} (grad/mode: 'repeat)
			| {spreadMethod="pad"} (grad/mode: 'normal)
			| "gradientTransform=" get-attribut (push transform attribut rollback) (
				switch pile/1/1 [
					scale [grad/matrix: reduce [pile/1/2 0 0 pile/1/3 0 0]]
					matrix [grad/matrix: pile/1/2]
				]
			)
			| {gradientUnits="userSpaceOnUse"} (grad/units: "userSpaceOnUse")
			| {gradientUnits="objectBoundingBox"} (grad/units: "objectBoundingBox")
			| "x1=" unit (grad/x1: &unit)
			| "y1=" unit (grad/y1: &unit)
			| "cx=" unit (grad/cx: &unit)
			| "cy=" unit (grad/cy: &unit)
			| "fx=" unit (grad/fx: &unit)
			| "fy=" unit (grad/fy: &unit)
			| "r="  unit (grad/r:  &unit)
			| "x2=" unit (grad/x2: &unit)
			| "y2=" unit (grad/y2: &unit)
			| not end copy error to #" " ;skip (print ["-- Skipped gardient attribute:" error])
		]
	]
]
mulm: func [
	{multiply a matrix [a b c d e f] by coordinates x y, return coordinates [x' y']}
	x y m [block!]
][
	reuse [x * m/1 + (y * m/3) + m/5 x * m/2 + (y * m/4) + m/6]
]
reuse: funco [b [block!]][head reduce/into b clear []]
atan2: func [
	{Angle of the vector (0,0)-(x,y) with artangent y / x. The resulting angle is extended to -pi,+pi}
	x y
][
	if x = 0 [x: 0.0000000001]
	add arctangent y / x pick [0 180] x > 0
]
Project: func [
	{orthogonal projection of a point P on a line AB, return coordinates [x y]}
	ax ay bx by px py
	/local sx sy ux uy ratio
][
	sx: bx - ax
	sy: by - ay
	ux: px - ax
	uy: py - ay
	ratio:  sx * ux + (sy * uy) / (sx * sx + (sy * sy))
	reuse [ratio * sx + ax  ratio * sy + ay]
]
vector-length: func [x1 y1 x2 y2][square-root add x2 - x1 ** 2 y2 - y1  ** 2]

grad-pen: use [id type mode x1 y1 cx cy x2 y2 fx fy r colors matrix units][
	funco [
		{http://www.rebol.net/wiki/Grad-Pen} grad
		/local angle sx sy
	][
		resolve/all bind? 'id grad
		special: copy []
		out 'grad-pen
		out type
		out mode
		switch type [
			linear [
				unless x2 [x2: x1]
				unless y2 [y2: y1]

				if units = "objectBoundingBox" [
					print "Linear objectBoundingBox"
					x1: box/2/x - box/1/x * x1 + box/1/x 
					y1: box/2/y - box/1/y * y1 + box/1/y
					x2: box/2/x - box/1/x * x2 + box/1/x
					y2: box/2/y - box/1/y * y2 + box/1/y
					;** if the roundingBox is not square, we have to calculate a scaling matrix
					;matrix: probe reduce [1 0 0 ( (box/2/y - box/1/y) / (box/2/x - box/1/x)) 0 0]
				]
				
				if matrix [
					; ** apply the matrix on the vector rotated of 90�, then rotate it back,  gives the vector V1
					set [y1' x1'] mulm y1 negate x1 matrix
					set [y2' x2'] mulm y2 negate x2 matrix
					x1': negate x1'
					x2': negate x2'
					;** apply the matrix on the initial vector, gives the vector V2
					set [x1 y1] mulm x1 y1 matrix
					set [x2 y2] mulm x2 y2 matrix
					;** project the vector V2 on the line V1
					set [x1 y1] project x1' y1' x2' y2' x1 y1
					set [x2 y2] project x1' y1' x2' y2' x2 y2
				]

				angle: atan2 x2 - x1 y2 - y1 
				out as-pair x1 y1	;** offset
				out 0				;** start rng
				;out  max abs x2 - x1 * cosine angle  abs y2 - y1 * sine angle
				out vector-length x1 y1 x2 y2 ;** stop rng
				out angle			;** angle
			]
			radial [
				unless fx [fx: cx]
				unless fy [fy: cy]
				if matrix [
					;** The matrix in SVG, is used to produce rotated ellipsoids containing a radial gradient.
					;** Rebol can manage them with 2 scale factors (sx and sy) and an angle used by grad-pen.				
					sx: sy: 1
					angle: 0
					;** Construct 2 vectors (fx,fy  fx,fy+r) and (fx,fy  fx+r,fy) starting at fx,cy
					;** 1 vertical and 1 horizontal of length r

					;** apply the matrix on these 2 vectors (3 points)
					set [x2 y2] mulm fx fy + r matrix
					set [x3 y3] mulm fx + r fy matrix
					set [fx fy] mulm fx fy matrix
					
					;** calculate the scaling transformation on the horizontal vector
					sx: (vector-length fx fy x3 y3) / r
					;** calculate the scaling transformation on the vertical vector
					sy: (vector-length fx fy x2 y2) / r
					
					;** calculate the rotation of the ellipsoid.
					angle: atan2 x3 - fx y3 - fy
				]				
				if units = "objectBoundingBox" [
					print "Radial objectBoundingBox"
					fx: box/2/x - box/1/x * fx + box/1/x
					fy: box/2/y - box/1/y * fy + box/1/x
					r: r * min box/2/x - box/1/x box/2/y - box/1/y 
				]
				out as-pair fx fy	;** offset = focal point
				out 0 		;** start rng
				out r 		;** stop rng = radius
				out angle	;** angle (produces rotated ellipsoids)
				out sx		;** horizontal scaling transformation (produces ellipsoids)
				out sy		;** vertical scaling transformation 
			]
		]
		out reuse [colors]		;** colors
	]
]
child?: does [#"/" <> last tag]
ids: copy []
collect-id: funco [tag idx][
	parse tag [
		thru " id=" get-attribut
		(reduce/into [copy attribut -1 + index? idx] tail ids)
	]
]

stop: funco [tag][
	parse tag [thru " style=" get-attribut (style attribut)]
	parse tag [thru " offset=^"" out-num ]
]
stop-tag: [
	(push) any [to #"<" and ["<stop" _] valid-tag (stop tag)] 
	(rollback pile/0/1/colors: pile/1)
]
content: [
	 and ["<defs" _] valid-tag opt [if (child?) some [to #"<" not "</defs>" [valid-tag (collect-id tag here)]]]
	| "<desc>" copy desc to "</desc>" (s desc) "</desc>"
	| and ["<g" _] valid-tag (push g-group tag)
	| "</g>" (pop push)
	| and ["<path" _] valid-tag (path tag) 
	| and ["<rect" _] valid-tag (rect tag)
	| and ["<radialGradient" _] valid-tag (gradient tag) opt [ 
			if (child?) stop-tag to #"<" "</radialGradient>"
	] (pop-flat)
	| and ["<linearGradient" _] valid-tag (gradient tag) opt [
			if (child?) stop-tag to #"<" "</linearGradient>"
	] (pop-flat)
	| copy error thru [#" " | #">"] ;(print ["-- Skipped tag:" error])
]
svg: funco [tag][
	parse tag [thru " width=" get-attribut (parse attribut [unit (width: &unit)])]
	parse tag [thru " height=" get-attribut (parse attribut [unit (eight: &unit)])]
]
;print: :none
parse src [to "<svg" and ["<svg" _]  valid-tag (svg tag) some [to #"<" not "</svg>" content]]
;write %lizard.r append enbase compress mold/all pile/0 read/string %lizard.r 

init-screen
siz: probe (as-pair width eight)
img: make image! siz
img/rgb: white
img: draw img [ scale 1 1 push pile/0]
;siz: 350x260
 

append screen append make gob! [offset: 50x50 size: siz color: white flags: [resize]] win: make gob! [
	size: siz
	image: img
	;draw: [scale s-x s-y clip 0x0 siz push pile push special] 
	;draw: [scale s-x s-y clip 0x0 siz pen red shape [move start arc point rx ry angle large] push special]
]
;img: draw img [clip 0x0 siz scale 0.6 0.6 push pile/0]
;write %lizard-grad.png encode 'png 
show screen
print "--- showed"
;probe pile/0
do-events
halt


pile: intern first transcode decompress debase enbase compress mold pile/0
;siz: 100x200

rot: funco [x [number!] y [number!] angle [number!]][
	{rotate x y of angle, returns [x' y']}
	reuse [
		subtract x * cosine angle	y * sine angle
		add 	 x * sine angle		y * cosine angle
	]
]
rot-pair: funco [xy [pair!] angle [number!]][xy: rot xy/x xy/y angle as-pair xy/1 + 0.5 xy/2 + 0.5]

sweep: false
sweep: pick [-1 1] sweep
large: true
if large [sweep: negate sweep]
start: 50x50
point: start + 50x0

rx: 40
ry: 20
angle: 40

set [x y]  rot point/x - start/x point/y - start/y 0

;set [rx ry] probe rot rx ry angle

v-angle: atan2 x y
AB: vector-length 0 0 x y
x: AB / 2
y: square-root abs ry * ry - (ry / rx * x ** 2)

probe set [x y] rot x y * negate sweep v-angle

center: rr: as-pair x y 

append special compose/deep [push [
		pen blue ellipse (start + center - as-pair rx ry) (2 * as-pair rx ry)
]]
either not large [
	append special compose [pen blue circle (center + as-pair 0 sweep * ry) 2]
][
	append special compose [
		pen blue circle (start + rot-pair center + rot-pair as-pair 0 negate sweep * ry v-angle angle) 2
		pen blue circle (start + rot-pair center + rot-pair as-pair negate rx 0 v-angle angle) 2
		pen blue circle (start + rot-pair center + rot-pair as-pair rx 0 v-angle angle) 2
	]
]

insert special compose/deep [
	push [
		translate point
		rotate (negate angle)
		translate (negate point)
		pen yellow shape [move start arc point rx ry angle large]
	]
]