From ecd518eddcc2bb9cc8a84ba544ef7c596d303ab1 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Sat, 12 Dec 2020 09:38:33 -0800
Subject: [PATCH] sequences: improving cartesian-product to return type of
 original sequences.

Adding cartesian-product-as for cases where you don't want that.
---
 core/sequences/sequences-docs.factor | 20 +++++++++++++++++++-
 core/sequences/sequences.factor      |  7 +++++--
 2 files changed, 24 insertions(+), 3 deletions(-)

diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 4bc691345c..690e888ca1 100644
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -1657,17 +1657,35 @@ HELP: cartesian-map
 { $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation ( ... elt1 elt2 -- ... newelt ) } } { "newseq" "a new sequence of sequences" } }
 { $description "Applies the quotation to every possible pairing of elements from the two sequences, collecting results into a new sequence of sequences." } ;
 
+HELP: cartesian-product-as
+{ $values { "seq1" sequence } { "seq2" sequence } { "exemplar" sequence } { "newseq" "a new sequence of sequences of pairs" } }
+{ $description "Outputs a sequence of all possible pairings of elements from the two sequences so that the output sequence is the exemplar's type." }
+{ $examples
+    { $example
+        "USING: bit-arrays prettyprint sequences ;"
+        "\"ab\" ?{ t f } { } cartesian-product-as ."
+        "{ { { 97 t } { 97 f } } { { 98 t } { 98 f } } }"
+    }
+} ;
+
 HELP: cartesian-product
 { $values { "seq1" sequence } { "seq2" sequence } { "newseq" "a new sequence of sequences of pairs" } }
-{ $description "Outputs a sequence of all possible pairings of elements from the two sequences." }
+{ $description "Outputs a sequence of all possible pairings of elements from the two sequences, using the type of " { $snippet "seq2" } "." }
 { $examples
     { $example
         "USING: prettyprint sequences ;"
         "{ 1 2 } { 3 4 } cartesian-product ."
         "{ { { 1 3 } { 1 4 } } { { 2 3 } { 2 4 } } }"
     }
+    { $example
+        "USING: prettyprint sequences ;"
+        "\"abc\" \"def\" cartesian-product ."
+        "{ { \"ad\" \"ae\" \"af\" } { \"bd\" \"be\" \"bf\" } { \"cd\" \"ce\" \"cf\" } }"
+    }
 } ;
 
+{ cartesian-find cartesian-each cartesian-map cartesian-product cartesian-product-as } related-words
+
 ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
 "The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
 $nl
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 95cd2a2bc3..a0e9d79c4c 100644
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -1097,10 +1097,13 @@ M: repetition sum [ elt>> ] [ length>> ] bi * ; inline
     [ with each ] 2curry each ; inline
 
 : cartesian-map ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... newseq )
-    [ with map ] 2curry map ; inline
+    [ with { } map-as ] 2curry { } map-as ; inline
+
+: cartesian-product-as ( seq1 seq2 exemplar -- newseq )
+    [ 2sequence ] curry cartesian-map ; inline
 
 : cartesian-product ( seq1 seq2 -- newseq )
-    [ { } 2sequence ] cartesian-map ;
+    dup cartesian-product-as ; inline
 
 : cartesian-find ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... elt1 elt2 )
     [ f ] 3dip [ with find swap ] 2curry [ nip ] prepose find nip swap ; inline
-- 
2.34.1