From cdc1f1e041c943de32ddf7678d857d58bd8790b1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 25 Nov 2009 23:18:18 -0600
Subject: [PATCH] add product-map-as and use it in poker vocab

---
 basis/sequences/product/product-docs.factor | 5 +++++
 basis/sequences/product/product.factor      | 6 ++++--
 extra/poker/poker.factor                    | 3 ++-
 3 files changed, 11 insertions(+), 3 deletions(-)

diff --git a/basis/sequences/product/product-docs.factor b/basis/sequences/product/product-docs.factor
index 0b6805eb71..117d77d38e 100644
--- a/basis/sequences/product/product-docs.factor
+++ b/basis/sequences/product/product-docs.factor
@@ -44,6 +44,10 @@ HELP: product-map
 { $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence." }
 { $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] map" } "." } ;
 
+HELP: product-map-as
+{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- value )" } } { "exemplar" sequence } { "sequence" sequence } }
+{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence the same type as the " { $snippet "exemplar" } " sequence." } ;
+
 HELP: product-each
 { $values { "sequences" sequence } { "quot" { $quotation "( sequence -- )" } } }
 { $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." }
@@ -57,6 +61,7 @@ ARTICLE: "sequences.product" "Product sequences"
     product-sequence
     <product-sequence>
     product-map
+    product-map-as
     product-each
 } ;
 
diff --git a/basis/sequences/product/product.factor b/basis/sequences/product/product.factor
index f783fad312..52d4a2d937 100644
--- a/basis/sequences/product/product.factor
+++ b/basis/sequences/product/product.factor
@@ -55,11 +55,13 @@ M: product-sequence nth
         [ ns sequences nths quot call ns lengths product-iter ] until
     ] unless ; inline
 
-:: product-map ( sequences quot -- sequence )
+:: product-map-as ( sequences quot exemplar -- sequence )
     0 :> i!
-    sequences [ length ] [ * ] map-reduce sequences
+    sequences [ length ] [ * ] map-reduce exemplar
     [| result |
         sequences [ quot call i result set-nth i 1 + i! ] product-each
         result
     ] new-like ; inline
 
+: product-map ( sequences quot -- sequence )
+    over product-map-as ; inline
diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor
index a5a5a93628..9c320a9510 100644
--- a/extra/poker/poker.factor
+++ b/extra/poker/poker.factor
@@ -202,8 +202,9 @@ TUPLE: deck
     { cards sequence } ;
 
 : <deck> ( -- deck )
-    RANK_STR SUIT_STR 2array [ concat >ckf ] product-map deck boa ;
+    RANK_STR SUIT_STR 2array [ concat >ckf ] V{ } product-map-as deck boa ;
 
 : shuffle ( deck -- deck )
     [ randomize ] change-cards ;
 
+: draw-card ( deck -- card ) cards>> pop ;