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.
USING: accessors arrays classes kernel sequences sets
io prettyprint ;
FROM: multi-methods => GENERIC: METHOD: ;
IN: boolean-expr
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 ;
GENERIC: ⋀ ( x y -- expr )
MULTI-GENERIC: ⋀ ( x y -- expr )
METHOD: ⋀ { ⊤ □ } nip ;
METHOD: ⋀ { □ ⊤ } drop ;
@ -27,7 +26,7 @@ METHOD: ⋀ { □ ⋁ } [ x>> ⋀ ] [ y>> ⋀ ] 2bi ⋁ ;
METHOD: ⋀ { □ □ } \ ⋀ boa ;
GENERIC: ⋁ ( x y -- expr )
MULTI-GENERIC: ⋁ ( x y -- expr )
METHOD: ⋁ { ⊤ □ } drop ;
METHOD: ⋁ { □ ⊤ } nip ;
@ -36,7 +35,7 @@ METHOD: ⋁ { □ ⊥ } drop ;
METHOD: ⋁ { □ □ } \ ⋁ boa ;
GENERIC: ¬ ( x -- expr )
MULTI-GENERIC: ¬ ( x -- expr )
METHOD: ¬ { ⊤ } drop ⊥ ;
METHOD: ¬ { ⊥ } drop ⊤ ;
@ -50,17 +49,17 @@ METHOD: ¬ { □ } \ ¬ boa ;
: ⊕ ( x y -- expr ) [ ⋁ ] [ ⋀ ¬ ] 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) { □ } 1array ;
GENERIC: dnf ( expr -- dnf )
MULTI-GENERIC: dnf ( expr -- dnf )
METHOD: dnf { ⋁ } [ x>> dnf ] [ y>> dnf ] bi append ;
METHOD: dnf { □ } (dnf) 1array ;
GENERIC: satisfiable? ( expr -- ? )
MULTI-GENERIC: satisfiable? ( expr -- ? )
METHOD: satisfiable? { ⊤ } drop t ;
METHOD: satisfiable? { ⊥ } drop f ;
@ -72,7 +71,7 @@ METHOD: satisfiable? { ⊥ } drop f ;
METHOD: satisfiable? { □ }
dnf [ (satisfiable?) ] any? ;
GENERIC: (expr.) ( expr -- )
MULTI-GENERIC: (expr.) ( expr -- )
METHOD: (expr.) { □ } pprint ;

49
extra/flatland/flatland.factor
View File

@ -2,56 +2,55 @@
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 )
MULTI-GENERIC: x ( obj -- x )
MULTI-GENERIC: y ( obj -- y )
GENERIC: (x!) ( x obj -- )
GENERIC: (y!) ( y obj -- )
MULTI-GENERIC: (x!) ( x obj -- )
MULTI-GENERIC: (y!) ( y obj -- )
: x! ( obj x -- obj ) over (x!) ;
: y! ( obj y -- obj ) over (y!) ;
GENERIC: width ( obj -- width )
GENERIC: height ( obj -- height )
MULTI-GENERIC: width ( obj -- width )
MULTI-GENERIC: height ( obj -- height )
GENERIC: (width!) ( width obj -- )
GENERIC: (height!) ( height obj -- )
MULTI-GENERIC: (width!) ( width obj -- )
MULTI-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 -- ? )
MULTI-GENERIC: to-the-left-of? ( obj obj -- ? )
MULTI-GENERIC: to-the-right-of? ( obj obj -- ? )
GENERIC: below? ( obj obj -- ? )
GENERIC: above? ( obj obj -- ? )
MULTI-GENERIC: below? ( 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 -- )
GENERIC: move-right-by ( obj obj -- )
MULTI-GENERIC: move-left-by ( obj obj -- )
MULTI-GENERIC: move-right-by ( obj obj -- )
GENERIC: left ( obj -- left )
GENERIC: right ( obj -- right )
GENERIC: bottom ( obj -- bottom )
GENERIC: top ( obj -- top )
MULTI-GENERIC: left ( obj -- left )
MULTI-GENERIC: right ( obj -- right )
MULTI-GENERIC: bottom ( obj -- bottom )
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 }
{

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

@ -140,14 +140,14 @@ PREDICATE: generic < word
: methods ( word -- alist )
"multi-methods" word-prop >alist ;
: make-generic ( generic -- quot )
: make-multi-generic ( generic -- quot )
[
[ methods prepare-methods % sort-methods ] keep
multi-dispatch-quot %
] [ ] make ;
: update-generic ( word -- )
dup make-generic define ;
dup make-multi-generic define ;
! Methods
PREDICATE: method-body < word
@ -215,7 +215,7 @@ M: no-method error.
[ "multi-method-specializer" word-prop ]
[ "multi-method-generic" word-prop ] bi prefix ;
: define-generic ( word effect -- )
: define-multi-generic ( word effect -- )
over set-stack-effect
dup "multi-methods" word-prop [ drop ] [
[ H{ } clone "multi-methods" set-word-prop ]
@ -224,31 +224,34 @@ M: no-method error.
] if ;
! 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-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 ;
: scan-new-method ( -- method )
scan-word scan-object swap create-method-in ;
: scan-new-multi-method ( -- method )
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 ;
! For compatibility
SYNTAX: \M:
scan-word 1array scan-word create-method-in
scan-word 1array scan-word create-multi-method-in
parse-definition
define ;
! Definition protocol. We qualify core generics here
QUALIFIED: syntax
syntax::M: generic definer drop \ GENERIC: f ;
syntax::M: generic definer drop \ MULTI-GENERIC: 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 make-generic quotation? ] unit-test
[ t ] [ \ fake make-multi-generic quotation? ] unit-test
[ ] [ \ fake update-generic ] unit-test
[ ] [ \ testing ( -- ) define-generic ] unit-test
[ ] [ \ testing ( -- ) define-multi-generic ] unit-test
[ t ] [ \ testing generic? ] unit-test
] 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
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 ( -- )
MULTI-GENERIC: first-test ( -- )
[ t ] [ \ first-test generic? ] unit-test
@ -14,7 +13,7 @@ SINGLETON: paper INSTANCE: paper thing
SINGLETON: scissors INSTANCE: scissors 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? { scissors rock } 2drop t ;
@ -35,7 +34,7 @@ METHOD: beats? { thing thing } 2drop f ;
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 { { some-var array } } class-of ;
@ -58,7 +57,7 @@ TUPLE: busted-1 ;
TUPLE: busted-2 ; INSTANCE: busted-2 busted
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-2 busted-3 } ;