1 ! (c)2009 Joe Groff bsd license
2 USING: accessors arrays assocs kernel locals math sequences ;
3 FROM: sequences => change-nth ;
6 TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
8 : <product-sequence> ( sequences -- product-sequence )
9 >array dup [ length ] map product-sequence boa ;
11 INSTANCE: product-sequence sequence
13 M: product-sequence length lengths>> product ;
17 : ns ( n lengths -- ns )
20 : nths ( ns seqs -- nths )
23 : product@ ( n product-sequence -- ns seqs )
24 [ lengths>> ns ] [ nip sequences>> ] 2bi ;
26 :: (carry-n) ( ns lengths i -- )
28 i ns nth i lengths nth = [
30 i 1 + ns [ 1 + ] change-nth
31 ns lengths i 1 + (carry-n)
35 : carry-ns ( ns lengths -- )
38 : product-iter ( ns lengths -- )
39 [ 0 over [ 1 + ] change-nth ] dip carry-ns ;
41 : start-product-iter ( sequences -- ns lengths )
42 [ length 0 <array> ] [ [ length ] map ] bi ;
44 : end-product-iter? ( ns lengths -- ? )
49 M: product-sequence nth
52 :: product-each ( ... sequences quot: ( ... seq -- ... ) -- ... )
53 sequences start-product-iter :> ( ns lengths )
54 lengths [ 0 = ] any? [
55 [ ns lengths end-product-iter? ]
56 [ ns sequences nths quot call ns lengths product-iter ] until
59 :: product-map-as ( ... sequences quot: ( ... seq -- ... value ) exemplar -- ... sequence )
61 sequences [ length ] [ * ] map-reduce exemplar
63 sequences [ quot call i result set-nth i 1 + i! ] product-each
67 : product-map ( ... sequences quot: ( ... seq -- ... value ) -- ... sequence )
68 over product-map-as ; inline
70 :: product-map>assoc ( ... sequences quot: ( ... seq -- ... key value ) exemplar -- ... assoc )
72 sequences [ length ] [ * ] map-reduce { }
74 sequences [ quot call 2array i result set-nth i 1 + i! ] product-each
76 ] new-like exemplar assoc-like ; inline