Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
93be5a84bd
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: help.markup help.syntax multiline quotations sequences sequences.product ;
|
||||
IN: sequences
|
||||
|
||||
HELP: product-sequence
|
||||
{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }
|
||||
{ $examples
|
||||
{ $example <" USING: arrays prettyprint sequences.product ;
|
||||
{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
|
||||
"> <" {
|
||||
{ 1 "a" }
|
||||
{ 2 "a" }
|
||||
{ 3 "a" }
|
||||
{ 1 "b" }
|
||||
{ 2 "b" }
|
||||
{ 3 "b" }
|
||||
{ 1 "c" }
|
||||
{ 2 "c" }
|
||||
{ 3 "c" }
|
||||
}"> } } ;
|
||||
|
||||
HELP: <product-sequence>
|
||||
{ $values { "sequences" sequence } { "product-sequence" product-sequence } }
|
||||
{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." }
|
||||
{ $examples
|
||||
{ $example <" USING: arrays prettyprint sequences.product ;
|
||||
{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
|
||||
"> <" {
|
||||
{ 1 "a" }
|
||||
{ 2 "a" }
|
||||
{ 3 "a" }
|
||||
{ 1 "b" }
|
||||
{ 2 "b" }
|
||||
{ 3 "b" }
|
||||
{ 1 "c" }
|
||||
{ 2 "c" }
|
||||
{ 3 "c" }
|
||||
}"> } } ;
|
||||
|
||||
{ product-sequence <product-sequence> } related-words
|
||||
|
||||
HELP: product-map
|
||||
{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- value )" } } { "sequence" sequence } }
|
||||
{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence." }
|
||||
{ $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] map" } "." } ;
|
||||
|
||||
HELP: product-each
|
||||
{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- )" } } }
|
||||
{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." }
|
||||
{ $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] each" } "." } ;
|
||||
|
||||
{ product-map product-each } related-words
|
||||
|
||||
ARTICLE: "sequences.product" "Product sequences"
|
||||
"The " { $vocab-link "sequences.product" } " vocabulary provides a virtual sequence and combinators for manipulating the cartesian product of a set of sequences."
|
||||
{ $subsection product-sequence }
|
||||
{ $subsection <product-sequence> }
|
||||
{ $subsection product-map }
|
||||
{ $subsection product-each } ;
|
||||
|
||||
ABOUT: "sequences.product"
|
||||
|
|
@ -1,3 +1,4 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: arrays kernel make sequences sequences.product tools.test ;
|
||||
IN: sequences.product.tests
|
||||
|
||||
|
|
@ -5,8 +6,10 @@ IN: sequences.product.tests
|
|||
[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
|
||||
[ { { 0 1 2 } { "a" "b" } } <product-sequence> >array ] unit-test
|
||||
|
||||
[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
|
||||
[ { { 0 1 2 } { "a" "b" } } [ ] product-map ] unit-test
|
||||
: x ( n s -- sss ) <repetition> concat ;
|
||||
|
||||
[ { "a" "aa" "aaa" "b" "bb" "bbb" } ]
|
||||
[ { { 1 2 3 } { "a" "b" } } [ first2 x ] product-map ] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: accessors arrays kernel math sequences ;
|
||||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors arrays kernel locals math sequences ;
|
||||
IN: sequences.product
|
||||
|
||||
TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
|
||||
|
|
@ -10,19 +11,53 @@ INSTANCE: product-sequence sequence
|
|||
|
||||
M: product-sequence length lengths>> product ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: ns ( n lengths -- ns )
|
||||
[ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
|
||||
|
||||
: nths ( ns seqs -- nths )
|
||||
[ nth ] { } 2map-as ;
|
||||
|
||||
: product@ ( n product-sequence -- ns seqs )
|
||||
[ lengths>> ns ] [ nip sequences>> ] 2bi ;
|
||||
|
||||
:: (carry-n) ( ns lengths i -- )
|
||||
ns length i 1+ = [
|
||||
i ns nth i lengths nth = [
|
||||
0 i ns set-nth
|
||||
i 1+ ns [ 1+ ] change-nth
|
||||
ns lengths i 1+ (carry-n)
|
||||
] when
|
||||
] unless ;
|
||||
|
||||
: carry-ns ( ns lengths -- )
|
||||
0 (carry-n) ;
|
||||
|
||||
: product-iter ( ns lengths -- )
|
||||
[ 0 over [ 1+ ] change-nth ] dip carry-ns ;
|
||||
|
||||
: start-product-iter ( sequence-product -- ns lengths )
|
||||
[ [ drop 0 ] map ] [ [ length ] map ] bi ;
|
||||
|
||||
: end-product-iter? ( ns lengths -- ? )
|
||||
[ 1 tail* first ] bi@ = ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: product-sequence nth
|
||||
product@ [ nth ] { } 2map-as ;
|
||||
product@ nths ;
|
||||
|
||||
M: product-sequence set-nth
|
||||
immutable ;
|
||||
:: product-each ( sequences quot -- )
|
||||
sequences start-product-iter :> lengths :> ns
|
||||
[ ns lengths end-product-iter? ]
|
||||
[ ns sequences nths quot call ns lengths product-iter ] until ; inline
|
||||
|
||||
:: product-map ( sequences quot -- sequence )
|
||||
0 :> i!
|
||||
sequences [ length ] [ * ] map-reduce sequences
|
||||
[| result |
|
||||
sequences [ quot call i result set-nth i 1+ i! ] product-each
|
||||
result
|
||||
] new-like ; inline
|
||||
|
||||
: product-map ( sequences quot -- sequence )
|
||||
[ <product-sequence> ] dip map ; inline
|
||||
: product-each ( sequences quot -- )
|
||||
[ <product-sequence> ] dip each ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Cartesian products of sequences
|
||||
Loading…
Reference in New Issue