REBOL [
	Author: "Shadwolf, AShley, Vincent, Gavin F. MacKenzie "
	purpose: "parser and rendering od SVG files"
	details: {
		The goal of this script is to render 
		SVG file content to screen using
		AGG/draw commands.
		This script use the xml-to-object
		to convert xml SVG structure to a 
		object tree.
		
	}
]


; xml file to rebol  object parser
xml-to-object: function [{
    Convert a series of nested blocks, created from an XML document by
    parse-xml, into a series of nested objects that represent the original 
    content of the XML document processed.

    Returns the root object.
}
    document [block!] "The block representing the processed XML document."
][
    name
    children
    child attr-list
    contains-char-content 
    contains-element-content
    content-model
    potential-new-content
    new-content
    is-allspace
    do-character-content
    do-element-content
    add-mixed-content
    get-mixed-value
][
    is-allspace: function [s] [] [
        either (type? s) = string! [
            s: copy s
        ][
            s: form copy s
        ]
        s: trim/all s
        either (length? s) = 0 [
            return true
        ][
            return false
        ]
    ]

    do-character-content: func [
        children [string!]
    ][
        append new-content reduce [to-set-word 'value? children]
        remove next next document
    ]

    do-empty-content: func [
    ][
        append new-content reduce [to-set-word 'value? ""]
        remove next next document
    ]

    do-element-content: func [
        children [block!]
        /local entry
    ][
        ;
        ; Process all child content of this element
        ;
        forall children [
            potential-new-content: xml-to-object children/1
            ;
            ; Is there already an object member known by this name?
            ; (i.e. does it look like this is the beginning of
            ;  multiply occurring elements?)
            ;
            entry: find new-content (to-set-word potential-new-content/1)
            ;
            ; Yes, there is already an object member known by this name
            ;
            either entry [
                if entry/3 = 'object! [
                    ; ...so we need to transform the existing object member
                    ; from a single object into a block of objects,
                    ; and append the potential-new-content into the block
                    ;
                    change/part at entry 3 reduce ['block! 'reduce] 1
                    change/only at entry 5 reduce [
                        'make 'object! entry/5
                    ]
                ]
                append entry/5 (copy/part at potential-new-content 2 3)
            ][
                append new-content potential-new-content
            ]
        ]
    ]

    add-mixed-content: func [
        children [string! block!]
        /local v
    ][
        either (empty? new-content) or 
               (none? find new-content to-set-word 'content?) [
            append new-content reduce [
                to-set-word 'content? 
                    'make 'block! reduce [children] 
                to-set-word 'value? 
                    'does [get-mixed-value self]
            ]
        ][
            v: find new-content to-set-word 'content?
            either (type? children) = string! [
                append v/4 children
            ][
                append v/4 to-word children/1
            ]
        ]
    ]

    get-mixed-value: function [
        obj [object!]
    ][
        item
        cooked-value?
    ][
        cooked-value?: copy "" 
        foreach item (reduce obj/content?) [
            either (type? item) = string! [
                append cooked-value? item
            ][
                append cooked-value? item/value?
            ]
        ]
        cooked-value?
    ]

    name: to-word document/1
    change document to-set-word document/1

    new-content: copy []
    contains-char-content: false
    contains-element-content: false
    content-model: 'empty

    ;
    ; Extract attributes and children
    ;
    attr-list:  document/2
    children:   document/3
    remove/part next document 2

    ;
    ; Determine the content model
    ;
    if not none? children [
        for i 1 (length? children) 1 [
            child: pick children i
            switch type?/word child [
                string! [
                    content-model: 'character
                    either is-allspace child [
                        contains-char-content: 'ignoreable-ws
                    ][
                        contains-char-content: 'true
                    ]
                ]
                block! [
                    contains-element-content: true
                    content-model: 'element
                ]
            ]
            if (contains-char-content = 'true) and 
               (contains-element-content = true) [
              content-model: 'mixed
              break
            ]
        ]
    ]

    ;
    ; Remove any ignoreable whitespace nodes
    ;
    if (contains-char-content = 'ignoreable-ws) and 
       (contains-element-content = true) [
        content-model: 'element
        while [not tail? children] [
            either (type? children/1) = string! [
                remove children
            ][
                children: next children
            ]
        ]
        children: head children
    ]

    ;
    ; Actually do the work of 'objectifying' the block
    ; 
    switch content-model [
        empty [
            do-empty-content
        ]
        character [
            do-character-content children/1
        ]
        element [
            do-element-content children
        ]
        mixed [
            forall children [
                switch type?/word children/1 [
                    string! [
                        add-mixed-content children/1
                    ]
                    block! [
                        add-mixed-content children/1
                        do-element-content copy/part children 1
                    ]
                ]
            ]
        ]
    ]

    ;
    ; Process attributes
    ;
    if (not none? attr-list) [
        forskip attr-list 2 [
            change attr-list to-set-word attr-list/1
        ]
        attr-list: head attr-list
        append new-content attr-list
    ]

    ;
    ; Insert the result of all our hard work into the block
    ;
    if not empty? new-content [
        insert/only at document 2 new-content
        insert at document 2 reduce ['make 'object!]
    ]
	document
]

; helper function
to-unit: func [s [string!]] [
	switch/default skip tail s -2 [
		"pt"	[1.25 * to decimal! copy/part s -2 + length? s]
		"pc"	[15 * to decimal! copy/part s -2 + length? s]
		"mm"	[3.543307 * to decimal! copy/part s -2 + length? s]
		"cm"	[35.43307 * to decimal! copy/part s -2 + length? s]
		"in"	[90 * to decimal! copy/part s -2 + length? s]
		"px"	[to decimal! copy/part s -2 + length? s]
	][
		to decimal! s
	]
]

to-color: func [s [string!]] [	; converts a string in the form "#FFFFFF" to a 4-byte tuple
		to tuple! load rejoin ["#{" next s "00}"]
	]

to-byte: func [s [string!]] [	; converts a string with a value 0-1 to an inverted byte
		255 - to integer! 255 * to decimal! s
	]

; SVG-to-agg files

; eval style line
eval-style-line: function [val scale-x scale-y] 
[ attr draw-blk  line-width 
	xy x y pen-color fill-color mode
]
[
	draw-blk: []
	xy: 0x0
	size: 0x0
	line-width: 1
	 
	fill-color: pen-color: mode: x: y: none
	foreach [attr val] parse val ":;" [
		switch/default attr [
			"font-size" [ ]
			"stroke" [
				switch/default first val [
					#"#" [pen-color: to-color val]
					#"n" [pen-color: none]
				][
					print ["Unknown stroke:" val]
				]
			]
			"stroke-width" [line-width:  to-unit val 
				if all [ none? pen-color none? fill-color][fill-color: 0.0.0]
			]
			"fill" [
				probe val 
				fill-color: switch/default first val [
					#"#" [to-color val]
					#"n" [none]
					#"u" [ 255.0.0]
				][
					print ["Unknown fill value:" val]
					none
				]
			]
			"fill-rule" [
				mode: switch/default val [
					"evenodd"	['even-odd]
				][
					print ["Unknown fill-rule value:" val]
					none
				]
			]
			"stroke-opacity" [pen-color: any [pen-color 0.0.0.0] pen-color/4: to-byte val]
			"fill-opacity" [fill-color: any [fill-color 0.0.0.0] fill-color/4: to-byte val]
			"stroke-linejoin" [
				insert tail draw-blk switch/default val [
					"miter"		[compose [line-join miter]]
					"round"		[compose [line-join round]]
					"bevel"		[compose [line-join bevel]]
				][
					print ["Unknown stroke-linejoin value:" val]
					none
				]
			]
			"stroke-linecap" [
				insert tail draw-blk 'line-cap
				insert tail draw-blk to word! val
			]
		][
			print ["Unknown style:" attr]
		]
	]
	insert tail draw-blk compose [
		pen (pen-color)
		fill-pen (fill-color)
		fill-rule (mode)
		line-width (line-width * min scale-x scale-y)
		]
	return draw-blk
]

; eval path object
eval-p-blk: function [o-path scale-x scale-y ]
[draw-blk cmd val xy size line-width tmp style-blk shape
rx ry angle sweep large matrix? ]
[
	xy: 0x0
	size: 0x0
	line-width: 1
	rx: ry: angle: sweep: large: pen-color: fill-color: mode: x: y: none
	draw-blk: copy []
	style-blk: copy [] 
	tmp: first o-path 
	matrix?: false
	; eval style field
	closed?: false
	foreach cmd tmp [
		switch cmd [
			style [	val: o-path/style
				insert tail style-blk eval-style-line val scale-x scale-y
			]
			transform [
				print "Found TRansform field in PATH TAG"
				val: o-path/transform
				matrix?: true
				insert tail draw-blk eval-transform o-path/transform scale-x scale-y
			]
			d [
				val: o-path/d
				x: y: none
				shape: copy []
				closed?: false
				if find val "," [ ; adapattion routine to adapt inkscape format for d= code...
						print "INK SCAPE FORMAT FOUND"
						val: parse val ","
						b: ""
						forall val [
							b: either empty? b [val/1][rejoin [b " " val/1]]
						] 
						val: copy b b: none
						]
				pair: [set x number! set y number! (insert tail shape as-pair scale-x * x scale-y * y)]
				add-command: func [token [word!] command [word!]][
					insert tail shape either (first form token) = first uppercase form token
						[command][to-lit-word command]
				]
				parse load val [
					any [
						[set token 'A (add-command token 'arc ) any [
							set rx number! set ry number! set angle number! set large number! set sweep number!
							set x number! set y number! (insert tail shape  compose [(as-pair scale-x * x scale-y * y) (rx * scale-x) (ry *  scale-y) (angle) (to-logic sweep) (to-logic large) ] ) 
						]] |
						[set token 'M (add-command token 'move)   any pair] |
						[set token 'L (add-command token 'line)   any pair] |
						[set token 'H (add-command token 'hline)  any [
							set x number! (insert tail shape scale-x * x)]
						] |
						[set token 'V (add-command token 'vline)  any [
							set y number! (insert tail shape scale-y * y)]
						] |
						[set token 'C (add-command token 'curve)  any pair] |
						[set token 'S (add-command token 'curv)   any pair] |
						[set token 'Q (add-command token 'qcurve) any pair] |
						[set token 'T (add-command token 'qcurv)  any pair] |
						'z (closed?: true) |
						set token 1 skip 
							(unless number? token [print ["Unknown path command:" token]])
					]
				]
			]
		]
	]
	;treatement for d field
	unless closed? [insert tail shape reduce ['move 0x0]]
	if not empty?  style-blk [insert tail draw-blk style-blk ]
	insert tail draw-blk compose/only [ shape (shape)] 
	either matrix? [return compose/only [push (draw-blk) ] ]
	[return draw-blk]
]
eval-rect-blk: function [o-rect scale-x scale-y ]
[ xy x y size radius fi draw-blk ]
[	xy: 0x0
	size: 0x0 x: y: radius: none draw-blk: copy []
	foreach fi first o-rect [
		switch fi [
			x	    [xy/x: scale-x * to-unit o-rect/x]
			y		[xy/y: scale-y * to-unit o-rect/y]
			width	[size/x: scale-x * to-unit o-rect/width]
			height	[size/y: scale-y * to-unit o-rect/height]
			rx		[print "rx"]
			ry		[radius: to decimal! o-rect/ry]
			style   [ insert tail draw-blk eval-style-line o-rect/style scale-x scale-y]
		]
	]
	insert tail draw-blk compose [box (xy) (xy + size)]
	if radius [insert tail draw-blk radius]
	return draw-blk
]

eval-ellipse-blk: function [o-elli scale-x scale-y]
[xy radius fi cx cy o draw-blk]
[
	xy: 0x0 radius: 0x0
	draw-blk: copy []
	;probe "found ellipse" halt
	o: first o-elli
	probe o
	probe o-elli/rx
	foreach fi o [
		switch fi [
			cx	    [xy/x: scale-x * to-unit o-elli/cx]
			cy		[xy/y: scale-y * to-unit o-elli/cy]
			rx		[radius/x: scale-x  * to-unit o-elli/rx]
			ry		[radius/y: scale-y * to-unit o-elli/ry]
			style   [ insert tail draw-blk eval-style-line o-elli/style scale-x scale-y]
		]
	]
	insert tail draw-blk compose [ ellipse (xy) (radius)]
	return draw-blk
]
eval-transform: function [o-trans scale-x scale-y]
[draw-blk val a b]
[
	draw-blk: copy []
	;probe o-trans halt
	val: copy o-trans
	val: parse val "(),"
	a: copy first val
	switch a [
		"matrix" [ remove val 1 insert tail draw-blk compose/only [ matrix (compose/only [(to-unit val/1) (to-unit val/2) (to-unit val/3) ( to-unit val/4) (scale-x * to-unit val/5) (scale-y * to-unit val/6)]) ]   ]
	]
	return draw-blk
]

; eval rect tag 
switch-tag: function [command tag-ob o-path scale-x scale-y][draw-blk cmd path-tmp a g-blk ][
	draw-blk: copy []
	g-blk: copy []
	switch command [
		defs [ probe "found defs tag" ;defs treatment collect gradient infos
			 ;probe tag-ob
		]
		transform [print " found tranform tag!!"
			probe tag-ob
			insert tail draw-blk eval-transform tag-ob scale-x scale-y 
		]
		ellipse [ print "found ellipse tag !!!"
				insert tail draw-blk eval-ellipse-blk tag-ob scale-x scale-y
		]
		rect [print "found rect tag !!!'"
			insert tail draw-blk eval-rect-blk tag-ob scale-x scale-y
		]
		path [ print "found path tag!!!'"
			insert tail draw-blk eval-p-blk tag-ob scale-x scale-y
		]
		g [print "found G tag !!!'"
			;insert tail draw-blk eval-g-blk tag-ob o-path scale-x scale-y
			a: sort/reverse first do to-path o-path 
			foreach cmd a [
				path-tmp: copy o-path 
				insert tail  path-tmp cmd
				tag-ob: do to-path path-tmp
				insert tail g-blk process-tag cmd tag-ob path-tmp scale-x scale-y
			]
			insert tail draw-blk compose/only [push (g-blk)] 
		]
	]
	return draw-blk
]

process-tag: function [command tag-ob o-path scale-x scale-y]
[draw-blk sz tag-o tmp-tag-ob tmp-path]
[
	draw-blk: copy []
	probe tag-ob
	either object? tag-ob[
		insert tail draw-blk switch-tag command tag-ob o-path scale-x scale-y
	][
		either command == 'g [
			probe command probe "object? !!"
			sz: length? tag-ob
			for i 1 sz 1 [
				tmp-path: copy o-path 
				insert tail tmp-path :i
				tmp-tag-ob: do to-path tmp-path
				insert tail draw-blk switch-tag command tmp-tag-ob tmp-path scale-x scale-y
			]
		][
			either string? tag-ob [
				insert tail draw-blk switch-tag command tag-ob o-path scale-x scale-y
			][
				foreach tag-o tag-ob [
					insert tail draw-blk switch-tag command tag-o o-path scale-x scale-y
			]]]]
	return draw-blk
]


