Skip to content

Instantly share code, notes, and snippets.

@rgchris rgchris/svg.red
Last active Jan 25, 2020

Embed
What would you like to do?
Red SVG loader/converter
Red [
Title: "SVG Tools"
Date: 24-Jan-2020
Author: "Christopher Ross-Gill"
Rights: http://opensource.org/licenses/Apache-2.0
Version: 0.3.1
History: [
0.3.1 24-Jan-2020 "PATH model rewrite; VIEW wrapper to view an SVG"
0.3.0 23-Jan-2020 "Reorganise PATH handling; render whole/partial object; further refactoring"
0.2.2 13-Sep-2019 "Some functions for manipulating paths; refactoring"
0.2.1 26-Aug-2019 "Set Stroke/Fill off by default; handle numbers with units; open paths"
0.2.0 25-Aug-2019 "Text support in TO-DRAW"
0.1.0 23-Dec-2018 "Rudimentary Shape Support"
]
]
#macro _: func [][none] ; literal for NONE!
do either exists? %altxml.red [%altxml.red][
https://raw.githubusercontent.com/rgchris/Scripts/master/experimental/altxml.red
]
do either exists? %rsp.red [%rsp.red][
https://raw.githubusercontent.com/rgchris/Scripts/master/red/rsp.red
]
neaten: func [
block [block!] /pairs /flat /words
][
either words [
forall block [
new-line block to logic! all [
any-word? block/1
not find [off] block/1
]
]
][
new-line/all/skip block not flat either pairs [2] [1]
]
head block
]
svg: make object! [
; quickie number parsing
; number*: charset "-.0123456789eE"
name*: complement charset {^-^/^L^M "',;}
spacers*: charset "^-^/^L^M "
digit*: charset "0123456789"
hex*: charset "0123456789abcdefABCDEF"
space*: [
some spacers*
]
comma*: [
space* opt #"," opt space*
|
#"," opt space*
]
unsigned*: [
[
some digit* opt #"." any digit*
|
#"." some digit*
]
opt [
[#"e" | #"E"] opt [#"-" | #"+"] some digit*
]
]
number*: [
opt [#"+" | #"-"] unsigned*
]
as-number: func [
value [string! integer! float! percent!]
][
if string? value [
value: load value
]
switch type?/word value [
; default rounding is bad, it has a destructive
; influence on relative path values
float! percent! [round/to value 0.001]
integer! [value]
]
]
is-value-from: func [
value [string!]
list [block!]
][
if find list value [load value]
]
fail-mark: _
fail-if-not-end: [
end
|
fail-mark: (
do make error! rejoin [
"Parse Error: " copy/part mold fail-mark 30
]
)
]
paths: make object! [
comment {
MDN Overview: https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/d
SVG (1.1): https://www.w3.org/TR/SVG11/paths.html#PathDataBNF
SVG (2--incomplete as-of 22-Jan-2020): https://www.w3.org/TR/SVG/paths.html#PathDataBNF
Length: evaluate https://github.com/MadLittleMods/svg-curve-lib
}
command: _
relative?: _
implicit?: _
offset: _
origin: _
params: _
stack: make block! 8
precision: 0.001
mark: value: _
commands: #(
#"M" move #"m" 'move
#"Z" close #"z" 'close
#"L" line #"l" 'line
#"H" hline #"h" 'hline
#"V" vline #"v" 'vline
#"C" curve #"c" 'curve
#"S" curv #"s" 'curv
#"Q" qcurve #"q" 'qcurve
#"T" qcurv #"t" 'qcurv
#"A" arc #"a" 'arc
)
fail: func [message [string!]][
do make error! rejoin [
message ": (" any [command #"_"] ") " mold copy/part mark 30
]
]
; Unit Products
flag: [
[#"0" (append stack false) | #"1" (append stack true)]
|
(fail "Could not consume flag")
]
nonnegative-number: [
copy value unsigned*
(append stack as-number value)
|
(fail "Could not consume non-negative number")
]
number: [
copy value number*
(append stack as-number value)
|
mark: (fail "Could not consume number")
]
; Parameter Templates
coordinate: [
number
]
coordinate-pair: [
coordinate
opt comma*
coordinate
]
coordinate-pair-double: [
coordinate-pair
opt comma*
coordinate-pair
]
coordinate-pair-triple: [
coordinate-pair
opt comma*
coordinate-pair
opt comma*
coordinate-pair
]
elliptical-arc-sequence: [
nonnegative-number
opt comma*
nonnegative-number
opt comma*
number
comma*
flag
opt comma*
flag
opt comma*
coordinate-pair
]
; Commands
move-to: [
[#"M" | #"m"] (params: coordinate-pair)
]
close-path: [
[#"Z" | #"z"] (params: [])
]
line-to: [
[#"L" | #"l"] (params: coordinate-pair)
]
horizontal-line-to: [
[#"H" | #"h"] (params: coordinate)
]
vertical-line-to: [
[#"V" | #"v"] (params: coordinate)
]
curve-to: [
[#"C" | #"c"] (params: coordinate-pair-triple)
]
smooth-curve-to: [
[#"S" | #"s"] (params: coordinate-pair-double)
]
quadratic-bezier-curve-to: [
[#"Q" | #"q"] (params: coordinate-pair-double)
]
smooth-quadratic-bezier-curve-to: [
[#"T" | #"t"] (params: coordinate-pair)
]
elliptical-arc: [
[#"A" | #"a"] (params: elliptical-arc-sequence)
]
; Structure
keep-params: [
(
switch command [
move [
if relative? [
stack/1: round/to stack/1 + offset/1 precision
stack/2: round/to stack/2 + offset/2 precision
]
origin/1: offset/1: stack/1
origin/2: offset/2: stack/2
]
hline [
if relative? [
stack/1: round/to stack/1 + offset/1 precision
]
offset/1: stack/1
]
vline [
if relative? [
stack/1: round/to stack/1 + offset/2 precision
]
offset/2: stack/1
]
line qcurv [
if relative? [
stack/1: round/to stack/1 + offset/1 precision
stack/2: round/to stack/2 + offset/2 precision
]
offset/1: stack/1
offset/2: stack/2
]
curv qcurve [
if relative? [
stack/1: round/to stack/1 + offset/1 precision
stack/2: round/to stack/2 + offset/2 precision
stack/3: round/to stack/3 + offset/1 precision
stack/4: round/to stack/4 + offset/2 precision
]
offset/1: stack/3
offset/2: stack/4
]
curve [
if relative? [
stack/1: round/to stack/1 + offset/1 precision
stack/2: round/to stack/2 + offset/2 precision
stack/3: round/to stack/3 + offset/1 precision
stack/4: round/to stack/4 + offset/2 precision
stack/5: round/to stack/5 + offset/1 precision
stack/6: round/to stack/6 + offset/2 precision
]
offset/1: stack/5
offset/2: stack/6
]
arc [
if relative? [
stack/6: round/to stack/6 + offset/1 precision
stack/7: round/to stack/7 + offset/2 precision
]
offset/1: stack/6
offset/2: stack/7
]
close [
offset/1: origin/1
offset/2: origin/2
]
]
)
keep (command)
keep (take/part stack tail stack)
]
expand: [
(
command: _
relative?: _
implicit?: _
offset: [0 0]
origin: [0 0]
clear stack
)
opt space*
collect opt [
mark: set command move-to
opt space* params
(
command: commands/:command
implicit?: false
relative?: lit-word? command
command: to word! command
)
keep-params
any [
opt space*
set command [
move-to
|
close-path
|
line-to
|
horizontal-line-to
|
vertical-line-to
|
curve-to
|
smooth-curve-to
|
quadratic-bezier-curve-to
|
smooth-quadratic-bezier-curve-to
|
elliptical-arc
]
opt space* params
(
command: commands/:command
implicit?: false
relative?: lit-word? command
command: to word! command
)
keep-params
|
opt space* end
|
opt comma* params
(
implicit?: true
if command = 'move [
command: 'line
]
)
keep-params
]
]
fail-if-not-end
]
; Interpret
command-name: [
'move | 'line | 'hline | 'vline | 'arc | 'curve | 'qcurve | 'curv | 'qcurv | 'close
]
draw-params: #(
move: [pair!]
line: [pair!]
hline: [number!]
vline: [number!]
arc: [pair! 3 number! opt 'sweep opt 'large]
curve: [3 pair!]
qcurve: [2 pair!]
curv: [2 pair!]
qcurv: [pair!]
close: []
)
draw-path-to-path: func [
path [block!]
/local here command offset origin params relative? implicit? value
][
command: _
offset: [0 0]
origin: [0 0]
implicit?: relative?: false
neaten/words collect [
origin/1: origin/2: offset/1: offset/2: 0
if not parse path [
some [
end break
|
[
here:
command-name (
command: to word! here/1
implicit?: false
relative?: lit-word? here/1
params: select draw-params here/1
)
|
(
implicit?: true
params: any [params [fail]]
if command = 'move [
command: 'line
]
)
]
copy part params (
switch command [
move [
if relative? [
part/1: part/1 + offset/1
part/2: part/2 + offset/2
]
origin/1: offset/1: part/1
origin/2: offset/2: part/2
]
hline [
if relative? [
part/1: part/1 + offset/1
]
offset/1: part/1
]
vline [
if relative? [
part/1: part/1 + offset/2
]
offset/2: part/1
]
line qcurv [
if relative? [
part/1: part/1 + offset/1
part/2: part/2 + offset/2
]
offset/1: part/1
offset/2: part/2
]
curv qcurve [
if relative? [
part/1: part/1 + offset/1
part/2: part/2 + offset/2
part/3: part/3 + offset/1
part/4: part/4 + offset/2
]
offset/1: part/4
offset/2: part/5
]
curve [
if relative? [
part/1: part/1 + offset/1
part/2: part/2 + offset/2
part/3: part/3 + offset/1
part/4: part/4 + offset/2
part/5: part/5 + offset/1
part/6: part/6 + offset/2
]
offset/1: part/5
offset/2: part/6
]
arc [
part: reduce [
part/2
part/3
part/4
block? find part 'large
block? find part 'sweep
part/1/x
part/1/y
]
if relative? [
part/6: part/6 + offset/1
part/7: part/7 + offset/2
]
offset/1: part/6
offset/2: part/7
]
close [
offset/1: origin/1
offset/2: origin/2
]
]
keep reduce [command part]
)
]
][
do make error! rejoin ["Could not parse path (at #" copy/part here 8 ")"]
]
]
]
next-command: func [
here [block!]
/local params part implicit?
][
if head? here [
current/command: none
current/position: 0x0
implicit?: false
]
comment {
Return format is: [
command relative? implicit? offset params new-position
]
}
case [
tail? here [_]
parse here [
[
command-name (
current/command: here/1
implicit?: false
params: command-params/:current-command
)
|
(
implicit?: true
params: either none? current/command [
[fail]
][
select path-params current/command
]
)
]
copy part params
here: to end
][
reduce [
to word! current/command
lit-word? current/command
part
here
]
]
'else [
do make error! rejoin ["Could not parse path (at #" index? here ")"]
]
]
]
]
unit-to-number: func [
number [string!]
/local value unit
][
if parse number [
copy value number*
copy unit opt [
"%" | "px" | "mm" | "cm" | "in" | "pt"
]
][
switch unit [
"" "px" [as-number value]
"%" [1% * to float! value]
; "mm" "cm" "in" "pt" [none] ; not yet supported
]
]
]
parse-numeric-list: func [
list [string!]
/local part
][
parse list [
collect any [
part:
space* opt #"," opt space*
|
#"," opt space*
|
copy part number* keep (
as-number part
)
]
fail-if-not-end
]
]
parse-path: func [
path [string!]
/local out
][
if out: parse/case path paths/expand [
neaten/words out
]
]
style-to-map: func [
style [string!]
/local key value
][
; quickie parsing for now
style: split style charset ":;"
if even? index? tail style [
remove back tail style
]
make map! collect [
foreach [key value] style [
keep to word! trim/head/tail key
keep trim/head/tail value
]
]
]
parse-transformation: func [
transformation [string!]
/local type part value
][
collect [
parse transformation [
opt space*
any [
copy type [
"matrix" | "rotate" | "scale" | "translate" | "skewX" | "skewY"
]
opt space*
"(" copy part to ")" skip
opt comma* ; shouldn't accept trailing commas, but -- oh well..
(
keep to word! type
keep/only to paren! parse-numeric-list part
)
]
fail-if-not-end
]
]
]
parse-font-name: func [
names [string!]
/local name
][
collect [
if not parse names [
some [
[
copy name [some name* any [" " some name*]] (
name: switch/default name [
"serif" "sans-serif" "cursive" "fantasy" "monospace" [
to word! name
]
][
name
]
)
|
{"} copy name some [some name* | " " | "," | "'"] {"}
|
"'" copy name some [some name* | " " | "," | {"}] "'"
] (
keep name
)
opt space* ["," opt space* | end]
]
][
keep 'sans-serif
]
]
]
handle-attributes: func [
node [object!]
/local attribute handler value style part
][
attributes: make map! collect [
foreach attribute node/attributes [
keep either attribute/namespace [
to word! rejoin [
form attribute/namespace "|" form attribute/name
]
][
attribute/name
]
keep/only switch/default attribute/name [
viewbox [
if all [
value: parse-numeric-list attribute/value
parse value [4 integer!]
][
value
]
]
id [
to issue! attribute/value
]
class [
collect [
foreach part split value " " [
if not empty? trim/head/tail part [
attempt [keep to word! part]
]
]
]
]
fill stroke [
any [
attempt [load attribute/value]
attribute/value
]
]
d [
parse-path attribute/value
]
points stroke-dasharray [
parse-numeric-list attribute/value
]
x x1 x2 y y1 y2 cx cy dx dy r rx ry width height stroke-width stroke-miterlimit font-size [
any [
is-value-from attribute/value ["auto"]
unit-to-number attribute/value
]
]
fill-rule clip-rule [
is-value-from attribute/value [
"nonzero" "evenodd"
]
]
stroke-linecap [
is-value-from attribute/value [
"butt" "round" "square"
]
]
stroke-linejoin [
is-value-from attribute/value [
"arcs" "bevel" "miter" "miter-clip" "round"
]
]
font-family [
parse-font-name attribute/value
]
font-style [
is-value-from attribute/value [
"normal" "italic" "oblique"
]
]
font-weight [
switch is-value-from attribute/value [
"normal" "bold" "lighter" "bolder"
"100" "200" "300" "400" "500" "600" "700" "800" "900"
][
normal 100 200 300 400 500 lighter ['normal]
bold 600 700 800 900 bolder ['bold]
]
]
transform [
parse-transformation attribute/value
]
href [
case [
find/match attribute/value #"#" [to issue! next attribute/value]
find attribute/value #":" [to url! attribute/value]
'else [to file! attribute/value]
]
]
style [
style-to-map attribute/value
]
][
any [
attempt [load attribute/value]
attribute/value
]
]
]
]
if map? attributes/style [
; Style attributes have greater precedence:
; https://www.w3.org/TR/2008/REC-CSS2-20080411/cascade.html#q12
foreach attribute words-of attributes/style [
attribute
value: attributes/style/:attribute
if value: switch/default attribute [
; this is largely a repeat of the above, need to hang out to DRY.
fill stroke [
attempt [load value]
]
stroke-dasharray [
parse-numeric-list value
]
stroke-width stroke-miterlimit font-size [
unit-to-number value
]
fill-rule clip-rule [
is-value-from value [
"nonzero" "evenodd"
]
]
stroke-linecap [
is-value-from value [
"butt" "round" "square"
]
]
stroke-linejoin [
is-value-from value [
"arcs" "bevel" "miter" "miter-clip" "round"
]
]
font-family [
parse-font-name value
]
font-style [
is-value-from value [
"normal" "italic" "oblique"
]
]
font-weight [
switch is-value-from value [
"normal" "bold" "lighter" "bolder"
"100" "200" "300" "400" "500" "600" "700" "800" "900"
][
normal 100 200 300 400 500 lighter ['normal]
bold 600 700 800 900 bolder ['bold]
]
]
transform [
parse-transformation value
]
][
value
][
attributes/(attribute): value
]
]
]
attributes/style: none
attributes
]
handle-kid: func [
node [object!]
/local attributes kids kid
][
neaten/words collect [
keep switch/default node/name [
g ['group]
][
node/name
]
keep attributes: handle-attributes node
keep/only either empty? kids: collect [
kids: node/children
while [not tail? kids][
kid: kids/1
switch/default kid/type [
element [
keep handle-kid kid
]
text [
keep quote 'text
keep '_
keep either node/name = 'text [
kid: copy kid/value
if head? kids [trim/head kid]
if tail? next kids [trim/tail kid]
kid
][
kid/value
]
]
whitespace
][
probe kids/1/type
]
kids: next kids
]
][
'_
][
kids
]
]
]
load-svg: func [
svg [string! binary!]
/local kid kids desc defs
][
case/all [
binary? svg [
svg: to string! svg
]
string? svg [
svg: load-xml/dom svg
]
]
neaten/words collect [
keep 'svg
keep handle-attributes svg
keep/only either empty? kids: collect [
foreach kid svg/children [
if kid/type = 'element [
; switch/default kid/name [
; ; defs [defs: handle-defs kid]
; desc [desc: kid/text]
; ][
keep handle-kid kid
; ]
]
]
][
'_
][
kids
]
]
]
; Draw
as-pair: func [
x [number!]
y [number!]
][
make pair! reduce [round/to x 1 round/to y 1]
]
adjust-font-size: func [
size [integer! float!]
][
; round/to size * 72.0 / 96 1
round/to size * 75.0 / 96 1
]
path-to-draw-path: func [
path [block!]
/local
command params open?
][
comment {
SVG Path/D: https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/d
(with links to various W3 specs)
Draw (Red): https://doc.red-lang.org/en/draw.html#_shape_commands
Draw (Rebol 3): http://www.rebol.com/r3/docs/view/draw-shapes.html
Draw (Rebol 2): http://www.rebol.com/docs/draw-ref.html#section-74
Some incongruities:
SVG calls it PATH with D attribute, Draw calls it SHAPE.
In SVG, MOVE may have one or more coordinate pairs. The first moves the pen
without a mark, the following are implicit LINE commands. This is an error in
Red (does work in Rebol 2).
SVG Path commands are fixed arity, however Draw's ARC has optional LARGE and
SWEEP keywords.
}
neaten/words collect [
open?: true
foreach [command params] path [
keep command
switch command [
move [
keep as-pair params/1 params/2
open?: true
]
line qcurv [
keep as-pair params/1 params/2
]
hline vline [
keep round params/1
]
arc [
keep as-pair params/6 params/7
keep round params/1
keep round params/2
keep round params/3
if params/5 [keep 'sweep]
if params/4 [keep 'large]
]
curve [
keep as-pair params/1 params/2
keep as-pair params/3 params/4
keep as-pair params/5 params/6
]
curv qcurve [
keep as-pair params/1 params/2
keep as-pair params/3 params/4
]
close [
open?: false
]
]
]
; prevents Red's auto-closing behaviour
if open? [
keep [
move -1x-1
]
]
]
]
numbers-to-points: func [
numbers [block!]
/local mark
][
parse numbers [
collect [
some [
mark: number! number!
keep (as-pair mark/1 mark/2)
]
]
]
]
colors: #(
none: off
transparent: off
black: #000000
navy: #000080
darkblue: #00008b
mediumblue: #0000cd
blue: #0000ff
darkgreen: #006400
green: #008000
teal: #008080
darkcyan: #008b8b
deepskyblue: #00bfff
darkturquoise: #00ced1
mediumspringgreen: #00fa9a
lime: #00ff00
springgreen: #00ff7f
cyan: #00ffff
aqua: #00ffff
midnightblue: #191970
dodgerblue: #1e90ff
lightseagreen: #20b2aa
forestgreen: #228b22
seagreen: #2e8b57
darkslategray: #2f4f4f
darkslategrey: #2f4f4f
limegreen: #32cd32
mediumseagreen: #3cb371
turquoise: #40e0d0
royalblue: #4169e1
steelblue: #4682b4
darkslateblue: #483d8b
mediumturquoise: #48d1cc
indigo: #4b0082
darkolivegreen: #556b2f
cadetblue: #5f9ea0
cornflowerblue: #6495ed
mediumaquamarine: #66cdaa
dimgrey: #696969
dimgray: #696969
slateblue: #6a5acd
olivedrab: #6b8e23
slategrey: #708090
slategray: #708090
lightslategray: #778899
lightslategrey: #778899
mediumslateblue: #7b68ee
lawngreen: #7cfc00
chartreuse: #7fff00
aquamarine: #7fffd4
maroon: #800000
purple: #800080
olive: #808000
gray: #808080
grey: #808080
skyblue: #87ceeb
lightskyblue: #87cefa
blueviolet: #8a2be2
darkred: #8b0000
darkmagenta: #8b008b
saddlebrown: #8b4513
darkseagreen: #8fbc8f
lightgreen: #90ee90
mediumpurple: #9370db
darkviolet: #9400d3
palegreen: #98fb98
darkorchid: #9932cc
yellowgreen: #9acd32
sienna: #a0522d
brown: #a52a2a
darkgray: #a9a9a9
darkgrey: #a9a9a9
lightblue: #add8e6
greenyellow: #adff2f
paleturquoise: #afeeee
lightsteelblue: #b0c4de
powderblue: #b0e0e6
firebrick: #b22222
darkgoldenrod: #b8860b
mediumorchid: #ba55d3
rosybrown: #bc8f8f
darkkhaki: #bdb76b
silver: #c0c0c0
mediumvioletred: #c71585
indianred: #cd5c5c
peru: #cd853f
chocolate: #d2691e
tan: #d2b48c
lightgray: #d3d3d3
lightgrey: #d3d3d3
thistle: #d8bfd8
orchid: #da70d6
goldenrod: #daa520
palevioletred: #db7093
crimson: #dc143c
gainsboro: #dcdcdc
plum: #dda0dd
burlywood: #deb887
lightcyan: #e0ffff
lavender: #e6e6fa
darksalmon: #e9967a
violet: #ee82ee
palegoldenrod: #eee8aa
lightcoral: #f08080
khaki: #f0e68c
aliceblue: #f0f8ff
honeydew: #f0fff0
azure: #f0ffff
sandybrown: #f4a460
wheat: #f5deb3
beige: #f5f5dc
whitesmoke: #f5f5f5
mintcream: #f5fffa
ghostwhite: #f8f8ff
salmon: #fa8072
antiquewhite: #faebd7
linen: #faf0e6
lightgoldenrodyellow: #fafad2
oldlace: #fdf5e6
red: #ff0000
fuchsia: #ff00ff
magenta: #ff00ff
deeppink: #ff1493
orangered: #ff4500
tomato: #ff6347
hotpink: #ff69b4
coral: #ff7f50
darkorange: #ff8c00
lightsalmon: #ffa07a
orange: #ffa500
lightpink: #ffb6c1
pink: #ffc0cb
gold: #ffd700
peachpuff: #ffdab9
navajowhite: #ffdead
moccasin: #ffe4b5
bisque: #ffe4c4
mistyrose: #ffe4e1
blanchedalmond: #ffebcd
papayawhip: #ffefd5
lavenderblush: #fff0f5
seashell: #fff5ee
cornsilk: #fff8dc
lemonchiffon: #fffacd
floralwhite: #fffaf0
snow: #fffafa
yellow: #ffff00
lightyellow: #ffffe0
ivory: #fffff0
white: #ffffff
)
default-style: #(
pen: off
fill-pen: off
line-width: 0
)
size-of: func [
svg-block [block!]
][
all [
parse svg-block ['svg map! block!]
block? select svg-block/2 'viewbox
any [
all [
parse svg-block/2/viewbox [4 number!]
as-pair round svg-block/2/viewbox/3 round svg-block/2/viewbox/4
]
all [
number? select svg-block/2 width
number? select svg-block/2 height
as-pair round svg-block/2/width round svg-block/2/height
]
]
]
]
facets-of: func [
facets [map!] /local facet
][
neaten/pairs collect [
foreach facet words-of facets [
if facets/:facet [
keep to word! facet
keep facets/:facet
]
]
]
]
handle-facets: func [
inherited [map! none!]
attributes [map!]
/local style font-object value facet keepers function params
][
style: copy either map? inherited [
inherited
][
default-style
]
style: make map! []
foreach [facet keepers][
stroke [
style/pen: case [
word? value [
any [
select colors value
'off
]
]
tuple? value [value]
issue? value [
either parse to string! value [6 hex* | 3 hex*][
value
][
; Pending DEFS resolution
'off
]
]
/else ['off]
]
]
fill [
style/fill-pen: case [
word? value [
any [
select colors value
'off
]
]
tuple? value [value]
issue? value [
either parse to string! value [6 hex* | 3 hex*][
value
][
; Pending DEFS resolution
'off
]
]
/else ['off]
]
]
stroke-width [
style/line-width: value
]
stroke-linejoin [
style/line-join: value
]
transform [
; need to expand on this for multiple transforms
foreach [function params] value [
switch function [
matrix [
style/matrix: reduce [to block! params]
]
translate [
style/translate: as-pair params/1 params/2
]
]
]
]
; stroke-dasharray
][
value: any [
select attributes facet
select default-style facet
]
if value keepers
]
font-object: #()
foreach [facet keepers][
font-family [
font-object/name: any [
case [
block? value [first value]
string? value [value]
word? value [
switch/default value [
serif cursive fantasy ['serif]
sans-serif ['sans-serif]
monospace ['monospace]
]
]
]
'system
]
]
font-size [
font-object/size: adjust-font-size value
]
; font-style [
;
; ]
;
; font-weight [
; case [
;
; ]
; ]
; rotate [
; font-object/angle
; ]
][
if value: select attributes facet keepers
]
if not empty? font-object [
font-object/color: style/fill-pen
font-object/size: any [
font-object/size 12
]
style/font: make font! body-of font-object
]
style
]
text-sizer: make face! []
width-of: func [
text [string!]
font [none! object!]
][
text-sizer/text: text
text-sizer/font: any [font font!]
first size-text text-sizer
]
text-offset: 0x0
text-to-draw: func [
svg-block [block!] inherited [map!]
/at position [pair!]
/local node attributes style kids
][
if at [
text-offset: :position
]
neaten/words collect [
foreach [node attributes kids] svg-block [
switch/default node [
'text [
keep reduce [
'text
text-offset - as-pair 0 inherited/font/size
kids
]
text-offset/x: text-offset/x + width-of kids inherited/font
]
tspan [
case/all [
number? attributes/x [text-offset/x: to integer! attributes/x]
number? attributes/y [text-offset/y: to integer! attributes/y]
number? attributes/dx [text-offset/x: text-offset/x + round/to attributes/dx 1]
number? attributes/dy [text-offset/y: text-offset/y + round/to attributes/dy 1]
]
keep 'push
keep/only compose [
(facets-of style: handle-facets inherited attributes)
(text-to-draw kids style)
]
]
][
probe node
]
]
]
]
to-draw: func [
svg-block [block!] "Block created from LOAD-SVG function"
/with inherited [map! none!] "Style inherited from parent"
/wrap "Creates a viewable layout window."
/local node attributes style position kids draw-code
][
draw-code: neaten/words collect [
keep [pen off fill-pen off]
foreach [node attributes kids] svg-block [
switch/default node [
svg [
keep compose [
(facets-of style: handle-facets none attributes)
(to-draw/with kids style)
]
]
defs [
; to follow
]
clippath [
; to follow
]
group a [
keep 'push
keep/only compose [
(facets-of style: handle-facets inherited attributes)
(to-draw/with kids style)
]
]
text [
; Here be dragons
position: 0x0
case/all [
number? attributes/x [position/x: to integer! attributes/x]
number? attributes/y [position/y: to integer! attributes/y]
number? attributes/dx [position/x: position/x + to integer! attributes/dx]
number? attributes/dy [position/y: position/y + to integer! attributes/dy]
]
keep 'push
keep/only compose [
(facets-of style: handle-facets inherited attributes)
(text-to-draw/at kids style position)
]
]
rect [
keep 'push
keep/only neaten/words collect [
keep facets-of handle-facets inherited attributes
keep 'box
keep as-pair attributes/x attributes/y
keep as-pair attributes/x + attributes/width attributes/y + attributes/height
; only one radius dimension allowed...
if any [
attributes/rx
attributes/ry
][
keep any [
attributes/rx
attributes/ry
]
]
]
]
circle [
keep 'push
keep/only neaten/words compose [
(facets-of handle-facets inherited attributes)
circle
(as-pair attributes/cx attributes/cy)
(attributes/r)
]
]
ellipse [
keep 'push
keep/only neaten/words compose [
(facets-of handle-facets inherited attributes)
circle
(as-pair attributes/cx attributes/cy)
(attributes/rx)
(attributes/ry)
]
]
line [
keep 'push
keep/only neaten/words compose [
(facets-of handle-facets inherited attributes)
line
(as-pair attributes/x1 attributes/y1)
(as-pair attributes/x2 attributes/y2)
]
]
polyline [
keep 'push
keep/only neaten/words compose [
(facets-of handle-facets inherited attributes)
line (numbers-to-points attributes/points)
]
]
polygon [
keep 'push
keep/only neaten/words compose [
(facets-of handle-facets inherited attributes)
polygon (numbers-to-points attributes/points)
]
]
path [
keep 'push
keep/only neaten/words compose/deep [
(facets-of handle-facets inherited attributes)
shape [(path-to-draw-path attributes/d)]
]
]
use [
keep [text 0x0 "`USE` TO FOLLOW"]
]
][
probe node
]
]
]
either wrap [
compose/deep [
backdrop coal
panel 400x400 [
backdrop silver
origin 0x0 space 0x0
box loose (
any [
size-of svg-block
500x500
]
)
draw [
scale 1 1 [(draw-code)]
]
on-drag [
face/offset: min 0x0 max face/offset face/parent/size - face/size
]
]
do [
self/actors: make object! [
on-resize: func [face event /local fixed sizes gutters][
face/pane/1/size: face/size - 20
]
]
]
]
][
draw-code
]
]
; Transform/Render
form-number: func [
number [number!]
][
switch type?/word number [
integer! percent! [form number]
float! [
number: form number
case [
parse number [thru ".0" end][
clear find number ".0"
]
find/match number "0." [
remove number
]
find/match number "-0." [
remove next number
]
]
number
]
]
]
form-path: func [
path [block!]
/precise precision [number!]
/local out emit command params value type last offset origin
][
precision: any [precision paths/precision]
offset: copy [0 0]
origin: copy [0 0]
last: _
out: make string! 16 * length? path ; approx. pre-allocation
emit: func [values][
append out collect [
foreach value reduce values [
switch type?/word value [
char! [
keep value
last: 'word
]
logic! [
if find [integer float] last [keep " "]
keep pick [1 0] value
last: 'logic
]
float! integer! [
value: form-number round/to value precision
case [
; can always append negative numbers without padding
find/match value "-" [
keep value
]
find/match value "." [
if find [integer] last [keep #" "]
keep value
]
find [integer float] last [
keep " "
keep value
]
'else [
keep value
]
]
last: either find value "." ['float]['integer]
]
]
]
]
]
foreach [command params] path [
switch command [
move [
emit [
#"m"
params/1 - offset/1 params/2 - offset/2
]
origin/1: offset/1: params/1
origin/2: offset/2: params/2
]
hline [
emit [
#"h"
params/1 - offset/1
]
offset/1: params/1
]
vline [
emit [
#"v"
params/1 - offset/2
]
offset/2: params/1
]
line qcurv [
emit [
select [line #"l" qcurv #"t"] command
params/1 - offset/1 params/2 - offset/2
]
offset/1: params/1
offset/2: params/2
]
curv qcurve [
emit [
select [curv #"s" qcurve #"q"] command
params/1 - offset/1 params/2 - offset/2
params/3 - offset/1 params/4 - offset/2
]
offset/1: params/3
offset/2: params/4
]
curve [
emit [
#"c"
params/1 - offset/1 params/2 - offset/2
params/3 - offset/1 params/4 - offset/2
params/5 - offset/1 params/6 - offset/2
]
offset/1: params/5
offset/2: params/6
]
arc [
emit [
#"a"
params/1 params/2
params/3
params/4 params/5
params/6 - offset/1 params/7 - offset/2
]
offset/1: params/6
offset/2: params/7
]
close [
append out #"z"
offset/1: origin/1
offset/2: origin/2
]
]
]
uppercase/part out 1
]
; experimental, unfinished
; would be nice to support TRANSFORM attribute *and* a general ability
; to arbitrarily transform shapes, e.g. move shape 100x100 or resize shape 150%
apply-transform: func [
point [pair! block!]
matrix [block!]
][
point: collect [
switch type?/word point [
pair! [
keep to float! point/x
keep to float! point/y
]
block! [
parse point [
2 [
point: [
integer! (keep to float! point/1)
|
float! (keep point/1)
]
]
]
]
]
]
if all [
parse point [2 float!]
parse matrix [6 number!]
][
reduce [
(x * matrix/1) + (y * matrix/3) + matrix/5
(x * matrix/2) + (y * matrix/4) + matrix/6
]
]
]
wrap-shape: func [
size [pair!]
shape [string! tag!]
/window top-left [pair!] bottom-right [pair!]
][
top-left: any [top-left 0x0]
bottom-right: any [bottom-right size]
trim/auto rejoin [
{
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<svg width="} size/x {" height="} size/y
{" viewBox="} reform [top-left/x top-left/y bottom-right/x bottom-right/y]
{" version="1.1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
} shape {
</svg>
}
]
]
listify: func [list [block! paren!] /with-comma][
with-comma: either with-comma [","][" "]
rejoin back change collect [
forall list [
keep with-comma
keep case [
number? list/1 [form-number list/1]
issue? list/1 [sanitize mold list/1]
none? list/1 [do make error! rejoin ["Should not be NONE! here: " mold list]]
'else [sanitize form list/1]
]
]
] ""
]
render-precision: 0.001
indent-by: _
render-node: func [
name [word!] attributes [map! none!] kids [block! none!]
/precise precision [number!]
/indent indentation [string!]
/local attribute part
][
render-precision: any [precision 0.001]
indentation: any [indentation ""]
rejoin collect [
keep form build-tag collect [
keep name: switch/default name [
group ['g]
][
name
]
if map? attributes [
foreach attribute words-of attributes [
if not none? attributes/:attribute [
keep either find form attribute #"|" [
to path! replace form attribute #"|" #"/"
][
attribute
]
keep case [
all [
name = 'path
attribute = 'd
block? attributes/:attribute
][
form-path/precise attributes/:attribute render-precision
]
all [
attribute = 'id
issue? attributes/:attribute
][
to string! attributes/:attribute
]
all [
; tranform attribute, others?
block? attributes/:attribute
parse attributes/:attribute [some [word! paren!]]
][
listify/with-comma collect [
parse attributes/:attribute [
some [
copy part [word! paren!]
(keep rejoin [form part/1 "(" listify part/2 ")"])
]
]
]
]
all [
attribute = 'transform
parse attributes/:attribute [copy part [word! some number!]]
][
rejoin [form part/1 "(" form next part ")"]
]
block? attributes/:attribute [
listify/with-comma attributes/:attribute
]
float? part: attributes/:attribute [
if find [x x1 x2 y y1 y2 cx cy dx dy r rx ry width height] attribute [
part: round/to part render-precision
]
form-number part
]
'else [
attributes/:attribute
]
]
]
]
]
if any [
none? kids
empty? kids
][
keep [/]
]
]
case [
none? kids []
string? kids [
keep sanitize kids
keep rejoin [indentation "</" form name ">"]
]
not empty? kids [
; probe copy/part kids 2
while [not tail? kids][
if not any [
find/same [tspan] name
all [
find/same [text] name
not head? kids
]
][
keep indentation
keep indent-by
]
keep either same? kids/1 quote 'text [
sanitize kids/3
][
render-node/precise/indent kids/1 kids/2 kids/3 render-precision either kids/1 = 'tspan [
""
][
rejoin [indentation indent-by]
]
]
kids: skip kids 3
]
keep indentation
keep rejoin ["</" form name ">"]
]
]
]
]
render: func [document [block!] /precise precision [number!] /no-indent][
render-precision: any [precision 0.001]
indent-by: either no-indent [""][" "]
either parse document ['svg map! [block! | none!]][
rejoin [
render-node/precise/indent 'svg document/2 document/3 render-precision "^/"
]
][
do make error! "Not an SVG document"
]
]
; more things to consider:
; https://stackoverflow.com/questions/5149301/baking-transforms-into-svg-path-element-commands
; wrt. 'apply-transform
]
load-svg: get in svg 'load-svg
convert-svg: func [source [file!] /local target content][
target: append copy source %.red
save/header target content: load-svg read source make object! [
Title: "SVG Converter"
Date: now/date
]
content
]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.