From 63b86900e78d114e4aa35bd0d606cde1ceaab0cf Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 5 Jan 2009 04:11:43 -0600 Subject: [PATCH 1/7] Add L-system (complete rewrite of lsys) --- extra/L-system/L-system.factor | 448 +++++++++++++++++++++++++++++++++ 1 file changed, 448 insertions(+) create mode 100644 extra/L-system/L-system.factor diff --git a/extra/L-system/L-system.factor b/extra/L-system/L-system.factor new file mode 100644 index 0000000000..97a971de47 --- /dev/null +++ b/extra/L-system/L-system.factor @@ -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: 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 ) 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: < 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 * ] | + + 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:: 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:: graft* ( L-SYSTEM -- ) + + L-SYSTEM find-gl-context + + 1 glGenLists L-SYSTEM (>>display-list) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M:: 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 ; + + +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 ) + + new-gadget + + turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + From 6416cb78b09c91cd8ccbd34c997c09be1bd1a5d4 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 5 Jan 2009 04:12:27 -0600 Subject: [PATCH 2/7] Add 'abop-1' L-system model --- extra/L-system/models/abop-1/abop-1.factor | 29 ++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100644 extra/L-system/models/abop-1/abop-1.factor diff --git a/extra/L-system/models/abop-1/abop-1.factor b/extra/L-system/models/abop-1/abop-1.factor new file mode 100644 index 0000000000..45cc522470 --- /dev/null +++ b/extra/L-system/models/abop-1/abop-1.factor @@ -0,0 +1,29 @@ + +USING: accessors kernel ui L-system ; + +IN: L-system.models.abop-1 + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: abop-1 ( -- ) + + 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 From 7b110b0bfd09b86e35b1c2388a85a908160795e6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Jan 2009 17:32:08 -0600 Subject: [PATCH 3/7] Move 3each, 3map from compiler.utilities to sequences --- basis/compiler/utilities/utilities.factor | 8 ------- core/sequences/sequences-tests.factor | 20 ++++++++++++++-- core/sequences/sequences.factor | 28 ++++++++++++++++------- 3 files changed, 38 insertions(+), 18 deletions(-) diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index 1f488b3dde..e8082edb68 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -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 diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index dcca525e2b..80352faf72 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -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 \ No newline at end of file diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 40a8892e8b..557a52c482 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -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 @@ -352,6 +352,10 @@ PRIVATE> : 2map-into ( seq1 seq2 quot into -- newseq ) [ (2each) ] dip collect ; inline +: (3each) ( seq1 seq2 seq3 quot -- n quot' ) + [ [ [ length ] tri@ min min ] 3keep ] dip + [ [ [ [ nth-unsafe ] curry ] tri@ tri ] 3curry ] dip compose ; inline + : finish-find ( i seq -- i elt ) over [ dupd nth-unsafe ] [ drop f ] if ; inline @@ -419,6 +423,12 @@ PRIVATE> : 2all? ( seq1 seq2 quot -- ? ) (2each) all-integers? ; inline +: 3each ( seq1 seq2 seq3 quot -- ) + (3each) each ; inline + +: 3map ( seq1 seq2 seq3 quot -- newseq ) + (3each) map ; inline + : find-from ( n seq quot -- i elt ) [ (find-integer) ] (find-from) ; inline @@ -494,10 +504,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 +578,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 +840,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 From 7c6d86491b9bfdb478eed63be66ccee84e21727e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Jan 2009 17:32:28 -0600 Subject: [PATCH 4/7] Add .# to gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index f4334f3727..a7cbeeeef3 100644 --- a/.gitignore +++ b/.gitignore @@ -21,3 +21,4 @@ logs work build-support/wordsize *.bak +.#* From 16cdedb838e68c18f6d9cbaca2882c2653353992 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Jan 2009 17:33:06 -0600 Subject: [PATCH 5/7] Update copyright year --- license.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/license.txt b/license.txt index 768c13c549..8f4f53585a 100644 --- a/license.txt +++ b/license.txt @@ -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: From 4c25fef273697a1c9a692fe1908c1fb8f4529e08 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Jan 2009 17:33:27 -0600 Subject: [PATCH 6/7] Remove extra/faq now that we don't need it anymore --- extra/faq/authors.txt | 1 - extra/faq/faq.factor | 113 ------------------------------------------ extra/faq/summary.txt | 1 - 3 files changed, 115 deletions(-) delete mode 100755 extra/faq/authors.txt delete mode 100644 extra/faq/faq.factor delete mode 100755 extra/faq/summary.txt diff --git a/extra/faq/authors.txt b/extra/faq/authors.txt deleted file mode 100755 index f990dd0ed2..0000000000 --- a/extra/faq/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor deleted file mode 100644 index 512817bc4d..0000000000 --- a/extra/faq/faq.factor +++ /dev/null @@ -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 - -: li>q/a ( li -- q/a ) - [ "br" tag-named*? not ] filter - [ "strong" tag-named*? ] find-after - [ children>> ] dip ; - -: 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>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 - -: xml>question-list ( list -- question-list ) - [ "title" swap at ] keep - children>> [ tag? ] filter [ xml>q/a ] map - ; - -: 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>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 - -: html>faq ( div -- faq ) - unclip swap { "h3" "ol" } [ tags-named ] with map - first2 [ f prefix ] dip [ html>question-list ] 2map ; - -: 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>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 ; diff --git a/extra/faq/summary.txt b/extra/faq/summary.txt deleted file mode 100755 index c33f8cffeb..0000000000 --- a/extra/faq/summary.txt +++ /dev/null @@ -1 +0,0 @@ -The Factor FAQ From af49278d3fefc608afac4cc35e5037d1425184f5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Jan 2009 18:12:34 -0600 Subject: [PATCH 7/7] Add 2tri* and 2tri@ combinators, clean up (3each), and fix failing unit test for 3map --- core/kernel/kernel-docs.factor | 42 ++++++++++++++++++++++++++-- core/kernel/kernel-tests.factor | 6 ++++ core/kernel/kernel.factor | 8 ++++++ core/sequences/sequences-docs.factor | 9 ------ core/sequences/sequences.factor | 27 ++++++++++-------- 5 files changed, 69 insertions(+), 23 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 1404491d10..bac4048706 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -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 } diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index eae225e543..7ebaaeb3a8 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -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 \ No newline at end of file diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index d4df6fa407..a8f9281760 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -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 ) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index b3df0b889f..9f18fd4e66 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -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 } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 557a52c482..91c9d52404 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -346,15 +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 ] dip - [ [ [ [ nth-unsafe ] curry ] tri@ tri ] 3curry ] dip compose ; inline + [ + [ [ 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 @@ -411,23 +415,22 @@ 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 ) - (3each) map ; inline + [ pick ] dip swap 3map-as ; inline : find-from ( n seq quot -- i elt ) [ (find-integer) ] (find-from) ; inline