From dd08bdfdd17c17283221820c2d97b9b51236dd3f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 10 May 2008 23:59:02 -0500 Subject: [PATCH] Class algebra changes --- core/bootstrap/primitives.factor | 11 +- core/classes/algebra/algebra-tests.factor | 15 +++ core/classes/algebra/algebra.factor | 143 +++++++++++----------- 3 files changed, 95 insertions(+), 74 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 31ba4e4b6d..5ab623b8de 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -127,7 +127,7 @@ bootstrapping? on : register-builtin ( class -- ) [ dup lookup-type-number "type" set-word-prop ] [ dup "type" word-prop builtins get set-nth ] - [ f f builtin-class define-class ] + [ f f f builtin-class define-class ] tri ; : define-builtin-slots ( symbol slotspec -- ) @@ -160,10 +160,15 @@ bootstrapping? on ! Catch-all class for providing a default method. "object" "kernel" create -[ f builtins get [ ] filter union-class define-class ] +[ f builtins get [ ] filter f union-class define-class ] [ [ drop t ] "predicate" set-word-prop ] bi +! "object" "kernel" create +! [ f f { } intersection-class define-class ] +! [ [ drop t ] "predicate" set-word-prop ] +! bi + "object?" "kernel" vocab-words delete-at ! Class of objects with object tag @@ -172,7 +177,7 @@ builtins get num-tags get tail define-union-class ! Empty class with no instances "null" "kernel" create -[ f { } union-class define-class ] +[ f { } f union-class define-class ] [ [ drop f ] "predicate" set-word-prop ] bi diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 7d5181ad04..a0d516abe0 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -282,3 +282,18 @@ INTERSECTION: generic-class generic class ; [ H{ { word word } } ] [ generic-class flatten-class ] unit-test + +INTERSECTION: empty-intersection ; + +[ t ] [ object empty-intersection class<= ] unit-test +[ t ] [ empty-intersection object class<= ] unit-test +[ t ] [ \ f class-not empty-intersection class<= ] unit-test +[ f ] [ empty-intersection \ f class-not class<= ] unit-test +[ t ] [ \ number empty-intersection class<= ] unit-test +[ t ] [ empty-intersection class-not null class<= ] unit-test +[ t ] [ null empty-intersection class-not class<= ] unit-test + +[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test +[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test + +[ t ] [ object \ f class-not \ f class-or class<= ] unit-test diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 47149f91ff..f6d5179ec2 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -48,18 +48,6 @@ C: anonymous-complement : superclass<= ( first second -- ? ) >r superclass r> class<= ; -: left-union-class<= ( first second -- ? ) - >r members r> [ class<= ] curry all? ; - -: right-union-class<= ( first second -- ? ) - members [ class<= ] with contains? ; - -: left-intersection-class<= ( first second -- ? ) - >r participants r> [ class<= ] curry contains? ; - -: right-intersection-class<= ( first second -- ? ) - participants [ class<= ] with all? ; - : left-anonymous-union<= ( first second -- ? ) >r members>> r> [ class<= ] curry all? ; @@ -75,24 +63,56 @@ C: anonymous-complement : anonymous-complement<= ( first second -- ? ) [ class>> ] bi@ swap class<= ; -: (class<=) ( first second -- -1/0/1 ) +: normalize-class ( class -- class' ) + { + { [ dup members ] [ members ] } + { [ dup participants ] [ participants ] } + [ ] + } cond ; + +: normalize-complement ( class -- class' ) + class>> normalize-class { + { [ dup anonymous-union? ] [ + members>> + [ class-not normalize-class ] map + + ] } + { [ dup anonymous-intersection? ] [ + participants>> + [ class-not normalize-class ] map + + ] } + } cond ; + +: left-anonymous-complement<= ( first second -- ? ) + >r normalize-complement r> class<= ; + +PREDICATE: nontrivial-anonymous-complement < anonymous-complement + class>> { + [ anonymous-union? ] + [ anonymous-intersection? ] + [ members ] + [ participants ] + } cleave or or or ; + +: (class<=) ( first second -- -1/0/1 ) { { [ 2dup eq? ] [ 2drop t ] } { [ dup object eq? ] [ 2drop t ] } { [ over null eq? ] [ 2drop t ] } - { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] } - { [ over anonymous-union? ] [ left-anonymous-union<= ] } - { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] } - { [ over members ] [ left-union-class<= ] } - { [ over participants ] [ left-intersection-class<= ] } - { [ dup anonymous-union? ] [ right-anonymous-union<= ] } - { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] } - { [ over anonymous-complement? ] [ 2drop f ] } - { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } - { [ dup members ] [ right-union-class<= ] } - { [ dup participants ] [ right-intersection-class<= ] } - { [ over superclass ] [ superclass<= ] } - [ 2drop f ] + [ + [ normalize-class ] bi@ { + { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] } + { [ over anonymous-union? ] [ left-anonymous-union<= ] } + { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] } + { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] } + { [ dup anonymous-union? ] [ right-anonymous-union<= ] } + { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] } + { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } + { [ over superclass ] [ superclass<= ] } + [ 2drop f ] + } cond + ] } cond ; : anonymous-union-intersect? ( first second -- ? ) @@ -104,12 +124,6 @@ C: anonymous-complement : anonymous-complement-intersect? ( first second -- ? ) class>> class<= not ; -: union-class-intersect? ( first second -- ? ) - members [ classes-intersect? ] with contains? ; - -: intersection-class-intersect? ( first second -- ? ) - participants [ classes-intersect? ] with all? ; - : tuple-class-intersect? ( first second -- ? ) { { [ over tuple eq? ] [ 2drop t ] } @@ -126,39 +140,19 @@ C: anonymous-complement } cond ; : (classes-intersect?) ( first second -- ? ) - { + normalize-class { { [ dup anonymous-union? ] [ anonymous-union-intersect? ] } { [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] } { [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] } { [ dup tuple-class? ] [ tuple-class-intersect? ] } { [ dup builtin-class? ] [ builtin-class-intersect? ] } { [ dup superclass ] [ superclass classes-intersect? ] } - { [ dup members ] [ union-class-intersect? ] } - { [ dup participants ] [ intersection-class-intersect? ] } } cond ; -: left-union-and ( first second -- class ) - >r members r> [ class-and ] curry map ; - -: right-union-and ( first second -- class ) - members [ class-and ] with map ; - -: left-intersection-and ( first second -- class ) - >r participants r> suffix ; - -: right-intersection-and ( first second -- class ) - participants swap suffix ; - -: left-anonymous-union-and ( first second -- class ) - >r members>> r> [ class-and ] curry map ; - -: right-anonymous-union-and ( first second -- class ) +: anonymous-union-and ( first second -- class ) members>> [ class-and ] with map ; -: left-anonymous-intersection-and ( first second -- class ) - >r participants>> r> suffix ; - -: right-anonymous-intersection-and ( first second -- class ) +: anonymous-intersection-and ( first second -- class ) participants>> swap suffix ; : (class-and) ( first second -- class ) @@ -166,30 +160,37 @@ C: anonymous-complement { [ 2dup class<= ] [ drop ] } { [ 2dup swap class<= ] [ nip ] } { [ 2dup classes-intersect? not ] [ 2drop null ] } - { [ dup members ] [ right-union-and ] } - { [ dup participants ] [ right-intersection-and ] } - { [ dup anonymous-union? ] [ right-anonymous-union-and ] } - { [ dup anonymous-intersection? ] [ right-anonymous-intersection-and ] } - { [ over members ] [ left-union-and ] } - { [ over participants ] [ left-intersection-and ] } - { [ over anonymous-union? ] [ left-anonymous-union-and ] } - { [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] } - [ 2array ] + [ + [ normalize-class ] bi@ { + { [ dup anonymous-union? ] [ anonymous-union-and ] } + { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] } + { [ over anonymous-union? ] [ swap anonymous-union-and ] } + { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] } + [ 2array ] + } cond + ] } cond ; -: left-anonymous-union-or ( first second -- class ) - >r members>> r> suffix ; - -: right-anonymous-union-or ( first second -- class ) +: anonymous-union-or ( first second -- class ) members>> swap suffix ; +: ((class-or)) ( first second -- class ) + [ normalize-class ] bi@ { + { [ dup anonymous-union? ] [ anonymous-union-or ] } + { [ over anonymous-union? ] [ swap anonymous-union-or ] } + [ 2array ] + } cond ; + +: anonymous-complement-or ( first second -- class ) + 2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ; + : (class-or) ( first second -- class ) { { [ 2dup class<= ] [ nip ] } { [ 2dup swap class<= ] [ drop ] } - { [ dup anonymous-union? ] [ right-anonymous-union-or ] } - { [ over anonymous-union? ] [ left-anonymous-union-or ] } - [ 2array ] + { [ dup anonymous-complement? ] [ anonymous-complement-or ] } + { [ over anonymous-complement? ] [ swap anonymous-complement-or ] } + [ ((class-or)) ] } cond ; : (class-not) ( class -- complement )