steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

multi-methods: Rename stuff. About to refactor.

modern-harvey2
Doug Coleman 2018-01-28 11:42:58 -06:00
parent de247bf0fa
commit be5f77a319
5 changed files with 50 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
extra/boolean-expr/boolean-expr.factor
View File

@ -2,7 +2,6 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes kernel sequences sets USING: accessors arrays classes kernel sequences sets
io prettyprint ; io prettyprint ;
FROM: multi-methods => GENERIC: METHOD: ;
IN: boolean-expr IN: boolean-expr
TUPLE: ⋀ x y ; TUPLE: ⋀ x y ;
@ -15,7 +14,7 @@ SINGLETONS: P Q R S T U V W X Y Z ;
UNION: □ ⋀ ⋁ ¬ ⊤ ⊥ P Q R S T U V W X Y Z ; UNION: □ ⋀ ⋁ ¬ ⊤ ⊥ P Q R S T U V W X Y Z ;
GENERIC: ⋀ ( x y -- expr ) MULTI-GENERIC: ⋀ ( x y -- expr )
METHOD: ⋀ { ⊤ □ } nip ; METHOD: ⋀ { ⊤ □ } nip ;
METHOD: ⋀ { □ ⊤ } drop ; METHOD: ⋀ { □ ⊤ } drop ;
@ -27,7 +26,7 @@ METHOD: ⋀ { □ ⋁ } [ x>> ⋀ ] [ y>> ⋀ ] 2bi ⋁ ;
METHOD: ⋀ { □ □ } \ ⋀ boa ; METHOD: ⋀ { □ □ } \ ⋀ boa ;
GENERIC: ⋁ ( x y -- expr ) MULTI-GENERIC: ⋁ ( x y -- expr )
METHOD: ⋁ { ⊤ □ } drop ; METHOD: ⋁ { ⊤ □ } drop ;
METHOD: ⋁ { □ ⊤ } nip ; METHOD: ⋁ { □ ⊤ } nip ;
@ -36,7 +35,7 @@ METHOD: ⋁ { □ ⊥ } drop ;
METHOD: ⋁ { □ □ } \ ⋁ boa ; METHOD: ⋁ { □ □ } \ ⋁ boa ;
GENERIC: ¬ ( x -- expr ) MULTI-GENERIC: ¬ ( x -- expr )
METHOD: ¬ { ⊤ } drop ⊥ ; METHOD: ¬ { ⊤ } drop ⊥ ;
METHOD: ¬ { ⊥ } drop ⊤ ; METHOD: ¬ { ⊥ } drop ⊤ ;
@ -50,17 +49,17 @@ METHOD: ¬ { □ } \ ¬ boa ;
: ⊕ ( x y -- expr ) [ ⋁ ] [ ⋀ ¬ ] 2bi ⋀ ; : ⊕ ( x y -- expr ) [ ⋁ ] [ ⋀ ¬ ] 2bi ⋀ ;
: ≣ ( x y -- expr ) [ ⋀ ] [ [ ¬ ] bi@ ⋀ ] 2bi ⋁ ; : ≣ ( x y -- expr ) [ ⋀ ] [ [ ¬ ] bi@ ⋀ ] 2bi ⋁ ;
GENERIC: (dnf) ( expr -- dnf ) MULTI-GENERIC: (dnf) ( expr -- dnf )
METHOD: (dnf) { ⋀ } [ x>> (dnf) ] [ y>> (dnf) ] bi append ; METHOD: (dnf) { ⋀ } [ x>> (dnf) ] [ y>> (dnf) ] bi append ;
METHOD: (dnf) { □ } 1array ; METHOD: (dnf) { □ } 1array ;
GENERIC: dnf ( expr -- dnf ) MULTI-GENERIC: dnf ( expr -- dnf )
METHOD: dnf { ⋁ } [ x>> dnf ] [ y>> dnf ] bi append ; METHOD: dnf { ⋁ } [ x>> dnf ] [ y>> dnf ] bi append ;
METHOD: dnf { □ } (dnf) 1array ; METHOD: dnf { □ } (dnf) 1array ;
GENERIC: satisfiable? ( expr -- ? ) MULTI-GENERIC: satisfiable? ( expr -- ? )
METHOD: satisfiable? { ⊤ } drop t ; METHOD: satisfiable? { ⊤ } drop t ;
METHOD: satisfiable? { ⊥ } drop f ; METHOD: satisfiable? { ⊥ } drop f ;
@ -72,7 +71,7 @@ METHOD: satisfiable? { ⊥ } drop f ;
METHOD: satisfiable? { □ } METHOD: satisfiable? { □ }
dnf [ (satisfiable?) ] any? ; dnf [ (satisfiable?) ] any? ;
GENERIC: (expr.) ( expr -- ) MULTI-GENERIC: (expr.) ( expr -- )
METHOD: (expr.) { □ } pprint ; METHOD: (expr.) { □ } pprint ;

49
extra/flatland/flatland.factor
View File

