1 ! (c)2009 Joe Groff bsd license
2 USING: accessors arrays kernel locals math sequences ;
5 TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
7 : <product-sequence> ( sequences -- product-sequence )
8 >array dup [ length ] map product-sequence boa ;
10 INSTANCE: product-sequence sequence
12 M: product-sequence length lengths>> product ;
16 : ns ( n lengths -- ns )
17 [ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
19 : nths ( ns seqs -- nths )
22 : product@ ( n product-sequence -- ns seqs )
23 [ lengths>> ns ] [ nip sequences>> ] 2bi ;
25 :: (carry-n) ( ns lengths i -- )
27 i ns nth i lengths nth = [
29 i 1+ ns [ 1+ ] change-nth
30 ns lengths i 1+ (carry-n)
34 : carry-ns ( ns lengths -- )
37 : product-iter ( ns lengths -- )
38 [ 0 over [ 1+ ] change-nth ] dip carry-ns ;
40 : start-product-iter ( sequence-product -- ns lengths )
41 [ [ drop 0 ] map ] [ [ length ] map ] bi ;
43 : end-product-iter? ( ns lengths -- ? )
44 [ 1 tail* first ] bi@ = ;
48 M: product-sequence nth
51 :: product-each ( sequences quot -- )
52 sequences start-product-iter :> lengths :> ns
53 [ ns lengths end-product-iter? ]
54 [ ns sequences nths quot call ns lengths product-iter ] until ; inline
56 :: product-map ( sequences quot -- sequence )
58 sequences [ length ] [ * ] map-reduce sequences
60 sequences [ quot call i result set-nth i 1+ i! ] product-each