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

classes.algebra: output cleaner anonymous unions and intersections

db4
Slava Pestov 2009-11-13 03:01:22 -06:00
parent ff25aaef54
commit 14a4535ad9
2 changed files with 14 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
core/classes/algebra/algebra-tests.factor
View File

@ -37,6 +37,8 @@ INTERSECTION: empty-intersection ;
INTERSECTION: generic-class generic class ; INTERSECTION: generic-class generic class ;
UNION: union-with-one-member a ;
! class<= ! class<=
[ t ] [ \ fixnum \ integer class<= ] unit-test [ t ] [ \ fixnum \ integer class<= ] unit-test
[ t ] [ \ fixnum \ fixnum 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 generic class<= ] unit-test
[ t ] [ generic-class \ class 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
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;

12
core/classes/algebra/algebra.factor
View File

@ -9,11 +9,14 @@ IN: classes.algebra
TUPLE: anonymous-union { members read-only } ; 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 } ; 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 } ; TUPLE: anonymous-complement { class read-only } ;
@ -114,6 +117,7 @@ M: word valid-class? drop f ;
[ class-not normalize-class ] map [ class-not normalize-class ] map
<anonymous-union> <anonymous-union>
] } ] }
[ <anonymous-complement> ]
} cond ; } cond ;
: left-anonymous-complement<= ( first second -- ? ) : left-anonymous-complement<= ( first second -- ? )
@ -133,8 +137,10 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
: (class<=) ( first second -- ? ) : (class<=) ( first second -- ? )
2dup eq? [ 2drop t ] [ 2dup eq? [ 2drop t ] [
[ normalize-class ] bi@
2dup superclass<= [ 2drop t ] [ 2dup superclass<= [ 2drop t ] [
[ normalize-class ] bi@ { {
{ [ 2dup eq? ] [ 2drop t ] }
{ [ dup empty-intersection? ] [ 2drop t ] } { [ dup empty-intersection? ] [ 2drop t ] }
{ [ over empty-union? ] [ 2drop t ] } { [ over empty-union? ] [ 2drop t ] }
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] } { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }