From e4f108714a3d6b7dfb68e556773385e4c5a367e7 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 22 Oct 2009 15:32:34 -0500 Subject: [PATCH] add nproduce and nproduce-as combinators to sequences.generalizations --- .../generalizations-docs.factor | 12 ++++++++- .../generalizations-tests.factor | 13 ++++++++++ .../generalizations/generalizations.factor | 26 ++++++++++++++++--- 3 files changed, 47 insertions(+), 4 deletions(-) diff --git a/basis/sequences/generalizations/generalizations-docs.factor b/basis/sequences/generalizations/generalizations-docs.factor index d2e8c0c5fc..7940427e69 100644 --- a/basis/sequences/generalizations/generalizations-docs.factor +++ b/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" diff --git a/basis/sequences/generalizations/generalizations-tests.factor b/basis/sequences/generalizations/generalizations-tests.factor index ac1990743e..d1861b8f9d 100644 --- a/basis/sequences/generalizations/generalizations-tests.factor +++ b/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 diff --git a/basis/sequences/generalizations/generalizations.factor b/basis/sequences/generalizations/generalizations.factor index 4365c1494d..210b27f3f3 100644 --- a/basis/sequences/generalizations/generalizations.factor +++ b/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