From 7826543d2e85f9304c00f8c02c4657b2ea9e9825 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 25 Feb 2010 20:54:41 +1300 Subject: [PATCH] sequences: add cartesian-each, cartesian-map, cartesian-product words to eliminate some duplication throughout the codebase --- basis/delegate/delegate.factor | 7 ++--- basis/images/processing/processing.factor | 2 +- basis/math/matrices/matrices-tests.factor | 3 --- basis/math/matrices/matrices.factor | 5 +--- basis/opengl/textures/textures.factor | 6 ++--- basis/ui/gadgets/grids/grids.factor | 11 ++++---- core/sequences/sequences-docs.factor | 33 +++++++++++++++++++++++ core/sequences/sequences-tests.factor | 3 +++ core/sequences/sequences.factor | 9 +++++++ extra/project-euler/004/004.factor | 2 +- extra/project-euler/027/027.factor | 2 +- extra/project-euler/029/029.factor | 2 +- extra/project-euler/032/032.factor | 12 ++++----- extra/project-euler/033/033.factor | 2 +- extra/project-euler/043/043.factor | 3 ++- extra/project-euler/056/056.factor | 2 +- extra/project-euler/081/081.factor | 4 +-- extra/project-euler/common/common.factor | 3 --- 18 files changed, 72 insertions(+), 39 deletions(-) diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index d033b7115b..662a2840a1 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -99,11 +99,8 @@ M: consultation forget* ! Protocols 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 e53383c98b..9284a151f5 100644 --- 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 ; : ( 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 2e964b48b6..d103ce401c 100644 --- 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-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-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 46b4dcd4ec..94e8e97998 100644 --- 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 be1111b826..665e7a7ada 100644 --- 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 2eafe2ceb8..9f59d98468 100644 --- 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 fe09914d9f..1bb9ebbef5 100644 --- 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 0c697236aa..cd2620bc4f 100644 --- 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 73773e1887..31be1a566b 100644 --- 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 8fb7a2bfaa..7def55b659 100644 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -62,17 +62,17 @@ PRIVATE> 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 780015ab77..77bae6d2f2 100644 --- a/extra/project-euler/033/033.factor +++ b/extra/project-euler/033/033.factor @@ -30,7 +30,7 @@ IN: project-euler.033 : 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 76c275e4dd..98e39ebd36 100644 --- 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 cc5e93d7a8..73936ba2ed 100644 --- 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 48520ef565..895eba4deb 100644 --- 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@ / ; -- 2.34.1