Merge branch 'master' of git://factorcode.org/git/factor

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

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 ;

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 ;

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"
+} ;
+

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

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
+

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*
+

extra/bake/bake.factor

@@ -1,6 +1,7 @@
 
-USING: kernel parser combinators sequences splitting quotations arrays macros
+USING: kernel parser namespaces sequences quotations arrays vectors splitting
-       arrays.lib combinators.cleave combinators.conditional newfx ;
+       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 ]               ] }
+      { [ comma?    ] [ drop [ >r ]          ] }
-      { [ array? ] [ [bake-array] [ >r ] append ] }
+      { [ integer?  ] [ [ >r ] prefix-on     ] }
-      { [ drop t ] [ [ >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  [ drop [ r> ]   ] map concat ]
-    [ length [ narray ] prefix-on ]
+    [ 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 ]
+    [ [ [bake] [connector] append [ >r ] append ] map concat ]
-    [ length [ drop [ 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 ;
+: [bake] ( seq -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
-
-MACRO: bake-array ( array -- quot ) [bake-array] ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: `{ \ } [ >array ] parse-literal \ bake-array parsed ; parsing
+MACRO: bake ( seq -- quot ) [bake] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: `{  \ } [ >array     ] parse-literal \ bake parsed ; parsing
+: `V{ \ } [ >vector    ] parse-literal \ bake parsed ; parsing
+: `[  \ ] [ >quotation ] parse-literal \ bake parsed ; parsing

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,26 +35,22 @@ DEFER: (shallow-fry)
 
 : shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
 
-: deep-fry ( quot -- quot' )
+: deep-fry ( quot -- quot )
-    { _ } last-split1 [
+    { _ } last-split1 dup [
-        [
+      shallow-fry [ >r ] rot
-            shallow-fry %
+      deep-fry    [ [ dip ] curry r> compose ] 4array concat
-            [ >r ] %
-            deep-fry %
-            [ [ dip ] curry r> compose ] %
-        ] [ ] make
     ] [
-        shallow-fry
+        drop shallow-fry
-    ] if* ;
+    ] if ;
 
 : fry-specifier? ( obj -- ? ) { , namespaces:, @ } member? ;
 
 : count-inputs ( quot -- n )
     [
         {
-            { [ dup callable? ] [ count-inputs ] }
+            { [ dup callable?      ] [ count-inputs ] }
-            { [ dup fry-specifier? ] [ drop 1 ] }
+            { [ dup fry-specifier? ] [ drop 1       ] }
-            [ drop 0 ]
+                                     [ drop 0       ]
         } cond
     ] map sum ;
     

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 ;
@@ -200,3 +205,35 @@ METHOD: as-mutate { object object assoc }       set-at ;
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : 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 ;

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." }

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

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