+++ /dev/null
-
-USING: accessors arrays combinators combinators.short-circuit
-fry kernel locals math math.intervals math.vectors multi-methods
-sequences ;
-FROM: multi-methods => GENERIC: ;
-IN: flatland
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Two dimensional world protocol
-
-GENERIC: x ( obj -- x )
-GENERIC: y ( obj -- y )
-
-GENERIC: (x!) ( x obj -- )
-GENERIC: (y!) ( y obj -- )
-
-: x! ( obj x -- obj ) over (x!) ;
-: y! ( obj y -- obj ) over (y!) ;
-
-GENERIC: width ( obj -- width )
-GENERIC: height ( obj -- height )
-
-GENERIC: (width!) ( width obj -- )
-GENERIC: (height!) ( height obj -- )
-
-: width! ( obj width -- obj ) over (width!) ;
-: height! ( obj height -- obj ) over (width!) ;
-
-! Predicates on relative placement
-
-GENERIC: to-the-left-of? ( obj obj -- ? )
-GENERIC: to-the-right-of? ( obj obj -- ? )
-
-GENERIC: below? ( obj obj -- ? )
-GENERIC: above? ( obj obj -- ? )
-
-GENERIC: in-between-horizontally? ( obj obj -- ? )
-
-GENERIC: horizontal-interval ( obj -- interval )
-
-GENERIC: move-to ( obj obj -- )
-
-GENERIC: move-by ( obj delta -- )
-
-GENERIC: move-left-by ( obj obj -- )
-GENERIC: move-right-by ( obj obj -- )
-
-GENERIC: left ( obj -- left )
-GENERIC: right ( obj -- right )
-GENERIC: bottom ( obj -- bottom )
-GENERIC: top ( obj -- top )
-
-GENERIC: distance ( a b -- c )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Some of the above methods work on two element sequences.
-! A two element sequence may represent a point in space or describe
-! width and height.
-
-METHOD: x { sequence } first ;
-METHOD: y { sequence } second ;
-
-METHOD: (x!) { number sequence } set-first ;
-METHOD: (y!) { number sequence } set-second ;
-
-METHOD: width { sequence } first ;
-METHOD: height { sequence } second ;
-
-: changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline
-: changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline
-
-METHOD: move-to { sequence sequence } [ x x! ] [ y y! ] bi drop ;
-METHOD: move-by { sequence sequence } dupd v+ [ x x! ] [ y y! ] bi drop ;
-
-METHOD: move-left-by { sequence number } '[ _ - ] changed-x ;
-METHOD: move-right-by { sequence number } '[ _ + ] changed-x ;
-
-! METHOD: move-left-by { sequence number } neg 0 2array move-by ;
-! METHOD: move-right-by { sequence number } 0 2array move-by ;
-
-! METHOD:: move-left-by { SEQ:sequence X:number -- )
-! SEQ { X 0 } { -1 0 } v* move-by ;
-
-METHOD: distance { sequence sequence } v- norm ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! A class for objects with a position
-
-TUPLE: <pos> pos ;
-
-METHOD: x { <pos> } pos>> first ;
-METHOD: y { <pos> } pos>> second ;
-
-METHOD: (x!) { number <pos> } pos>> set-first ;
-METHOD: (y!) { number <pos> } pos>> set-second ;
-
-METHOD: to-the-left-of? { <pos> number } [ x ] dip < ;
-METHOD: to-the-right-of? { <pos> number } [ x ] dip > ;
-
-METHOD: move-left-by { <pos> number } [ pos>> ] dip move-left-by ;
-METHOD: move-right-by { <pos> number } [ pos>> ] dip move-right-by ;
-
-METHOD: above? { <pos> number } [ y ] dip > ;
-METHOD: below? { <pos> number } [ y ] dip < ;
-
-METHOD: move-by { <pos> sequence } '[ _ v+ ] change-pos drop ;
-
-METHOD: distance { <pos> <pos> } [ pos>> ] bi@ distance ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! A class for objects with velocity. It inherits from <pos>. Hey, if
-! it's moving it has a position right? Unless it's some alternate universe...
-
-TUPLE: <vel> < <pos> vel ;
-
-: moving-up? ( obj -- ? ) vel>> y 0 > ;
-: moving-down? ( obj -- ? ) vel>> y 0 < ;
-
-: step-size ( vel time -- dist ) [ vel>> ] dip v*n ;
-: move-for ( vel time -- ) dupd step-size move-by ;
-
-: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! The 'pos' slot indicates the lower left hand corner of the
-! rectangle. The 'dim' is holds the width and height.
-
-TUPLE: <rectangle> < <pos> dim ;
-
-METHOD: width { <rectangle> } dim>> first ;
-METHOD: height { <rectangle> } dim>> second ;
-
-METHOD: left { <rectangle> } x ;
-METHOD: right { <rectangle> } [ x ] [ width ] bi + ;
-METHOD: bottom { <rectangle> } y ;
-METHOD: top { <rectangle> } [ y ] [ height ] bi + ;
-
-: bottom-left ( rectangle -- pos ) pos>> ;
-
-: center-x ( rectangle -- x ) [ left ] [ width 2 / ] bi + ;
-: center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ;
-
-: center ( rectangle -- seq ) [ center-x ] [ center-y ] bi 2array ;
-
-METHOD: to-the-left-of? { <pos> <rectangle> } [ x ] [ left ] bi* < ;
-METHOD: to-the-right-of? { <pos> <rectangle> } [ x ] [ right ] bi* > ;
-
-METHOD: below? { <pos> <rectangle> } [ y ] [ bottom ] bi* < ;
-METHOD: above? { <pos> <rectangle> } [ y ] [ top ] bi* > ;
-
-METHOD: horizontal-interval { <rectangle> }
- [ left ] [ right ] bi [a,b] ;
-
-METHOD: in-between-horizontally? { <pos> <rectangle> }
- [ x ] [ horizontal-interval ] bi* interval-contains? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <extent> left right bottom top ;
-
-METHOD: left { <extent> } left>> ;
-METHOD: right { <extent> } right>> ;
-METHOD: bottom { <extent> } bottom>> ;
-METHOD: top { <extent> } top>> ;
-
-METHOD: width { <extent> } [ right>> ] [ left>> ] bi - ;
-METHOD: height { <extent> } [ top>> ] [ bottom>> ] bi - ;
-
-! METHOD: to-extent ( <rectangle> -- <extent> )
-! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: to-the-left-of? { sequence <rectangle> } [ x ] [ left ] bi* < ;
-METHOD: to-the-right-of? { sequence <rectangle> } [ x ] [ right ] bi* > ;
-
-METHOD: below? { sequence <rectangle> } [ y ] [ bottom ] bi* < ;
-METHOD: above? { sequence <rectangle> } [ y ] [ top ] bi* > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Some support for the' 'rect' class from math.geometry.rect'
-
-! METHOD: width ( rect -- width ) dim>> first ;
-! METHOD: height ( rect -- height ) dim>> second ;
-
-! METHOD: left ( rect -- left ) loc>> x
-! METHOD: right ( rect -- right ) [ loc>> x ] [ width ] bi + ;
-
-! METHOD: to-the-left-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* < ;
-! METHOD: to-the-right-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: wrap ( POINT RECT -- POINT )
- {
- { [ POINT RECT to-the-left-of? ] [ RECT right ] }
- { [ POINT RECT to-the-right-of? ] [ RECT left ] }
- { [ t ] [ POINT x ] }
- }
- cond
-
- {
- { [ POINT RECT below? ] [ RECT top ] }
- { [ POINT RECT above? ] [ RECT bottom ] }
- { [ t ] [ POINT y ] }
- }
- cond
-
- 2array ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: within? ( a b -- ? )
-
-METHOD: within? { <pos> <rectangle> }
- {
- [ left to-the-right-of? ]
- [ right to-the-left-of? ]
- [ bottom above? ]
- [ top below? ]
- }
- 2&& ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences vectors classes classes.algebra
-combinators arrays words assocs parser namespaces make
-definitions prettyprint prettyprint.backend prettyprint.custom
-quotations generalizations sequences.generalizations debugger io
-compiler.units kernel.private effects accessors hashtables
-sorting shuffle math.order sets see effects.parser ;
-FROM: namespaces => set ;
-IN: multi-methods
-
-! PART I: Converting hook specializers
-: canonicalize-specializer-0 ( specializer -- specializer' )
- [ \ f or ] map ;
-
-SYMBOL: args
-
-SYMBOL: hooks
-
-SYMBOL: total
-
-: canonicalize-specializer-1 ( specializer -- specializer' )
- [
- [ class? ] filter
- [ length iota <reversed> [ 1 + neg ] map ] keep zip
- [ length args [ max ] change ] keep
- ]
- [
- [ pair? ] filter
- [ keys [ hooks get adjoin ] each ] keep
- ] bi append ;
-
-: canonicalize-specializer-2 ( specializer -- specializer' )
- [
- [
- {
- { [ dup integer? ] [ ] }
- { [ dup word? ] [ hooks get index ] }
- } cond args get +
- ] dip
- ] assoc-map ;
-
-: canonicalize-specializer-3 ( specializer -- specializer' )
- [ total get object <array> <enum> ] dip assoc-union! seq>> ;
-
-: canonicalize-specializers ( methods -- methods' hooks )
- [
- [ [ canonicalize-specializer-0 ] dip ] assoc-map
-
- 0 args set
- V{ } clone hooks set
-
- [ [ canonicalize-specializer-1 ] dip ] assoc-map
-
- hooks [ natural-sort ] change
-
- [ [ canonicalize-specializer-2 ] dip ] assoc-map
-
- args get hooks get length + total set
-
- [ [ canonicalize-specializer-3 ] dip ] assoc-map
-
- hooks get
- ] with-scope ;
-
-: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
-
-: prepare-method ( method n -- quot )
- [ 1quotation ] [ drop-n-quot ] bi* prepend ;
-
-: prepare-methods ( methods -- methods' prologue )
- canonicalize-specializers
- [ length [ prepare-method ] curry assoc-map ] keep
- [ [ get ] curry ] map concat [ ] like ;
-
-! Part II: Topologically sorting specializers
-: maximal-element ( seq quot -- n elt )
- dupd [
- swapd [ call +lt+ = ] 2curry any? not
- ] 2curry find [ "Topological sort failed" throw ] unless* ;
- inline
-
-: topological-sort ( seq quot -- newseq )
- [ >vector [ dup empty? not ] ] dip
- [ dupd maximal-element [ over remove-nth! drop ] dip ] curry
- produce nip ; inline
-
-: classes< ( seq1 seq2 -- lt/eq/gt )
- [
- {
- { [ 2dup eq? ] [ +eq+ ] }
- { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
- { [ 2dup class<= ] [ +lt+ ] }
- { [ 2dup swap class<= ] [ +gt+ ] }
- [ +eq+ ]
- } cond 2nip
- ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
-
-: sort-methods ( alist -- alist' )
- [ [ first ] bi@ classes< ] topological-sort ;
-
-! PART III: Creating dispatch quotation
-: picker ( n -- quot )
- {
- { 0 [ [ dup ] ] }
- { 1 [ [ over ] ] }
- { 2 [ [ pick ] ] }
- [ 1 - picker [ dip swap ] curry ]
- } case ;
-
-: (multi-predicate) ( class picker -- quot )
- swap predicate-def append ;
-
-: multi-predicate ( classes -- quot )
- dup length iota <reversed>
- [ picker 2array ] 2map
- [ drop object eq? ] assoc-reject
- [ [ t ] ] [
- [ (multi-predicate) ] { } assoc>map
- unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
- ] if-empty ;
-
-: argument-count ( methods -- n )
- keys 0 [ length max ] reduce ;
-
-ERROR: no-method arguments generic ;
-
-: make-default-method ( methods generic -- quot )
- [ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
-
-: multi-dispatch-quot ( methods generic -- quot )
- [ make-default-method ]
- [ drop [ [ multi-predicate ] dip ] assoc-map reverse! ]
- 2bi alist>quot ;
-
-! Generic words
-PREDICATE: generic < word
- "multi-methods" word-prop >boolean ;
-
-: methods ( word -- alist )
- "multi-methods" word-prop >alist ;
-
-: make-generic ( generic -- quot )
- [
- [ methods prepare-methods % sort-methods ] keep
- multi-dispatch-quot %
- ] [ ] make ;
-
-: update-generic ( word -- )
- dup make-generic define ;
-
-! Methods
-PREDICATE: method-body < word
- "multi-method-generic" word-prop >boolean ;
-
-M: method-body stack-effect
- "multi-method-generic" word-prop stack-effect ;
-
-M: method-body crossref?
- "forgotten" word-prop not ;
-
-: method-word-name ( specializer generic -- string )
- [ name>> % "-" % unparse % ] "" make ;
-
-: method-word-props ( specializer generic -- assoc )
- [
- "multi-method-generic" ,,
- "multi-method-specializer" ,,
- ] H{ } make ;
-
-: <method> ( specializer generic -- word )
- [ method-word-props ] 2keep
- method-word-name f <word>
- swap >>props ;
-
-: with-methods ( word quot -- )
- over [
- [ "multi-methods" word-prop ] dip call
- ] dip update-generic ; inline
-
-: reveal-method ( method classes generic -- )
- [ set-at ] with-methods ;
-
-: method ( classes word -- method )
- "multi-methods" word-prop at ;
-
-: create-method ( classes generic -- method )
- 2dup method dup [
- 2nip
- ] [
- drop [ <method> dup ] 2keep reveal-method
- ] if ;
-
-: niceify-method ( seq -- seq )
- [ dup \ f eq? [ drop f ] when ] map ;
-
-M: no-method error.
- "Type check error" print
- nl
- "Generic word " write dup generic>> pprint
- " does not have a method applicable to inputs:" print
- dup arguments>> short.
- nl
- "Inputs have signature:" print
- dup arguments>> [ class-of ] map niceify-method .
- nl
- "Available methods: " print
- generic>> methods canonicalize-specializers drop sort-methods
- keys [ niceify-method ] map stack. ;
-
-: forget-method ( specializer generic -- )
- [ delete-at ] with-methods ;
-
-: method>spec ( method -- spec )
- [ "multi-method-specializer" word-prop ]
- [ "multi-method-generic" word-prop ] bi prefix ;
-
-: define-generic ( word effect -- )
- over set-stack-effect
- dup "multi-methods" word-prop [ drop ] [
- [ H{ } clone "multi-methods" set-word-prop ]
- [ update-generic ]
- bi
- ] if ;
-
-! Syntax
-SYNTAX: GENERIC: scan-new-word scan-effect define-generic ;
-
-: parse-method ( -- quot classes generic )
- parse-definition [ 2 tail ] [ second ] [ first ] tri ;
-
-: create-method-in ( specializer generic -- method )
- create-method dup save-location f set-last-word ;
-
-: scan-new-method ( -- method )
- scan-word scan-object swap create-method-in ;
-
-: (METHOD:) ( -- method def ) scan-new-method parse-definition ;
-
-SYNTAX: METHOD: (METHOD:) define ;
-
-! For compatibility
-SYNTAX: M:
- scan-word 1array scan-word create-method-in
- parse-definition
- define ;
-
-! Definition protocol. We qualify core generics here
-QUALIFIED: syntax
-
-syntax:M: generic definer drop \ GENERIC: f ;
-
-syntax:M: generic definition drop f ;
-
-PREDICATE: method-spec < array
- unclip generic? [ [ class? ] all? ] dip and ;
-
-syntax:M: method-spec where
- dup unclip method [ ] [ first ] ?if where ;
-
-syntax:M: method-spec set-where
- unclip method set-where ;
-
-syntax:M: method-spec definer
- unclip method definer ;
-
-syntax:M: method-spec definition
- unclip method definition ;
-
-syntax:M: method-spec synopsis*
- unclip method synopsis* ;
-
-syntax:M: method-spec forget*
- unclip method forget* ;
-
-syntax:M: method-body definer
- drop \ METHOD: \ ; ;
-
-syntax:M: method-body synopsis*
- dup definer.
- [ "multi-method-generic" word-prop pprint-word ]
- [ "multi-method-specializer" word-prop pprint* ] bi ;
+++ /dev/null
-Experimental multiple dispatch implementation
+++ /dev/null
-extensions
+++ /dev/null
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings ;
-IN: multi-methods.tests
-
-[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
-
-: setup-canon-test ( -- )
- 0 args set
- V{ } clone hooks set ;
-
-: canon-test-1 ( -- seq )
- { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
-
-[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
- [
- setup-canon-test
- canon-test-1
- ] with-scope
-] unit-test
-
-[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
- [
- setup-canon-test
- canon-test-1
- canonicalize-specializer-2
- ] with-scope
-] unit-test
-
-[ { integer sequence x86 } ] [
- [
- setup-canon-test
- canon-test-1
- canonicalize-specializer-2
- args get hooks get length + total set
- canonicalize-specializer-3
- ] with-scope
-] unit-test
-
-CONSTANT: example-1
- {
- { { { cpu x86 } { os linux } } "a" }
- { { { cpu ppc } } "b" }
- { { string { os windows } } "c" }
- }
-
-[
- {
- { { object x86 linux } "a" }
- { { object ppc object } "b" }
- { { string object windows } "c" }
- }
- { cpu os }
-] [
- example-1 canonicalize-specializers
-] unit-test
-
-[
- {
- { { object x86 linux } [ drop drop "a" ] }
- { { object ppc object } [ drop drop "b" ] }
- { { string object windows } [ drop drop "c" ] }
- }
- [ \ cpu get \ os get ]
-] [
- example-1 prepare-methods
-] unit-test
+++ /dev/null
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings words compiler.units quotations ;
-IN: multi-methods.tests
-
-DEFER: fake
-\ fake H{ } clone "multi-methods" set-word-prop
-<< ( -- ) \ fake set-stack-effect >>
-
-[
- [ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
-
- [ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
- [ { } \ fake method-word-props ] unit-test
-
- [ t ] [ { } \ fake <method> method-body? ] unit-test
-
- [ { } [ ] ] [ \ fake methods prepare-methods [ sort-methods ] dip ] unit-test
-
- [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
-
- [ t ] [ \ fake make-generic quotation? ] unit-test
-
- [ ] [ \ fake update-generic ] unit-test
-
- DEFER: testing
-
- [ ] [ \ testing ( -- ) define-generic ] unit-test
-
- [ t ] [ \ testing generic? ] unit-test
-] with-compilation-unit
+++ /dev/null
-USING: math strings sequences tools.test ;
-IN: multi-methods.tests
-
-GENERIC: legacy-test ( a -- b )
-
-M: integer legacy-test sq ;
-M: string legacy-test " hey" append ;
-
-[ 25 ] [ 5 legacy-test ] unit-test
-[ "hello hey" ] [ "hello" legacy-test ] unit-test
+++ /dev/null
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings definitions prettyprint debugger arrays
-hashtables continuations classes assocs accessors see ;
-RENAME: GENERIC: multi-methods => multi-methods:GENERIC:
-IN: multi-methods.tests
-
-multi-methods:GENERIC: first-test ( -- )
-
-[ t ] [ \ first-test generic? ] unit-test
-
-MIXIN: thing
-
-SINGLETON: paper INSTANCE: paper thing
-SINGLETON: scissors INSTANCE: scissors thing
-SINGLETON: rock INSTANCE: rock thing
-
-multi-methods:GENERIC: beats? ( obj1 obj2 -- ? )
-
-METHOD: beats? { paper scissors } 2drop t ;
-METHOD: beats? { scissors rock } 2drop t ;
-METHOD: beats? { rock paper } 2drop t ;
-METHOD: beats? { thing thing } 2drop f ;
-
-: play ( obj1 obj2 -- ? ) beats? ;
-
-[ { } 3 play ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ ] [ error get error. ] unit-test
-[ { { } 3 } ] [ error get arguments>> ] unit-test
-[ t ] [ paper scissors play ] unit-test
-[ f ] [ scissors paper play ] unit-test
-
-[ t ] [ { beats? paper scissors } method-spec? ] unit-test
-[ ] [ { beats? paper scissors } see ] unit-test
-
-SYMBOL: some-var
-
-multi-methods:GENERIC: hook-test ( obj -- obj )
-
-METHOD: hook-test { array { some-var array } } reverse ;
-METHOD: hook-test { { some-var array } } class-of ;
-METHOD: hook-test { hashtable { some-var number } } assoc-size ;
-
-{ 1 2 3 } some-var set
-[ { f t t } ] [ { t t f } hook-test ] unit-test
-[ fixnum ] [ 3 hook-test ] unit-test
-5.0 some-var set
-[ 0 ] [ H{ } hook-test ] unit-test
-
-"error" some-var set
-[ H{ } hook-test ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ { H{ } "error" } ] [ error get arguments>> ] unit-test
-
-MIXIN: busted
-
-TUPLE: busted-1 ;
-TUPLE: busted-2 ; INSTANCE: busted-2 busted
-TUPLE: busted-3 ;
-
-multi-methods:GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
-
-METHOD: busted-sort { busted-1 busted-2 } ;
-METHOD: busted-sort { busted-2 busted-3 } ;
-METHOD: busted-sort { busted busted } ;
+++ /dev/null
-USING: kernel multi-methods tools.test math arrays sequences
-math.order ;
-IN: multi-methods.tests
-
-[ { 1 2 3 4 5 6 } ] [
- { 6 4 5 1 3 2 } [ <=> ] topological-sort
-] unit-test
-
-[ +lt+ ] [
- { fixnum array } { number sequence } classes<
-] unit-test
-
-[ +eq+ ] [
- { number sequence } { number sequence } classes<
-] unit-test
-
-[ +gt+ ] [
- { object object } { number sequence } classes<
-] unit-test
+++ /dev/null
-USING: accessors alien.c-types alien.data arrays calendar colors
-combinators combinators.short-circuit flatland generalizations
-grouping kernel locals math math.intervals math.order
-math.rectangles math.vectors namespaces opengl opengl.gl
-opengl.glu processing.shapes sequences sequences.generalizations
-shuffle threads ui ui.gadgets ui.gestures ui.render ;
-FROM: multi-methods => GENERIC: METHOD: ;
-FROM: syntax => M: ;
-IN: pong
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
-!
-! Which was based on this Nodebox version: http://billmill.org/pong.html
-! by Bill Mill.
-!
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: clamp-to-interval ( x interval -- x )
- [ from>> first max ] [ to>> first min ] bi ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <play-field> < <rectangle> ;
-TUPLE: <paddle> < <rectangle> ;
-
-TUPLE: <computer> < <paddle> { speed initial: 10 } ;
-
-: computer-move-left ( computer -- ) dup speed>> move-left-by ;
-: computer-move-right ( computer -- ) dup speed>> move-right-by ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <ball> < <vel>
- { diameter initial: 20 }
- { bounciness initial: 1.2 }
- { max-speed initial: 10 } ;
-
-: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
-: below-upper-bound? ( ball field -- ? ) top 50 + below? ;
-
-: in-bounds? ( ball field -- ? )
- {
- [ above-lower-bound? ]
- [ below-upper-bound? ]
- } 2&& ;
-
-:: bounce-change-vertical-velocity ( BALL -- )
-
- BALL vel>> y neg
- BALL bounciness>> *
-
- BALL max-speed>> min
-
- BALL vel>> (y!) ;
-
-:: bounce-off-paddle ( BALL PADDLE -- )
-
- BALL bounce-change-vertical-velocity
-
- BALL x PADDLE center x - 0.25 * BALL vel>> (x!)
-
- PADDLE top BALL pos>> (y!) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mouse-x ( -- x ) hand-loc get first ;
-
-:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
-
- PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
-
-:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
-
- mouse-x
-
- PADDLE PLAY-FIELD valid-paddle-interval
-
- clamp-to-interval
-
- PADDLE pos>> (x!) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Protocol for drawing PONG objects
-
-GENERIC: draw ( obj -- )
-
-METHOD: draw { <paddle> } [ bottom-left ] [ dim>> ] bi rectangle ;
-METHOD: draw { <ball> } [ pos>> ] [ diameter>> 2 / ] bi circle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <pong> < gadget paused field ball player computer ;
-
-: pong ( -- gadget )
- <pong> new
- T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } clone >>field
- T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
- T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } clone >>player
- T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ;
-
-M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
-M: <pong> ungraft* ( <pong> -- ) t >>paused drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <pong> draw-gadget* ( PONG -- )
-
- PONG computer>> draw
- PONG player>> draw
- PONG ball>> draw ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-system ( GADGET -- )
-
- GADGET field>> :> FIELD
- GADGET ball>> :> BALL
- GADGET player>> :> PLAYER
- GADGET computer>> :> COMPUTER
-
- BALL FIELD in-bounds? [
-
- PLAYER FIELD align-paddle-with-mouse
-
- BALL 1 move-for
-
- ! computer reaction
-
- BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
- BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
-
- ! check if ball bounced off something
-
- ! player-blocked-ball?
- BALL PLAYER { [ above? ] [ in-between-horizontally? ] } 2&&
- [ BALL PLAYER bounce-off-paddle ] when
-
- ! computer-blocked-ball?
- BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } 2&&
- [ BALL COMPUTER bounce-off-paddle ] when
-
- ! bounced-off-wall?
- BALL FIELD in-between-horizontally? not
- [ BALL reverse-horizontal-velocity ] when
-
- ] [ t GADGET paused<< ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-pong-thread ( GADGET -- )
- f GADGET paused<<
- [
- [
- GADGET paused>>
- [ f ]
- [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
- if
- ]
- loop
- ]
- in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ;
-
-: pong-main ( -- ) [ pong-window ] with-ui ;
-
-MAIN: pong-window
--- /dev/null
+
+USING: accessors arrays combinators combinators.short-circuit
+fry kernel locals math math.intervals math.vectors multi-methods
+sequences ;
+FROM: multi-methods => GENERIC: ;
+IN: flatland
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Two dimensional world protocol
+
+GENERIC: x ( obj -- x )
+GENERIC: y ( obj -- y )
+
+GENERIC: (x!) ( x obj -- )
+GENERIC: (y!) ( y obj -- )
+
+: x! ( obj x -- obj ) over (x!) ;
+: y! ( obj y -- obj ) over (y!) ;
+
+GENERIC: width ( obj -- width )
+GENERIC: height ( obj -- height )
+
+GENERIC: (width!) ( width obj -- )
+GENERIC: (height!) ( height obj -- )
+
+: width! ( obj width -- obj ) over (width!) ;
+: height! ( obj height -- obj ) over (width!) ;
+
+! Predicates on relative placement
+
+GENERIC: to-the-left-of? ( obj obj -- ? )
+GENERIC: to-the-right-of? ( obj obj -- ? )
+
+GENERIC: below? ( obj obj -- ? )
+GENERIC: above? ( obj obj -- ? )
+
+GENERIC: in-between-horizontally? ( obj obj -- ? )
+
+GENERIC: horizontal-interval ( obj -- interval )
+
+GENERIC: move-to ( obj obj -- )
+
+GENERIC: move-by ( obj delta -- )
+
+GENERIC: move-left-by ( obj obj -- )
+GENERIC: move-right-by ( obj obj -- )
+
+GENERIC: left ( obj -- left )
+GENERIC: right ( obj -- right )
+GENERIC: bottom ( obj -- bottom )
+GENERIC: top ( obj -- top )
+
+GENERIC: distance ( a b -- c )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Some of the above methods work on two element sequences.
+! A two element sequence may represent a point in space or describe
+! width and height.
+
+METHOD: x { sequence } first ;
+METHOD: y { sequence } second ;
+
+METHOD: (x!) { number sequence } set-first ;
+METHOD: (y!) { number sequence } set-second ;
+
+METHOD: width { sequence } first ;
+METHOD: height { sequence } second ;
+
+: changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline
+: changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline
+
+METHOD: move-to { sequence sequence } [ x x! ] [ y y! ] bi drop ;
+METHOD: move-by { sequence sequence } dupd v+ [ x x! ] [ y y! ] bi drop ;
+
+METHOD: move-left-by { sequence number } '[ _ - ] changed-x ;
+METHOD: move-right-by { sequence number } '[ _ + ] changed-x ;
+
+! METHOD: move-left-by { sequence number } neg 0 2array move-by ;
+! METHOD: move-right-by { sequence number } 0 2array move-by ;
+
+! METHOD:: move-left-by { SEQ:sequence X:number -- )
+! SEQ { X 0 } { -1 0 } v* move-by ;
+
+METHOD: distance { sequence sequence } v- norm ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! A class for objects with a position
+
+TUPLE: <pos> pos ;
+
+METHOD: x { <pos> } pos>> first ;
+METHOD: y { <pos> } pos>> second ;
+
+METHOD: (x!) { number <pos> } pos>> set-first ;
+METHOD: (y!) { number <pos> } pos>> set-second ;
+
+METHOD: to-the-left-of? { <pos> number } [ x ] dip < ;
+METHOD: to-the-right-of? { <pos> number } [ x ] dip > ;
+
+METHOD: move-left-by { <pos> number } [ pos>> ] dip move-left-by ;
+METHOD: move-right-by { <pos> number } [ pos>> ] dip move-right-by ;
+
+METHOD: above? { <pos> number } [ y ] dip > ;
+METHOD: below? { <pos> number } [ y ] dip < ;
+
+METHOD: move-by { <pos> sequence } '[ _ v+ ] change-pos drop ;
+
+METHOD: distance { <pos> <pos> } [ pos>> ] bi@ distance ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! A class for objects with velocity. It inherits from <pos>. Hey, if
+! it's moving it has a position right? Unless it's some alternate universe...
+
+TUPLE: <vel> < <pos> vel ;
+
+: moving-up? ( obj -- ? ) vel>> y 0 > ;
+: moving-down? ( obj -- ? ) vel>> y 0 < ;
+
+: step-size ( vel time -- dist ) [ vel>> ] dip v*n ;
+: move-for ( vel time -- ) dupd step-size move-by ;
+
+: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! The 'pos' slot indicates the lower left hand corner of the
+! rectangle. The 'dim' is holds the width and height.
+
+TUPLE: <rectangle> < <pos> dim ;
+
+METHOD: width { <rectangle> } dim>> first ;
+METHOD: height { <rectangle> } dim>> second ;
+
+METHOD: left { <rectangle> } x ;
+METHOD: right { <rectangle> } [ x ] [ width ] bi + ;
+METHOD: bottom { <rectangle> } y ;
+METHOD: top { <rectangle> } [ y ] [ height ] bi + ;
+
+: bottom-left ( rectangle -- pos ) pos>> ;
+
+: center-x ( rectangle -- x ) [ left ] [ width 2 / ] bi + ;
+: center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ;
+
+: center ( rectangle -- seq ) [ center-x ] [ center-y ] bi 2array ;
+
+METHOD: to-the-left-of? { <pos> <rectangle> } [ x ] [ left ] bi* < ;
+METHOD: to-the-right-of? { <pos> <rectangle> } [ x ] [ right ] bi* > ;
+
+METHOD: below? { <pos> <rectangle> } [ y ] [ bottom ] bi* < ;
+METHOD: above? { <pos> <rectangle> } [ y ] [ top ] bi* > ;
+
+METHOD: horizontal-interval { <rectangle> }
+ [ left ] [ right ] bi [a,b] ;
+
+METHOD: in-between-horizontally? { <pos> <rectangle> }
+ [ x ] [ horizontal-interval ] bi* interval-contains? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <extent> left right bottom top ;
+
+METHOD: left { <extent> } left>> ;
+METHOD: right { <extent> } right>> ;
+METHOD: bottom { <extent> } bottom>> ;
+METHOD: top { <extent> } top>> ;
+
+METHOD: width { <extent> } [ right>> ] [ left>> ] bi - ;
+METHOD: height { <extent> } [ top>> ] [ bottom>> ] bi - ;
+
+! METHOD: to-extent ( <rectangle> -- <extent> )
+! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: to-the-left-of? { sequence <rectangle> } [ x ] [ left ] bi* < ;
+METHOD: to-the-right-of? { sequence <rectangle> } [ x ] [ right ] bi* > ;
+
+METHOD: below? { sequence <rectangle> } [ y ] [ bottom ] bi* < ;
+METHOD: above? { sequence <rectangle> } [ y ] [ top ] bi* > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Some support for the' 'rect' class from math.geometry.rect'
+
+! METHOD: width ( rect -- width ) dim>> first ;
+! METHOD: height ( rect -- height ) dim>> second ;
+
+! METHOD: left ( rect -- left ) loc>> x
+! METHOD: right ( rect -- right ) [ loc>> x ] [ width ] bi + ;
+
+! METHOD: to-the-left-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* < ;
+! METHOD: to-the-right-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: wrap ( POINT RECT -- POINT )
+ {
+ { [ POINT RECT to-the-left-of? ] [ RECT right ] }
+ { [ POINT RECT to-the-right-of? ] [ RECT left ] }
+ { [ t ] [ POINT x ] }
+ }
+ cond
+
+ {
+ { [ POINT RECT below? ] [ RECT top ] }
+ { [ POINT RECT above? ] [ RECT bottom ] }
+ { [ t ] [ POINT y ] }
+ }
+ cond
+
+ 2array ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: within? ( a b -- ? )
+
+METHOD: within? { <pos> <rectangle> }
+ {
+ [ left to-the-right-of? ]
+ [ right to-the-left-of? ]
+ [ bottom above? ]
+ [ top below? ]
+ }
+ 2&& ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences vectors classes classes.algebra
+combinators arrays words assocs parser namespaces make
+definitions prettyprint prettyprint.backend prettyprint.custom
+quotations generalizations sequences.generalizations debugger io
+compiler.units kernel.private effects accessors hashtables
+sorting shuffle math.order sets see effects.parser ;
+FROM: namespaces => set ;
+IN: multi-methods
+
+! PART I: Converting hook specializers
+: canonicalize-specializer-0 ( specializer -- specializer' )
+ [ \ f or ] map ;
+
+SYMBOL: args
+
+SYMBOL: hooks
+
+SYMBOL: total
+
+: canonicalize-specializer-1 ( specializer -- specializer' )
+ [
+ [ class? ] filter
+ [ length iota <reversed> [ 1 + neg ] map ] keep zip
+ [ length args [ max ] change ] keep
+ ]
+ [
+ [ pair? ] filter
+ [ keys [ hooks get adjoin ] each ] keep
+ ] bi append ;
+
+: canonicalize-specializer-2 ( specializer -- specializer' )
+ [
+ [
+ {
+ { [ dup integer? ] [ ] }
+ { [ dup word? ] [ hooks get index ] }
+ } cond args get +
+ ] dip
+ ] assoc-map ;
+
+: canonicalize-specializer-3 ( specializer -- specializer' )
+ [ total get object <array> <enum> ] dip assoc-union! seq>> ;
+
+: canonicalize-specializers ( methods -- methods' hooks )
+ [
+ [ [ canonicalize-specializer-0 ] dip ] assoc-map
+
+ 0 args set
+ V{ } clone hooks set
+
+ [ [ canonicalize-specializer-1 ] dip ] assoc-map
+
+ hooks [ natural-sort ] change
+
+ [ [ canonicalize-specializer-2 ] dip ] assoc-map
+
+ args get hooks get length + total set
+
+ [ [ canonicalize-specializer-3 ] dip ] assoc-map
+
+ hooks get
+ ] with-scope ;
+
+: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
+
+: prepare-method ( method n -- quot )
+ [ 1quotation ] [ drop-n-quot ] bi* prepend ;
+
+: prepare-methods ( methods -- methods' prologue )
+ canonicalize-specializers
+ [ length [ prepare-method ] curry assoc-map ] keep
+ [ [ get ] curry ] map concat [ ] like ;
+
+! Part II: Topologically sorting specializers
+: maximal-element ( seq quot -- n elt )
+ dupd [
+ swapd [ call +lt+ = ] 2curry any? not
+ ] 2curry find [ "Topological sort failed" throw ] unless* ;
+ inline
+
+: topological-sort ( seq quot -- newseq )
+ [ >vector [ dup empty? not ] ] dip
+ [ dupd maximal-element [ over remove-nth! drop ] dip ] curry
+ produce nip ; inline
+
+: classes< ( seq1 seq2 -- lt/eq/gt )
+ [
+ {
+ { [ 2dup eq? ] [ +eq+ ] }
+ { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
+ { [ 2dup class<= ] [ +lt+ ] }
+ { [ 2dup swap class<= ] [ +gt+ ] }
+ [ +eq+ ]
+ } cond 2nip
+ ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
+
+: sort-methods ( alist -- alist' )
+ [ [ first ] bi@ classes< ] topological-sort ;
+
+! PART III: Creating dispatch quotation
+: picker ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1 - picker [ dip swap ] curry ]
+ } case ;
+
+: (multi-predicate) ( class picker -- quot )
+ swap predicate-def append ;
+
+: multi-predicate ( classes -- quot )
+ dup length iota <reversed>
+ [ picker 2array ] 2map
+ [ drop object eq? ] assoc-reject
+ [ [ t ] ] [
+ [ (multi-predicate) ] { } assoc>map
+ unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+ ] if-empty ;
+
+: argument-count ( methods -- n )
+ keys 0 [ length max ] reduce ;
+
+ERROR: no-method arguments generic ;
+
+: make-default-method ( methods generic -- quot )
+ [ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
+
+: multi-dispatch-quot ( methods generic -- quot )
+ [ make-default-method ]
+ [ drop [ [ multi-predicate ] dip ] assoc-map reverse! ]
+ 2bi alist>quot ;
+
+! Generic words
+PREDICATE: generic < word
+ "multi-methods" word-prop >boolean ;
+
+: methods ( word -- alist )
+ "multi-methods" word-prop >alist ;
+
+: make-generic ( generic -- quot )
+ [
+ [ methods prepare-methods % sort-methods ] keep
+ multi-dispatch-quot %
+ ] [ ] make ;
+
+: update-generic ( word -- )
+ dup make-generic define ;
+
+! Methods
+PREDICATE: method-body < word
+ "multi-method-generic" word-prop >boolean ;
+
+M: method-body stack-effect
+ "multi-method-generic" word-prop stack-effect ;
+
+M: method-body crossref?
+ "forgotten" word-prop not ;
+
+: method-word-name ( specializer generic -- string )
+ [ name>> % "-" % unparse % ] "" make ;
+
+: method-word-props ( specializer generic -- assoc )
+ [
+ "multi-method-generic" ,,
+ "multi-method-specializer" ,,
+ ] H{ } make ;
+
+: <method> ( specializer generic -- word )
+ [ method-word-props ] 2keep
+ method-word-name f <word>
+ swap >>props ;
+
+: with-methods ( word quot -- )
+ over [
+ [ "multi-methods" word-prop ] dip call
+ ] dip update-generic ; inline
+
+: reveal-method ( method classes generic -- )
+ [ set-at ] with-methods ;
+
+: method ( classes word -- method )
+ "multi-methods" word-prop at ;
+
+: create-method ( classes generic -- method )
+ 2dup method dup [
+ 2nip
+ ] [
+ drop [ <method> dup ] 2keep reveal-method
+ ] if ;
+
+: niceify-method ( seq -- seq )
+ [ dup \ f eq? [ drop f ] when ] map ;
+
+M: no-method error.
+ "Type check error" print
+ nl
+ "Generic word " write dup generic>> pprint
+ " does not have a method applicable to inputs:" print
+ dup arguments>> short.
+ nl
+ "Inputs have signature:" print
+ dup arguments>> [ class-of ] map niceify-method .
+ nl
+ "Available methods: " print
+ generic>> methods canonicalize-specializers drop sort-methods
+ keys [ niceify-method ] map stack. ;
+
+: forget-method ( specializer generic -- )
+ [ delete-at ] with-methods ;
+
+: method>spec ( method -- spec )
+ [ "multi-method-specializer" word-prop ]
+ [ "multi-method-generic" word-prop ] bi prefix ;
+
+: define-generic ( word effect -- )
+ over set-stack-effect
+ dup "multi-methods" word-prop [ drop ] [
+ [ H{ } clone "multi-methods" set-word-prop ]
+ [ update-generic ]
+ bi
+ ] if ;
+
+! Syntax
+SYNTAX: GENERIC: scan-new-word scan-effect define-generic ;
+
+: parse-method ( -- quot classes generic )
+ parse-definition [ 2 tail ] [ second ] [ first ] tri ;
+
+: create-method-in ( specializer generic -- method )
+ create-method dup save-location f set-last-word ;
+
+: scan-new-method ( -- method )
+ scan-word scan-object swap create-method-in ;
+
+: (METHOD:) ( -- method def ) scan-new-method parse-definition ;
+
+SYNTAX: METHOD: (METHOD:) define ;
+
+! For compatibility
+SYNTAX: M:
+ scan-word 1array scan-word create-method-in
+ parse-definition
+ define ;
+
+! Definition protocol. We qualify core generics here
+QUALIFIED: syntax
+
+syntax:M: generic definer drop \ GENERIC: f ;
+
+syntax:M: generic definition drop f ;
+
+PREDICATE: method-spec < array
+ unclip generic? [ [ class? ] all? ] dip and ;
+
+syntax:M: method-spec where
+ dup unclip method [ ] [ first ] ?if where ;
+
+syntax:M: method-spec set-where
+ unclip method set-where ;
+
+syntax:M: method-spec definer
+ unclip method definer ;
+
+syntax:M: method-spec definition
+ unclip method definition ;
+
+syntax:M: method-spec synopsis*
+ unclip method synopsis* ;
+
+syntax:M: method-spec forget*
+ unclip method forget* ;
+
+syntax:M: method-body definer
+ drop \ METHOD: \ ; ;
+
+syntax:M: method-body synopsis*
+ dup definer.
+ [ "multi-method-generic" word-prop pprint-word ]
+ [ "multi-method-specializer" word-prop pprint* ] bi ;
--- /dev/null
+Experimental multiple dispatch implementation
--- /dev/null
+extensions
--- /dev/null
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings ;
+IN: multi-methods.tests
+
+[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
+
+: setup-canon-test ( -- )
+ 0 args set
+ V{ } clone hooks set ;
+
+: canon-test-1 ( -- seq )
+ { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
+
+[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ ] with-scope
+] unit-test
+
+[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ ] with-scope
+] unit-test
+
+[ { integer sequence x86 } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ args get hooks get length + total set
+ canonicalize-specializer-3
+ ] with-scope
+] unit-test
+
+CONSTANT: example-1
+ {
+ { { { cpu x86 } { os linux } } "a" }
+ { { { cpu ppc } } "b" }
+ { { string { os windows } } "c" }
+ }
+
+[
+ {
+ { { object x86 linux } "a" }
+ { { object ppc object } "b" }
+ { { string object windows } "c" }
+ }
+ { cpu os }
+] [
+ example-1 canonicalize-specializers
+] unit-test
+
+[
+ {
+ { { object x86 linux } [ drop drop "a" ] }
+ { { object ppc object } [ drop drop "b" ] }
+ { { string object windows } [ drop drop "c" ] }
+ }
+ [ \ cpu get \ os get ]
+] [
+ example-1 prepare-methods
+] unit-test
--- /dev/null
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings words compiler.units quotations ;
+IN: multi-methods.tests
+
+DEFER: fake
+\ fake H{ } clone "multi-methods" set-word-prop
+<< ( -- ) \ fake set-stack-effect >>
+
+[
+ [ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
+
+ [ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
+ [ { } \ fake method-word-props ] unit-test
+
+ [ t ] [ { } \ fake <method> method-body? ] unit-test
+
+ [ { } [ ] ] [ \ fake methods prepare-methods [ sort-methods ] dip ] unit-test
+
+ [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
+
+ [ t ] [ \ fake make-generic quotation? ] unit-test
+
+ [ ] [ \ fake update-generic ] unit-test
+
+ DEFER: testing
+
+ [ ] [ \ testing ( -- ) define-generic ] unit-test
+
+ [ t ] [ \ testing generic? ] unit-test
+] with-compilation-unit
--- /dev/null
+USING: math strings sequences tools.test ;
+IN: multi-methods.tests
+
+GENERIC: legacy-test ( a -- b )
+
+M: integer legacy-test sq ;
+M: string legacy-test " hey" append ;
+
+[ 25 ] [ 5 legacy-test ] unit-test
+[ "hello hey" ] [ "hello" legacy-test ] unit-test
--- /dev/null
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings definitions prettyprint debugger arrays
+hashtables continuations classes assocs accessors see ;
+RENAME: GENERIC: multi-methods => multi-methods:GENERIC:
+IN: multi-methods.tests
+
+multi-methods:GENERIC: first-test ( -- )
+
+[ t ] [ \ first-test generic? ] unit-test
+
+MIXIN: thing
+
+SINGLETON: paper INSTANCE: paper thing
+SINGLETON: scissors INSTANCE: scissors thing
+SINGLETON: rock INSTANCE: rock thing
+
+multi-methods:GENERIC: beats? ( obj1 obj2 -- ? )
+
+METHOD: beats? { paper scissors } 2drop t ;
+METHOD: beats? { scissors rock } 2drop t ;
+METHOD: beats? { rock paper } 2drop t ;
+METHOD: beats? { thing thing } 2drop f ;
+
+: play ( obj1 obj2 -- ? ) beats? ;
+
+[ { } 3 play ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ ] [ error get error. ] unit-test
+[ { { } 3 } ] [ error get arguments>> ] unit-test
+[ t ] [ paper scissors play ] unit-test
+[ f ] [ scissors paper play ] unit-test
+
+[ t ] [ { beats? paper scissors } method-spec? ] unit-test
+[ ] [ { beats? paper scissors } see ] unit-test
+
+SYMBOL: some-var
+
+multi-methods:GENERIC: hook-test ( obj -- obj )
+
+METHOD: hook-test { array { some-var array } } reverse ;
+METHOD: hook-test { { some-var array } } class-of ;
+METHOD: hook-test { hashtable { some-var number } } assoc-size ;
+
+{ 1 2 3 } some-var set
+[ { f t t } ] [ { t t f } hook-test ] unit-test
+[ fixnum ] [ 3 hook-test ] unit-test
+5.0 some-var set
+[ 0 ] [ H{ } hook-test ] unit-test
+
+"error" some-var set
+[ H{ } hook-test ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ { H{ } "error" } ] [ error get arguments>> ] unit-test
+
+MIXIN: busted
+
+TUPLE: busted-1 ;
+TUPLE: busted-2 ; INSTANCE: busted-2 busted
+TUPLE: busted-3 ;
+
+multi-methods:GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
+
+METHOD: busted-sort { busted-1 busted-2 } ;
+METHOD: busted-sort { busted-2 busted-3 } ;
+METHOD: busted-sort { busted busted } ;
--- /dev/null
+USING: kernel multi-methods tools.test math arrays sequences
+math.order ;
+IN: multi-methods.tests
+
+[ { 1 2 3 4 5 6 } ] [
+ { 6 4 5 1 3 2 } [ <=> ] topological-sort
+] unit-test
+
+[ +lt+ ] [
+ { fixnum array } { number sequence } classes<
+] unit-test
+
+[ +eq+ ] [
+ { number sequence } { number sequence } classes<
+] unit-test
+
+[ +gt+ ] [
+ { object object } { number sequence } classes<
+] unit-test
--- /dev/null
+USING: accessors alien.c-types alien.data arrays calendar colors
+combinators combinators.short-circuit flatland generalizations
+grouping kernel locals math math.intervals math.order
+math.rectangles math.vectors namespaces opengl opengl.gl
+opengl.glu processing.shapes sequences sequences.generalizations
+shuffle threads ui ui.gadgets ui.gestures ui.render ;
+FROM: multi-methods => GENERIC: METHOD: ;
+FROM: syntax => M: ;
+IN: pong
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
+!
+! Which was based on this Nodebox version: http://billmill.org/pong.html
+! by Bill Mill.
+!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: clamp-to-interval ( x interval -- x )
+ [ from>> first max ] [ to>> first min ] bi ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <play-field> < <rectangle> ;
+TUPLE: <paddle> < <rectangle> ;
+
+TUPLE: <computer> < <paddle> { speed initial: 10 } ;
+
+: computer-move-left ( computer -- ) dup speed>> move-left-by ;
+: computer-move-right ( computer -- ) dup speed>> move-right-by ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <ball> < <vel>
+ { diameter initial: 20 }
+ { bounciness initial: 1.2 }
+ { max-speed initial: 10 } ;
+
+: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
+: below-upper-bound? ( ball field -- ? ) top 50 + below? ;
+
+: in-bounds? ( ball field -- ? )
+ {
+ [ above-lower-bound? ]
+ [ below-upper-bound? ]
+ } 2&& ;
+
+:: bounce-change-vertical-velocity ( BALL -- )
+
+ BALL vel>> y neg
+ BALL bounciness>> *
+
+ BALL max-speed>> min
+
+ BALL vel>> (y!) ;
+
+:: bounce-off-paddle ( BALL PADDLE -- )
+
+ BALL bounce-change-vertical-velocity
+
+ BALL x PADDLE center x - 0.25 * BALL vel>> (x!)
+
+ PADDLE top BALL pos>> (y!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mouse-x ( -- x ) hand-loc get first ;
+
+:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
+
+ PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
+
+:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
+
+ mouse-x
+
+ PADDLE PLAY-FIELD valid-paddle-interval
+
+ clamp-to-interval
+
+ PADDLE pos>> (x!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Protocol for drawing PONG objects
+
+GENERIC: draw ( obj -- )
+
+METHOD: draw { <paddle> } [ bottom-left ] [ dim>> ] bi rectangle ;
+METHOD: draw { <ball> } [ pos>> ] [ diameter>> 2 / ] bi circle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <pong> < gadget paused field ball player computer ;
+
+: pong ( -- gadget )
+ <pong> new
+ T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } clone >>field
+ T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
+ T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } clone >>player
+ T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ;
+
+M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
+M: <pong> ungraft* ( <pong> -- ) t >>paused drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <pong> draw-gadget* ( PONG -- )
+
+ PONG computer>> draw
+ PONG player>> draw
+ PONG ball>> draw ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-system ( GADGET -- )
+
+ GADGET field>> :> FIELD
+ GADGET ball>> :> BALL
+ GADGET player>> :> PLAYER
+ GADGET computer>> :> COMPUTER
+
+ BALL FIELD in-bounds? [
+
+ PLAYER FIELD align-paddle-with-mouse
+
+ BALL 1 move-for
+
+ ! computer reaction
+
+ BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
+ BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
+
+ ! check if ball bounced off something
+
+ ! player-blocked-ball?
+ BALL PLAYER { [ above? ] [ in-between-horizontally? ] } 2&&
+ [ BALL PLAYER bounce-off-paddle ] when
+
+ ! computer-blocked-ball?
+ BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } 2&&
+ [ BALL COMPUTER bounce-off-paddle ] when
+
+ ! bounced-off-wall?
+ BALL FIELD in-between-horizontally? not
+ [ BALL reverse-horizontal-velocity ] when
+
+ ] [ t GADGET paused<< ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-pong-thread ( GADGET -- )
+ f GADGET paused<<
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ;
+
+: pong-main ( -- ) [ pong-window ] with-ui ;
+
+MAIN: pong-window
projects / factor.git / commitdiff