add nproduce and nproduce-as combinators to sequences.generalizations

basis/sequences/generalizations/generalizations-docs.factor

@@ -20,9 +20,17 @@ HELP: mnmap
 { $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel and provide any number of output sequences." } ;
 
 HELP: mnmap-as
-{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the " { $snippet "exemplar" } "s" } }
+{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
 { $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel and provide any number of output sequences of distinct types." } ;
 
+HELP: nproduce
+{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "n" integer } { "seq..." { $snippet "n" } " arrays on the datastack" } }
+{ $description "A generalization of " { $link produce } " that generates " { $snippet "n" } " arrays in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
+
+HELP: nproduce-as
+{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "...exemplar" { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
+{ $description "A generalization of " { $link produce-as } " that generates " { $snippet "n" } " sequences in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
+
 ARTICLE: "sequences.generalizations" "Generalized sequence iteration combinators"
 "The " { $vocab-link "sequences.generalizations" } " vocabulary defines generalized versions of the iteration " { $link "sequences-combinators" } "."
 { $subsections
@@ -31,6 +39,8 @@ ARTICLE: "sequences.generalizations" "Generalized sequence iteration combinators
     nmap-as
     mnmap
     mnmap-as
+    nproduce
+    nproduce-as
 } ;
 
 ABOUT: "sequences.generalizations"

basis/sequences/generalizations/generalizations-tests.factor

@@ -19,6 +19,14 @@ IN: sequences.generalizations.tests
     [ 4 nappend ] 4 1 mnmap ;
 : mnmap-0-test ( a b c d -- )
     [ 4 nappend print ] 4 0 mnmap ;
+: nproduce-as-test ( n -- a b )
+    [ dup zero? not ]
+    [ [ 2 - ] [ ] [ 1 - ] tri ] { } B{ } 2 nproduce-as
+    [ drop ] 2dip ;
+: nproduce-test ( n -- a b )
+    [ dup zero? not ]
+    [ [ 2 - ] [ ] [ 1 - ] tri ] 2 nproduce
+    [ drop ] 2dip ;
 
 [ """A1a!
 B2b@
@@ -105,3 +113,8 @@ D4d$
     [ mnmap-0-test ] with-string-writer
 ] unit-test
 
+[ { 10 8 6 4 2 } B{ 9 7 5 3 1 } ]
+[ 10 nproduce-as-test ] unit-test
+
+[ { 10 8 6 4 2 } { 9 7 5 3 1 } ]
+[ 10 nproduce-test ] unit-test

basis/sequences/generalizations/generalizations.factor

@@ -1,3 +1,4 @@
+! (c)2009 Joe Groff bsd license
 USING: kernel sequences sequences.private math
 combinators macros math.order math.ranges quotations fry effects
 memoize.private generalizations ;
@@ -32,7 +33,7 @@ MACRO: nnew-sequence ( n -- )
     [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
 
 : nnew-like ( len ...exemplar quot n -- result... )
-    dup dup dup dup '[
+    5 dupn '[
         _ nover
         [ [ _ nnew-sequence ] dip call ]
         _ ndip [ like ]
@@ -41,14 +42,14 @@ MACRO: nnew-sequence ( n -- )
     ] call ; inline
 
 MACRO: (ncollect) ( n -- )
-    dup dup 1 +
+    3 dupn 1 +
     '[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
 
 : ncollect ( len quot ...into n -- )
     (ncollect) each-integer ; inline
 
 : nmap-integers ( len quot ...exemplar n -- result... )
-    dup dup dup
+    4 dupn
     '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
 
 : mnmap-as ( m*seq quot n*exemplar m n -- result*n )
@@ -57,3 +58,22 @@ MACRO: (ncollect) ( n -- )
 : mnmap ( m*seq quot m n -- result*n )
     2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
 
+: naccumulator-for ( quot ...exemplar n -- quot' vec... )
+    5 dupn '[
+        [ [ length ] keep new-resizable ] _ napply
+        [ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
+    ] call ; inline
+
+: naccumulator ( quot n -- quot' vec... )
+    [ V{ } swap dupn ] keep naccumulator-for ; inline
+
+: nproduce-as ( pred quot ...exemplar n -- seq... )
+    7 dupn '[
+        _ ndup
+        [ _ naccumulator-for [ while ] _ ndip ]
+        _ ncurry _ ndip
+        [ like ] _ apply-curry _ spread*
+    ] call ; inline
+
+: nproduce ( pred quot n -- seq... )
+    [ { } swap dupn ] keep nproduce-as ; inline