classes.algebra: output cleaner anonymous unions and intersections
parent
ff25aaef54
commit
14a4535ad9
|
@ -37,6 +37,8 @@ INTERSECTION: empty-intersection ;
|
|||
|
||||
INTERSECTION: generic-class generic class ;
|
||||
|
||||
UNION: union-with-one-member a ;
|
||||
|
||||
! class<=
|
||||
[ t ] [ \ fixnum \ integer class<= ] unit-test
|
||||
[ t ] [ \ fixnum \ fixnum class<= ] unit-test
|
||||
|
@ -122,6 +124,9 @@ INTERSECTION: generic-class generic class ;
|
|||
[ t ] [ generic-class generic class<= ] unit-test
|
||||
[ t ] [ generic-class \ class class<= ] unit-test
|
||||
|
||||
[ t ] [ a union-with-one-member class<= ] unit-test
|
||||
[ f ] [ union-with-one-member class-not integer class<= ] unit-test
|
||||
|
||||
! class-and
|
||||
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
|
||||
|
||||
|
|
|
@ -9,11 +9,14 @@ IN: classes.algebra
|
|||
|
||||
TUPLE: anonymous-union { members read-only } ;
|
||||
|
||||
C: <anonymous-union> anonymous-union
|
||||
: <anonymous-union> ( members -- class )
|
||||
[ null eq? not ] filter prune
|
||||
dup length 1 = [ first ] [ anonymous-union boa ] if ;
|
||||
|
||||
TUPLE: anonymous-intersection { participants read-only } ;
|
||||
|
||||
C: <anonymous-intersection> anonymous-intersection
|
||||
: <anonymous-intersection> ( participants -- class )
|
||||
prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;
|
||||
|
||||
TUPLE: anonymous-complement { class read-only } ;
|
||||
|
||||
|
@ -114,6 +117,7 @@ M: word valid-class? drop f ;
|
|||
[ class-not normalize-class ] map
|
||||
<anonymous-union>
|
||||
] }
|
||||
[ <anonymous-complement> ]
|
||||
} cond ;
|
||||
|
||||
: left-anonymous-complement<= ( first second -- ? )
|
||||
|
@ -133,8 +137,10 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
|
|||
|
||||
: (class<=) ( first second -- ? )
|
||||
2dup eq? [ 2drop t ] [
|
||||
[ normalize-class ] bi@
|
||||
2dup superclass<= [ 2drop t ] [
|
||||
[ normalize-class ] bi@ {
|
||||
{
|
||||
{ [ 2dup eq? ] [ 2drop t ] }
|
||||
{ [ dup empty-intersection? ] [ 2drop t ] }
|
||||
{ [ over empty-union? ] [ 2drop t ] }
|
||||
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
|
||||
|
|
Loading…
Reference in New Issue