basis/sequences/product/product.factor

   1 ! Copyright (C) 2009 Joe Groff.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs kernel locals math sequences
   4 sequences.private ;
   5 IN: sequences.product
   6
   7 TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
   8
   9 : <product-sequence> ( sequences -- product-sequence )
  10     >array dup [ length ] map product-sequence boa ;
  11
  12 INSTANCE: product-sequence sequence
  13
  14 M: product-sequence length lengths>> product ;
  15
  16 <PRIVATE
  17
  18 : ns ( n lengths -- ns )
  19     [ /mod ] map nip ;
  20
  21 : nths ( ns seqs -- nths )
  22     [ nth ] { } 2map-as ;
  23
  24 : product@ ( n product-sequence -- ns seqs )
  25     [ lengths>> ns ] [ nip sequences>> ] 2bi ;
  26
  27 :: (carry-n) ( ns lengths i -- )
  28     ns length i 1 + = [
  29         i ns nth-unsafe i lengths nth-unsafe = [
  30             0 i ns set-nth-unsafe
  31             i 1 + ns [ 1 + ] change-nth-unsafe
  32             ns lengths i 1 + (carry-n)
  33         ] when
  34     ] unless ; inline recursive
  35
  36 : carry-ns ( ns lengths -- )
  37     0 (carry-n) ; inline
  38
  39 : product-iter ( ns lengths -- )
  40     [ 0 over [ 1 + ] change-nth-unsafe ] dip carry-ns ; inline
  41
  42 : start-product-iter ( sequences -- ns lengths )
  43     [ length 0 <array> ] [ [ length ] map ] bi ; inline
  44
  45 : end-product-iter? ( ns lengths -- ? )
  46     [ last-unsafe ] same? ; inline
  47
  48 : product-length ( sequences -- length )
  49     [ length ] [ * ] map-reduce ; inline
  50
  51 PRIVATE>
  52
  53 M: product-sequence nth
  54     product@ nths ;
  55
  56 :: product-each ( ... sequences quot: ( ... seq -- ... ) -- ... )
  57     sequences start-product-iter :> ( ns lengths )
  58     lengths [ 0 = ] any? [
  59         [ ns lengths end-product-iter? ]
  60         [ ns sequences nths quot call ns lengths product-iter ] until
  61     ] unless ; inline
  62
  63 :: product-map-as ( ... sequences quot: ( ... seq -- ... value ) exemplar -- ... sequence )
  64     0 :> i!
  65     sequences product-length exemplar
  66     [| result |
  67         sequences [ quot call i result set-nth-unsafe i 1 + i! ] product-each
  68         result
  69     ] new-like ; inline
  70
  71 : product-map ( ... sequences quot: ( ... seq -- ... value ) -- ... sequence )
  72     over product-map-as ; inline
  73
  74 :: product-map>assoc ( ... sequences quot: ( ... seq -- ... key value ) exemplar -- ... assoc )
  75     0 :> i!
  76     sequences product-length { }
  77     [| result |
  78         sequences [ quot call 2array i result set-nth-unsafe i 1 + i! ] product-each
  79         result
  80     ] new-like exemplar assoc-like ; inline
  81
  82 :: product-find ( ... sequences quot: ( ... seq -- ... ? ) -- ... sequence )
  83     sequences start-product-iter :> ( ns lengths )
  84     lengths [ 0 = ] any? [ f ] [
  85         f [ ns lengths end-product-iter? over or ]
  86         [ drop ns sequences nths quot keep and ns lengths product-iter ] until
  87     ] if ; inline