Merge branch 'master' into new_ui
Slava Pestov
commit
651c298eb3
|
|
@ -21,3 +21,4 @@ logs
|
|||
work
|
||||
build-support/wordsize
|
||||
*.bak
|
||||
.#*
|
||||
|
|
|
|||
|
|
@ -21,11 +21,3 @@ IN: compiler.utilities
|
|||
: map-flat ( seq quot -- seq' ) [ each ] flattening ; inline
|
||||
|
||||
: 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline
|
||||
|
||||
: (3each) ( seq1 seq2 seq3 quot -- n quot' )
|
||||
[ [ [ length ] tri@ min min ] 3keep ] dip
|
||||
'[ [ _ nth-unsafe ] [ _ nth-unsafe ] [ _ nth-unsafe ] tri @ ] ; inline
|
||||
|
||||
: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
|
||||
|
||||
: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
|
||||
|
|
|
|||
|
|
@ -359,6 +359,17 @@ HELP: 2bi*
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: 2tri*
|
||||
{ $values { "u" object } { "v" object } { "w" object } { "x" object } { "y" object } { "z" object } { "p" { $quotation "( u v -- ... )" } } { "q" { $quotation "( w x -- ... )" } } { "r" { $quotation "( y z -- ... )" } } }
|
||||
{ $description "Applies " { $snippet "p" } " to " { $snippet "u" } " and " { $snippet "v" } ", then applies " { $snippet "q" } " to " { $snippet "w" } " and " { $snippet "x" } ", and finally applies " { $snippet "r" } " to " { $snippet "y" } " and " { $snippet "z" } "." }
|
||||
{ $examples
|
||||
"The following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] [ r ] 2tri*"
|
||||
"[ [ p ] 2dip q ] 2dip r"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: tri*
|
||||
{ $values { "x" object } { "y" object } { "z" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( y -- ... )" } } { "r" { $quotation "( z -- ... )" } } }
|
||||
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } ", and finally applies " { $snippet "r" } " to " { $snippet "z" } "." }
|
||||
|
|
@ -418,6 +429,22 @@ HELP: tri@
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: 2tri@
|
||||
{ $values { "u" object } { "v" object } { "w" object } { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj1 obj2 -- ... )" } } }
|
||||
{ $description "Applies the quotation to " { $snippet "u" } " and " { $snippet "v" } ", then to " { $snippet "w" } " and " { $snippet "x" } ", and then to " { $snippet "y" } " and " { $snippet "z" } "." }
|
||||
{ $examples
|
||||
"The following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] 2tri@"
|
||||
"[ [ p ] 2dip p ] 2dip p"
|
||||
}
|
||||
"The following two lines are also equivalent:"
|
||||
{ $code
|
||||
"[ p ] 2tri@"
|
||||
"[ p ] [ p ] [ p ] 2tri*"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: if
|
||||
{ $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } }
|
||||
{ $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation."
|
||||
|
|
@ -595,12 +622,20 @@ HELP: 2dip
|
|||
|
||||
HELP: 3dip
|
||||
{ $values { "x" object } { "y" object } { "z" object } { "quot" quotation } }
|
||||
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } " hidden on the retain stack." }
|
||||
{ $description "Calls " { $snippet "quot" } " with " { $snippet "x" } ", " { $snippet "y" } " and " { $snippet "z" } " hidden on the retain stack." }
|
||||
{ $notes "The following are equivalent:"
|
||||
{ $code "[ [ [ foo bar ] dip ] dip ] dip" }
|
||||
{ $code "[ foo bar ] 3dip" }
|
||||
} ;
|
||||
|
||||
HELP: 4dip
|
||||
{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" quotation } }
|
||||
{ $description "Calls " { $snippet "quot" } " with " { $snippet "w" } ", " { $snippet "x" } ", " { $snippet "y" } " and " { $snippet "z" } " hidden on the retain stack." }
|
||||
{ $notes "The following are equivalent:"
|
||||
{ $code "[ [ [ [ foo bar ] dip ] dip ] dip ] dip" }
|
||||
{ $code "[ foo bar ] 4dip" }
|
||||
} ;
|
||||
|
||||
HELP: while
|
||||
{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
|
||||
{ $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link f } "." } ;
|
||||
|
|
@ -735,7 +770,7 @@ $nl
|
|||
{ $subsection "cleave-shuffle-equivalence" } ;
|
||||
|
||||
ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
|
||||
"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "."
|
||||
"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", " { $link tri* } ", and " { $link 2tri* } "."
|
||||
$nl
|
||||
"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
|
||||
{ $code
|
||||
|
|
@ -775,6 +810,7 @@ $nl
|
|||
{ $subsection 2bi* }
|
||||
"Three quotations:"
|
||||
{ $subsection tri* }
|
||||
{ $subsection 2tri* }
|
||||
"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
|
||||
{ $code
|
||||
"! First alternative; uses dip"
|
||||
|
|
@ -793,6 +829,7 @@ $nl
|
|||
{ $subsection 2bi@ }
|
||||
"Three quotations:"
|
||||
{ $subsection tri@ }
|
||||
{ $subsection 2tri@ }
|
||||
"A pair of utility words built from " { $link bi@ } ":"
|
||||
{ $subsection both? }
|
||||
{ $subsection either? } ;
|
||||
|
|
@ -804,6 +841,7 @@ $nl
|
|||
{ $subsection dip }
|
||||
{ $subsection 2dip }
|
||||
{ $subsection 3dip }
|
||||
{ $subsection 4dip }
|
||||
"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
|
||||
{ $subsection slip }
|
||||
{ $subsection 2slip }
|
||||
|
|
|
|||
|
|
@ -163,3 +163,9 @@ IN: kernel.tests
|
|||
[ [ 1 2 3 throw [ ] [ ] if 4 ] call ] ignore-errors
|
||||
last-frame
|
||||
] unit-test
|
||||
|
||||
[ 10 2 3 4 5 ] [ 1 2 3 4 5 [ 10 * ] 4dip ] unit-test
|
||||
|
||||
[ 3 -1 5/6 ] [ 1 2 3 4 5 6 [ + ] [ - ] [ / ] 2tri* ] unit-test
|
||||
|
||||
[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test
|
||||
|
|
@ -79,6 +79,8 @@ DEFER: if
|
|||
|
||||
: 3dip ( x y z quot -- x y z ) -roll 3slip ;
|
||||
|
||||
: 4dip ( w x y z quot -- w x y z ) swap [ 3dip ] dip ; inline
|
||||
|
||||
! Keepers
|
||||
: keep ( x quot -- x ) over slip ; inline
|
||||
|
||||
|
|
@ -118,6 +120,9 @@ DEFER: if
|
|||
: 2bi* ( w x y z p q -- )
|
||||
[ 2dip ] dip call ; inline
|
||||
|
||||
: 2tri* ( u v w x y z p q r -- )
|
||||
[ 4dip ] 2dip 2bi* ; inline
|
||||
|
||||
! Appliers
|
||||
: bi@ ( x y quot -- )
|
||||
dup bi* ; inline
|
||||
|
|
@ -129,6 +134,9 @@ DEFER: if
|
|||
: 2bi@ ( w x y z quot -- )
|
||||
dup 2bi* ; inline
|
||||
|
||||
: 2tri@ ( u v w y x z quot -- )
|
||||
dup dup 2tri* ; inline
|
||||
|
||||
! Object protocol
|
||||
GENERIC: hashcode* ( depth obj -- code )
|
||||
|
||||
|
|
|
|||
|
|
@ -1112,15 +1112,6 @@ HELP: virtual@
|
|||
{ "n'" integer } { "seq'" sequence } }
|
||||
{ $description "Part of the sequence protocol, this word translates the input index " { $snippet "n" } " into an index into the underlying storage returned by " { $link virtual-seq } "." } ;
|
||||
|
||||
HELP: 2change-each
|
||||
{ $values
|
||||
{ "seq1" sequence } { "seq2" sequence } { "quot" quotation } }
|
||||
{ $description "Calls the quotation on subsequent pairs of objects from the two input sequences. The resulting computation replaces the element in the first sequence." }
|
||||
{ $examples { $example "USING: kernel math sequences prettyprint ;"
|
||||
"{ 10 20 30 } dup { 60 70 80 } [ + ] 2change-each ."
|
||||
"{ 70 90 110 }"
|
||||
} } ;
|
||||
|
||||
HELP: 2map-reduce
|
||||
{ $values
|
||||
{ "seq1" sequence } { "seq2" sequence } { "map-quot" quotation } { "reduce-quot" quotation }
|
||||
|
|
|
|||
|
|
@ -32,8 +32,8 @@ IN: sequences.tests
|
|||
[ 4 CHAR: o ]
|
||||
[ 3 "hello world" "aeiou" [ member? ] curry find-from ] unit-test
|
||||
|
||||
[ f ] [ 3 [ ] member? ] unit-test
|
||||
[ f ] [ 3 [ 1 2 ] member? ] unit-test
|
||||
[ f ] [ 3 [ ] member? ] unit-test
|
||||
[ f ] [ 3 [ 1 2 ] member? ] unit-test
|
||||
[ t ] [ 1 [ 1 2 ] member? ] unit-test
|
||||
[ t ] [ 2 [ 1 2 ] member? ] unit-test
|
||||
|
||||
|
|
@ -55,6 +55,11 @@ IN: sequences.tests
|
|||
|
||||
[ [ 3 ] ] [ [ 1 2 3 ] 2 [ swap < ] curry filter ] unit-test
|
||||
|
||||
[ V{ 1 2 3 } ] [ V{ 1 4 2 5 3 6 } clone [ [ 4 < ] filter-here ] keep ] unit-test
|
||||
[ V{ 4 2 6 } ] [ V{ 1 4 2 5 3 6 } clone [ [ 2 mod 0 = ] filter-here ] keep ] unit-test
|
||||
|
||||
[ V{ 3 } ] [ V{ 1 2 3 } clone [ 2 [ swap < ] curry filter-here ] keep ] unit-test
|
||||
|
||||
[ "hello world how are you" ]
|
||||
[ { "hello" "world" "how" "are" "you" } " " join ]
|
||||
unit-test
|
||||
|
|
@ -261,3 +266,14 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
|
|||
|
||||
[ "a,b" ] [ "a" "b" "," glue ] unit-test
|
||||
[ "(abc)" ] [ "abc" "(" ")" surround ] unit-test
|
||||
|
||||
[ "HELLO" ] [
|
||||
"HELLO" { -1 -1 -1 -1 -1 } { 2 2 2 2 2 2 }
|
||||
[ * 2 + + ] 3map
|
||||
] unit-test
|
||||
|
||||
{ 3 1 } [ [ 3array ] 3map ] must-infer-as
|
||||
|
||||
{ 3 0 } [ [ 3drop ] 3each ] must-infer-as
|
||||
|
||||
[ V{ 0 3 } ] [ "A" { "A" "B" "C" "A" "D" } indices ] unit-test
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel kernel.private slots.private math
|
||||
math.private math.order ;
|
||||
|
|
@ -117,9 +117,9 @@ INSTANCE: integer immutable-sequence
|
|||
[ tuck [ nth-unsafe ] 2bi@ ]
|
||||
[ tuck [ set-nth-unsafe ] 2bi@ ] 3bi ; inline
|
||||
|
||||
: (head) ( seq n -- from to seq ) 0 spin ; inline
|
||||
: (head) ( seq n -- from to seq ) [ 0 ] 2dip swap ; inline
|
||||
|
||||
: (tail) ( seq n -- from to seq ) over length rot ; inline
|
||||
: (tail) ( seq n -- from to seq ) swap [ length ] keep ; inline
|
||||
|
||||
: from-end ( seq n -- seq n' ) [ dup length ] dip - ; inline
|
||||
|
||||
|
|
@ -346,11 +346,19 @@ PRIVATE>
|
|||
[ over ] dip [ nth-unsafe ] 2bi@ ; inline
|
||||
|
||||
: (2each) ( seq1 seq2 quot -- n quot' )
|
||||
[ [ min-length ] 2keep ] dip
|
||||
[ [ 2nth-unsafe ] dip call ] 3curry ; inline
|
||||
[
|
||||
[ min-length ] 2keep
|
||||
[ 2nth-unsafe ] 2curry
|
||||
] dip compose ; inline
|
||||
|
||||
: 2map-into ( seq1 seq2 quot into -- newseq )
|
||||
[ (2each) ] dip collect ; inline
|
||||
: 3nth-unsafe ( n seq1 seq2 seq3 -- elt1 elt2 elt3 )
|
||||
[ over ] 2dip [ over ] dip [ nth-unsafe ] 2tri@ ; inline
|
||||
|
||||
: (3each) ( seq1 seq2 seq3 quot -- n quot' )
|
||||
[
|
||||
[ [ length ] tri@ min min ] 3keep
|
||||
[ 3nth-unsafe ] 3curry
|
||||
] dip compose ; inline
|
||||
|
||||
: finish-find ( i seq -- i elt )
|
||||
over [ dupd nth-unsafe ] [ drop f ] if ; inline
|
||||
|
|
@ -407,18 +415,23 @@ PRIVATE>
|
|||
[ -rot ] dip 2each ; inline
|
||||
|
||||
: 2map-as ( seq1 seq2 quot exemplar -- newseq )
|
||||
[ 2over min-length ] dip
|
||||
[ [ 2map-into ] keep ] new-like ; inline
|
||||
[ (2each) ] dip map-as ; inline
|
||||
|
||||
: 2map ( seq1 seq2 quot -- newseq )
|
||||
pick 2map-as ; inline
|
||||
|
||||
: 2change-each ( seq1 seq2 quot -- )
|
||||
pick 2map-into ; inline
|
||||
|
||||
: 2all? ( seq1 seq2 quot -- ? )
|
||||
(2each) all-integers? ; inline
|
||||
|
||||
: 3each ( seq1 seq2 seq3 quot -- )
|
||||
(3each) each ; inline
|
||||
|
||||
: 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq )
|
||||
[ (3each) ] dip map-as ; inline
|
||||
|
||||
: 3map ( seq1 seq2 seq3 quot -- newseq )
|
||||
[ pick ] dip swap 3map-as ; inline
|
||||
|
||||
: find-from ( n seq quot -- i elt )
|
||||
[ (find-integer) ] (find-from) ; inline
|
||||
|
||||
|
|
@ -494,10 +507,12 @@ PRIVATE>
|
|||
: last-index-from ( obj i seq -- n )
|
||||
rot [ = ] curry find-last-from drop ;
|
||||
|
||||
: (indices) ( elt i obj accum -- )
|
||||
[ swap [ = ] dip ] dip [ push ] 2curry when ; inline
|
||||
|
||||
: indices ( obj seq -- indices )
|
||||
V{ } clone spin
|
||||
[ rot = [ over push ] [ drop ] if ]
|
||||
curry each-index ;
|
||||
swap V{ } clone
|
||||
[ [ (indices) ] 2curry each-index ] keep ;
|
||||
|
||||
: nths ( indices seq -- seq' )
|
||||
[ nth ] curry map ;
|
||||
|
|
@ -566,7 +581,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
|||
PRIVATE>
|
||||
|
||||
: filter-here ( seq quot -- )
|
||||
0 0 roll (filter-here) ; inline
|
||||
swap [ 0 0 ] dip (filter-here) ; inline
|
||||
|
||||
: delete ( elt seq -- )
|
||||
[ = not ] with filter-here ;
|
||||
|
|
@ -828,7 +843,7 @@ PRIVATE>
|
|||
|
||||
: supremum ( seq -- n ) dup first [ max ] reduce ;
|
||||
|
||||
: sigma ( seq quot -- n ) 0 -rot [ rot slip + ] curry each ; inline
|
||||
: sigma ( seq quot -- n ) [ 0 ] 2dip [ rot slip + ] curry each ; inline
|
||||
|
||||
: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,448 @@
|
|||
|
||||
USING: accessors arrays assocs colors combinators.short-circuit
|
||||
kernel locals math math.functions math.matrices math.order
|
||||
math.parser math.trig math.vectors opengl opengl.demo-support
|
||||
opengl.gl sbufs sequences strings ui.gadgets ui.gadgets.worlds
|
||||
ui.gestures ui.render ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
IN: L-system
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <turtle> pos ori angle length thickness color vertices saved ;
|
||||
|
||||
DEFER: default-L-parser-values
|
||||
|
||||
: reset-turtle ( turtle -- turtle )
|
||||
{ 0 0 0 } clone >>pos
|
||||
3 identity-matrix >>ori
|
||||
V{ } clone >>vertices
|
||||
V{ } clone >>saved
|
||||
|
||||
default-L-parser-values ;
|
||||
|
||||
: turtle ( -- turtle ) <turtle> new reset-turtle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: step-turtle ( TURTLE LENGTH -- turtle )
|
||||
|
||||
TURTLE
|
||||
TURTLE pos>> TURTLE ori>> { 0 0 LENGTH } m.v v+
|
||||
>>pos ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: Rx ( ANGLE -- Rx )
|
||||
|
||||
[let | ANGLE [ ANGLE deg>rad ] |
|
||||
|
||||
[let | A [ ANGLE cos ]
|
||||
B [ ANGLE sin neg ]
|
||||
C [ ANGLE sin ]
|
||||
D [ ANGLE cos ] |
|
||||
|
||||
{ { 1 0 0 }
|
||||
{ 0 A B }
|
||||
{ 0 C D } }
|
||||
|
||||
] ] ;
|
||||
|
||||
:: Ry ( ANGLE -- Ry )
|
||||
|
||||
[let | ANGLE [ ANGLE deg>rad ] |
|
||||
|
||||
[let | A [ ANGLE cos ]
|
||||
B [ ANGLE sin ]
|
||||
C [ ANGLE sin neg ]
|
||||
D [ ANGLE cos ] |
|
||||
|
||||
{ { A 0 B }
|
||||
{ 0 1 0 }
|
||||
{ C 0 D } }
|
||||
|
||||
] ] ;
|
||||
|
||||
:: Rz ( ANGLE -- Rz )
|
||||
|
||||
[let | ANGLE [ ANGLE deg>rad ] |
|
||||
|
||||
[let | A [ ANGLE cos ]
|
||||
B [ ANGLE sin neg ]
|
||||
C [ ANGLE sin ]
|
||||
D [ ANGLE cos ] |
|
||||
|
||||
{ { A B 0 }
|
||||
{ C D 0 }
|
||||
{ 0 0 1 } }
|
||||
|
||||
] ] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: apply-rotation ( TURTLE ROTATION -- turtle )
|
||||
|
||||
TURTLE TURTLE ori>> ROTATION m. >>ori ;
|
||||
|
||||
: rotate-x ( turtle angle -- turtle ) Rx apply-rotation ;
|
||||
: rotate-y ( turtle angle -- turtle ) Ry apply-rotation ;
|
||||
: rotate-z ( turtle angle -- turtle ) Rz apply-rotation ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: pitch-up ( turtle angle -- turtle ) neg rotate-x ;
|
||||
: pitch-down ( turtle angle -- turtle ) rotate-x ;
|
||||
|
||||
: turn-left ( turtle angle -- turtle ) rotate-y ;
|
||||
: turn-right ( turtle angle -- turtle ) neg rotate-y ;
|
||||
|
||||
: roll-left ( turtle angle -- turtle ) neg rotate-z ;
|
||||
: roll-right ( turtle angle -- turtle ) rotate-z ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: V ( -- V ) { 0 1 0 } ;
|
||||
|
||||
: X ( turtle -- 3array ) ori>> [ first ] map ;
|
||||
: Y ( turtle -- 3array ) ori>> [ second ] map ;
|
||||
: Z ( turtle -- 3array ) ori>> [ third ] map ;
|
||||
|
||||
: set-X ( turtle seq -- turtle ) over ori>> [ set-first ] 2each ;
|
||||
: set-Y ( turtle seq -- turtle ) over ori>> [ set-second ] 2each ;
|
||||
: set-Z ( turtle seq -- turtle ) over ori>> [ set-third ] 2each ;
|
||||
|
||||
:: roll-until-horizontal ( TURTLE -- turtle )
|
||||
|
||||
TURTLE
|
||||
|
||||
V TURTLE Z cross normalize set-X
|
||||
|
||||
TURTLE Z TURTLE X cross normalize set-Y ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: strafe-up ( TURTLE LENGTH -- turtle )
|
||||
TURTLE 90 pitch-up LENGTH step-turtle 90 pitch-down ;
|
||||
|
||||
:: strafe-down ( TURTLE LENGTH -- turtle )
|
||||
TURTLE 90 pitch-down LENGTH step-turtle 90 pitch-up ;
|
||||
|
||||
:: strafe-left ( TURTLE LENGTH -- turtle )
|
||||
TURTLE 90 turn-left LENGTH step-turtle 90 turn-right ;
|
||||
|
||||
:: strafe-right ( TURTLE LENGTH -- turtle )
|
||||
TURTLE 90 turn-right LENGTH step-turtle 90 turn-left ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: polygon ( vertices -- ) GL_POLYGON glBegin [ first3 glVertex3d ] each glEnd ;
|
||||
|
||||
: start-polygon ( turtle -- turtle ) dup vertices>> delete-all ;
|
||||
|
||||
: finish-polygon ( turtle -- turtle ) dup vertices>> polygon ;
|
||||
|
||||
: polygon-vertex ( turtle -- turtle ) dup [ pos>> ] [ vertices>> ] bi push ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: record-vertex ( turtle -- turtle ) dup pos>> first3 glVertex3d ;
|
||||
|
||||
: draw-forward ( turtle length -- turtle )
|
||||
GL_LINES glBegin [ record-vertex ] dip step-turtle record-vertex glEnd ;
|
||||
|
||||
: move-forward ( turtle length -- turtle ) step-turtle polygon-vertex ;
|
||||
|
||||
: sneak-forward ( turtle length -- turtle ) step-turtle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: scale-length ( turtle m -- turtle ) over length>> * >>length ;
|
||||
: scale-angle ( turtle m -- turtle ) over angle>> * >>angle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: set-thickness ( turtle i -- turtle ) dup glLineWidth >>thickness ;
|
||||
|
||||
: scale-thickness ( turtle m -- turtle )
|
||||
over thickness>> * 0.5 max set-thickness ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: color-table ( -- colors )
|
||||
{
|
||||
T{ rgba f 0 0 0 1 } ! black
|
||||
T{ rgba f 0.5 0.5 0.5 1 } ! grey
|
||||
T{ rgba f 1 0 0 1 } ! red
|
||||
T{ rgba f 1 1 0 1 } ! yellow
|
||||
T{ rgba f 0 1 0 1 } ! green
|
||||
T{ rgba f 0.25 0.88 0.82 1 } ! turquoise
|
||||
T{ rgba f 0 0 1 1 } ! blue
|
||||
T{ rgba f 0.63 0.13 0.94 1 } ! purple
|
||||
T{ rgba f 0.00 0.50 0.00 1 } ! dark green
|
||||
T{ rgba f 0.00 0.82 0.82 1 } ! dark turquoise
|
||||
T{ rgba f 0.00 0.00 0.50 1 } ! dark blue
|
||||
T{ rgba f 0.58 0.00 0.82 1 } ! dark purple
|
||||
T{ rgba f 0.50 0.00 0.00 1 } ! dark red
|
||||
T{ rgba f 0.25 0.25 0.25 1 } ! dark grey
|
||||
T{ rgba f 0.75 0.75 0.75 1 } ! medium grey
|
||||
T{ rgba f 1 1 1 1 } ! white
|
||||
} ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! : material-color ( color -- )
|
||||
! GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
|
||||
|
||||
: material-color ( color -- )
|
||||
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot color>raw 4array gl-material ;
|
||||
|
||||
: set-color ( turtle i -- turtle )
|
||||
dup color-table nth dup gl-color material-color >>color ;
|
||||
|
||||
: inc-color ( turtle -- turtle ) dup color>> 1 + set-color ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: save-turtle ( turtle -- turtle ) dup clone over saved>> push ;
|
||||
: restore-turtle ( turtle -- turtle ) saved>> pop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: default-L-parser-values ( turtle -- turtle )
|
||||
1 >>length 45 >>angle 1 >>thickness 2 >>color ;
|
||||
|
||||
: L-parser-dialect ( -- commands )
|
||||
|
||||
{
|
||||
{ "+" [ dup angle>> turn-left ] }
|
||||
{ "-" [ dup angle>> turn-right ] }
|
||||
{ "&" [ dup angle>> pitch-down ] }
|
||||
{ "^" [ dup angle>> pitch-up ] }
|
||||
{ "<" [ dup angle>> roll-left ] }
|
||||
{ ">" [ dup angle>> roll-right ] }
|
||||
|
||||
{ "|" [ 180.0 rotate-y ] }
|
||||
{ "%" [ 180.0 rotate-z ] }
|
||||
{ "$" [ roll-until-horizontal ] }
|
||||
|
||||
{ "F" [ dup length>> draw-forward ] }
|
||||
{ "Z" [ dup length>> 2 / draw-forward ] }
|
||||
{ "f" [ dup length>> move-forward ] }
|
||||
{ "z" [ dup length>> 2 / move-forward ] }
|
||||
{ "g" [ dup length>> sneak-forward ] }
|
||||
{ "." [ polygon-vertex ] }
|
||||
|
||||
{ "[" [ save-turtle ] }
|
||||
{ "]" [ restore-turtle ] }
|
||||
|
||||
{ "{" [ start-polygon ] }
|
||||
{ "}" [ finish-polygon ] }
|
||||
|
||||
{ "/" [ 1.1 scale-length ] } ! double quote command in lparser
|
||||
{ "'" [ 0.9 scale-length ] }
|
||||
{ ";" [ 1.1 scale-angle ] }
|
||||
{ ":" [ 0.9 scale-angle ] }
|
||||
{ "?" [ 1.4 scale-thickness ] }
|
||||
{ "!" [ 0.7 scale-thickness ] }
|
||||
|
||||
{ "c" [ dup color>> 1 + color-table length mod set-color ] }
|
||||
|
||||
}
|
||||
;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <L-system> < gadget
|
||||
camera display-list
|
||||
commands axiom rules string ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: open-paren ( -- ch ) CHAR: ( ;
|
||||
: close-paren ( -- ch ) CHAR: ) ;
|
||||
|
||||
: open-paren? ( obj -- ? ) open-paren = ;
|
||||
: close-paren? ( obj -- ? ) close-paren = ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: read-instruction ( STRING -- next rest )
|
||||
|
||||
{ [ STRING length 1 > ] [ STRING second open-paren? ] } 0&&
|
||||
[ STRING close-paren STRING index 1 + cut ]
|
||||
[ STRING 1 cut ]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-string-loop ( STRING RULES ACCUM -- )
|
||||
STRING empty? not
|
||||
[
|
||||
STRING read-instruction
|
||||
|
||||
[let | REST [ ] NEXT [ ] |
|
||||
|
||||
NEXT 1 head RULES at NEXT or ACCUM push-all
|
||||
|
||||
REST RULES ACCUM iterate-string-loop ]
|
||||
]
|
||||
when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-string ( STRING RULES -- string )
|
||||
|
||||
[let | ACCUM [ STRING length 10 * <sbuf> ] |
|
||||
|
||||
STRING RULES ACCUM iterate-string-loop
|
||||
|
||||
ACCUM >string ] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: interpret-string ( STRING COMMANDS -- )
|
||||
|
||||
STRING empty? not
|
||||
[
|
||||
STRING read-instruction
|
||||
|
||||
[let | REST [ ] NEXT [ ] |
|
||||
|
||||
[let | COMMAND [ NEXT 1 head COMMANDS at ] |
|
||||
|
||||
COMMAND
|
||||
[
|
||||
NEXT length 1 =
|
||||
[ COMMAND call ]
|
||||
[
|
||||
NEXT 2 tail 1 head* string>number
|
||||
COMMAND 1 tail*
|
||||
call
|
||||
]
|
||||
if
|
||||
]
|
||||
when ]
|
||||
|
||||
REST COMMANDS interpret-string ]
|
||||
]
|
||||
when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-L-system-string ( L-SYSTEM -- )
|
||||
L-SYSTEM string>>
|
||||
L-SYSTEM rules>>
|
||||
iterate-string
|
||||
L-SYSTEM (>>string) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: do-camera-look-at ( CAMERA -- )
|
||||
|
||||
[let | EYE [ CAMERA pos>> ]
|
||||
FOCUS [ CAMERA clone 1 step-turtle pos>> ]
|
||||
UP [ CAMERA clone 90 pitch-up 1 step-turtle pos>> CAMERA pos>> v- ]
|
||||
|
|
||||
|
||||
EYE FOCUS UP gl-look-at ] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: generate-display-list ( L-SYSTEM -- )
|
||||
|
||||
L-SYSTEM find-gl-context
|
||||
|
||||
L-SYSTEM display-list>> GL_COMPILE glNewList
|
||||
|
||||
turtle
|
||||
L-SYSTEM string>>
|
||||
L-SYSTEM commands>>
|
||||
interpret-string
|
||||
drop
|
||||
|
||||
glEndList ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M:: <L-system> draw-gadget* ( L-SYSTEM -- )
|
||||
|
||||
black gl-clear
|
||||
|
||||
GL_FLAT glShadeModel
|
||||
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
-1 1 -1 1 1.5 200 glFrustum
|
||||
|
||||
GL_MODELVIEW glMatrixMode
|
||||
|
||||
glLoadIdentity
|
||||
|
||||
L-SYSTEM camera>> do-camera-look-at
|
||||
|
||||
GL_FRONT_AND_BACK GL_LINE glPolygonMode
|
||||
|
||||
! draw axis
|
||||
white gl-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
|
||||
|
||||
L-SYSTEM display-list>> glCallList ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M:: <L-system> graft* ( L-SYSTEM -- )
|
||||
|
||||
L-SYSTEM find-gl-context
|
||||
|
||||
1 glGenLists L-SYSTEM (>>display-list) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M:: <L-system> pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: camera-left ( L-SYSTEM -- )
|
||||
L-SYSTEM camera>> 5 turn-left drop
|
||||
L-SYSTEM relayout-1 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: with-camera ( L-SYSTEM QUOT -- )
|
||||
L-SYSTEM camera>> QUOT call drop
|
||||
L-SYSTEM relayout-1 ;
|
||||
|
||||
<L-system>
|
||||
H{
|
||||
{ T{ key-down f f "LEFT" } [ [ 5 turn-left ] with-camera ] }
|
||||
{ T{ key-down f f "RIGHT" } [ [ 5 turn-right ] with-camera ] }
|
||||
{ T{ key-down f f "UP" } [ [ 5 pitch-down ] with-camera ] }
|
||||
{ T{ key-down f f "DOWN" } [ [ 5 pitch-up ] with-camera ] }
|
||||
|
||||
{ T{ key-down f f "a" } [ [ 1 step-turtle ] with-camera ] }
|
||||
{ T{ key-down f f "z" } [ [ -1 step-turtle ] with-camera ] }
|
||||
|
||||
{
|
||||
T{ key-down f f "x" }
|
||||
[
|
||||
dup iterate-L-system-string
|
||||
dup generate-display-list
|
||||
dup relayout-1
|
||||
drop
|
||||
]
|
||||
}
|
||||
|
||||
}
|
||||
set-gestures
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: L-system ( -- L-system )
|
||||
|
||||
<L-system> new-gadget
|
||||
|
||||
turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
|
||||
USING: accessors kernel ui L-system ;
|
||||
|
||||
IN: L-system.models.abop-1
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-1 ( <L-system> -- <L-system> )
|
||||
|
||||
L-parser-dialect >>commands
|
||||
|
||||
"c(12)FFAL" >>axiom
|
||||
|
||||
{
|
||||
{ "A" "F[&'(.8)!BL]>(137)'!(.9)A" }
|
||||
{ "B" "F[-'(.8)!(.9)$CL]'!(.9)C" }
|
||||
{ "C" "F[+'(.8)!(.9)$BL]'!(.9)B" }
|
||||
|
||||
{ "L" "~c(8){+(30)f-(120)f-(120)f}" }
|
||||
}
|
||||
>>rules
|
||||
|
||||
dup axiom>> >>string ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: main ( -- ) [ L-system abop-1 "L-system" open-window ] with-ui ;
|
||||
|
||||
MAIN: main
|
||||
|
|
@ -1 +0,0 @@
|
|||
Daniel Ehrenberg
|
||||
|
|
@ -1,113 +0,0 @@
|
|||
! Copyright (C) 2007 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: xml kernel sequences xml.utilities math xml.data
|
||||
arrays assocs xml.generator xml.writer namespaces
|
||||
make math.parser io accessors ;
|
||||
IN: faq
|
||||
|
||||
: find-after ( seq quot -- elem after )
|
||||
over [ find ] dip rot 1+ tail ; inline
|
||||
|
||||
: tag-named*? ( tag name -- ? )
|
||||
assure-name swap tag-named? ;
|
||||
|
||||
! Questions
|
||||
TUPLE: q/a question answer ;
|
||||
C: <q/a> q/a
|
||||
|
||||
: li>q/a ( li -- q/a )
|
||||
[ "br" tag-named*? not ] filter
|
||||
[ "strong" tag-named*? ] find-after
|
||||
[ children>> ] dip <q/a> ;
|
||||
|
||||
: q/a>li ( q/a -- li )
|
||||
[ question>> "strong" build-tag* f "br" build-tag* 2array ] keep
|
||||
answer>> append "li" build-tag* ;
|
||||
|
||||
: xml>q/a ( xml -- q/a )
|
||||
[ "question" tag-named children>> ] keep
|
||||
"answer" tag-named children>> <q/a> ;
|
||||
|
||||
: q/a>xml ( q/a -- xml )
|
||||
[ question>> "question" build-tag* ] keep
|
||||
answer>> "answer" build-tag*
|
||||
"\n" swap 3array "qa" build-tag* ;
|
||||
|
||||
! Lists of questions
|
||||
TUPLE: question-list title seq ;
|
||||
C: <question-list> question-list
|
||||
|
||||
: xml>question-list ( list -- question-list )
|
||||
[ "title" swap at ] keep
|
||||
children>> [ tag? ] filter [ xml>q/a ] map
|
||||
<question-list> ;
|
||||
|
||||
: question-list>xml ( question-list -- list )
|
||||
[ seq>> [ q/a>xml "\n" swap 2array ]
|
||||
map concat "list" build-tag* ] keep
|
||||
title>> [ "title" pick set-at ] when* ;
|
||||
|
||||
: html>question-list ( h3 ol -- question-list )
|
||||
[ [ children>string ] [ f ] if* ] dip
|
||||
children-tags [ li>q/a ] map <question-list> ;
|
||||
|
||||
: question-list>h3 ( id question-list -- h3 )
|
||||
title>> [
|
||||
"h3" build-tag
|
||||
swap number>string "id" pick set-at
|
||||
] [ drop f ] if* ;
|
||||
|
||||
: question-list>html ( question-list start id -- h3/f ol )
|
||||
-rot [ [ question-list>h3 ] keep seq>> [ q/a>li ] map "ol" build-tag* ] dip
|
||||
number>string "start" pick set-at
|
||||
"margin-left: 5em" "style" pick set-at ;
|
||||
|
||||
! Overall everything
|
||||
TUPLE: faq header lists ;
|
||||
C: <faq> faq
|
||||
|
||||
: html>faq ( div -- faq )
|
||||
unclip swap { "h3" "ol" } [ tags-named ] with map
|
||||
first2 [ f prefix ] dip [ html>question-list ] 2map <faq> ;
|
||||
|
||||
: header, ( faq -- )
|
||||
dup header>> ,
|
||||
lists>> first 1 -1 question-list>html nip , ;
|
||||
|
||||
: br, ( -- )
|
||||
"br" contained, nl, ;
|
||||
|
||||
: toc-link, ( question-list number -- )
|
||||
number>string "#" prepend "href" swap 2array 1array
|
||||
"a" swap [ title>> , ] tag*, br, ;
|
||||
|
||||
: toc, ( faq -- )
|
||||
"div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [
|
||||
"strong" [ "The big questions" , ] tag, br,
|
||||
lists>> rest dup length [ toc-link, ] 2each
|
||||
] tag*, ;
|
||||
|
||||
: faq-sections, ( question-lists -- )
|
||||
unclip seq>> length 1+ dupd
|
||||
[ seq>> length + ] accumulate nip
|
||||
0 -rot [ pick question-list>html [ , nl, ] bi@ 1+ ] 2each drop ;
|
||||
|
||||
: faq>html ( faq -- div )
|
||||
"div" [
|
||||
dup header,
|
||||
dup toc,
|
||||
lists>> faq-sections,
|
||||
] make-xml ;
|
||||
|
||||
: xml>faq ( xml -- faq )
|
||||
[ "header" tag-named children>string ] keep
|
||||
"list" tags-named [ xml>question-list ] map <faq> ;
|
||||
|
||||
: faq>xml ( faq -- xml )
|
||||
"faq" [
|
||||
"header" [ dup header>> , ] tag,
|
||||
lists>> [ question-list>xml , nl, ] each
|
||||
] make-xml ;
|
||||
|
||||
: read-write-faq ( xml-stream -- )
|
||||
read-xml xml>faq faq>html write-xml ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
The Factor FAQ
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
Copyright (C) 2003, 2008 Slava Pestov and friends.
|
||||
Copyright (C) 2003, 2009 Slava Pestov and friends.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
|
|
|||
Loading…
Reference in New Issue