@ -2,56 +2,55 @@
USING: accessors arrays combinators combinators.short-circuit USING: accessors arrays combinators combinators.short-circuit
fry kernel locals math math.intervals math.vectors multi-methods fry kernel locals math math.intervals math.vectors multi-methods
sequences ; sequences ;
FROM: multi-methods => \GENERIC: ;
IN: flatland IN: flatland
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Two dimensional world protocol ! Two dimensional world protocol
GENERIC: x ( obj -- x ) MULTI-GENERIC: x ( obj -- x )
GENERIC: y ( obj -- y ) MULTI-GENERIC: y ( obj -- y )
GENERIC: (x!) ( x obj -- ) MULTI-GENERIC: (x!) ( x obj -- )
GENERIC: (y!) ( y obj -- ) MULTI-GENERIC: (y!) ( y obj -- )
: x! ( obj x -- obj ) over (x!) ; : x! ( obj x -- obj ) over (x!) ;
: y! ( obj y -- obj ) over (y!) ; : y! ( obj y -- obj ) over (y!) ;
GENERIC: width ( obj -- width ) MULTI-GENERIC: width ( obj -- width )
GENERIC: height ( obj -- height ) MULTI-GENERIC: height ( obj -- height )
GENERIC: (width!) ( width obj -- ) MULTI-GENERIC: (width!) ( width obj -- )
GENERIC: (height!) ( height obj -- ) MULTI-GENERIC: (height!) ( height obj -- )
: width! ( obj width -- obj ) over (width!) ; : width! ( obj width -- obj ) over (width!) ;
: height! ( obj height -- obj ) over (width!) ; : height! ( obj height -- obj ) over (width!) ;
! Predicates on relative placement ! Predicates on relative placement
GENERIC: to-the-left-of? ( obj obj -- ? ) MULTI-GENERIC: to-the-left-of? ( obj obj -- ? )
GENERIC: to-the-right-of? ( obj obj -- ? ) MULTI-GENERIC: to-the-right-of? ( obj obj -- ? )
GENERIC: below? ( obj obj -- ? ) MULTI-GENERIC: below? ( obj obj -- ? )
GENERIC: above? ( obj obj -- ? ) MULTI-GENERIC: above? ( obj obj -- ? )
GENERIC: in-between-horizontally? ( obj obj -- ? ) MULTI-GENERIC: in-between-horizontally? ( obj obj -- ? )
GENERIC: horizontal-interval ( obj -- interval ) MULTI-GENERIC: horizontal-interval ( obj -- interval )
GENERIC: move-to ( obj obj -- ) MULTI-GENERIC: move-to ( obj obj -- )
GENERIC: move-by ( obj delta -- ) MULTI-GENERIC: move-by ( obj delta -- )
GENERIC: move-left-by ( obj obj -- ) MULTI-GENERIC: move-left-by ( obj obj -- )
GENERIC: move-right-by ( obj obj -- ) MULTI-GENERIC: move-right-by ( obj obj -- )
GENERIC: left ( obj -- left ) MULTI-GENERIC: left ( obj -- left )
GENERIC: right ( obj -- right ) MULTI-GENERIC: right ( obj -- right )
GENERIC: bottom ( obj -- bottom ) MULTI-GENERIC: bottom ( obj -- bottom )
GENERIC: top ( obj -- top ) MULTI-GENERIC: top ( obj -- top )
GENERIC: distance ( a b -- c ) MULTI-GENERIC: distance ( a b -- c )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -216,7 +215,7 @@ METHOD: above? { sequence rectangle } [ y ] [ top ] bi* > ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
GENERIC: within? ( a b -- ? ) MULTI-GENERIC: within? ( a b -- ? )
METHOD: within? { pos rectangle } METHOD: within? { pos rectangle }
{ {

23
extra/multi-methods/multi-methods.factor
View File

@ -140,14 +140,14 @@ PREDICATE: generic < word
: methods ( word -- alist ) : methods ( word -- alist )
"multi-methods" word-prop >alist ; "multi-methods" word-prop >alist ;
: make-generic ( generic -- quot ) : make-multi-generic ( generic -- quot )
[ [
[ methods prepare-methods % sort-methods ] keep [ methods prepare-methods % sort-methods ] keep
multi-dispatch-quot % multi-dispatch-quot %
] [ ] make ; ] [ ] make ;
: update-generic ( word -- ) : update-generic ( word -- )
dup make-generic define ; dup make-multi-generic define ;
! Methods ! Methods
PREDICATE: method-body < word PREDICATE: method-body < word
@ -215,7 +215,7 @@ M: no-method error.
[ "multi-method-specializer" word-prop ] [ "multi-method-specializer" word-prop ]
[ "multi-method-generic" word-prop ] bi prefix ; [ "multi-method-generic" word-prop ] bi prefix ;
: define-generic ( word effect -- ) : define-multi-generic ( word effect -- )
over set-stack-effect over set-stack-effect
dup "multi-methods" word-prop [ drop ] [ dup "multi-methods" word-prop [ drop ] [
[ H{ } clone "multi-methods" set-word-prop ] [ H{ } clone "multi-methods" set-word-prop ]
@ -224,31 +224,34 @@ M: no-method error.
] if ; ] if ;
! Syntax ! Syntax
SYNTAX: \GENERIC: scan-new-word scan-effect define-generic ; SYNTAX: \MULTI-GENERIC: scan-new-word scan-effect define-multi-generic ;
SYNTAX: \MULTI-HOOK:
scan-new-word scan-object 2array scan-effect define-multi-generic ;
: parse-method ( -- quot classes generic ) : parse-method ( -- quot classes generic )
parse-definition [ 2 tail ] [ second ] [ first ] tri ; parse-definition [ 2 tail ] [ second ] [ first ] tri ;
: create-method-in ( specializer generic -- method ) : create-multi-method-in ( specializer generic -- method )
create-method dup save-location f set-last-word ; create-method dup save-location f set-last-word ;
: scan-new-method ( -- method ) : scan-new-multi-method ( -- method )
scan-word scan-object swap create-method-in ; scan-word scan-object swap create-multi-method-in ;
: (METHOD:) ( -- method def ) scan-new-method parse-definition ; : (METHOD:) ( -- method def ) scan-new-multi-method parse-definition ;
SYNTAX: \METHOD: (METHOD:) define ; SYNTAX: \METHOD: (METHOD:) define ;
! For compatibility ! For compatibility
SYNTAX: \M: SYNTAX: \M:
scan-word 1array scan-word create-method-in scan-word 1array scan-word create-multi-method-in
parse-definition parse-definition
define ; define ;
! Definition protocol. We qualify core generics here ! Definition protocol. We qualify core generics here
QUALIFIED: syntax QUALIFIED: syntax
syntax::M: generic definer drop \ GENERIC: f ; syntax::M: generic definer drop \ MULTI-GENERIC: f ;
syntax::M: generic definition drop f ; syntax::M: generic definition drop f ;

4
extra/multi-methods/tests/definitions.factor
View File

@ -19,11 +19,11 @@ DEFER: testing
[ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
[ t ] [ \ fake make-generic quotation? ] unit-test [ t ] [ \ fake make-multi-generic quotation? ] unit-test
[ ] [ \ fake update-generic ] unit-test [ ] [ \ fake update-generic ] unit-test
[ ] [ \ testing ( -- ) define-generic ] unit-test [ ] [ \ testing ( -- ) define-multi-generic ] unit-test
[ t ] [ \ testing generic? ] unit-test [ t ] [ \ testing generic? ] unit-test
] with-compilation-unit ] with-compilation-unit

9
extra/multi-methods/tests/syntax.factor
View File

@ -1,10 +1,9 @@
USING: multi-methods tools.test math sequences namespaces system USING: multi-methods tools.test math sequences namespaces system
kernel strings definitions prettyprint debugger arrays kernel strings definitions prettyprint debugger arrays
hashtables continuations classes assocs accessors see ; hashtables continuations classes assocs accessors see ;
RENAME: \GENERIC: multi-methods => \multi-methods:GENERIC:
IN: multi-methods.tests IN: multi-methods.tests
multi-methods:GENERIC: first-test ( -- ) MULTI-GENERIC: first-test ( -- )
[ t ] [ \ first-test generic? ] unit-test [ t ] [ \ first-test generic? ] unit-test
@ -14,7 +13,7 @@ SINGLETON: paper INSTANCE: paper thing
SINGLETON: scissors INSTANCE: scissors thing SINGLETON: scissors INSTANCE: scissors thing
SINGLETON: rock INSTANCE: rock thing SINGLETON: rock INSTANCE: rock thing
multi-methods:GENERIC: beats? ( obj1 obj2 -- ? ) MULTI-GENERIC: beats? ( obj1 obj2 -- ? )
METHOD: beats? { paper scissors } 2drop t ; METHOD: beats? { paper scissors } 2drop t ;
METHOD: beats? { scissors rock } 2drop t ; METHOD: beats? { scissors rock } 2drop t ;
@ -35,7 +34,7 @@ METHOD: beats? { thing thing } 2drop f ;
SYMBOL: some-var SYMBOL: some-var
multi-methods:GENERIC: hook-test ( obj -- obj ) MULTI-GENERIC: hook-test ( obj -- obj )
METHOD: hook-test { array { some-var array } } reverse ; METHOD: hook-test { array { some-var array } } reverse ;
METHOD: hook-test { { some-var array } } class-of ; METHOD: hook-test { { some-var array } } class-of ;
@ -58,7 +57,7 @@ TUPLE: busted-1 ;
TUPLE: busted-2 ; INSTANCE: busted-2 busted TUPLE: busted-2 ; INSTANCE: busted-2 busted
TUPLE: busted-3 ; TUPLE: busted-3 ;
multi-methods:GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 ) MULTI-GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
METHOD: busted-sort { busted-1 busted-2 } ; METHOD: busted-sort { busted-1 busted-2 } ;
METHOD: busted-sort { busted-2 busted-3 } ; METHOD: busted-sort { busted-2 busted-3 } ;