Add more class algebra opeations

db4
Slava Pestov 2008-07-22 01:27:52 -05:00
parent af09eae727
commit 0582f45fcb
3 changed files with 11 additions and 4 deletions
core

View File

@ -13,8 +13,6 @@ IN: classes.algebra.tests
\ flatten-class must-infer
\ flatten-builtin-class must-infer
: class= ( cls1 cls2 -- ? ) [ class<= ] [ swap class<= ] 2bi and ;
: class-and* ( cls1 cls2 cls3 -- ? ) >r class-and r> class= ;
: class-or* ( cls1 cls2 cls3 -- ? ) >r class-or r> class= ;

View File

@ -186,6 +186,9 @@ M: anonymous-complement (classes-intersect?)
[ [ rank-class ] bi@ < ]
} cond ;
: class= ( first second -- ? )
[ class<= ] [ swap class<= ] 2bi and ;
: largest-class ( seq -- n elt )
dup [ [ class< ] with contains? not ] curry find-last
[ "Topological sort failed" throw ] unless* ;

View File

@ -22,8 +22,14 @@ PREDICATE: math-class < class
[ drop { 100 100 } ]
} cond ;
: math-class-max ( class class -- class )
[ [ math-precedence ] compare +gt+ eq? ] most ;
: math-class<=> ( class1 class2 -- class )
[ math-precedence ] compare +gt+ eq? ;
: math-class-max ( class1 class2 -- class )
[ math-class<=> ] most ;
: math-class-min ( class1 class2 -- class )
[ swap math-class<=> ] most ;
: (math-upgrade) ( max class -- quot )
dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;