From 303ce55dc6d9ed566d05f36a995ba21200a56626 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 12:27:50 -0500 Subject: [PATCH 1/4] more efficient product-each and product-map that don't /mod all over the place --- extra/sequences/product/product-tests.factor | 6 ++- extra/sequences/product/product.factor | 50 ++++++++++++++++---- 2 files changed, 46 insertions(+), 10 deletions(-) diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor index 0a984072e0..087d7a6175 100644 --- a/extra/sequences/product/product-tests.factor +++ b/extra/sequences/product/product-tests.factor @@ -5,8 +5,10 @@ IN: sequences.product.tests [ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ] [ { { 0 1 2 } { "a" "b" } } >array ] unit-test -[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ] -[ { { 0 1 2 } { "a" "b" } } [ ] product-map ] unit-test +: x ( n s -- sss ) concat ; + +[ { "a" "aa" "aaa" "b" "bb" "bbb" } ] +[ { { 1 2 3 } { "a" "b" } } [ first2 x ] product-map ] unit-test [ { diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor index 73ba1e4e01..0c5bb88f32 100644 --- a/extra/sequences/product/product.factor +++ b/extra/sequences/product/product.factor @@ -1,4 +1,4 @@ -USING: accessors arrays kernel math sequences ; +USING: accessors arrays kernel locals math sequences ; IN: sequences.product TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ; @@ -10,19 +10,53 @@ INSTANCE: product-sequence sequence M: product-sequence length lengths>> product ; +> ns ] [ nip sequences>> ] 2bi ; +:: (carry-n) ( ns lengths i -- ) + ns length i 1+ = [ + i ns nth i lengths nth = [ + 0 i ns set-nth + i 1+ ns [ 1+ ] change-nth + ns lengths i 1+ (carry-n) + ] when + ] unless ; + +: carry-ns ( ns lengths -- ) + 0 (carry-n) ; + +: product-iter ( ns lengths -- ) + [ 0 over [ 1+ ] change-nth ] dip carry-ns ; + +: start-product-iter ( sequence-product -- ns lengths ) + [ [ drop 0 ] map ] [ [ length ] map ] bi ; + +: end-product-iter? ( ns lengths -- ? ) + [ 1 tail* first ] bi@ = ; + +PRIVATE> + M: product-sequence nth - product@ [ nth ] { } 2map-as ; + product@ nths ; -M: product-sequence set-nth - immutable ; +:: product-each ( sequences quot -- ) + sequences start-product-iter :> lengths :> ns + [ ns lengths end-product-iter? ] + [ ns sequences nths quot call ns lengths product-iter ] until ; inline + +:: product-map ( sequences quot -- sequence ) + 0 :> i! + sequences [ length ] [ * ] map-reduce sequences + [| result | + sequences [ quot call i result set-nth i 1+ i! ] product-each + result + ] new-like ; inline -: product-map ( sequences quot -- sequence ) - [ ] dip map ; inline -: product-each ( sequences quot -- ) - [ ] dip each ; inline From f007c281e3b2c0645a095b1f9febb31668eea9e9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 13:08:15 -0500 Subject: [PATCH 2/4] docs for sequences.product --- extra/sequences/product/product-docs.factor | 60 +++++++++++++++++++++ 1 file changed, 60 insertions(+) create mode 100644 extra/sequences/product/product-docs.factor diff --git a/extra/sequences/product/product-docs.factor b/extra/sequences/product/product-docs.factor new file mode 100644 index 0000000000..6033767f47 --- /dev/null +++ b/extra/sequences/product/product-docs.factor @@ -0,0 +1,60 @@ +USING: help.markup help.syntax multiline quotations sequences sequences.product ; +IN: sequences + +HELP: product-sequence +{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link } " word." } +{ $examples +{ $example <" USING: arrays prettyprint sequences.product ; +{ { 1 2 3 } { "a" "b" "c" } } >array . +"> <" { + { 1 "a" } + { 2 "a" } + { 3 "a" } + { 1 "b" } + { 2 "b" } + { 3 "b" } + { 1 "c" } + { 2 "c" } + { 3 "c" } +}"> } } ; + +HELP: +{ $values { "sequences" sequence } { "product-sequence" product-sequence } } +{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." } +{ $examples +{ $example <" USING: arrays prettyprint sequences.product ; +{ { 1 2 3 } { "a" "b" "c" } } >array . +"> <" { + { 1 "a" } + { 2 "a" } + { 3 "a" } + { 1 "b" } + { 2 "b" } + { 3 "b" } + { 1 "c" } + { 2 "c" } + { 3 "c" } +}"> } } ; + +{ product-sequence } related-words + +HELP: product-map +{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- value )" } } { "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." } +{ $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet " [ ... ] map" } "." } ; + +HELP: product-each +{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- )" } } } +{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." } +{ $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet " [ ... ] each" } "." } ; + +{ product-map product-each } related-words + +ARTICLE: "sequences.product" "Product sequences" +"The " { $vocab-link "sequences.product" } " vocabulary provides a virtual sequence and combinators for manipulating the cartesian product of a set of sequences." +{ $subsection product-sequence } +{ $subsection } +{ $subsection product-map } +{ $subsection product-each } ; + +ABOUT: "sequences.product" From a2056d932c3c02fd6ecc5673a3f75ee067648990 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 13:09:30 -0500 Subject: [PATCH 3/4] gold plating for sequences.product --- extra/sequences/product/authors.txt | 1 + extra/sequences/product/product-docs.factor | 1 + extra/sequences/product/product-tests.factor | 1 + extra/sequences/product/product.factor | 1 + extra/sequences/product/summary.txt | 1 + 5 files changed, 5 insertions(+) create mode 100644 extra/sequences/product/authors.txt create mode 100644 extra/sequences/product/summary.txt diff --git a/extra/sequences/product/authors.txt b/extra/sequences/product/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/sequences/product/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/sequences/product/product-docs.factor b/extra/sequences/product/product-docs.factor index 6033767f47..b7dcaa626e 100644 --- a/extra/sequences/product/product-docs.factor +++ b/extra/sequences/product/product-docs.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff bsd license USING: help.markup help.syntax multiline quotations sequences sequences.product ; IN: sequences diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor index 087d7a6175..5e0997dc2e 100644 --- a/extra/sequences/product/product-tests.factor +++ b/extra/sequences/product/product-tests.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff bsd license USING: arrays kernel make sequences sequences.product tools.test ; IN: sequences.product.tests diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor index 0c5bb88f32..665d43f0cd 100644 --- a/extra/sequences/product/product.factor +++ b/extra/sequences/product/product.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff bsd license USING: accessors arrays kernel locals math sequences ; IN: sequences.product diff --git a/extra/sequences/product/summary.txt b/extra/sequences/product/summary.txt new file mode 100644 index 0000000000..c234c84a94 --- /dev/null +++ b/extra/sequences/product/summary.txt @@ -0,0 +1 @@ +Cartesian products of sequences From 06012cf2917e632f3b14c1a80c221b59e1f383b4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 14:58:31 -0500 Subject: [PATCH 4/4] order-insensitive pair methods --- extra/pair-methods/authors.txt | 1 + extra/pair-methods/pair-methods-tests.factor | 43 +++++++++++++++ extra/pair-methods/pair-methods.factor | 57 ++++++++++++++++++++ extra/pair-methods/summary.txt | 1 + 4 files changed, 102 insertions(+) create mode 100644 extra/pair-methods/authors.txt create mode 100644 extra/pair-methods/pair-methods-tests.factor create mode 100644 extra/pair-methods/pair-methods.factor create mode 100644 extra/pair-methods/summary.txt diff --git a/extra/pair-methods/authors.txt b/extra/pair-methods/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/pair-methods/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/pair-methods/pair-methods-tests.factor b/extra/pair-methods/pair-methods-tests.factor new file mode 100644 index 0000000000..f88ca966aa --- /dev/null +++ b/extra/pair-methods/pair-methods-tests.factor @@ -0,0 +1,43 @@ +! (c)2009 Joe Groff bsd license +USING: accessors pair-methods classes kernel sequences tools.test ; +IN: pair-methods.tests + +TUPLE: thang ; + +TUPLE: foom < thang ; +TUPLE: barm < foom ; + +TUPLE: zim < thang ; +TUPLE: zang < zim ; + +: class-names ( a b prefix -- string ) + [ [ class name>> ] bi@ "-" glue ] dip prepend ; + +PAIR-GENERIC: blibble ( a b -- c ) + +PAIR-M: thang thang blibble + "vanilla " class-names ; + +PAIR-M: foom thang blibble + "chocolate " class-names ; + +PAIR-M: barm thang blibble + "strawberry " class-names ; + +PAIR-M: barm zim blibble + "coconut " class-names ; + +[ "vanilla zang-zim" ] [ zim new zang new blibble ] unit-test + +! args automatically swap to match most specific method +[ "chocolate foom-zim" ] [ foom new zim new blibble ] unit-test +[ "chocolate foom-zim" ] [ zim new foom new blibble ] unit-test + +[ "strawberry barm-barm" ] [ barm new barm new blibble ] unit-test +[ "strawberry barm-foom" ] [ barm new foom new blibble ] unit-test +[ "strawberry barm-foom" ] [ foom new barm new blibble ] unit-test + +[ "coconut barm-zang" ] [ zang new barm new blibble ] unit-test +[ "coconut barm-zim" ] [ barm new zim new blibble ] unit-test + +[ 1 2 blibble ] [ no-pair-method? ] must-fail-with diff --git a/extra/pair-methods/pair-methods.factor b/extra/pair-methods/pair-methods.factor new file mode 100644 index 0000000000..d44d5bce78 --- /dev/null +++ b/extra/pair-methods/pair-methods.factor @@ -0,0 +1,57 @@ +! (c)2009 Joe Groff bsd license +USING: arrays assocs classes classes.tuple.private combinators +effects.parser generic.parser kernel math math.order parser +quotations sequences sorting words ; +IN: pair-methods + +ERROR: no-pair-method a b generic ; + +: ?swap ( a b ? -- a/b b/a ) + [ swap ] when ; + +: method-sort-key ( pair -- key ) + first2 [ tuple-layout third ] bi@ + ; + +: pair-match-condition ( pair -- quot ) + first2 [ [ instance? ] swap prefix ] bi@ [ ] 2sequence + [ 2dup ] [ bi* and ] surround ; + +: pair-method-cond ( pair quot -- array ) + [ pair-match-condition ] [ ] bi* 2array ; + +: sorted-pair-methods ( word -- alist ) + "pair-generic-methods" word-prop >alist + [ [ first method-sort-key ] bi@ >=< ] sort ; + +: pair-generic-definition ( word -- def ) + [ sorted-pair-methods [ first2 pair-method-cond ] map ] + [ [ no-pair-method ] curry suffix ] bi 1quotation + [ 2dup [ class ] bi@ <=> +gt+ eq? ?swap ] [ cond ] surround ; + +: make-pair-generic ( word -- ) + dup pair-generic-definition define ; + +: define-pair-generic ( word effect -- ) + [ swap set-stack-effect ] + [ drop H{ } clone "pair-generic-methods" set-word-prop ] + [ drop make-pair-generic ] 2tri ; + +: (PAIR-GENERIC:) ( -- ) + CREATE-GENERIC complete-effect define-pair-generic ; + +SYNTAX: PAIR-GENERIC: (PAIR-GENERIC:) ; + +: define-pair-method ( a b pair-generic definition -- ) + [ 2array ] 2dip swap + [ "pair-generic-methods" word-prop [ swap ] dip set-at ] + [ make-pair-generic ] bi ; + +: ?prefix-swap ( quot ? -- quot' ) + [ \ swap prefix ] when ; + +: (PAIR-M:) ( -- ) + scan-word scan-word 2dup <=> +gt+ eq? [ + ?swap scan-word parse-definition + ] keep ?prefix-swap define-pair-method ; + +SYNTAX: PAIR-M: (PAIR-M:) ; diff --git a/extra/pair-methods/summary.txt b/extra/pair-methods/summary.txt new file mode 100644 index 0000000000..823bc712f6 --- /dev/null +++ b/extra/pair-methods/summary.txt @@ -0,0 +1 @@ +Order-insensitive double dispatch generics