From 303ce55dc6d9ed566d05f36a995ba21200a56626 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 26 Apr 2009 12:27:50 -0500
Subject: [PATCH] more efficient product-each and product-map that don't /mod
 all over the place

---
 extra/sequences/product/product-tests.factor |  6 ++-
 extra/sequences/product/product.factor       | 50 ++++++++++++++++----
 2 files changed, 46 insertions(+), 10 deletions(-)

diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor
index 0a984072e0..087d7a6175 100644
--- a/extra/sequences/product/product-tests.factor
+++ b/extra/sequences/product/product-tests.factor
@@ -5,8 +5,10 @@ IN: sequences.product.tests
 [ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
 [ { { 0 1 2 } { "a" "b" } } <product-sequence> >array ] unit-test
 
-[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
-[ { { 0 1 2 } { "a" "b" } } [ ] product-map ] unit-test
+: x ( n s -- sss ) <repetition> concat ;
+
+[ { "a" "aa" "aaa" "b" "bb" "bbb" } ]
+[ { { 1 2 3 } { "a" "b" } } [ first2 x ] product-map ] unit-test
 
 [
     {
diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor
index 73ba1e4e01..0c5bb88f32 100644
--- a/extra/sequences/product/product.factor
+++ b/extra/sequences/product/product.factor
@@ -1,4 +1,4 @@
-USING: accessors arrays kernel math sequences ;
+USING: accessors arrays kernel locals math sequences ;
 IN: sequences.product
 
 TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
@@ -10,19 +10,53 @@ INSTANCE: product-sequence sequence
 
 M: product-sequence length lengths>> product ;
 
+<PRIVATE
+
 : ns ( n lengths -- ns )
     [ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
 
+: nths ( ns seqs -- nths )
+    [ nth ] { } 2map-as ;
+
 : product@ ( n product-sequence -- ns seqs )
     [ lengths>> ns ] [ nip sequences>> ] 2bi ;
 
+:: (carry-n) ( ns lengths i -- )
+    ns length i 1+ = [
+        i ns nth i lengths nth = [
+            0 i ns set-nth
+            i 1+ ns [ 1+ ] change-nth
+            ns lengths i 1+ (carry-n)
+        ] when
+    ] unless ;
+
+: carry-ns ( ns lengths -- )
+    0 (carry-n) ;
+    
+: product-iter ( ns lengths -- )
+    [ 0 over [ 1+ ] change-nth ] dip carry-ns ;
+
+: start-product-iter ( sequence-product -- ns lengths )
+    [ [ drop 0 ] map ] [ [ length ] map ] bi ;
+
+: end-product-iter? ( ns lengths -- ? )
+    [ 1 tail* first ] bi@ = ;
+
+PRIVATE>
+
 M: product-sequence nth 
-    product@ [ nth ] { } 2map-as ;
+    product@ nths ;
 
-M: product-sequence set-nth
-    immutable ;
+:: product-each ( sequences quot -- )
+    sequences start-product-iter :> lengths :> ns
+    [ ns lengths end-product-iter? ]
+    [ ns sequences nths quot call ns lengths product-iter ] until ; inline
+
+:: product-map ( sequences quot -- sequence )
+    0 :> i!
+    sequences [ length ] [ * ] map-reduce sequences
+    [| result |
+        sequences [ quot call i result set-nth i 1+ i! ] product-each
+        result
+    ] new-like ; inline
 
-: product-map ( sequences quot -- sequence )
-    [ <product-sequence> ] dip map ; inline
-: product-each ( sequences quot -- )
-    [ <product-sequence> ] dip each ; inline