basis/sequences/product/product.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: accessors arrays assocs kernel locals math sequences
   3 sequences.private ;
   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-unsafe i lengths nth-unsafe = [
  29             0 i ns set-nth-unsafe
  30             i 1 + ns [ 1 + ] change-nth-unsafe
  31             ns lengths i 1 + (carry-n)
  32         ] when
  33     ] unless ; inline recursive
  34
  35 : carry-ns ( ns lengths -- )
  36     0 (carry-n) ; inline
  37
  38 : product-iter ( ns lengths -- )
  39     [ 0 over [ 1 + ] change-nth-unsafe ] dip carry-ns ; inline
  40
  41 : start-product-iter ( sequences -- ns lengths )
  42     [ length 0 <array> ] [ [ length ] map ] bi ; inline
  43
  44 : end-product-iter? ( ns lengths -- ? )
  45     [ last-unsafe ] same? ; inline
  46
  47 : product-length ( sequences -- length )
  48     [ length ] [ * ] map-reduce ; inline
  49
  50 PRIVATE>
  51
  52 M: product-sequence nth
  53     product@ nths ;
  54
  55 :: product-each ( ... sequences quot: ( ... seq -- ... ) -- ... )
  56     sequences start-product-iter :> ( ns lengths )
  57     lengths [ 0 = ] any? [
  58         [ ns lengths end-product-iter? ]
  59         [ ns sequences nths quot call ns lengths product-iter ] until
  60     ] unless ; inline
  61
  62 :: product-map-as ( ... sequences quot: ( ... seq -- ... value ) exemplar -- ... sequence )
  63     0 :> i!
  64     sequences product-length exemplar
  65     [| result |
  66         sequences [ quot call i result set-nth-unsafe i 1 + i! ] product-each
  67         result
  68     ] new-like ; inline
  69
  70 : product-map ( ... sequences quot: ( ... seq -- ... value ) -- ... sequence )
  71     over product-map-as ; inline
  72
  73 :: product-map>assoc ( ... sequences quot: ( ... seq -- ... key value ) exemplar -- ... assoc )
  74     0 :> i!
  75     sequences product-length { }
  76     [| result |
  77         sequences [ quot call 2array i result set-nth-unsafe i 1 + i! ] product-each
  78         result
  79     ] new-like exemplar assoc-like ; inline