--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup kernel sequences quotations
+math arrays combinators ;
+IN: sequences.generalizations
+
+HELP: nsequence
+{ $values { "n" integer } { "seq" "an exemplar" } }
+{ $description "A generalization of " { $link 2sequence } ", "
+{ $link 3sequence } ", and " { $link 4sequence } " "
+"that constructs a sequence from the top " { $snippet "n" } " elements of the stack."
+}
+{ $examples
+ { $example "USING: prettyprint sequences.generalizations ;" "CHAR: f CHAR: i CHAR: s CHAR: h 4 \"\" nsequence ." "\"fish\"" }
+} ;
+
+HELP: narray
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link 1array } ", "
+{ $link 2array } ", " { $link 3array } " and " { $link 4array } " "
+"that constructs an array from the top " { $snippet "n" } " elements of the stack."
+}
+{ $examples
+ "Some core words expressed in terms of " { $link narray } ":"
+ { $table
+ { { $link 1array } { $snippet "1 narray" } }
+ { { $link 2array } { $snippet "2 narray" } }
+ { { $link 3array } { $snippet "3 narray" } }
+ { { $link 4array } { $snippet "4 narray" } }
+ }
+} ;
+
+{ nsequence narray } related-words
+
+HELP: firstn
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link first } ", "
+{ $link first2 } ", " { $link first3 } " and " { $link first4 } " "
+"that pushes the first " { $snippet "n" } " elements of a sequence on the stack."
+}
+{ $examples
+ "Some core words expressed in terms of " { $link firstn } ":"
+ { $table
+ { { $link first } { $snippet "1 firstn" } }
+ { { $link first2 } { $snippet "2 firstn" } }
+ { { $link first3 } { $snippet "3 firstn" } }
+ { { $link first4 } { $snippet "4 firstn" } }
+ }
+} ;
+
+HELP: ?firstn
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link ?first } " that pushes the first " { $snippet "n" } " elements of a sequence on the stack, or " { $link f } " if the sequence is shorter than the requested number of elements." }
+{ $examples
+ "Some core words expressed in terms of " { $link ?firstn } ":"
+ { $table
+ { { $link ?first } { $snippet "1 ?firstn" } }
+ }
+} ;
+
+HELP: set-firstn
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link set-first } " "
+"that sets the first " { $snippet "n" } " elements of a sequence from the top " { $snippet "n" } " elements of the stack." } ;
+
+HELP: nappend
+{ $values
+ { "n" integer }
+ { "seq" sequence }
+}
+{ $description "Outputs a new sequence consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." }
+{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." }
+{ $examples
+ { $example "USING: math prettyprint sequences.generalizations ;"
+ "{ 1 2 } { 3 4 } { 5 6 } { 7 8 } 4 nappend ."
+ "{ 1 2 3 4 5 6 7 8 }"
+ }
+} ;
+
+HELP: nappend-as
+{ $values
+ { "n" integer } { "exemplar" sequence }
+ { "seq" sequence }
+}
+{ $description "Outputs a new sequence of type " { $snippet "exemplar" } " consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." }
+{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." }
+{ $examples
+ { $example "USING: math prettyprint sequences.generalizations ;"
+ "{ 1 2 } { 3 4 } { 5 6 } { 7 8 } 4 V{ } nappend-as ."
+ "V{ 1 2 3 4 5 6 7 8 }"
+ }
+} ;
+
+{ nappend nappend-as } related-words
+
+HELP: neach
+{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ) } } { "n" integer } }
+{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;
+
+HELP: nmap
+{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- result ) } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }
+{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ;
+
+HELP: nmap-as
+{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- result ) } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }
+{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ;
+
+HELP: mnmap
+{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" { $quotation ( m*element -- result*n ) } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } }
+{ $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" { $quotation ( 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." } ;
+
+HELP: nmap-reduce
+{ $values { "map-quot" { $quotation ( element... -- intermediate ) } } { "reduce-quot" { $quotation ( prev intermediate -- next ) } } { "n" integer } }
+{ $description "A generalization of " { $link map-reduce } " that can be applied to any number of sequences." } ;
+
+HELP: nall?
+{ $values { "seqs..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ? ) } } { "n" integer } { "?" boolean } }
+{ $description "A generalization of " { $link all? } " that can be applied to any number of sequences." } ;
+
+HELP: nfind
+{ $values { "seqs..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ? ) } } { "n" integer } { "i" integer } { "elts..." { $snippet "n" } " elements on the datastack" } }
+{ $description "A generalization of " { $link find } " that can be applied to any number of sequences." } ;
+
+HELP: nany?
+{ $values { "seqs..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ? ) } } { "n" integer } { "?" boolean } }
+{ $description "A generalization of " { $link any? } " that can be applied to any number of sequences." } ;
+
+ARTICLE: "sequences.generalizations" "Generalized sequence words"
+"The " { $vocab-link "sequences.generalizations" } " vocabulary defines generalized versions of various sequence operations."
+{ $subsections
+ narray
+ nsequence
+ firstn
+ set-firstn
+ nappend
+ nappend-as
+}
+"Generalized " { $link "sequences-combinators" } ":"
+{ $subsections
+ neach
+ nmap
+ nmap-as
+ mnmap
+ mnmap-as
+ nproduce
+ nproduce-as
+} ;
+
+ABOUT: "sequences.generalizations"
--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.streams.string kernel math sequences
+sequences.generalizations tools.test ;
+IN: sequences.generalizations.tests
+
+{ 1 2 3 4 } [ { 1 2 3 4 } 4 firstn ] unit-test
+{ { 1 2 3 4 } } [ 1 2 3 4 { f f f f } [ 4 set-firstn ] keep ] unit-test
+[ 1 2 3 4 { f f f } [ 4 set-firstn ] keep ] must-fail
+{ } [ { } 0 firstn ] unit-test
+{ "a" } [ { "a" } 1 firstn ] unit-test
+
+{ } [ { } 0 ?firstn ] unit-test
+{ f } [ { } 1 ?firstn ] unit-test
+{ f f } [ { } 2 ?firstn ] unit-test
+{ 1 f } [ { 1 } 2 ?firstn ] unit-test
+{ 1 2 } [ { 1 2 } 2 ?firstn ] unit-test
+{ 1 2 } [ { 1 2 3 } 2 ?firstn ] unit-test
+
+{ [ 1 2 ] } [ 1 2 2 [ ] nsequence ] unit-test
+{ { 1 2 3 4 5 } } [ 1 2 3 4 5 { 0 0 0 0 0 } 5 (nsequence) ] unit-test
+
+{ { 1 2 3 4 } } [ { 1 } { 2 } { 3 } { 4 } 4 nappend ] unit-test
+{ V{ 1 2 3 4 } } [ { 1 } { 2 } { 3 } { 4 } 4 V{ } nappend-as ] unit-test
+
+[ 4 nappend ] must-infer
+[ 4 { } nappend-as ] must-infer
+
+: neach-test ( a b c d -- )
+ [ 4 nappend print ] 4 neach ;
+: nmap-test ( a b c d -- e )
+ [ 4 nappend ] 4 nmap ;
+: nmap-as-test ( a b c d -- e )
+ [ 4 nappend ] [ ] 4 nmap-as ;
+: mnmap-3-test ( a b c d -- e f g )
+ [ append ] 4 3 mnmap ;
+: mnmap-2-test ( a b c d -- e f )
+ [ [ append ] 2bi@ ] 4 2 mnmap ;
+: mnmap-as-test ( a b c d -- e f )
+ [ [ append ] 2bi@ ] { } [ ] 4 2 mnmap-as ;
+: mnmap-1-test ( a b c d -- e )
+ [ 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 nipd ;
+: nproduce-test ( n -- a b )
+ [ dup zero? not ]
+ [ [ 2 - ] [ ] [ 1 - ] tri ] 2 nproduce nipd ;
+
+{ "A1a!
+B2b@
+C3c#
+D4d$
+" } [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ [ neach-test ] with-string-writer
+] unit-test
+
+{ { "A1a!" "B2b@" "C3c#" "D4d$" } }
+[
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ nmap-test
+] unit-test
+
+{ [ "A1a!" "B2b@" "C3c#" "D4d$" ] }
+[
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ nmap-as-test
+] unit-test
+
+{
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a!" "b@" "c#" "d$" }
+} [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-3-test
+] unit-test
+
+{
+ { "A1" "B2" "C3" "D4" }
+ { "a!" "b@" "c#" "d$" }
+} [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-2-test
+] unit-test
+
+{
+ { "A1" "B2" "C3" "D4" }
+ [ "a!" "b@" "c#" "d$" ]
+} [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-as-test
+] unit-test
+
+{ { "A1a!" "B2b@" "C3c#" "D4d$" } }
+[
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-1-test
+] unit-test
+
+{ "A1a!
+B2b@
+C3c#
+D4d$
+" } [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ [ 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
+
+{ 45 } [
+ { 1 2 3 } { 4 5 6 } { 7 8 9 } [ + + ] [ + ] 3 nmap-reduce
+] unit-test
+
+{ t } [
+ { 1 3 5 } { 2 4 6 } { 4 8 12 } [ + + odd? ] 3 nall?
+] unit-test
+
+{ t } [
+ { 2 4 5 } { 4 6 7 } { 6 8 9 }
+ [ [ odd? ] tri@ and and ] 3 nany?
+] unit-test
+
+{ f } [
+ { 1 2 3 } { 4 5 6 } { 7 8 9 }
+ [ [ odd? ] tri@ and and ] 3 nany?
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators generalizations kernel math math.order
+memoize.private quotations sequences sequences.private ;
+IN: sequences.generalizations
+
+MACRO: (nsequence) ( n -- quot )
+ <iota> reverse [ '[ [ _ swap set-nth-unsafe ] keep ] ] map concat ;
+
+MACRO: nsequence ( n exemplar -- quot )
+ [ [nsequence] ] keep '[ @ _ like ] ;
+
+MACRO: narray ( n -- quot )
+ '[ _ { } nsequence ] ;
+
+MACRO: firstn-unsafe ( n -- quot )
+ [firstn] ;
+
+MACRO: firstn ( n -- quot )
+ [ [ drop ] ] [
+ [ 1 - swap bounds-check 2drop ]
+ [ firstn-unsafe ]
+ bi-curry '[ _ _ bi ]
+ ] if-zero ;
+
+MACRO: set-firstn-unsafe ( n -- quot )
+ [ 1 + ]
+ [ <iota> [ '[ _ rot [ set-nth-unsafe ] keep ] ] map ] bi
+ '[ _ -nrot _ spread drop ] ;
+
+MACRO: set-firstn ( n -- quot )
+ [ [ drop ] ] [
+ [ 1 - swap bounds-check 2drop ]
+ [ set-firstn-unsafe ]
+ bi-curry '[ _ _ bi ]
+ ] if-zero ;
+
+MACRO: ?firstn ( n -- quot )
+ dup '[ _ f pad-tail _ firstn-unsafe ] ;
+
+: nappend ( n -- seq ) narray concat ; inline
+
+: nappend-as ( n exemplar -- seq )
+ [ narray ] [ concat-as ] bi* ; inline
+
+MACRO: nmin-length ( n -- quot )
+ dup 1 - [ min ] n*quot
+ '[ [ length ] _ napply @ ] ;
+
+: nnth ( n seq... n -- )
+ [ nth ] swap [ apply-curry ] [ cleave* ] bi ; inline
+
+: nnth-unsafe ( n seq... n -- )
+ [ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
+
+MACRO: nset-nth-unsafe ( n -- quot )
+ [ [ drop ] ]
+ [ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
+ if-zero ;
+
+: (neach) ( seq... quot n -- len quot' )
+ dup dup dup
+ '[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
+
+: neach ( seq... quot n -- )
+ (neach) each-integer ; inline
+
+: nmap-as ( seq... quot exemplar n -- result )
+ '[ _ (neach) ] dip map-integers ; inline
+
+: nmap ( seq... quot n -- result )
+ dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
+
+MACRO: nnew-sequence ( n -- quot )
+ [ [ drop ] ]
+ [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
+
+: nnew-like ( len exemplar... quot n -- result... )
+ 5 dupn '[
+ _ nover
+ [ [ _ nnew-sequence ] dip call ]
+ _ ndip [ like ]
+ _ apply-curry
+ _ spread*
+ ] call ; inline
+
+MACRO: (ncollect) ( n -- quot )
+ 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... )
+ 4 dupn
+ '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
+
+: mnmap-as ( m*seq quot n*exemplar m n -- result*n )
+ dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline
+
+: mnmap ( m*seq quot m n -- result*n )
+ 2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
+
+: ncollector-as ( quot exemplar... n -- quot' vec... )
+ 5 dupn '[
+ [ [ length ] keep new-resizable ] _ napply
+ [ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
+ ] call ; inline
+
+: ncollector ( quot n -- quot' vec... )
+ [ V{ } swap dupn ] keep ncollector-as ; inline
+
+: nproduce-as ( pred quot exemplar... n -- seq... )
+ 7 dupn '[
+ _ ndup
+ [ _ ncollector-as [ while ] _ ndip ]
+ _ ncurry _ ndip
+ [ like ] _ apply-curry _ spread*
+ ] call ; inline
+
+: nproduce ( pred quot n -- seq... )
+ [ { } swap dupn ] keep nproduce-as ; inline
+
+MACRO: nmap-reduce ( map-quot reduce-quot n -- quot )
+ -rot dupd compose overd over '[
+ [ [ first ] _ napply @ 1 ] _ nkeep
+ _ _ (neach) (each-integer)
+ ] ;
+
+: nall? ( seqs... quot n -- ? )
+ (neach) all-integers? ; inline
+
+MACRO: finish-nfind ( n -- quot )
+ [ 1 + ] keep dup dup dup f <array> >quotation '[
+ _ npick
+ [ [ dup ] _ ndip _ nnth-unsafe ]
+ [ _ ndrop @ ]
+ if
+ ] ;
+
+: (nfind) ( seqs... quot n quot' -- i elts... )
+ over
+ [ '[ _ _ (neach) @ ] ] dip
+ [ '[ _ finish-nfind ] ] keep
+ nbi ; inline
+
+: nfind ( seqs... quot n -- i elts... )
+ [ find-integer ] (nfind) ; inline
+
+: nany? ( seqs... quot n -- ? )
+ [ nfind ] [ ndrop ] bi >boolean ; inline
+++ /dev/null
-! Copyright (C) 2009 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup kernel sequences quotations
-math arrays combinators ;
-IN: sequences.generalizations
-
-HELP: nsequence
-{ $values { "n" integer } { "seq" "an exemplar" } }
-{ $description "A generalization of " { $link 2sequence } ", "
-{ $link 3sequence } ", and " { $link 4sequence } " "
-"that constructs a sequence from the top " { $snippet "n" } " elements of the stack."
-}
-{ $examples
- { $example "USING: prettyprint sequences.generalizations ;" "CHAR: f CHAR: i CHAR: s CHAR: h 4 \"\" nsequence ." "\"fish\"" }
-} ;
-
-HELP: narray
-{ $values { "n" integer } }
-{ $description "A generalization of " { $link 1array } ", "
-{ $link 2array } ", " { $link 3array } " and " { $link 4array } " "
-"that constructs an array from the top " { $snippet "n" } " elements of the stack."
-}
-{ $examples
- "Some core words expressed in terms of " { $link narray } ":"
- { $table
- { { $link 1array } { $snippet "1 narray" } }
- { { $link 2array } { $snippet "2 narray" } }
- { { $link 3array } { $snippet "3 narray" } }
- { { $link 4array } { $snippet "4 narray" } }
- }
-} ;
-
-{ nsequence narray } related-words
-
-HELP: firstn
-{ $values { "n" integer } }
-{ $description "A generalization of " { $link first } ", "
-{ $link first2 } ", " { $link first3 } " and " { $link first4 } " "
-"that pushes the first " { $snippet "n" } " elements of a sequence on the stack."
-}
-{ $examples
- "Some core words expressed in terms of " { $link firstn } ":"
- { $table
- { { $link first } { $snippet "1 firstn" } }
- { { $link first2 } { $snippet "2 firstn" } }
- { { $link first3 } { $snippet "3 firstn" } }
- { { $link first4 } { $snippet "4 firstn" } }
- }
-} ;
-
-HELP: ?firstn
-{ $values { "n" integer } }
-{ $description "A generalization of " { $link ?first } " that pushes the first " { $snippet "n" } " elements of a sequence on the stack, or " { $link f } " if the sequence is shorter than the requested number of elements." }
-{ $examples
- "Some core words expressed in terms of " { $link ?firstn } ":"
- { $table
- { { $link ?first } { $snippet "1 ?firstn" } }
- }
-} ;
-
-HELP: set-firstn
-{ $values { "n" integer } }
-{ $description "A generalization of " { $link set-first } " "
-"that sets the first " { $snippet "n" } " elements of a sequence from the top " { $snippet "n" } " elements of the stack." } ;
-
-HELP: nappend
-{ $values
- { "n" integer }
- { "seq" sequence }
-}
-{ $description "Outputs a new sequence consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." }
-{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." }
-{ $examples
- { $example "USING: math prettyprint sequences.generalizations ;"
- "{ 1 2 } { 3 4 } { 5 6 } { 7 8 } 4 nappend ."
- "{ 1 2 3 4 5 6 7 8 }"
- }
-} ;
-
-HELP: nappend-as
-{ $values
- { "n" integer } { "exemplar" sequence }
- { "seq" sequence }
-}
-{ $description "Outputs a new sequence of type " { $snippet "exemplar" } " consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." }
-{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." }
-{ $examples
- { $example "USING: math prettyprint sequences.generalizations ;"
- "{ 1 2 } { 3 4 } { 5 6 } { 7 8 } 4 V{ } nappend-as ."
- "V{ 1 2 3 4 5 6 7 8 }"
- }
-} ;
-
-{ nappend nappend-as } related-words
-
-HELP: neach
-{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ) } } { "n" integer } }
-{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;
-
-HELP: nmap
-{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- result ) } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }
-{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ;
-
-HELP: nmap-as
-{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- result ) } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }
-{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ;
-
-HELP: mnmap
-{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" { $quotation ( m*element -- result*n ) } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } }
-{ $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" { $quotation ( 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." } ;
-
-HELP: nmap-reduce
-{ $values { "map-quot" { $quotation ( element... -- intermediate ) } } { "reduce-quot" { $quotation ( prev intermediate -- next ) } } { "n" integer } }
-{ $description "A generalization of " { $link map-reduce } " that can be applied to any number of sequences." } ;
-
-HELP: nall?
-{ $values { "seqs..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ? ) } } { "n" integer } { "?" boolean } }
-{ $description "A generalization of " { $link all? } " that can be applied to any number of sequences." } ;
-
-HELP: nfind
-{ $values { "seqs..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ? ) } } { "n" integer } { "i" integer } { "elts..." { $snippet "n" } " elements on the datastack" } }
-{ $description "A generalization of " { $link find } " that can be applied to any number of sequences." } ;
-
-HELP: nany?
-{ $values { "seqs..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ? ) } } { "n" integer } { "?" boolean } }
-{ $description "A generalization of " { $link any? } " that can be applied to any number of sequences." } ;
-
-ARTICLE: "sequences.generalizations" "Generalized sequence words"
-"The " { $vocab-link "sequences.generalizations" } " vocabulary defines generalized versions of various sequence operations."
-{ $subsections
- narray
- nsequence
- firstn
- set-firstn
- nappend
- nappend-as
-}
-"Generalized " { $link "sequences-combinators" } ":"
-{ $subsections
- neach
- nmap
- nmap-as
- mnmap
- mnmap-as
- nproduce
- nproduce-as
-} ;
-
-ABOUT: "sequences.generalizations"
+++ /dev/null
-! Copyright (C) 2009 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io io.streams.string kernel math sequences
-sequences.generalizations tools.test ;
-IN: sequences.generalizations.tests
-
-{ 1 2 3 4 } [ { 1 2 3 4 } 4 firstn ] unit-test
-{ { 1 2 3 4 } } [ 1 2 3 4 { f f f f } [ 4 set-firstn ] keep ] unit-test
-[ 1 2 3 4 { f f f } [ 4 set-firstn ] keep ] must-fail
-{ } [ { } 0 firstn ] unit-test
-{ "a" } [ { "a" } 1 firstn ] unit-test
-
-{ } [ { } 0 ?firstn ] unit-test
-{ f } [ { } 1 ?firstn ] unit-test
-{ f f } [ { } 2 ?firstn ] unit-test
-{ 1 f } [ { 1 } 2 ?firstn ] unit-test
-{ 1 2 } [ { 1 2 } 2 ?firstn ] unit-test
-{ 1 2 } [ { 1 2 3 } 2 ?firstn ] unit-test
-
-{ [ 1 2 ] } [ 1 2 2 [ ] nsequence ] unit-test
-{ { 1 2 3 4 5 } } [ 1 2 3 4 5 { 0 0 0 0 0 } 5 (nsequence) ] unit-test
-
-{ { 1 2 3 4 } } [ { 1 } { 2 } { 3 } { 4 } 4 nappend ] unit-test
-{ V{ 1 2 3 4 } } [ { 1 } { 2 } { 3 } { 4 } 4 V{ } nappend-as ] unit-test
-
-[ 4 nappend ] must-infer
-[ 4 { } nappend-as ] must-infer
-
-: neach-test ( a b c d -- )
- [ 4 nappend print ] 4 neach ;
-: nmap-test ( a b c d -- e )
- [ 4 nappend ] 4 nmap ;
-: nmap-as-test ( a b c d -- e )
- [ 4 nappend ] [ ] 4 nmap-as ;
-: mnmap-3-test ( a b c d -- e f g )
- [ append ] 4 3 mnmap ;
-: mnmap-2-test ( a b c d -- e f )
- [ [ append ] 2bi@ ] 4 2 mnmap ;
-: mnmap-as-test ( a b c d -- e f )
- [ [ append ] 2bi@ ] { } [ ] 4 2 mnmap-as ;
-: mnmap-1-test ( a b c d -- e )
- [ 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 nipd ;
-: nproduce-test ( n -- a b )
- [ dup zero? not ]
- [ [ 2 - ] [ ] [ 1 - ] tri ] 2 nproduce nipd ;
-
-{ "A1a!
-B2b@
-C3c#
-D4d$
-" } [
- { "A" "B" "C" "D" }
- { "1" "2" "3" "4" }
- { "a" "b" "c" "d" }
- { "!" "@" "#" "$" }
- [ neach-test ] with-string-writer
-] unit-test
-
-{ { "A1a!" "B2b@" "C3c#" "D4d$" } }
-[
- { "A" "B" "C" "D" }
- { "1" "2" "3" "4" }
- { "a" "b" "c" "d" }
- { "!" "@" "#" "$" }
- nmap-test
-] unit-test
-
-{ [ "A1a!" "B2b@" "C3c#" "D4d$" ] }
-[
- { "A" "B" "C" "D" }
- { "1" "2" "3" "4" }
- { "a" "b" "c" "d" }
- { "!" "@" "#" "$" }
- nmap-as-test
-] unit-test
-
-{
- { "A" "B" "C" "D" }
- { "1" "2" "3" "4" }
- { "a!" "b@" "c#" "d$" }
-} [
- { "A" "B" "C" "D" }
- { "1" "2" "3" "4" }
- { "a" "b" "c" "d" }
- { "!" "@" "#" "$" }
- mnmap-3-test
-] unit-test
-
-{
- { "A1" "B2" "C3" "D4" }
- { "a!" "b@" "c#" "d$" }
-} [
- { "A" "B" "C" "D" }
- { "1" "2" "3" "4" }
- { "a" "b" "c" "d" }
- { "!" "@" "#" "$" }
- mnmap-2-test
-] unit-test
-
-{
- { "A1" "B2" "C3" "D4" }
- [ "a!" "b@" "c#" "d$" ]
-} [
- { "A" "B" "C" "D" }
- { "1" "2" "3" "4" }
- { "a" "b" "c" "d" }
- { "!" "@" "#" "$" }
- mnmap-as-test
-] unit-test
-
-{ { "A1a!" "B2b@" "C3c#" "D4d$" } }
-[
- { "A" "B" "C" "D" }
- { "1" "2" "3" "4" }
- { "a" "b" "c" "d" }
- { "!" "@" "#" "$" }
- mnmap-1-test
-] unit-test
-
-{ "A1a!
-B2b@
-C3c#
-D4d$
-" } [
- { "A" "B" "C" "D" }
- { "1" "2" "3" "4" }
- { "a" "b" "c" "d" }
- { "!" "@" "#" "$" }
- [ 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
-
-{ 45 } [
- { 1 2 3 } { 4 5 6 } { 7 8 9 } [ + + ] [ + ] 3 nmap-reduce
-] unit-test
-
-{ t } [
- { 1 3 5 } { 2 4 6 } { 4 8 12 } [ + + odd? ] 3 nall?
-] unit-test
-
-{ t } [
- { 2 4 5 } { 4 6 7 } { 6 8 9 }
- [ [ odd? ] tri@ and and ] 3 nany?
-] unit-test
-
-{ f } [
- { 1 2 3 } { 4 5 6 } { 7 8 9 }
- [ [ odd? ] tri@ and and ] 3 nany?
-] unit-test
+++ /dev/null
-! Copyright (C) 2009 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators generalizations kernel math math.order
-memoize.private quotations sequences sequences.private ;
-IN: sequences.generalizations
-
-MACRO: (nsequence) ( n -- quot )
- <iota> reverse [ '[ [ _ swap set-nth-unsafe ] keep ] ] map concat ;
-
-MACRO: nsequence ( n exemplar -- quot )
- [ [nsequence] ] keep '[ @ _ like ] ;
-
-MACRO: narray ( n -- quot )
- '[ _ { } nsequence ] ;
-
-MACRO: firstn-unsafe ( n -- quot )
- [firstn] ;
-
-MACRO: firstn ( n -- quot )
- [ [ drop ] ] [
- [ 1 - swap bounds-check 2drop ]
- [ firstn-unsafe ]
- bi-curry '[ _ _ bi ]
- ] if-zero ;
-
-MACRO: set-firstn-unsafe ( n -- quot )
- [ 1 + ]
- [ <iota> [ '[ _ rot [ set-nth-unsafe ] keep ] ] map ] bi
- '[ _ -nrot _ spread drop ] ;
-
-MACRO: set-firstn ( n -- quot )
- [ [ drop ] ] [
- [ 1 - swap bounds-check 2drop ]
- [ set-firstn-unsafe ]
- bi-curry '[ _ _ bi ]
- ] if-zero ;
-
-MACRO: ?firstn ( n -- quot )
- dup '[ _ f pad-tail _ firstn-unsafe ] ;
-
-: nappend ( n -- seq ) narray concat ; inline
-
-: nappend-as ( n exemplar -- seq )
- [ narray ] [ concat-as ] bi* ; inline
-
-MACRO: nmin-length ( n -- quot )
- dup 1 - [ min ] n*quot
- '[ [ length ] _ napply @ ] ;
-
-: nnth ( n seq... n -- )
- [ nth ] swap [ apply-curry ] [ cleave* ] bi ; inline
-
-: nnth-unsafe ( n seq... n -- )
- [ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
-
-MACRO: nset-nth-unsafe ( n -- quot )
- [ [ drop ] ]
- [ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
- if-zero ;
-
-: (neach) ( seq... quot n -- len quot' )
- dup dup dup
- '[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
-
-: neach ( seq... quot n -- )
- (neach) each-integer ; inline
-
-: nmap-as ( seq... quot exemplar n -- result )
- '[ _ (neach) ] dip map-integers ; inline
-
-: nmap ( seq... quot n -- result )
- dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
-
-MACRO: nnew-sequence ( n -- quot )
- [ [ drop ] ]
- [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
-
-: nnew-like ( len exemplar... quot n -- result... )
- 5 dupn '[
- _ nover
- [ [ _ nnew-sequence ] dip call ]
- _ ndip [ like ]
- _ apply-curry
- _ spread*
- ] call ; inline
-
-MACRO: (ncollect) ( n -- quot )
- 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... )
- 4 dupn
- '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
-
-: mnmap-as ( m*seq quot n*exemplar m n -- result*n )
- dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline
-
-: mnmap ( m*seq quot m n -- result*n )
- 2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
-
-: ncollector-as ( quot exemplar... n -- quot' vec... )
- 5 dupn '[
- [ [ length ] keep new-resizable ] _ napply
- [ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
- ] call ; inline
-
-: ncollector ( quot n -- quot' vec... )
- [ V{ } swap dupn ] keep ncollector-as ; inline
-
-: nproduce-as ( pred quot exemplar... n -- seq... )
- 7 dupn '[
- _ ndup
- [ _ ncollector-as [ while ] _ ndip ]
- _ ncurry _ ndip
- [ like ] _ apply-curry _ spread*
- ] call ; inline
-
-: nproduce ( pred quot n -- seq... )
- [ { } swap dupn ] keep nproduce-as ; inline
-
-MACRO: nmap-reduce ( map-quot reduce-quot n -- quot )
- -rot dupd compose overd over '[
- [ [ first ] _ napply @ 1 ] _ nkeep
- _ _ (neach) (each-integer)
- ] ;
-
-: nall? ( seqs... quot n -- ? )
- (neach) all-integers? ; inline
-
-MACRO: finish-nfind ( n -- quot )
- [ 1 + ] keep dup dup dup f <array> >quotation '[
- _ npick
- [ [ dup ] _ ndip _ nnth-unsafe ]
- [ _ ndrop @ ]
- if
- ] ;
-
-: (nfind) ( seqs... quot n quot' -- i elts... )
- over
- [ '[ _ _ (neach) @ ] ] dip
- [ '[ _ finish-nfind ] ] keep
- nbi ; inline
-
-: nfind ( seqs... quot n -- i elts... )
- [ find-integer ] (nfind) ; inline
-
-: nany? ( seqs... quot n -- ? )
- [ nfind ] [ ndrop ] bi >boolean ; inline
projects / factor.git / commitdiff