; fonction that converts SVG information to Draw block!

load-svg: function [svg-file [file! string!] size [pair!]] [
	x y data-blk draw-blk  scale-x scale-y to-parse command ob-path-tmp
	ob-path-str
][
	;probe "SVG-FILE:"
	;probe svg-file
	if file? svg-file [
		svg-file: read svg-file
	]
	if not find svg-file "<svg" [print "Error file is not an SVG format compliant" halt]
	do xml-to-object parse-xml svg-file
	xml: document
	
	;probe first xml/svg
	svg-size: as-pair to-unit xml/svg/width  to-unit xml/svg/height
	
	x: to-unit xml/svg/x
	y: to-unit xml/svg/y
	
	scale-x: size/x / svg-size/x
	scale-y: size/y / svg-size/y
	
	draw-blk: copy []
	
	probe scale-x probe scale-y
	
	data-blk: first xml/svg
	ob-path-str: [ xml svg ]
	
	foreach command data-blk [
		;probe command
		ob-path-tmp: copy ob-path-str
		insert tail ob-path-tmp command
		to-parse: do to-path ob-path-tmp
		insert tail draw-blk process-tag command to-parse ob-path-tmp scale-x scale-y
	]
	return draw-blk
]
; main windget (program starter ;))

view titi: make face [
	offset:	100x100
	size:	200x200
	action:	request-file/filter/only "*.svg"
	text:	rejoin ["SVG Demo [" last split-path action "]"]
	data:	read action
	color:	white
	effect: [ draw []];compose/only [draw (load-svg data size)]
	edge: font: para: none
	feel: make feel [
		redraw: func [face act pos] [
			if act = 'draw 
			[insert clear face/effect/draw load-svg face/data face/size]
		]
	]
	options: [resize]
]