Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Some SVG functions in Red
#!/usr/local/bin/red
Red [
Title: "Parse SVG"
Date: 23-Dec-2018
Author: "Christopher Ross-Gill"
Rights: http://opensource.org/licenses/Apache-2.0
]
; do %altxml.red
do https://raw.githubusercontent.com/rgchris/Scripts/master/experimental/altxml.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 _ x] block/1
]
]
][
new-line/all/skip block not flat either pairs [2] [1]
]
head block
]
load-svg: func [
svg [string! binary!]
/local kid kids desc defs
] bind [
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
]
]
]
make object! [
adjust: func [
value [integer! float! percent!]
][
switch type?/word value [
float! percent! [round/to value 0.001]
integer! [value]
]
]
number*: charset "-.0123456789"
as-number: func [
number [string!]
][
case [
not parse number [some number* opt "%"][number]
#"%" = last number [to percent! number]
find number "." [to decimal! number]
]
]
as-pair: func [
x [integer! float!]
y [integer! float!]
][
to paren! reduce (adjust x adjust y)
]
parse-path: func [
path [string!]
/local part
][
path: parse/case path [
collect any [
#" " | #"^/"
| #"A" keep ('arc)
| #"C" keep ('curve)
| #"H" keep ('hline)
| #"L" keep ('line)
| #"M" keep ('move)
| #"Q" keep ('qcurve)
| #"S" keep ('curv)
| #"T" keep ('qcurv)
| #"V" keep ('vline)
| #"Z" keep ('close)
| #"a" keep (quote 'arc)
| #"c" keep (quote 'curve)
| #"h" keep (quote 'hline)
| #"l" keep (quote 'line)
| #"m" keep (quote 'move)
| #"q" keep (quote 'qcurve)
| #"s" keep (quote 'curv)
| #"t" keep (quote 'qcurv)
| #"v" keep (quote 'vline)
| #"z" keep ('close)
| #"," ; keep ('x)
| copy part some number* keep (
adjust load part
)
]
]
neaten/words path
]
parse-style: func [
style [string!]
attributes [map!]
/local key value
][
; quickie parsing for now
style: split style charset ":;"
foreach [key value] style [
key: to word! trim/head/tail key
value: trim/head/tail value
attributes/(key): any [
attempt [load value]
value
]
]
]
parse-transformation: func [
transformation [string!]
/local type part value
][
transformation: if parse transformation [
copy type [
"matrix" | "rotate" | "scale" | "translate" | "skew" | "clip"
]
"(" copy part to ")" skip
][
collect [
keep to word! type
keep parse-path part
]
]
]
handle-attributes: func [
node [object!]
/local facet red-facet style attribute value
][
attributes: make map! collect [
foreach attribute node/attributes [
unless attribute/name = 'style [
keep attribute/name
keep/only switch/default attribute/name [
viewbox [
if all [
value: attempt [load attribute/value]
parse value [4 integer!]
][
reduce [
adjust value/1 'x adjust value/2
adjust value/3 'x adjust value/4
]
]
]
fill stroke [
any [
attempt [load attribute/value]
attribute/value
]
]
id [
attribute/value
]
d points stroke-dasharray [
parse-path attribute/value
]
transform [
parse-transformation attribute/value
]
x y cx cy r width height stroke-width font-size [
switch/default to word! type? value: attempt [load attribute/value][
integer! float! [adjust value]
percent! [value]
][
attribute/value
]
]
font-family [
attribute/value
]
][
any [
attempt [load attribute/value]
attribute/value
]
]
]
]
]
if style: node/get #style [
parse-style style attributes
]
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 [
foreach kid node/children [
switch/default kid/type [
element [
keep handle-kid kid
]
text [
keep quote 'text
keep '_
keep kid/value
]
whitespace
][
probe kid/type
]
]
][
'_
][
kids
]
]
]
]
svg-to-draw: func [
svg-block [block!] "Block created from LOAD-SVG function"
/scale scalar [integer!]
/local node attributes kids
] bind [
scalar: to float! any [:scalar 1]
neaten/words collect [
foreach [node attributes kids] svg-block [
switch/default node [
svg [
keep compose [
(set-style attributes)
(svg-to-draw/scale kids to integer! scalar)
]
]
defs [
; to follow
]
clippath [
; to follow
]
group [
keep 'push
keep/only compose [
(set-style attributes)
(svg-to-draw/scale kids to integer! scalar)
]
]
rect [
keep 'push
keep/only neaten/words collect [
keep set-style 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 [
(set-style attributes)
circle
(as-pair attributes/cx attributes/cy)
(attributes/r)
]
]
ellipse [
keep 'push
keep/only neaten/words compose [
(set-style attributes)
circle
(as-pair attributes/cx attributes/cy)
(attributes/rx)
(attributes/ry)
]
]
line [
keep 'push
keep/only neaten/words compose [
(set-style attributes)
line
(as-pair attributes/x1 attributes/y1)
(as-pair attributes/x2 attributes/y2)
]
]
polyline [
keep 'push
keep/only neaten/words compose [
(set-style attributes)
line (numbers-to-points attributes/points)
]
]
polygon [
keep 'push
keep/only neaten/words compose [
(set-style attributes)
polygon (numbers-to-points attributes/points)
]
]
path [
keep 'push
keep/only neaten/words compose/deep [
(set-style attributes)
shape [(path-to-points attributes/d)]
]
]
text [
; Here be dragons
; keep 'text
; keep compose [
; (set-style attributes)
; text
; ]
]
][
probe node
]
]
]
]
make object! [
path-to-points: func [
path [block!]
/local
mark part
][
parse path [
collect some [
mark:
['move | quote 'move | 'line | quote 'line] 2 number!
keep (mark/1)
keep (as-pair mark/2 mark/3)
|
['hline | quote 'hline | 'vline | quote 'vline] number!
keep (mark/1)
keep (mark/2)
|
['arc | quote 'arc] 7 number!
keep (mark/1)
keep (as-pair mark/7 mark/8)
keep (mark/2)
keep (mark/3)
keep (mark/4)
opt [if (mark/6 = 1) keep ('sweep)]
opt [if (mark/5 = 1) keep ('large)]
|
['curve | quote 'curve] 6 number!
keep (mark/1)
keep (as-pair mark/2 mark/3)
keep (as-pair mark/4 mark/5)
keep (as-pair mark/6 mark/7)
|
['qcurv | quote 'qcurv] 2 number!
keep (mark/1)
keep (as-pair mark/2 mark/3)
|
'close
keep (mark/1)
|
skip ; should not happen
keep (mark/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
)
hex: charset "0123456789abcdef"
set-style: func [
attributes [map!]
/local value facet keepers
][
neaten/pairs collect [
foreach [facet keepers][
stroke-width [
keep 'line-width
keep value
]
stroke-linejoin [
keep 'line-join
keep value
]
stroke [
keep 'pen
keep case [
word? value [
any [
select colors value
'off
]
]
tuple? value [value]
issue? value [
either parse probe to string! value [3 hex | 6 hex][
value
][
; Pending DEFS resolution
'off
]
]
/else ['off]
]
]
fill [
keep 'fill-pen
keep case [
word? value [
any [
select colors value
'off
]
]
tuple? value [value]
issue? value [
either parse to string! value [3 hex | 6 hex][
value
][
; Pending DEFS resolution
'off
]
]
/else ['off]
]
]
][
if value: select attributes facet keepers
]
]
]
]
pinkie: load-svg read http://reb4.me/x/red-pinkie.svg
view [
box 240x240 draw svg-to-draw pinkie
]
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.