Merge branch 'master' of git://factorcode.org/git/factor

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 -- )
     [

basis/images/processing/processing.factor

@@ -6,7 +6,7 @@ math.ranges math.vectors sequences sequences.deep fry ;
 IN: images.processing
 
 : coord-matrix ( dim -- m )
-    [ iota ] map first2 [ [ 2array ] with map ] curry map ;
+    [ iota ] map first2 cartesian-product ;
 
 : map^2 ( m quot -- m' ) '[ _ map ] map ; inline
 : each^2 ( m quot -- m' ) '[ _ each ] each ; inline

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

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 ;

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

basis/syndication/syndication.factor

@@ -70,7 +70,8 @@ TUPLE: entry title url description date ;
     tri ;
 
 : atom-entry-link ( tag -- url/f )
-    "link" tags-named [ "rel" attr "alternate" = ] find nip
+    "link" tags-named
+    [ "rel" attr { f "alternate" } member? ] find nip
     dup [ "href" attr >url ] when ;
 
 : atom1.0-entry ( tag -- entry )

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 ;
 

core/sequences/sequences-docs.factor

@@ -1364,6 +1364,25 @@ HELP: assert-sequence=
   }
 } ;
 
+HELP: cartesian-each
+{ $values { "seq1" sequence } { "seq2" 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 } { "seq2" 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 } { "seq2" 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:"

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

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

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)

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 * + + ;

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)

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)

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 ;

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>

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

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>

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@ / ;