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

Fix class<=; a predicate class derived from a union was not reported as being contained in the union

db4
Slava Pestov 2008-11-04 04:59:54 -06:00
parent cc94894441
commit fb64c1cb45
1 changed files with 15 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -55,7 +55,7 @@ DEFER: (class-or)
class-or-cache get [ (class-or) ] 2cache ; class-or-cache get [ (class-or) ] 2cache ;
: superclass<= ( first second -- ? ) : superclass<= ( first second -- ? )
>r superclass r> class<= ; swap superclass dup [ swap class<= ] [ 2drop f ] if ;
: left-anonymous-union<= ( first second -- ? ) : left-anonymous-union<= ( first second -- ? )
>r members>> r> [ class<= ] curry all? ; >r members>> r> [ class<= ] curry all? ;
@ -103,19 +103,20 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
: (class<=) ( first second -- -1/0/1 ) : (class<=) ( first second -- -1/0/1 )
2dup eq? [ 2drop t ] [ 2dup eq? [ 2drop t ] [
[ normalize-class ] bi@ { 2dup superclass<= [ 2drop t ] [
{ [ dup empty-intersection? ] [ 2drop t ] } [ normalize-class ] bi@ {
{ [ over empty-union? ] [ 2drop t ] } { [ dup empty-intersection? ] [ 2drop t ] }
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] } { [ over empty-union? ] [ 2drop t ] }
{ [ over anonymous-union? ] [ left-anonymous-union<= ] } { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] } { [ over anonymous-union? ] [ left-anonymous-union<= ] }
{ [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] } { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
{ [ dup anonymous-union? ] [ right-anonymous-union<= ] } { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] } { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
{ [ over superclass ] [ superclass<= ] } { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
[ 2drop f ] [ 2drop f ]
} cond } cond
] if
] if ; ] if ;
M: anonymous-union (classes-intersect?) M: anonymous-union (classes-intersect?)