Skip to content

Instantly share code, notes, and snippets.

@SteeveGit
Created July 1, 2016 16:04
Show Gist options
  • Save SteeveGit/2261be3a433d7ea121524d14dcb55b00 to your computer and use it in GitHub Desktop.
Save SteeveGit/2261be3a433d7ea121524d14dcb55b00 to your computer and use it in GitHub Desktop.
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]
]
]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment