build-support/wordsize
*.bak
.#*
+*.swo
{ $values
{ "seq" sequence } }
-{ $description "" } ;
+{ $description "Returns a sequence of key/value pairs from the operating system." }
+{ $notes "In most cases, use " { $link os-envs } " instead." } ;
HELP: (set-os-envs)
{ $values
{ "seq" sequence } }
-{ $description "" } ;
+{ $description "Low-level word for replacing the current set of environment variables." }
+{ $notes "In most cases, use " { $link set-os-envs } " instead." } ;
HELP: os-env ( key -- value )
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators generic assocs help http io io.styles
+USING: combinators generic assocs io io.styles
io.files continuations io.streams.string kernel math math.order
math.parser namespaces make quotations assocs sequences strings
words html.elements xml.entities sbufs continuations destructors
{ "n" integer } { "s" integer } { "w" integer }
{ "n" integer }
}
-{ $description "" } ;
+{ $description "Calls " { $link shift } " on " { $snippet "n" } " and " { $snippet "s" } ", wrapping the result to " { $snippet "w" } " bits." } ;
HELP: unmask
{ $values
-USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ;
+USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings multiline ;
IN: math.blas.matrices
ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
{ $subsection double-blas-matrix }
{ $subsection float-complex-blas-matrix }
{ $subsection double-complex-blas-matrix }
-"Syntax words are provided for constructing literal vectors and matrices in the " { $vocab-link "math.blas.syntax" } " vocabulary:"
-{ $subsection "math.blas.syntax" }
"There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:"
{ $subsection <float-blas-vector> }
{ $subsection <double-blas-vector> }
{ $subsection n*M! }
{ $subsection n*M }
{ $subsection M*n }
-{ $subsection M/n } ;
+{ $subsection M/n }
+"Literal syntax:"
+{ $subsection POSTPONE: smatrix{ }
+{ $subsection POSTPONE: dmatrix{ }
+{ $subsection POSTPONE: cmatrix{ }
+{ $subsection POSTPONE: zmatrix{ } ;
+
ABOUT: "math.blas.matrices"
{ $values { "length" "The length of the new vector" } { "exemplar" blas-vector-base blas-matrix-base } { "vector" blas-vector-base } }
{ $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ;
+HELP: smatrix{
+{ $syntax <" smatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 1.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ { 0.0 0.0 0.0 1.0 }
+} "> }
+{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+HELP: dmatrix{
+{ $syntax <" dmatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 1.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ { 0.0 0.0 0.0 1.0 }
+} "> }
+{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+HELP: cmatrix{
+{ $syntax <" cmatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 -1.0 3.0 }
+ { 0.0 0.0 0.0 C{ 0.0 -1.0 } }
+} "> }
+{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+HELP: zmatrix{
+{ $syntax <" zmatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 -1.0 3.0 }
+ { 0.0 0.0 0.0 C{ 0.0 -1.0 } }
+} "> }
+{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+{
+ POSTPONE: smatrix{ POSTPONE: dmatrix{
+ POSTPONE: cmatrix{ POSTPONE: zmatrix{
+} related-words
-USING: kernel math.blas.matrices math.blas.vectors math.blas.syntax
+USING: kernel math.blas.matrices math.blas.vectors
sequences tools.test ;
IN: math.blas.matrices.tests
math.complex math.functions math.order functors words
sequences sequences.merged sequences.private shuffle
specialized-arrays.direct.float specialized-arrays.direct.double
-specialized-arrays.float specialized-arrays.double ;
+specialized-arrays.float specialized-arrays.double
+parser prettyprint.backend prettyprint.custom ;
IN: math.blas.matrices
TUPLE: blas-matrix-base underlying ld rows cols transpose ;
MATRIX DEFINES ${TYPE}-blas-matrix
<MATRIX> DEFINES <${TYPE}-blas-matrix>
>MATRIX DEFINES >${TYPE}-blas-matrix
+XMATRIX{ DEFINES ${T}matrix{
WHERE
[ TYPE>ARG ] (prepare-ger)
[ XGERC ] dip ;
+: XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing
+
+M: MATRIX pprint-delims
+ drop \ XMATRIX{ \ } ;
+
;FUNCTOR
"double-complex" "z" define-complex-blas-matrix
>>
+
+M: blas-matrix-base >pprint-sequence Mrows ;
+M: blas-matrix-base pprint* pprint-object ;
+++ /dev/null
-Literal syntax for BLAS vectors and matrices
+++ /dev/null
-USING: help.markup help.syntax math.blas.matrices math.blas.vectors multiline ;
-IN: math.blas.syntax
-
-ARTICLE: "math.blas.syntax" "BLAS interface literal syntax"
-"Vectors:"
-{ $subsection POSTPONE: svector{ }
-{ $subsection POSTPONE: dvector{ }
-{ $subsection POSTPONE: cvector{ }
-{ $subsection POSTPONE: zvector{ }
-"Matrices:"
-{ $subsection POSTPONE: smatrix{ }
-{ $subsection POSTPONE: dmatrix{ }
-{ $subsection POSTPONE: cmatrix{ }
-{ $subsection POSTPONE: zmatrix{ } ;
-
-ABOUT: "math.blas.syntax"
-
-HELP: svector{
-{ $syntax "svector{ 1.0 -2.0 3.0 }" }
-{ $description "Construct a literal " { $link float-blas-vector } "." } ;
-
-HELP: dvector{
-{ $syntax "dvector{ 1.0 -2.0 3.0 }" }
-{ $description "Construct a literal " { $link double-blas-vector } "." } ;
-
-HELP: cvector{
-{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
-{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ;
-
-HELP: zvector{
-{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
-{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ;
-
-{
- POSTPONE: svector{ POSTPONE: dvector{
- POSTPONE: cvector{ POSTPONE: zvector{
-} related-words
-
-HELP: smatrix{
-{ $syntax <" smatrix{
- { 1.0 0.0 0.0 1.0 }
- { 0.0 1.0 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- { 0.0 0.0 0.0 1.0 }
-} "> }
-{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
-
-HELP: dmatrix{
-{ $syntax <" dmatrix{
- { 1.0 0.0 0.0 1.0 }
- { 0.0 1.0 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- { 0.0 0.0 0.0 1.0 }
-} "> }
-{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
-
-HELP: cmatrix{
-{ $syntax <" cmatrix{
- { 1.0 0.0 0.0 1.0 }
- { 0.0 C{ 0.0 1.0 } 0.0 2.0 }
- { 0.0 0.0 -1.0 3.0 }
- { 0.0 0.0 0.0 C{ 0.0 -1.0 } }
-} "> }
-{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
-
-HELP: zmatrix{
-{ $syntax <" zmatrix{
- { 1.0 0.0 0.0 1.0 }
- { 0.0 C{ 0.0 1.0 } 0.0 2.0 }
- { 0.0 0.0 -1.0 3.0 }
- { 0.0 0.0 0.0 C{ 0.0 -1.0 } }
-} "> }
-{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
-
-{
- POSTPONE: smatrix{ POSTPONE: dmatrix{
- POSTPONE: cmatrix{ POSTPONE: zmatrix{
-} related-words
+++ /dev/null
-USING: kernel math.blas.vectors math.blas.matrices parser
-arrays prettyprint.backend prettyprint.custom sequences ;
-IN: math.blas.syntax
-
-: svector{
- \ } [ >float-blas-vector ] parse-literal ; parsing
-: dvector{
- \ } [ >double-blas-vector ] parse-literal ; parsing
-: cvector{
- \ } [ >float-complex-blas-vector ] parse-literal ; parsing
-: zvector{
- \ } [ >double-complex-blas-vector ] parse-literal ; parsing
-
-: smatrix{
- \ } [ >float-blas-matrix ] parse-literal ; parsing
-: dmatrix{
- \ } [ >double-blas-matrix ] parse-literal ; parsing
-: cmatrix{
- \ } [ >float-complex-blas-matrix ] parse-literal ; parsing
-: zmatrix{
- \ } [ >double-complex-blas-matrix ] parse-literal ; parsing
-
-M: float-blas-vector pprint-delims
- drop \ svector{ \ } ;
-M: double-blas-vector pprint-delims
- drop \ dvector{ \ } ;
-M: float-complex-blas-vector pprint-delims
- drop \ cvector{ \ } ;
-M: double-complex-blas-vector pprint-delims
- drop \ zvector{ \ } ;
-
-M: float-blas-matrix pprint-delims
- drop \ smatrix{ \ } ;
-M: double-blas-matrix pprint-delims
- drop \ dmatrix{ \ } ;
-M: float-complex-blas-matrix pprint-delims
- drop \ cmatrix{ \ } ;
-M: double-complex-blas-matrix pprint-delims
- drop \ zmatrix{ \ } ;
-
-M: blas-vector-base >pprint-sequence ;
-M: blas-vector-base pprint* pprint-object ;
-M: blas-matrix-base >pprint-sequence Mrows ;
-M: blas-matrix-base pprint* pprint-object ;
{ $subsection V- }
"Vector inner products:"
{ $subsection V. }
-{ $subsection V.conj } ;
+{ $subsection V.conj }
+"Literal syntax:"
+{ $subsection POSTPONE: svector{ }
+{ $subsection POSTPONE: dvector{ }
+{ $subsection POSTPONE: cvector{ }
+{ $subsection POSTPONE: zvector{ } ;
ABOUT: "math.blas.vectors"
HELP: Vsub
{ $values { "v" blas-vector-base } { "start" integer } { "length" integer } { "sub" blas-vector-base } }
{ $description "Slice a subvector out of " { $snippet "v" } " starting at " { $snippet "start" } " with the given " { $snippet "length" } ". The subvector will share storage with the parent vector." } ;
+
+HELP: svector{
+{ $syntax "svector{ 1.0 -2.0 3.0 }" }
+{ $description "Construct a literal " { $link float-blas-vector } "." } ;
+
+HELP: dvector{
+{ $syntax "dvector{ 1.0 -2.0 3.0 }" }
+{ $description "Construct a literal " { $link double-blas-vector } "." } ;
+
+HELP: cvector{
+{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
+{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ;
+
+HELP: zvector{
+{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
+{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ;
+
+{
+ POSTPONE: svector{ POSTPONE: dvector{
+ POSTPONE: cvector{ POSTPONE: zvector{
+} related-words
+
-USING: kernel math.blas.vectors math.blas.syntax sequences tools.test ;
+USING: kernel math.blas.vectors sequences tools.test ;
IN: math.blas.vectors.tests
! clone
combinators.short-circuit fry kernel math math.blas.cblas
math.complex math.functions math.order sequences.complex
sequences.complex-components sequences sequences.private
-functors words locals
+functors words locals parser prettyprint.backend prettyprint.custom
specialized-arrays.float specialized-arrays.double
specialized-arrays.direct.float specialized-arrays.direct.double ;
IN: math.blas.vectors
<VECTOR> DEFINES <${TYPE}-blas-vector>
>VECTOR DEFINES >${TYPE}-blas-vector
+XVECTOR{ DEFINES ${T}vector{
+
WHERE
TUPLE: VECTOR < blas-vector-base ;
[ [ length>> ] [ inc>> ] bi * ] bi
<DIRECT-ARRAY> ;
+: XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing
+
+M: VECTOR pprint-delims
+ drop \ XVECTOR{ \ } ;
+
;FUNCTOR
>>
+M: blas-vector-base >pprint-sequence ;
+M: blas-vector-base pprint* pprint-object ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test constructors calendar kernel accessors
+combinators.short-circuit ;
+IN: constructors.tests
+
+TUPLE: stock-spread stock spread timestamp ;
+
+CONSTRUCTOR: stock-spread ( stock spread -- stock-spread )
+ now >>timestamp ;
+
+SYMBOL: AAPL
+
+[ t ] [
+ AAPL 1234 <stock-spread>
+ {
+ [ stock>> AAPL eq? ]
+ [ spread>> 1234 = ]
+ [ timestamp>> timestamp? ]
+ } 1&&
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: slots kernel sequences fry accessors parser lexer words
+effects.parser macros ;
+IN: constructors
+
+! An experiment
+
+MACRO: set-slots ( slots -- quot )
+ <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
+
+: construct ( ... class slots -- instance )
+ [ new ] dip set-slots ; inline
+
+: define-constructor ( name class effect body -- )
+ [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
+ define-declared ;
+
+: CONSTRUCTOR:
+ scan-word [ name>> "<" ">" surround create-in ] keep
+ "(" expect ")" parse-effect
+ parse-definition
+ define-constructor ; parsing
\ No newline at end of file
[ { 7 11 } ] [ { $ seven-eleven } ] unit-test
[ { 6 6 6 } ] [ { $ six-six-six } ] unit-test
+[ { 6 6 6 7 } ] [ { $ six-six-six 7 } ] unit-test
+
[ { 8 8 8 } ] [ { $[ six-six-six [ 2 + ] tri@ ] } ] unit-test
+
+[ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test
+
+[ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test
! (c) Joe Groff, see license for details
-USING: continuations kernel parser words quotations ;
+USING: continuations kernel parser words quotations vectors ;
IN: literals
-: $ scan-word [ execute ] curry with-datastack ; parsing
-: $[ \ ] parse-until >quotation with-datastack ; parsing
+: $ scan-word [ execute ] curry with-datastack >vector ; parsing
+: $[ \ ] parse-until >quotation with-datastack >vector ; parsing
--- /dev/null
+! (c)2009 Joe Groff, see BSD license
+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 } <affine-transform>
+ { 1.0 2.0 } a.v
+] unit-test
+
+[ -1.125 ] [
+ { 0.75 0.75 } { 0.75 -0.75 } { 5.0 5.0 } <affine-transform>
+ |a|
+] unit-test
+
+{ 1.0 3.0 } { 2.0 4.0 } { 5.0 6.0 } <affine-transform> 1array [
+ { 1.0 2.0 } { 3.0 4.0 } { 5.0 6.0 } <affine-transform>
+ transpose-axes
+] unit-test
+
+{ 1.0 -1.0 } { 1.0 1.0 } { 0.0 0.0 } <affine-transform> 1array [
+ { 0.5 0.5 } { -0.5 0.5 } { 5.0 5.0 } <affine-transform>
+ inverse-axes
+] unit-test
+
+{ 1.0 -1.0 } { 1.0 1.0 } { -10.0 0.0 } <affine-transform> 1array [
+ { 0.5 0.5 } { -0.5 0.5 } { 5.0 5.0 } <affine-transform>
+ inverse-transform
+] unit-test
+
+{ 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } <affine-transform> 1array [
+ { 0.5 0.5 } { -0.5 0.5 } { 5.0 5.0 } <affine-transform>
+ dup inverse-transform a.
+] unit-test
+
+[ t ] [
+ { 0.01 0.02 } { 0.03 0.04 } { 0.05 0.06 } <affine-transform>
+ { 0.011 0.021 } { 0.031 0.041 } { 0.051 0.061 } <affine-transform> 0.01 a~
+] unit-test
+
+{ 1.0 0.0 } { 0.0 1.0 } { 5.0 10.0 } <affine-transform> 1array [
+ { 5.0 10.0 } <translation>
+] unit-test
+
+{ $[ pi 0.25 * cos ] $[ pi 0.25 * sin ] }
+{ $[ pi -0.25 * sin ] $[ pi 0.25 * cos ] }
+{ 0.0 0.0 } <affine-transform> 1array [
+ pi 0.25 * <rotation>
+] unit-test
--- /dev/null
+! (c)2009 Joe Groff, see BSD license
+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> 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+ ;
+
+: <translation> ( origin -- a )
+ [ { 1.0 0.0 } { 0.0 1.0 } ] dip <affine-transform> ;
+: <rotation> ( theta -- transform )
+ [ cos ] [ sin ] bi
+ [ 2array ] [ neg swap 2array ] 2bi { 0.0 0.0 } <affine-transform> ;
+: <scale> ( x y -- transform )
+ [ 0.0 2array ] [ 0.0 swap 2array ] bi* { 0.0 0.0 } <affine-transform> ;
+
+: 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 } <affine-transform> ;
+
+: 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 <affine-transform> ;
+
+: 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 <affine-transform> ;
+
+: v~ ( a b epsilon -- ? )
+ [ ~ ] curry 2all? ;
+
+: a~ ( a b epsilon -- ? )
+ {
+ [ [ [ x>> ] bi@ ] dip v~ ]
+ [ [ [ y>> ] bi@ ] dip v~ ]
+ [ [ [ origin>> ] bi@ ] dip v~ ]
+ } 3&& ;
--- /dev/null
+Affine transforms for two-dimensional vectors
--- /dev/null
+USING: arrays kernel sequences sequences.cartesian-product tools.test ;
+IN: sequences.product.tests
+
+[
+ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } }
+] [ { { 0 1 2 } { "a" "b" } } [ ] cartesian-product-map ] unit-test
+
+[
+ {
+ { 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t }
+ { 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f }
+ }
+] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] cartesian-product-map ] unit-test
+
+[
+ { "012012" "aaabbb" }
+] [ { { "0" "1" "2" } { "a" "b" } } [ [ first2 ] bi* [ append ] bi@ 2array ] cartesian-product-each ] unit-test
+
+
--- /dev/null
+Slava Pestov
+Joe Groff
--- /dev/null
+! (c)2009 Slava Pestov & Joe Groff, see BSD license
+USING: kernel sequences sequences.squish tools.test vectors ;
+IN: sequences.squish.tests
+
+[ { { 1 2 3 } { 4 } { 5 6 } } ] [
+ V{ { 1 2 3 } V{ { 4 } { 5 6 } } }
+ [ vector? ] { } squish
+] unit-test
--- /dev/null
+! (c)2009 Slava Pestov & Joe Groff, see BSD license
+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 ;
--- /dev/null
+Sequence flattening with parameterized descent predicate
--- /dev/null
+Parsers for SVG data
--- /dev/null
+! (c)2009 Joe Groff, see BSD license
+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 } <affine-transform> 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 } <affine-transform> 1array [
+ "translate(5.0, 1e1 )" svg-transform>affine-transform
+] unit-test
+
+{ 1.0 0.0 } { 0.0 1.0 } { 5.0 10.0 } <affine-transform> 1array [
+ "translate( 5.0 1e+1)" svg-transform>affine-transform
+] unit-test
+
+{ 2.0 0.0 } { 0.0 2.0 } { 0.0 0.0 } <affine-transform> 1array [
+ "scale(2.0)" svg-transform>affine-transform
+] unit-test
+
+{ 2.0 0.0 } { 0.0 4.0 } { 0.0 0.0 } <affine-transform> 1array [
+ "scale(2.0 4.0)" svg-transform>affine-transform
+] unit-test
+
+{ 2.0 0.0 } { 0.0 4.0 } { 0.0 0.0 } <affine-transform> 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 } <affine-transform> 1array [
+ "skewX(45)" svg-transform>affine-transform
+] unit-test
+
+{ 1.0 $[ -45 degrees tan ] } { 0.0 1.0 } { 0.0 0.0 } <affine-transform> 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 } <affine-transform> 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 * - ]
+ } <affine-transform> 0.001 a~
+] unit-test
+
+{ $[ 30 degrees cos ] $[ 30 degrees sin ] }
+{ $[ -30 degrees sin ] $[ 30 degrees cos ] }
+{ 1.0 2.0 } <affine-transform> 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
--- /dev/null
+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 } <affine-transform> ]]
+translate =
+ "translate" wsp* "(" wsp* number:tx ( comma-wsp number:ty => [[ ty ]] )?:ty wsp* ")"
+ => [[ tx ty 0.0 or 2array <translation> ]]
+scale =
+ "scale" wsp* "(" wsp* number:sx ( comma-wsp number:sy => [[ sy ]] )?:sy wsp* ")"
+ => [[ sx sy sx or <scale> ]]
+rotate =
+ "rotate" wsp* "(" wsp* number:a ( comma-wsp number:cx comma-wsp number:cy => [[ cx cy 2array ]])?:c wsp* ")"
+ => [[ a degrees <rotation> 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 } <affine-transform> ]]
+skewY =
+ "skewY" wsp* "(" wsp* number:a wsp* ")"
+ => [[ 1.0 a degrees tan 2array { 0.0 1.0 } { 0.0 0.0 } <affine-transform> ]]
+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 ;
--- /dev/null
+xml
+graphics
+svg
projects / factor.git / commitdiff