From aad17e43efe9fb52349eb610011c5c51ffb48e35 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 30 Jan 2009 09:39:15 -0600 Subject: [PATCH] math.affine-transforms, sequences.squish, and svg vocabs --- .../affine-transforms-tests.factor | 48 +++++ .../affine-transforms/affine-transforms.factor | 70 +++++++ extra/sequences/squish/squish.factor | 12 ++ extra/svg/svg-tests.factor | 95 +++++++++ extra/svg/svg.factor | 223 +++++++++++++++++++++ 5 files changed, 448 insertions(+) create mode 100644 extra/math/affine-transforms/affine-transforms-tests.factor create mode 100644 extra/math/affine-transforms/affine-transforms.factor create mode 100644 extra/sequences/squish/squish.factor create mode 100644 extra/svg/svg-tests.factor create mode 100644 extra/svg/svg.factor diff --git a/extra/math/affine-transforms/affine-transforms-tests.factor b/extra/math/affine-transforms/affine-transforms-tests.factor new file mode 100644 index 0000000000..f79c0fa63b --- /dev/null +++ b/extra/math/affine-transforms/affine-transforms-tests.factor @@ -0,0 +1,48 @@ +USING: arrays kernel literals tools.test math math.affine-transforms +math.constants math.functions ; +IN: math.affine-transforms.tests + +[ { 7.25 4.25 } ] [ + { 0.75 0.75 } { 0.75 -0.75 } { 5.0 5.0 } + { 1.0 2.0 } a.v +] unit-test + +[ -1.125 ] [ + { 0.75 0.75 } { 0.75 -0.75 } { 5.0 5.0 } + |a| +] unit-test + +{ 1.0 3.0 } { 2.0 4.0 } { 5.0 6.0 } 1array [ + { 1.0 2.0 } { 3.0 4.0 } { 5.0 6.0 } + transpose-axes +] unit-test + +{ 1.0 -1.0 } { 1.0 1.0 } { 0.0 0.0 } 1array [ + { 0.5 0.5 } { -0.5 0.5 } { 5.0 5.0 } + inverse-axes +] unit-test + +{ 1.0 -1.0 } { 1.0 1.0 } { -10.0 0.0 } 1array [ + { 0.5 0.5 } { -0.5 0.5 } { 5.0 5.0 } + inverse-transform +] unit-test + +{ 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } 1array [ + { 0.5 0.5 } { -0.5 0.5 } { 5.0 5.0 } + dup inverse-transform a. +] unit-test + +[ t ] [ + { 0.01 0.02 } { 0.03 0.04 } { 0.05 0.06 } + { 0.011 0.021 } { 0.031 0.041 } { 0.051 0.061 } 0.01 a~ +] unit-test + +{ 1.0 0.0 } { 0.0 1.0 } { 5.0 10.0 } 1array [ + { 5.0 10.0 } +] unit-test + +{ $[ pi 0.25 * cos ] $[ pi 0.25 * sin ] } +{ $[ pi -0.25 * sin ] $[ pi 0.25 * cos ] } +{ 0.0 0.0 } 1array [ + pi 0.25 * +] unit-test diff --git a/extra/math/affine-transforms/affine-transforms.factor b/extra/math/affine-transforms/affine-transforms.factor new file mode 100644 index 0000000000..141dbf9634 --- /dev/null +++ b/extra/math/affine-transforms/affine-transforms.factor @@ -0,0 +1,70 @@ +USING: accessors arrays combinators combinators.short-circuit kernel math math.vectors +math.functions sequences ; +IN: math.affine-transforms + +TUPLE: affine-transform x y origin ; +C: affine-transform + +CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } } + +: a.v ( a v -- v ) + [ [ x>> ] [ first ] bi* v*n ] + [ [ y>> ] [ second ] bi* v*n ] + [ drop origin>> ] 2tri + v+ v+ ; + +: ( origin -- a ) + [ { 1.0 0.0 } { 0.0 1.0 } ] dip ; +: ( theta -- transform ) + [ cos ] [ sin ] bi + [ 2array ] [ neg swap 2array ] 2bi { 0.0 0.0 } ; +: ( x y -- transform ) + [ 0.0 2array ] [ 0.0 swap 2array ] bi* { 0.0 0.0 } ; + +: center-rotation ( transform center -- transform ) + [ clone dup ] dip [ vneg a.v ] [ v+ ] bi >>origin ; + +: flatten-transform ( transform -- array ) + [ x>> ] [ y>> ] [ origin>> ] tri 3append ; + +: |a| ( a -- det ) + [ [ x>> first ] [ y>> second ] bi * ] + [ [ x>> second ] [ y>> first ] bi * ] bi - ; + +: (inverted-axes) ( a -- x y ) + [ [ y>> second ] [ x>> second neg ] bi 2array ] + [ [ y>> first neg ] [ x>> first ] bi 2array ] + [ |a| ] tri + tuck [ v/n ] 2bi@ ; + +: inverse-axes ( a -- a^-1 ) + (inverted-axes) { 0.0 0.0 } ; + +: inverse-transform ( a -- a^-1 ) + [ inverse-axes dup ] [ origin>> ] bi + a.v vneg >>origin ; + +: transpose-axes ( a -- a^T ) + [ [ x>> first ] [ y>> first ] bi 2array ] + [ [ x>> second ] [ y>> second ] bi 2array ] + [ origin>> ] tri ; + +: a. ( a a -- a ) + transpose-axes { + [ [ x>> ] [ x>> ] bi* v. ] + [ [ x>> ] [ y>> ] bi* v. ] + [ [ y>> ] [ x>> ] bi* v. ] + [ [ y>> ] [ y>> ] bi* v. ] + [ origin>> a.v ] + } 2cleave + [ [ 2array ] 2bi@ ] dip ; + +: v~ ( a b epsilon -- ? ) + [ ~ ] curry 2all? ; + +: a~ ( a b epsilon -- ? ) + { + [ [ [ x>> ] bi@ ] dip v~ ] + [ [ [ y>> ] bi@ ] dip v~ ] + [ [ [ origin>> ] bi@ ] dip v~ ] + } 3&& ; diff --git a/extra/sequences/squish/squish.factor b/extra/sequences/squish/squish.factor new file mode 100644 index 0000000000..6a7ffb49f8 --- /dev/null +++ b/extra/sequences/squish/squish.factor @@ -0,0 +1,12 @@ +USING: combinators.short-circuit fry make math kernel sequences ; +IN: sequences.squish + +: (squish) ( seq quot: ( obj -- ? ) -- ) + 2dup call [ '[ _ (squish) ] each ] [ drop , ] if ; inline recursive + +: squish ( seq quot exemplar -- seq' ) + [ [ (squish) ] ] dip make ; inline + +: squish-strings ( seq -- seq' ) + [ { [ sequence? ] [ integer? not ] } 1&& ] "" squish ; + diff --git a/extra/svg/svg-tests.factor b/extra/svg/svg-tests.factor new file mode 100644 index 0000000000..4ad1514d38 --- /dev/null +++ b/extra/svg/svg-tests.factor @@ -0,0 +1,95 @@ +USING: arrays literals math math.affine-transforms math.functions multiline +svg tools.test ; +IN: svg.tests + +{ 1.0 2.25 } { -3.0 4.0 } { 5.5 0.000001 } 1array [ + "matrix ( 1 +2.25 -3 , 0.4e+1 ,5.5, 1e-6 )" svg-transform>affine-transform +] unit-test + +{ 1.0 0.0 } { 0.0 1.0 } { 5.0 10.0 } 1array [ + "translate(5.0, 1e1 )" svg-transform>affine-transform +] unit-test + +{ 1.0 0.0 } { 0.0 1.0 } { 5.0 10.0 } 1array [ + "translate( 5.0 1e+1)" svg-transform>affine-transform +] unit-test + +{ 2.0 0.0 } { 0.0 2.0 } { 0.0 0.0 } 1array [ + "scale(2.0)" svg-transform>affine-transform +] unit-test + +{ 2.0 0.0 } { 0.0 4.0 } { 0.0 0.0 } 1array [ + "scale(2.0 4.0)" svg-transform>affine-transform +] unit-test + +{ 2.0 0.0 } { 0.0 4.0 } { 0.0 0.0 } 1array [ + "scale(2.0 4.0)" svg-transform>affine-transform +] unit-test + +{ 1.0 0.0 } { $[ 45 degrees tan ] 1.0 } { 0.0 0.0 } 1array [ + "skewX(45)" svg-transform>affine-transform +] unit-test + +{ 1.0 $[ -45 degrees tan ] } { 0.0 1.0 } { 0.0 0.0 } 1array [ + "skewY(-4.5e1)" svg-transform>affine-transform +] unit-test + +{ $[ 30 degrees cos ] $[ 30 degrees sin ] } +{ $[ -30 degrees sin ] $[ 30 degrees cos ] } { 0.0 0.0 } 1array [ + "rotate(30)" svg-transform>affine-transform +] unit-test + +[ t ] [ + "rotate(30 1.0,2.0)" svg-transform>affine-transform + { $[ 30 degrees cos ] $[ 30 degrees sin ] } + { $[ -30 degrees sin ] $[ 30 degrees cos ] } { + $[ 1.0 30 degrees cos 1.0 * - 30 degrees sin 2.0 * + ] + $[ 2.0 30 degrees cos 2.0 * - 30 degrees sin 1.0 * - ] + } 0.001 a~ +] unit-test + +{ $[ 30 degrees cos ] $[ 30 degrees sin ] } +{ $[ -30 degrees sin ] $[ 30 degrees cos ] } +{ 1.0 2.0 } 1array [ + "translate(1 2) rotate(30)" svg-transform>affine-transform +] unit-test + +[ { + T{ moveto f { 1.0 1.0 } f } + T{ lineto f { 3.0 -1.0 } f } + + T{ lineto f { 2.0 2.0 } t } + T{ lineto f { 2.0 -2.0 } t } + T{ lineto f { 2.0 2.0 } t } + + T{ vertical-lineto f -9.0 t } + T{ vertical-lineto f 1.0 t } + T{ horizontal-lineto f 9.0 f } + T{ horizontal-lineto f 8.0 f } + + T{ closepath } + + T{ moveto f { 0.0 0.0 } f } + + T{ curveto f { -4.0 0.0 } { -8.0 4.0 } { -8.0 8.0 } f } + T{ curveto f { -8.0 4.0 } { -12.0 8.0 } { -16.0 8.0 } f } + + T{ smooth-curveto f { 0.0 2.0 } { 2.0 0.0 } t } + + T{ quadratic-bezier-curveto f { -2.0 0.0 } { 0.0 -2.0 } f } + T{ quadratic-bezier-curveto f { -3.0 0.0 } { 0.0 3.0 } f } + + T{ smooth-quadratic-bezier-curveto f { 1.0 2.0 } t } + T{ smooth-quadratic-bezier-curveto f { 3.0 4.0 } t } + + T{ elliptical-arc f { 5.0 6.0 } 7.0 t f { 8.0 9.0 } f } +} ] [ + <" + M 1.0,+1 3,-10e-1 l 2 2, 2 -2, 2 2 v -9 1 H 9 8 z + M 0 0 C -4.0 0.0 -8.0 4.0 -8.0 8.0 -8.0 4.0 -12.0 8.0 -16.0 8.0 + s 0.0,2.0 2.0,0.0 + Q -2 0 0 -2 -3. 0 0 3 + t 1 2 3 4 + A 5 6 7 1 0 8 9 + "> svg-path>array +] unit-test diff --git a/extra/svg/svg.factor b/extra/svg/svg.factor new file mode 100644 index 0000000000..b5c5e96e90 --- /dev/null +++ b/extra/svg/svg.factor @@ -0,0 +1,223 @@ +USING: accessors arrays assocs fry kernel math math.affine-transforms math.constants +math.functions math.parser math.vectors memoize peg.ebnf sequences sequences.squish +splitting strings xml.data xml.utilities ; +IN: svg + +XML-NS: svg-name http://www.w3.org/2000/svg +XML-NS: xlink-name http://www.w3.org/1999/xlink +XML-NS: sodipodi-name http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd +XML-NS: inkscape-name http://www.inkscape.org/namespaces/inkscape + +: svg-string>number ( string -- number ) + { { CHAR: E CHAR: e } } substitute "e" split1 + [ string>number ] [ [ string>number 10 swap ^ ] [ 1 ] if* ] bi* * + >float ; + +: degrees ( deg -- rad ) pi * 180.0 / ; + +EBNF: svg-transform>affine-transform + +transforms = + transform:m comma-wsp+ transforms:n => [[ m n a. ]] + | transform +transform = + matrix + | translate + | scale + | rotate + | skewX + | skewY +matrix = + "matrix" wsp* "(" wsp* + number:xx comma-wsp + number:xy comma-wsp + number:yx comma-wsp + number:yy comma-wsp + number:ox comma-wsp + number:oy wsp* ")" + => [[ { xx xy } { yx yy } { ox oy } ]] +translate = + "translate" wsp* "(" wsp* number:tx ( comma-wsp number:ty => [[ ty ]] )?:ty wsp* ")" + => [[ tx ty 0.0 or 2array ]] +scale = + "scale" wsp* "(" wsp* number:sx ( comma-wsp number:sy => [[ sy ]] )?:sy wsp* ")" + => [[ sx sy sx or ]] +rotate = + "rotate" wsp* "(" wsp* number:a ( comma-wsp number:cx comma-wsp number:cy => [[ cx cy 2array ]])?:c wsp* ")" + => [[ a degrees c [ center-rotation ] when* ]] +skewX = + "skewX" wsp* "(" wsp* number:a wsp* ")" + => [[ { 1.0 0.0 } a degrees tan 1.0 2array { 0.0 0.0 } ]] +skewY = + "skewY" wsp* "(" wsp* number:a wsp* ")" + => [[ 1.0 a degrees tan 2array { 0.0 1.0 } { 0.0 0.0 } ]] +number = + sign? (floating-point-constant | integer-constant) => [[ squish-strings svg-string>number ]] +comma-wsp = + (wsp+ comma? wsp*) | (comma wsp*) +comma = + "," +integer-constant = + digit-sequence +floating-point-constant = + fractional-constant exponent? + | digit-sequence exponent +fractional-constant = + digit-sequence? "." digit-sequence + | digit-sequence "." +exponent = + ( "e" | "E" ) sign? digit-sequence +sign = + "+" => [[ f ]] | "-" +digit-sequence = [0-9]+ => [[ >string ]] +wsp = (" " | "\t" | "\r" | "\n") + +transform-list = wsp* transforms?:t wsp* + => [[ t [ identity-transform ] unless* ]] + +;EBNF + +: tag-transform ( tag -- transform ) + "transform" svg-name swap at svg-transform>affine-transform ; + +TUPLE: moveto p relative? ; +TUPLE: closepath ; +TUPLE: lineto p relative? ; +TUPLE: horizontal-lineto x relative? ; +TUPLE: vertical-lineto y relative? ; +TUPLE: curveto p1 p2 p relative? ; +TUPLE: smooth-curveto p2 p relative? ; +TUPLE: quadratic-bezier-curveto p1 p relative? ; +TUPLE: smooth-quadratic-bezier-curveto p relative? ; +TUPLE: elliptical-arc radii x-axis-rotation large-arc? sweep? p relative? ; + +: (set-relative) ( args rel -- args ) + '[ [ _ >>relative? drop ] each ] keep ; + +EBNF: svg-path>array + +moveto-drawto-command-groups = + moveto-drawto-command-group:first wsp* moveto-drawto-command-groups:rest + => [[ first rest append ]] + | moveto-drawto-command-group +moveto-drawto-command-group = + moveto:m wsp* drawto-commands?:d => [[ m d append ]] +drawto-commands = + drawto-command:first wsp* drawto-commands:rest => [[ first rest append ]] + | drawto-command +drawto-command = + closepath + | lineto + | horizontal-lineto + | vertical-lineto + | curveto + | smooth-curveto + | quadratic-bezier-curveto + | smooth-quadratic-bezier-curveto + | elliptical-arc +moveto = + ("M" => [[ f ]] | "m" => [[ t ]]):rel wsp* moveto-argument-sequence:args + => [[ args rel (set-relative) ]] +moveto-argument = coordinate-pair => [[ f moveto boa ]] +moveto-argument-sequence = + moveto-argument:first comma-wsp? lineto-argument-sequence:rest + => [[ rest first prefix ]] + | moveto-argument => [[ 1array ]] +closepath = + ("Z" | "z") => [[ drop closepath boa 1array ]] +lineto = + ("L" => [[ f ]] | "l" => [[ t ]]):rel wsp* lineto-argument-sequence:args + => [[ args rel (set-relative) ]] +lineto-argument = coordinate-pair => [[ f lineto boa ]] +lineto-argument-sequence = + lineto-argument:first comma-wsp? lineto-argument-sequence:rest + => [[ rest first prefix ]] + | lineto-argument => [[ 1array ]] +horizontal-lineto = + ( "H" => [[ f ]] | "h" => [[ t ]]):rel wsp* horizontal-lineto-argument-sequence:args + => [[ args rel (set-relative) ]] +horizontal-lineto-argument = coordinate => [[ f horizontal-lineto boa ]] +horizontal-lineto-argument-sequence = + horizontal-lineto-argument:first comma-wsp? horizontal-lineto-argument-sequence:rest + => [[ rest first prefix ]] + | horizontal-lineto-argument => [[ 1array ]] +vertical-lineto = + ( "V" => [[ f ]] | "v" => [[ t ]]):rel wsp* vertical-lineto-argument-sequence:args + => [[ args rel (set-relative) ]] +vertical-lineto-argument = coordinate => [[ f vertical-lineto boa ]] +vertical-lineto-argument-sequence = + vertical-lineto-argument:first comma-wsp? vertical-lineto-argument-sequence:rest + => [[ rest first prefix ]] + | vertical-lineto-argument => [[ 1array ]] +curveto = + ( "C" => [[ f ]] | "c" => [[ t ]]):rel wsp* curveto-argument-sequence:args + => [[ args rel (set-relative) ]] +curveto-argument-sequence = + curveto-argument:first comma-wsp? curveto-argument-sequence:rest + => [[ rest first prefix ]] + | curveto-argument => [[ 1array ]] +curveto-argument = + coordinate-pair:pone comma-wsp? coordinate-pair:ptwo comma-wsp? coordinate-pair:p + => [[ pone ptwo p f curveto boa ]] +smooth-curveto = + ( "S" => [[ f ]] | "s" => [[ t ]] ):rel wsp* smooth-curveto-argument-sequence:args + => [[ args rel (set-relative) ]] +smooth-curveto-argument-sequence = + smooth-curveto-argument:first comma-wsp? smooth-curveto-argument-sequence:rest + => [[ rest first prefix ]] + | smooth-curveto-argument => [[ 1array ]] +smooth-curveto-argument = + coordinate-pair:ptwo comma-wsp? coordinate-pair:p + => [[ ptwo p f smooth-curveto boa ]] +quadratic-bezier-curveto = + ( "Q" => [[ f ]] | "q" => [[ t ]] ):rel wsp* quadratic-bezier-curveto-argument-sequence:args + => [[ args rel (set-relative) ]] +quadratic-bezier-curveto-argument-sequence = + quadratic-bezier-curveto-argument:first comma-wsp? + quadratic-bezier-curveto-argument-sequence:rest + => [[ rest first prefix ]] + | quadratic-bezier-curveto-argument => [[ 1array ]] +quadratic-bezier-curveto-argument = + coordinate-pair:pone comma-wsp? coordinate-pair:p + => [[ pone p f quadratic-bezier-curveto boa ]] +smooth-quadratic-bezier-curveto = + ( "T" => [[ f ]] | "t" => [[ t ]] ):rel wsp* smooth-quadratic-bezier-curveto-argument-sequence:args + => [[ args rel (set-relative) ]] +smooth-quadratic-bezier-curveto-argument-sequence = + smooth-quadratic-bezier-curveto-argument:first comma-wsp? smooth-quadratic-bezier-curveto-argument-sequence:rest + => [[ rest first prefix ]] + | smooth-quadratic-bezier-curveto-argument => [[ 1array ]] +smooth-quadratic-bezier-curveto-argument = coordinate-pair => [[ f smooth-quadratic-bezier-curveto boa ]] +elliptical-arc = + ( "A" => [[ f ]] | "a" => [[ t ]] ):rel wsp* elliptical-arc-argument-sequence:args + => [[ args rel (set-relative) ]] +elliptical-arc-argument-sequence = + elliptical-arc-argument:first comma-wsp? elliptical-arc-argument-sequence:rest + => [[ rest first prefix ]] + | elliptical-arc-argument => [[ 1array ]] +elliptical-arc-argument = + nonnegative-number:radiix comma-wsp? nonnegative-number:radiiy comma-wsp? + number:xrot comma-wsp flag:large comma-wsp flag:sweep + comma-wsp coordinate-pair:p + => [[ radiix radiiy 2array xrot large sweep p f elliptical-arc boa ]] +coordinate-pair = coordinate:x comma-wsp? coordinate:y => [[ x y 2array ]] +coordinate = number +nonnegative-number = (floating-point-constant | integer-constant) => [[ squish-strings svg-string>number ]] +number = sign? (floating-point-constant | integer-constant) => [[ squish-strings svg-string>number ]] +flag = "0" => [[ f ]] | "1" => [[ t ]] +comma-wsp = (wsp+ comma? wsp*) | (comma wsp*) +comma = "," +integer-constant = digit-sequence +floating-point-constant = fractional-constant exponent? | digit-sequence exponent +fractional-constant = digit-sequence? "." digit-sequence | digit-sequence "." +exponent = ( "e" | "E" ) sign? digit-sequence +sign = "+" => [[ drop f ]] | "-" +digit-sequence = [0-9]+ => [[ >string ]] +wsp = (" " | "\t" | "\r" | "\n") + +svg-path = wsp* moveto-drawto-command-groups?:x wsp* => [[ x ]] + +;EBNF + +: tag-d ( tag -- d ) + "d" svg-name swap at svg-path>array ; -- 2.11.4.GIT