sequences.extras: Add a word to take the cartesian product of a sequence

add ?cut

diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor
index 74180a963ad6ddb5c10b99d685e13476e1e46dd8..3653553f4f5d750395e4af6ae705c25226ce27ba 100644 (file)
--- a/extra/sequences/extras/extras-tests.factor
+++ b/extra/sequences/extras/extras-tests.factor
@@ -522,3 +522,23 @@ strings tools.test ;
 
 { "34_01_" } [ 2 0 3 "01_34_" [ exchange-subseq ] keep ] unit-test
 { "cdebaf" } [ 3 0 2 "abcdef" [ exchange-subseq ] keep ] unit-test
+
+{ { } } [ { } sequence-cartesian-product ] unit-test
+{ { } } [ { { } } sequence-cartesian-product ] unit-test
+{ { } } [ { { 1 2 } { } } sequence-cartesian-product ] unit-test
+{ { { 1 } { 2 } } } [ { { 1 2 } } sequence-cartesian-product ] unit-test
+
+{
+    {
+        { 1 3 5 6 { 9 } }
+        { 1 3 5 7 { 9 } }
+        { 1 4 5 6 { 9 } }
+        { 1 4 5 7 { 9 } }
+        { 2 3 5 6 { 9 } }
+        { 2 3 5 7 { 9 } }
+        { 2 4 5 6 { 9 } }
+        { 2 4 5 7 { 9 } }
+    }
+} [
+    { { 1 2 } { 3 4 } { 5 } { 6 7 } { { 9 } } } sequence-cartesian-product
+] unit-test

diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor
index 9fbd24341184002805f18b14e78d66bb4bb7b05a..fd5b8ee2bf6b820c4f952313e504bd0113188471 100644 (file)
--- a/extra/sequences/extras/extras.factor
+++ b/extra/sequences/extras/extras.factor
@@ -871,6 +871,8 @@ ERROR: slice-error-of from to seq ;
     [ find drop ] keepd swap
     [ cut ] [ f over like ] if* ; inline
 
+: ?cut ( seq n -- before after ) [ index-or-length head ] [ index-or-length tail ] 2bi ;
+
 : nth* ( n seq -- elt )
     [ length 1 - swap - ] [ nth ] bi ; inline
 
@@ -1207,3 +1209,11 @@ INSTANCE: virtual-zip-index immutable-sequence
         2dup _ exchange-unsafe
         [ 1 - ] [ 1 + ] [ 1 + ] tri*
     ] [ pick 0 > ] swap while 3drop ;
+
+: sequence-cartesian-product ( seqs -- seqs' )
+    dup length 1 <= [
+        [ [ 1array ] map ] map concat
+    ] [
+        2 cut [ first2 cartesian-product concat ] dip swap
+        [ [ suffix ] cartesian-map concat ] reduce
+    ] if ;