sequences: add cartesian-each, cartesian-map, cartesian-product words to eliminate...

diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor
index d033b7115bb28f252faba92c49d387ce483a2ab0..662a2840a1d1990946a2b45d03a6aed5bff30686 100644 (file)
--- a/basis/delegate/delegate.factor
+++ b/basis/delegate/delegate.factor
@@ -99,11 +99,8 @@ M: consultation forget*
 ! Protocols
 <PRIVATE
 
-: cross-2each ( seq1 seq2 quot -- )
-    [ with each ] 2curry each ; inline
-
 : forget-all-methods ( classes words -- )
-    [ first method forget ] cross-2each ;
+    [ first method forget ] cartesian-each ;
 
 : protocol-users ( protocol -- users )
     protocol-consult keys ;
@@ -120,7 +117,7 @@ M: consultation forget*
 
 : add-new-definitions ( protocol wordlist -- )
     [ drop protocol-consult values ] [ added-words ] 2bi
-    [ swap consult-method ] cross-2each ;
+    [ swap consult-method ] cartesian-each ;
 
 : initialize-protocol-props ( protocol wordlist -- )
     [

diff --git a/basis/images/processing/processing.factor b/basis/images/processing/processing.factor
index b21eb50c62c8d9890a86c0c3106a6895b275760f..aa6434743f4a17eaf4ed25f9efc8ff87fbad0d73 100644 (file)
--- a/basis/images/processing/processing.factor
+++ b/basis/images/processing/processing.factor
@@ -6,7 +6,7 @@ math.ranges math.vectors sequences sequences.deep fry ;
 IN: images.processing\r
 \r
 : coord-matrix ( dim -- m )\r
-    [ iota ] map first2 [ [ 2array ] with map ] curry map ;\r
+    [ iota ] map first2 cartesian-product ;\r
 \r
 : map^2 ( m quot -- m' ) '[ _ map ] map ; inline\r
 : each^2 ( m quot -- m' ) '[ _ each ] each ; inline\r

diff --git a/basis/math/matrices/matrices-tests.factor b/basis/math/matrices/matrices-tests.factor
index 3ee1ddbd6d229b5baa85c11afbf8c58840e207d2..a22f6cc97812abe75e3f80227526f761692808c5 100644 (file)
--- a/basis/math/matrices/matrices-tests.factor
+++ b/basis/math/matrices/matrices-tests.factor
@@ -105,8 +105,5 @@ USING: math.matrices math.vectors tools.test math ;
 
 [ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
 
-[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
-[ { 1 2 } { "a" "b" } cross-zip ] unit-test
-
 [ { { 4181 6765 } { 6765 10946 } } ]
 [ { { 0 1 } { 1 1 } } 20 m^n ] unit-test

diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor
index bf14d7ba13ccff4bcf5eb55385f561a5543c0e3b..2a1a217c2eabae901d63d2e0c4346752a402d56a 100644 (file)
--- a/basis/math/matrices/matrices.factor
+++ b/basis/math/matrices/matrices.factor
@@ -11,7 +11,7 @@ IN: math.matrices
 
 : identity-matrix ( n -- matrix )
     #! Make a nxn identity matrix.
-    iota dup [ [ = 1 0 ? ] with map ] curry map ;
+    iota dup [ = 1 0 ? ] cartesian-map ;
 
 :: rotation-matrix3 ( axis theta -- matrix )
     theta cos :> c
@@ -126,9 +126,6 @@ IN: math.matrices
 : norm-gram-schmidt ( seq -- orthonormal )
     gram-schmidt [ normalize ] map ;
 
-: cross-zip ( seq1 seq2 -- seq1xseq2 )
-    [ [ 2array ] with map ] curry map ;
-    
 : m^n ( m n -- n ) 
     make-bits over first length identity-matrix
     [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;

diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor
index e53383c98bf9899215e6eebf58e0dcdd449825eb..9284a151f5bb24b6f06d751070d063995c54eee7 100644 (file)
--- a/basis/opengl/textures/textures.factor
+++ b/basis/opengl/textures/textures.factor
@@ -1,9 +1,9 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs cache colors.constants destructors
 kernel opengl opengl.gl opengl.capabilities combinators images
 images.tesselation grouping sequences math math.vectors
-math.matrices generalizations fry arrays namespaces system
+generalizations fry arrays namespaces system
 locals literals specialized-arrays ;
 FROM: alien.c-types => float ;
 SPECIALIZED-ARRAY: float
@@ -354,7 +354,7 @@ TUPLE: multi-texture < disposable grid display-list loc ;
 : image-locs ( image-grid -- loc-grid )
     [ first [ dim>> first ] map ] [ [ first dim>> second ] map ] bi
     [ 0 [ + ] accumulate nip ] bi@
-    cross-zip flip ;
+    cartesian-product flip ;
 
 : <texture-grid> ( image-grid loc -- grid )
     [ dup image-locs ] dip

diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor
index 2e964b48b693a7b1b1cb40d81e26c1938e1993c1..d103ce401ca5936fe5320f36da04d603533b4d79 100644 (file)
--- a/basis/ui/gadgets/grids/grids.factor
+++ b/basis/ui/gadgets/grids/grids.factor
@@ -1,9 +1,8 @@
 ! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.order math.matrices namespaces
-make sequences words io math.vectors ui.gadgets
-ui.baseline-alignment columns accessors strings.tables
-math.rectangles fry ;
+USING: arrays kernel math math.order namespaces make sequences
+words io math.vectors ui.gadgets ui.baseline-alignment columns
+accessors strings.tables math.rectangles fry ;
 IN: ui.gadgets.grids
 
 TUPLE: grid < gadget
@@ -90,7 +89,7 @@ M: grid pref-dim* <grid-layout> grid-pref-dim ;
 : (compute-cell-locs) ( grid-layout -- locs )
     [ accumulate-cell-xs nip ]
     [ accumulate-cell-ys nip ]
-    bi cross-zip flip ;
+    bi cartesian-product flip ;
 
 : adjust-for-baseline ( row-locs row-cells -- row-locs' )
     align-baselines [ 0 swap 2array v+ ] 2map ;
@@ -104,7 +103,7 @@ M: grid pref-dim* <grid-layout> grid-pref-dim ;
 
 : cell-dims ( grid-layout -- dims )
     dup fill?>>
-    [ [ column-widths>> ] [ row-heights>> ] bi cross-zip flip ]
+    [ [ column-widths>> ] [ row-heights>> ] bi cartesian-product flip ]
     [ grid>> [ [ pref-dim>> ] map ] map ]
     if ;
 

diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 46b4dcd4ec7ed987bcb3c92bed7e4dad759ddd94..94e8e9799829e64b7db4479777983bad78244792 100644 (file)
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -1364,6 +1364,25 @@ HELP: assert-sequence=
   }
 } ;
 
+HELP: cartesian-each
+{ $values { "seq1" sequence } { "seq1" sequence } { "quot" { $quotation "( elt1 elt2 -- )" } } }
+{ $description "Applies the quotation to every possible pairing of elements from the two sequences." } ;
+
+HELP: cartesian-map
+{ $values { "seq1" sequence } { "seq1" sequence } { "quot" { $quotation "( elt1 elt2 -- result )" } } { "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
+{ $values { "seq1" sequence } { "seq1" sequence } { "newseq" "a new sequence of sequences of pairs" } }
+{ $description "Outputs a sequence of all possible pairings of elements from the two sequences." }
+{ $examples
+    { $example
+        "USING: prettyprint sequences ;"
+        "{ 1 2 } { 3 4 } cartesian-product ."
+        "{ { { 1 3 } { 1 4 } } { { 2 3 } { 2 4 } } }"
+    }
+} ;
+
 ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
 "The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
 $nl
@@ -1691,6 +1710,19 @@ ARTICLE: "sequences-combinator-implementation" "Implementing sequence combinator
     2selector
 } ;
 
+ARTICLE: "sequences-cartesian" "Cartesian product operations"
+"The cartesian product of two sequences is a sequence of all pairs where the first element of each pair is from the first sequence, and the second element of each pair is from the second sequence. The number of elements in the cartesian product is the product of the lengths of the two sequences."
+$nl
+"Combinators which pair every element of the first sequence with every element of the second:"
+{ $subsections
+    cartesian-each
+    cartesian-map
+}
+"Computing the cartesian product of two sequences:"
+{ $subsections
+    cartesian-product
+} ;
+
 ARTICLE: "sequences" "Sequence operations"
 "A " { $emphasis "sequence" } " is a finite, linearly-ordered collection of elements. Words for working with sequences are in the " { $vocab-link "sequences" } " vocabulary."
 $nl
@@ -1718,6 +1750,7 @@ $nl
     "binary-search"
     "sets"
     "sequences-trimming"
+    "sequences-cartesian"
     "sequences.deep"
 }
 "Using sequences for looping:"

diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor
index be1111b826f7f585f324006a3246e6e2862c0e3f..665e7a7ada07a6772f9efa1f7b9cb70e99034fbd 100644 (file)
--- a/core/sequences/sequences-tests.factor
+++ b/core/sequences/sequences-tests.factor
@@ -309,3 +309,6 @@ USE: make
 [ +gt+ ] [ { 0 0 0 0 } { 0 0 0 } <=> ] unit-test
 [ +eq+ ] [ { } { } <=> ] unit-test
 [ +eq+ ] [ { 1 2 3 } { 1 2 3 } <=> ] unit-test
+
+[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
+[ { 1 2 } { "a" "b" } cartesian-product ] unit-test

diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 2eafe2ceb8f8096dfb93b9fe306f7f3d0db19b12..9f59d98468cbbeed9f9559c3cdbe5a705ce07b8f 100644 (file)
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -947,6 +947,15 @@ M: object sum 0 [ + ] binary-reduce ; inline
 
 : count ( seq quot -- n ) [ 1 0 ? ] compose map-sum ; inline
 
+: cartesian-each ( seq1 seq2 quot -- )
+    [ with each ] 2curry each ; inline
+
+: cartesian-map ( seq1 seq2 quot -- newseq )
+    [ with map ] 2curry map ; inline
+
+: cartesian-product ( seq1 seq2 -- newseq )
+    [ { } 2sequence ] cartesian-map ;
+
 ! We hand-optimize flip to such a degree because type hints
 ! cannot express that an array is an array of arrays yet, and
 ! this word happens to be performance-critical since the compiler

diff --git a/extra/project-euler/004/004.factor b/extra/project-euler/004/004.factor
index fe09914d9f2edc125dd065df911e0383b825eab2..1bb9ebbef5751c420ac741e523c4b70ad5694dc7 100644 (file)
--- a/extra/project-euler/004/004.factor
+++ b/extra/project-euler/004/004.factor
@@ -29,7 +29,7 @@ IN: project-euler.004
 PRIVATE>
 
 : euler004 ( -- answer )
-    source-004 dup cartesian-product [ product ] map prune max-palindrome ;
+    source-004 dup [ * ] cartesian-map concat prune max-palindrome ;
 
 ! [ euler004 ] 100 ave-time
 ! 1164 ms ave run time - 39.35 SD (100 trials)

diff --git a/extra/project-euler/027/027.factor b/extra/project-euler/027/027.factor
index 0c697236aaa63d86dc05e17d46853db172e5c23c..cd2620bc4f7d30dc2185c08ce9fd6f02db678ecf 100644 (file)
--- a/extra/project-euler/027/027.factor
+++ b/extra/project-euler/027/027.factor
@@ -47,7 +47,7 @@ IN: project-euler.027
 
 : source-027 ( -- seq )
     1000 iota [ prime? ] filter [ dup [ neg ] map append ] keep
-    cartesian-product [ first2 < ] filter ;
+    cartesian-product concat [ first2 < ] filter ;
 
 : quadratic ( b a n -- m )
     dup sq -rot * + + ;

diff --git a/extra/project-euler/029/029.factor b/extra/project-euler/029/029.factor
index 73773e1887d146ab5e83b77e0883b64e03d0cb75..31be1a566b5bc09e847438bfc68f996d5f74fe89 100644 (file)
--- a/extra/project-euler/029/029.factor
+++ b/extra/project-euler/029/029.factor
@@ -29,7 +29,7 @@ IN: project-euler.029
 ! --------
 
 : euler029 ( -- answer )
-    2 100 [a,b] dup cartesian-product [ first2 ^ ] map prune length ;
+    2 100 [a,b] dup [ ^ ] cartesian-map concat prune length ;
 
 ! [ euler029 ] 100 ave-time
 ! 704 ms ave run time - 28.07 SD (100 trials)

diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor
index 8fb7a2bfaa8c83b45d0d8d7203cb1fb6ac3b1a46..7def55b659868755dc53212bf7d72f49bff18d18 100644 (file)
--- a/extra/project-euler/032/032.factor
+++ b/extra/project-euler/032/032.factor
@@ -62,17 +62,17 @@ PRIVATE>
 
 <PRIVATE
 
-: source-032a ( -- seq )
-    50 [1,b] 2000 [1,b] cartesian-product ;
-
 ! multiplicand/multiplier/product
-: mmp ( pair -- n )
-    first2 2dup * [ number>string ] tri@ 3append string>number ;
+: mmp ( x y -- n )
+    2dup * [ number>string ] tri@ 3append string>number ;
 
 PRIVATE>
 
 : euler032a ( -- answer )
-    source-032a [ mmp ] map [ pandigital? ] filter products prune sum ;
+    50 [1,b] 2000 [1,b]
+    [ mmp ] cartesian-map concat
+    [ pandigital? ] filter
+    products prune sum ;
 
 ! [ euler032a ] 10 ave-time
 ! 2624 ms ave run time - 131.91 SD (10 trials)

diff --git a/extra/project-euler/033/033.factor b/extra/project-euler/033/033.factor
index 780015ab77b8b6e90a96559036c2d69b0c4a20f8..77bae6d2f2309fb1ab3dfd8de21096bb9b7db677 100644 (file)
--- a/extra/project-euler/033/033.factor
+++ b/extra/project-euler/033/033.factor
@@ -30,7 +30,7 @@ IN: project-euler.033
 <PRIVATE
 
 : source-033 ( -- seq )
-    10 99 [a,b] dup cartesian-product [ first2 < ] filter ;
+    10 99 [a,b] dup cartesian-product concat [ first2 < ] filter ;
 
 : safe? ( ax xb -- ? )
     [ 10 /mod ] bi@ [ = ] dip zero? not and nip ;

diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor
index 4991d65a895c4f7c032ed0f68c134d774c35d23b..ab59843e2155ec30f91ec9cc48a50b6b00cdd990 100644 (file)
--- a/extra/project-euler/043/043.factor
+++ b/extra/project-euler/043/043.factor
@@ -86,7 +86,8 @@ PRIVATE>
 
 : interesting-pandigitals ( -- seq )
     17 candidates { 13 11 7 5 3 2 } [
-        candidates swap cartesian-product [ overlap? ] filter clean
+        candidates swap cartesian-product concat
+        [ overlap? ] filter clean
     ] each [ add-missing-digit ] map ;
 
 PRIVATE>

diff --git a/extra/project-euler/056/056.factor b/extra/project-euler/056/056.factor
index 76c275e4dde21dbabc1d3cb43061f3b9685e8cae..98e39ebd3695464c772a9777d9deab7b2b7878ec 100644 (file)
--- a/extra/project-euler/056/056.factor
+++ b/extra/project-euler/056/056.factor
@@ -23,7 +23,7 @@ IN: project-euler.056
 ! Through analysis, you only need to check when a and b > 90
 
 : euler056 ( -- answer )
-    90 100 [a,b) dup cartesian-product
+    90 100 [a,b) dup cartesian-product concat
     [ first2 ^ number>digits sum ] [ max ] map-reduce ;
 
 ! [ euler056 ] 100 ave-time

diff --git a/extra/project-euler/081/081.factor b/extra/project-euler/081/081.factor
index cc5e93d7a86412702e52cf175c1151c1b3162273..73936ba2ed1510e4ad1db4c8f60fb81f37365b01 100644 (file)
--- a/extra/project-euler/081/081.factor
+++ b/extra/project-euler/081/081.factor
@@ -60,8 +60,8 @@ IN: project-euler.081
     3dup minimal-path-sum-to '[ _ + ] change-matrix ;
 
 : (euler081) ( matrix -- n )
-    dup first length iota dup cartesian-product
-    [ first2 pick update-minimal-path-sum ] each
+    dup first length iota dup
+    [ pick update-minimal-path-sum ] cartesian-each
     last last ;
 
 PRIVATE>

diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index 48520ef56528f4dd17e5f45925f0a00ac461d876..895eba4deb66ccc067158d2022cf6e89c9ae2b6e 100644 (file)
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -68,9 +68,6 @@ PRIVATE>
 : alpha-value ( str -- n )
     >lower [ CHAR: a - 1 + ] map-sum ;
 
-: cartesian-product ( seq1 seq2 -- seq1xseq2 )
-    [ [ 2array ] with map ] curry map concat ;
-
 : mediant ( a/c b/d -- (a+b)/(c+d) )
     2>fraction [ + ] 2bi@ / ;