diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 5ee263469e..7edeeffd17 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -28,7 +28,7 @@ SYMBOL: bootstrap-time [ "bootstrap." prepend require ] each ; : count-words ( pred -- ) - all-words swap filter length number>string write ; + all-words swap count number>string write ; : print-report ( time -- ) 1000 /i diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index df59f34ff4..6056d200be 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -103,7 +103,7 @@ ERROR: bad-superclass class ; : superclass-size ( class -- n ) superclasses but-last-slice - [ slot-names length ] map sum ; + [ slot-names length ] sigma ; : generate-tuple-slots ( class slots -- slot-specs ) over superclass-size 2 + simple-slots ; diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 9e8f805acf..bbeb5e044f 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -48,7 +48,7 @@ DEFER: (flat-length) { [ dup word? ] [ word-flat-length ] } [ drop 1 ] } cond - ] map sum ; + ] sigma ; : flat-length ( seq -- n ) [ word-def (flat-length) ] with-scope ; diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 86a2aa12f6..a7481d46d5 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1,5 +1,5 @@ USING: arrays bit-arrays help.markup help.syntax math -sequences.private vectors strings sbufs kernel math.order ; +sequences.private vectors strings quotations sbufs kernel math.order ; IN: sequences ARTICLE: "sequences-unsafe" "Unsafe sequence operations" @@ -957,3 +957,23 @@ HELP: unfold "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link unfold } " call:" { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" } } ; + +HELP: sigma +{ $values { "seq" sequence } { "quot" quotation } { "n" number } } +{ $description "Like map sum, but without creating an intermediate sequence." } +{ $example + "! Find the sum of the squares [0,99]" + "USING: math math.ranges sequences.lib prettyprint ;" + "100 [1,b] [ sq ] sigma ." + "338350" +} ; + +HELP: count +{ $values { "seq" sequence } { "quot" quotation } { "n" integer } } +{ $description "Efficiently returns the number of elements that the predicate quotation matches." } +{ $example + "USING: math math.ranges sequences.lib prettyprint ;" + "100 [1,b] [ even? ] count ." + "50" +} ; + diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 60c75a8920..dc79c3e5f0 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -243,3 +243,8 @@ unit-test [ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test [ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test [ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test + +[ 328350 ] [ 100 [ sq ] sigma ] unit-test + +[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test +[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 2d05d3c2ef..d5389ef3f6 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -722,3 +722,8 @@ PRIVATE> dup [ length ] map infimum swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as ] unless ; + +: sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline + +: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline + diff --git a/extra/bake/bake-tests.factor b/extra/bake/bake-tests.factor new file mode 100644 index 0000000000..7b40d603f1 --- /dev/null +++ b/extra/bake/bake-tests.factor @@ -0,0 +1,34 @@ + +USING: kernel tools.test bake ; + +IN: bake.tests + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: unit-test* ( input output -- ) swap unit-test ; + +: must-be-t ( in -- ) [ t ] swap unit-test ; +: must-be-f ( in -- ) [ f ] swap unit-test ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +[ 10 20 30 `{ , , , } ] [ { 10 20 30 } ] unit-test* + +[ 10 20 30 `{ , { , } , } ] [ { 10 { 20 } 30 } ] unit-test* + +[ 10 { 20 21 22 } 30 `{ , , , } ] [ { 10 { 20 21 22 } 30 } ] unit-test* + +[ 10 { 20 21 22 } 30 `{ , @ , } ] [ { 10 20 21 22 30 } ] unit-test* + +[ { 1 2 3 } `{ @ } ] [ { 1 2 3 } ] unit-test* + +[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `{ @ @ @ } ] +[ { 1 2 3 4 5 6 7 8 9 } ] +unit-test* + +[ 10 20 30 40 `[ , V{ , { , } } , ] ] [ [ 10 V{ 20 { 30 } } 40 ] ] unit-test* + +[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `[ , { V{ @ } { , } } ] ] +[ [ { 1 2 3 } { V{ 4 5 6 } { { 7 8 9 } } } ] ] +unit-test* + diff --git a/extra/bake/bake.factor b/extra/bake/bake.factor index 7a12a3cc97..71818bc5c6 100644 --- a/extra/bake/bake.factor +++ b/extra/bake/bake.factor @@ -1,6 +1,7 @@ -USING: kernel parser combinators sequences splitting quotations arrays macros - arrays.lib combinators.cleave combinators.conditional newfx ; +USING: kernel parser namespaces sequences quotations arrays vectors splitting + math + macros arrays.lib combinators.lib combinators.conditional newfx ; IN: bake @@ -14,46 +15,79 @@ SYMBOL: @ ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -DEFER: [bake-array] +DEFER: [bake] : broil-element ( obj -- quot ) { - { [ comma? ] [ drop [ >r ] ] } - { [ array? ] [ [bake-array] [ >r ] append ] } - { [ drop t ] [ [ >r ] prefix-on ] } + { [ comma? ] [ drop [ >r ] ] } + { [ integer? ] [ [ >r ] prefix-on ] } + { [ sequence? ] [ [bake] [ >r ] append ] } + { [ drop t ] [ [ >r ] prefix-on ] } } 1cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: [broil] ( array -- quot ) +: constructor ( seq -- quot ) + { + { [ array? ] [ length [ narray ] prefix-on ] } + { [ quotation? ] [ length [ ncurry ] prefix-on [ ] prefix ] } + { [ vector? ] [ length [ narray >vector ] prefix-on ] } + } + 1cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: [broil] ( seq -- quot ) [ reverse [ broil-element ] map concat ] - [ length [ drop [ r> ] ] map concat ] - [ length [ narray ] prefix-on ] + [ length [ drop [ r> ] ] map concat ] + [ constructor ] tri append append >quotation ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: [simmer] ( array -- quot ) +SYMBOL: saved-sequence + +: [connector] ( -- quot ) + saved-sequence get quotation? [ [ compose ] ] [ [ append ] ] if ; + +: [starter] ( -- quot ) + saved-sequence get + { + { [ quotation? ] [ drop [ [ ] ] ] } + { [ array? ] [ drop [ { } ] ] } + { [ vector? ] [ drop [ V{ } ] ] } + } + 1cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: [simmer] ( seq -- quot ) + + dup saved-sequence set { @ } split reverse - [ [ [bake-array] [ append ] append [ >r ] append ] map concat ] - [ length [ drop [ r> append ] ] map concat ] + [ [ [bake] [connector] append [ >r ] append ] map concat ] + [ length [ drop [ r> ] [connector] append ] map concat ] bi - >r 2 head* [ >r ] append r> ! remove the last append + >r 1 invert-index pluck r> ! remove the last append/compose - [ { } ] swap append + [starter] prepend append ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: [bake-array] ( array -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ; - -MACRO: bake-array ( array -- quot ) [bake-array] ; +: [bake] ( seq -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: `{ \ } [ >array ] parse-literal \ bake-array parsed ; parsing \ No newline at end of file +MACRO: bake ( seq -- quot ) [bake] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing +: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing +: `[ \ ] [ >quotation ] parse-literal \ bake parsed ; parsing \ No newline at end of file diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor index f15a6b24c2..e2feb3cc17 100755 --- a/extra/fry/fry.factor +++ b/extra/fry/fry.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences combinators parser splitting +USING: kernel sequences combinators parser splitting math quotations arrays namespaces qualified ; QUALIFIED: namespaces IN: fry @@ -10,9 +10,10 @@ IN: fry : _ ( -- * ) "Only valid inside a fry" throw ; DEFER: (shallow-fry) +DEFER: shallow-fry : ((shallow-fry)) ( accum quot adder -- result ) - >r [ ] swap (shallow-fry) r> + >r shallow-fry r> append swap dup empty? [ drop ] [ [ prepose ] curry append ] if ; inline @@ -34,29 +35,25 @@ DEFER: (shallow-fry) : shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ; -: deep-fry ( quot -- quot' ) - { _ } last-split1 [ - [ - shallow-fry % - [ >r ] % - deep-fry % - [ [ dip ] curry r> compose ] % - ] [ ] make +: deep-fry ( quot -- quot ) + { _ } last-split1 dup [ + shallow-fry [ >r ] rot + deep-fry [ [ dip ] curry r> compose ] 4array concat ] [ - shallow-fry - ] if* ; + drop shallow-fry + ] if ; : fry-specifier? ( obj -- ? ) { , namespaces:, @ } member? ; : count-inputs ( quot -- n ) [ { - { [ dup callable? ] [ count-inputs ] } - { [ dup fry-specifier? ] [ drop 1 ] } - [ drop 0 ] + { [ dup callable? ] [ count-inputs ] } + { [ dup fry-specifier? ] [ drop 1 ] } + [ drop 0 ] } cond ] map sum ; - + : fry ( quot -- quot' ) [ [ diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index b59e204e0c..9335c61025 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -159,6 +159,11 @@ METHOD: as-mutate { object object assoc } set-at ; : prefix-on ( elt seq -- seq ) swap prefix ; : suffix-on ( elt seq -- seq ) swap suffix ; +: suffix! ( seq elt -- seq ) over sequences:push ; +: suffix-on! ( elt seq -- seq ) tuck sequences:push ; +: suffixed! ( seq elt -- ) swap sequences:push ; +: suffixed-on! ( elt seq -- ) sequences:push ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : subseq ( seq from to -- subseq ) rot sequences:subseq ; @@ -199,4 +204,36 @@ METHOD: as-mutate { object object assoc } set-at ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: start ( seq subseq -- i ) swap sequences:start ; \ No newline at end of file +: start ( seq subseq -- i ) swap sequences:start ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: pluck ( seq i -- seq ) cut-slice rest-slice append ; +: pluck-from ( i seq -- seq ) swap pluck ; +: pluck! ( seq i -- seq ) over delete-nth ; +: pluck-from! ( i seq -- seq ) tuck delete-nth ; +: plucked! ( seq i -- ) swap delete-nth ; +: plucked-from! ( i seq -- ) delete-nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: snip ( seq a b -- seq ) >r over r> [ head ] [ tail ] 2bi* append ; +: snip-this ( a b seq -- seq ) -rot snip ; +: snip! ( seq a b -- seq ) pick delete-slice ; +: snip-this! ( a b seq -- seq ) -rot pick delete-slice ; +: snipped! ( seq a b -- ) rot delete-slice ; +: snipped-from! ( a b seq -- ) delete-slice ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: invert-index ( seq i -- seq i ) >r dup length 1 - r> - ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: append! ( a b -- ab ) over sequences:push-all ; +: append-to! ( b a -- ab ) swap over sequences:push-all ; +: appended! ( a b -- ) swap sequences:push-all ; +: appended-to! ( b a -- ) sequences:push-all ; + +: prepend! ( a b -- ba ) over append 0 pick copy ; +: prepended! ( a b -- ) over append 0 rot copy ; diff --git a/extra/sequences/lib/lib-docs.factor b/extra/sequences/lib/lib-docs.factor index 14fb6eaebf..b2e805304e 100755 --- a/extra/sequences/lib/lib-docs.factor +++ b/extra/sequences/lib/lib-docs.factor @@ -19,25 +19,6 @@ HELP: each-withn } { $see-also map-withn } ; -HELP: sigma -{ $values { "seq" sequence } { "quot" quotation } { "n" number } } -{ $description "Like map sum, but without creating an intermediate sequence." } -{ $example - "! Find the sum of the squares [0,99]" - "USING: math math.ranges sequences.lib prettyprint ;" - "100 [1,b] [ sq ] sigma ." - "338350" -} ; - -HELP: count -{ $values { "seq" sequence } { "quot" quotation } { "n" integer } } -{ $description "Efficiently returns the number of elements that the predicate quotation matches." } -{ $example - "USING: math math.ranges sequences.lib prettyprint ;" - "100 [1,b] [ even? ] count ." - "50" -} ; - HELP: if-seq { $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } } { $description "Makes an implicit check if the sequence is empty. If the sequence has any elements, " { $snippet "quot1" } " is called on it. Otherwise, the empty sequence is dropped and " { $snippet "quot2" } " is called." } diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 019796c1a1..4b8114f67f 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -2,10 +2,6 @@ USING: arrays kernel sequences sequences.lib math math.functions math.ranges tools.test strings ; IN: sequences.lib.tests -[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test -[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test -[ 328350 ] [ 100 [ sq ] sigma ] unit-test - [ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer { 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test @@ -64,10 +60,6 @@ IN: sequences.lib.tests [ 3 ] [ { 1 2 3 } ?third ] unit-test [ f ] [ { 1 2 3 } ?fourth ] unit-test -[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test -[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test -[ 328350 ] [ 100 [ sq ] sigma ] unit-test - [ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer { { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test { { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index feb3793098..1128646849 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -51,14 +51,6 @@ MACRO: firstn ( n -- ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: sigma ( seq quot -- n ) - [ + ] compose 0 swap reduce ; inline - -: count ( seq quot -- n ) - [ 1 0 ? ] compose sigma ; inline - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : map-reduce ( seq map-quot reduce-quot -- result ) >r [ unclip ] dip [ call ] keep r> compose reduce ; inline