extra/sequences/product/product.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: accessors arrays kernel locals math sequences ;
   3 IN: sequences.product
   4
   5 TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
   6
   7 : <product-sequence> ( sequences -- product-sequence )
   8     >array dup [ length ] map product-sequence boa ;
   9
  10 INSTANCE: product-sequence sequence
  11
  12 M: product-sequence length lengths>> product ;
  13
  14 <PRIVATE
  15
  16 : ns ( n lengths -- ns )
  17     [ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
  18
  19 : nths ( ns seqs -- nths )
  20     [ nth ] { } 2map-as ;
  21
  22 : product@ ( n product-sequence -- ns seqs )
  23     [ lengths>> ns ] [ nip sequences>> ] 2bi ;
  24
  25 :: (carry-n) ( ns lengths i -- )
  26     ns length i 1 + = [
  27         i ns nth i lengths nth = [
  28             0 i ns set-nth
  29             i 1 + ns [ 1 + ] change-nth
  30             ns lengths i 1 + (carry-n)
  31         ] when
  32     ] unless ;
  33
  34 : carry-ns ( ns lengths -- )
  35     0 (carry-n) ;
  36
  37 : product-iter ( ns lengths -- )
  38     [ 0 over [ 1 + ] change-nth ] dip carry-ns ;
  39
  40 : start-product-iter ( sequence-product -- ns lengths )
  41     [ [ drop 0 ] map ] [ [ length ] map ] bi ;
  42
  43 : end-product-iter? ( ns lengths -- ? )
  44     [ 1 tail* first ] bi@ = ;
  45
  46 PRIVATE>
  47
  48 M: product-sequence nth
  49     product@ nths ;
  50
  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
  55
  56 :: product-map ( sequences quot -- sequence )
  57     0 :> i!
  58     sequences [ length ] [ * ] map-reduce sequences
  59     [| result |
  60         sequences [ quot call i result set-nth i 1 + i! ] product-each
  61         result
  62     ] new-like ; inline
  63