basis/sequences/product/product.factor

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