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

db4
Slava Pestov 2009-04-26 21:25:08 -05:00
commit 67fd98f42d
9 changed files with 213 additions and 10 deletions

View File

@ -0,0 +1 @@
Joe Groff

View File

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

View File

@ -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:) ;

View File

@ -0,0 +1 @@
Order-insensitive double dispatch generics

View File

@ -0,0 +1 @@
Joe Groff

View File

@ -0,0 +1,61 @@
! (c)2009 Joe Groff bsd license
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 <product-sequence> } " word." }
{ $examples
{ $example <" USING: arrays prettyprint sequences.product ;
{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
"> <" {
{ 1 "a" }
{ 2 "a" }
{ 3 "a" }
{ 1 "b" }
{ 2 "b" }
{ 3 "b" }
{ 1 "c" }
{ 2 "c" }
{ 3 "c" }
}"> } } ;
HELP: <product-sequence>
{ $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" } } <product-sequence> >array .
"> <" {
{ 1 "a" }
{ 2 "a" }
{ 3 "a" }
{ 1 "b" }
{ 2 "b" }
{ 3 "b" }
{ 1 "c" }
{ 2 "c" }
{ 3 "c" }
}"> } } ;
{ product-sequence <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 "<product-sequence> [ ... ] 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 "<product-sequence> [ ... ] 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 <product-sequence> }
{ $subsection product-map }
{ $subsection product-each } ;
ABOUT: "sequences.product"

View File

@ -1,3 +1,4 @@
! (c)2009 Joe Groff bsd license
USING: arrays kernel make sequences sequences.product tools.test ;
IN: sequences.product.tests
@ -5,8 +6,10 @@ IN: sequences.product.tests
[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
[ { { 0 1 2 } { "a" "b" } } <product-sequence> >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 ) <repetition> concat ;
[ { "a" "aa" "aaa" "b" "bb" "bbb" } ]
[ { { 1 2 3 } { "a" "b" } } [ first2 x ] product-map ] unit-test
[
{

View File

@ -1,4 +1,5 @@
USING: accessors arrays kernel math sequences ;
! (c)2009 Joe Groff bsd license
USING: accessors arrays kernel locals math sequences ;
IN: sequences.product
TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
@ -10,19 +11,53 @@ INSTANCE: product-sequence sequence
M: product-sequence length lengths>> product ;
<PRIVATE
: ns ( n lengths -- ns )
[ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
: nths ( ns seqs -- nths )
[ nth ] { } 2map-as ;
: product@ ( n product-sequence -- ns seqs )
[ lengths>> 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 )
[ <product-sequence> ] dip map ; inline
: product-each ( sequences quot -- )
[ <product-sequence> ] dip each ; inline

View File

@ -0,0 +1 @@
Cartesian products of sequences