-! Copyright (C) 2004, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel classes combinators accessors sequences arrays\r
-vectors assocs namespaces words sorting layouts math hashtables\r
-kernel.private sets math.order ;\r
-IN: classes.algebra\r
-\r
-<PRIVATE\r
-\r
-TUPLE: anonymous-union { members read-only } ;\r
-\r
-: <anonymous-union> ( members -- class )\r
- [ null eq? not ] filter prune\r
- dup length 1 = [ first ] [ anonymous-union boa ] if ;\r
-\r
-TUPLE: anonymous-intersection { participants read-only } ;\r
-\r
-: <anonymous-intersection> ( participants -- class )\r
- prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;\r
-\r
-TUPLE: anonymous-complement { class read-only } ;\r
-\r
-C: <anonymous-complement> anonymous-complement\r
-\r
-DEFER: (class<=)\r
-\r
-DEFER: (class-not)\r
-\r
-GENERIC: (classes-intersect?) ( first second -- ? )\r
-\r
-DEFER: (class-and)\r
-\r
-DEFER: (class-or)\r
-\r
-GENERIC: (flatten-class) ( class -- )\r
-\r
-GENERIC: normalize-class ( class -- class' )\r
-\r
-M: object normalize-class ;\r
-\r
-PRIVATE>\r
-\r
-GENERIC: classoid? ( obj -- ? )\r
-\r
-M: word classoid? class? ;\r
-M: anonymous-union classoid? members>> [ classoid? ] all? ;\r
-M: anonymous-intersection classoid? participants>> [ classoid? ] all? ;\r
-M: anonymous-complement classoid? class>> classoid? ;\r
-\r
-: class<= ( first second -- ? )\r
- class<=-cache get [ (class<=) ] 2cache ;\r
-\r
-: class< ( first second -- ? )\r
- {\r
- { [ 2dup class<= not ] [ 2drop f ] }\r
- { [ 2dup swap class<= not ] [ 2drop t ] }\r
- [ [ rank-class ] bi@ < ]\r
- } cond ;\r
-\r
-: class<=> ( first second -- ? )\r
- {\r
- { [ 2dup class<= not ] [ 2drop +gt+ ] }\r
- { [ 2dup swap class<= not ] [ 2drop +lt+ ] }\r
- [ [ rank-class ] bi@ <=> ]\r
- } cond ;\r
-\r
-: class= ( first second -- ? )\r
- [ class<= ] [ swap class<= ] 2bi and ;\r
-\r
-: class-not ( class -- complement )\r
- class-not-cache get [ (class-not) ] cache ;\r
-\r
-: classes-intersect? ( first second -- ? )\r
- classes-intersect-cache get [\r
- normalize-class (classes-intersect?)\r
- ] 2cache ;\r
-\r
-: class-and ( first second -- class )\r
- class-and-cache get [ (class-and) ] 2cache ;\r
-\r
-: class-or ( first second -- class )\r
- class-or-cache get [ (class-or) ] 2cache ;\r
-\r
-<PRIVATE\r
-\r
-: superclass<= ( first second -- ? )\r
- swap superclass dup [ swap class<= ] [ 2drop f ] if ;\r
-\r
-: left-anonymous-union<= ( first second -- ? )\r
- [ members>> ] dip [ class<= ] curry all? ;\r
-\r
-: right-union<= ( first second -- ? )\r
- members [ class<= ] with any? ;\r
-\r
-: right-anonymous-union<= ( first second -- ? )\r
- members>> [ class<= ] with any? ;\r
-\r
-: left-anonymous-intersection<= ( first second -- ? )\r
- [ participants>> ] dip [ class<= ] curry any? ;\r
-\r
-: right-anonymous-intersection<= ( first second -- ? )\r
- participants>> [ class<= ] with all? ;\r
-\r
-: anonymous-complement<= ( first second -- ? )\r
- [ class>> ] bi@ swap class<= ;\r
-\r
-: normalize-complement ( class -- class' )\r
- class>> normalize-class {\r
- { [ dup anonymous-union? ] [\r
- members>>\r
- [ class-not normalize-class ] map\r
- <anonymous-intersection> \r
- ] }\r
- { [ dup anonymous-intersection? ] [\r
- participants>>\r
- [ class-not normalize-class ] map\r
- <anonymous-union>\r
- ] }\r
- [ drop object ]\r
- } cond ;\r
-\r
-: left-anonymous-complement<= ( first second -- ? )\r
- [ normalize-complement ] dip class<= ;\r
-\r
-PREDICATE: nontrivial-anonymous-complement < anonymous-complement\r
- class>> {\r
- [ anonymous-union? ]\r
- [ anonymous-intersection? ]\r
- [ members ]\r
- [ participants ]\r
- } cleave or or or ;\r
-\r
-PREDICATE: empty-union < anonymous-union members>> empty? ;\r
-\r
-PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;\r
-\r
-: (class<=) ( first second -- ? )\r
- 2dup eq? [ 2drop t ] [\r
- [ normalize-class ] bi@\r
- 2dup superclass<= [ 2drop t ] [\r
- {\r
- { [ 2dup eq? ] [ 2drop t ] }\r
- { [ dup empty-intersection? ] [ 2drop t ] }\r
- { [ over empty-union? ] [ 2drop t ] }\r
- { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }\r
- { [ over anonymous-union? ] [ left-anonymous-union<= ] }\r
- { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }\r
- { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }\r
- { [ dup members ] [ right-union<= ] }\r
- { [ dup anonymous-union? ] [ right-anonymous-union<= ] }\r
- { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }\r
- { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }\r
- [ 2drop f ]\r
- } cond\r
- ] if\r
- ] if ;\r
-\r
-M: anonymous-union (classes-intersect?)\r
- members>> [ classes-intersect? ] with any? ;\r
-\r
-M: anonymous-intersection (classes-intersect?)\r
- participants>> [ classes-intersect? ] with all? ;\r
-\r
-M: anonymous-complement (classes-intersect?)\r
- class>> class<= not ;\r
-\r
-: anonymous-union-and ( first second -- class )\r
- members>> [ class-and ] with map <anonymous-union> ;\r
-\r
-: anonymous-intersection-and ( first second -- class )\r
- participants>> swap suffix <anonymous-intersection> ;\r
-\r
-: (class-and) ( first second -- class )\r
- {\r
- { [ 2dup class<= ] [ drop ] }\r
- { [ 2dup swap class<= ] [ nip ] }\r
- { [ 2dup classes-intersect? not ] [ 2drop null ] }\r
- [\r
- [ normalize-class ] bi@ {\r
- { [ dup anonymous-union? ] [ anonymous-union-and ] }\r
- { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] }\r
- { [ over anonymous-union? ] [ swap anonymous-union-and ] }\r
- { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] }\r
- [ 2array <anonymous-intersection> ]\r
- } cond\r
- ]\r
- } cond ;\r
-\r
-: anonymous-union-or ( first second -- class )\r
- members>> swap suffix <anonymous-union> ;\r
-\r
-: ((class-or)) ( first second -- class )\r
- [ normalize-class ] bi@ {\r
- { [ dup anonymous-union? ] [ anonymous-union-or ] }\r
- { [ over anonymous-union? ] [ swap anonymous-union-or ] }\r
- [ 2array <anonymous-union> ]\r
- } cond ;\r
-\r
-: anonymous-complement-or ( first second -- class )\r
- 2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ;\r
-\r
-: (class-or) ( first second -- class )\r
- {\r
- { [ 2dup class<= ] [ nip ] }\r
- { [ 2dup swap class<= ] [ drop ] }\r
- { [ dup anonymous-complement? ] [ anonymous-complement-or ] }\r
- { [ over anonymous-complement? ] [ swap anonymous-complement-or ] }\r
- [ ((class-or)) ]\r
- } cond ;\r
-\r
-: (class-not) ( class -- complement )\r
- {\r
- { [ dup anonymous-complement? ] [ class>> ] }\r
- { [ dup object eq? ] [ drop null ] }\r
- { [ dup null eq? ] [ drop object ] }\r
- [ <anonymous-complement> ]\r
- } cond ;\r
-\r
-M: anonymous-union (flatten-class)\r
- members>> [ (flatten-class) ] each ;\r
-\r
-PRIVATE>\r
-\r
-ERROR: topological-sort-failed ;\r
-\r
-: largest-class ( seq -- n elt )\r
- dup [ [ class< ] with any? not ] curry find-last\r
- [ topological-sort-failed ] unless* ;\r
-\r
-: sort-classes ( seq -- newseq )\r
- [ name>> ] sort-with >vector\r
- [ dup empty? not ]\r
- [ dup largest-class [ swap remove-nth! ] dip ]\r
- produce nip ;\r
-\r
-: smallest-class ( classes -- class/f )\r
- [ f ] [\r
- natural-sort <reversed>\r
- [ ] [ [ class<= ] most ] map-reduce\r
- ] if-empty ;\r
-\r
-: flatten-class ( class -- assoc )\r
- [ (flatten-class) ] H{ } make-assoc ;\r
+! Copyright (C) 2004, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel classes combinators accessors sequences arrays
+vectors assocs namespaces words sorting layouts math hashtables
+kernel.private sets math.order ;
+IN: classes.algebra
+
+<PRIVATE
+
+TUPLE: anonymous-union { members read-only } ;
+
+: <anonymous-union> ( members -- class )
+ [ null eq? not ] filter prune
+ dup length 1 = [ first ] [ anonymous-union boa ] if ;
+
+TUPLE: anonymous-intersection { participants read-only } ;
+
+: <anonymous-intersection> ( participants -- class )
+ prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;
+
+TUPLE: anonymous-complement { class read-only } ;
+
+C: <anonymous-complement> anonymous-complement
+
+DEFER: (class<=)
+
+DEFER: (class-not)
+
+GENERIC: (classes-intersect?) ( first second -- ? )
+
+DEFER: (class-and)
+
+DEFER: (class-or)
+
+GENERIC: (flatten-class) ( class -- )
+
+GENERIC: normalize-class ( class -- class' )
+
+M: object normalize-class ;
+
+PRIVATE>
+
- GENERIC: forgotten-class? ( obj -- ? )
++GENERIC: classoid? ( obj -- ? )
+
- M: word forgotten-class? "forgotten" word-prop ;
- M: anonymous-union forgotten-class? members>> [ forgotten-class? ] any? ;
- M: anonymous-intersection forgotten-class? participants>> [ forgotten-class? ] any? ;
- M: anonymous-complement forgotten-class? class>> forgotten-class? ;
++M: word classoid? class? ;
++M: anonymous-union classoid? members>> [ classoid? ] all? ;
++M: anonymous-intersection classoid? participants>> [ classoid? ] all? ;
++M: anonymous-complement classoid? class>> classoid? ;
+
+: class<= ( first second -- ? )
+ class<=-cache get [ (class<=) ] 2cache ;
+
+: class< ( first second -- ? )
+ {
+ { [ 2dup class<= not ] [ 2drop f ] }
+ { [ 2dup swap class<= not ] [ 2drop t ] }
+ [ [ rank-class ] bi@ < ]
+ } cond ;
+
+: class<=> ( first second -- ? )
+ {
+ { [ 2dup class<= not ] [ 2drop +gt+ ] }
+ { [ 2dup swap class<= not ] [ 2drop +lt+ ] }
+ [ [ rank-class ] bi@ <=> ]
+ } cond ;
+
+: class= ( first second -- ? )
+ [ class<= ] [ swap class<= ] 2bi and ;
+
+: class-not ( class -- complement )
+ class-not-cache get [ (class-not) ] cache ;
+
+: classes-intersect? ( first second -- ? )
+ classes-intersect-cache get [
+ normalize-class (classes-intersect?)
+ ] 2cache ;
+
+: class-and ( first second -- class )
+ class-and-cache get [ (class-and) ] 2cache ;
+
+: class-or ( first second -- class )
+ class-or-cache get [ (class-or) ] 2cache ;
+
+<PRIVATE
+
+: superclass<= ( first second -- ? )
+ swap superclass dup [ swap class<= ] [ 2drop f ] if ;
+
+: left-anonymous-union<= ( first second -- ? )
+ [ members>> ] dip [ class<= ] curry all? ;
+
+: right-union<= ( first second -- ? )
+ members [ class<= ] with any? ;
+
+: right-anonymous-union<= ( first second -- ? )
+ members>> [ class<= ] with any? ;
+
+: left-anonymous-intersection<= ( first second -- ? )
+ [ participants>> ] dip [ class<= ] curry any? ;
+
+: right-anonymous-intersection<= ( first second -- ? )
+ participants>> [ class<= ] with all? ;
+
+: anonymous-complement<= ( first second -- ? )
+ [ class>> ] bi@ swap class<= ;
+
+: normalize-complement ( class -- class' )
+ class>> normalize-class {
+ { [ dup anonymous-union? ] [
+ members>>
+ [ class-not normalize-class ] map
+ <anonymous-intersection>
+ ] }
+ { [ dup anonymous-intersection? ] [
+ participants>>
+ [ class-not normalize-class ] map
+ <anonymous-union>
+ ] }
+ [ drop object ]
+ } cond ;
+
+: left-anonymous-complement<= ( first second -- ? )
+ [ normalize-complement ] dip class<= ;
+
+PREDICATE: nontrivial-anonymous-complement < anonymous-complement
+ class>> {
+ [ anonymous-union? ]
+ [ anonymous-intersection? ]
+ [ members ]
+ [ participants ]
+ } cleave or or or ;
+
+PREDICATE: empty-union < anonymous-union members>> empty? ;
+
+PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
+
+: (class<=) ( first second -- ? )
+ 2dup eq? [ 2drop t ] [
+ [ normalize-class ] bi@
+ 2dup superclass<= [ 2drop t ] [
+ {
+ { [ 2dup eq? ] [ 2drop t ] }
+ { [ dup empty-intersection? ] [ 2drop t ] }
+ { [ over empty-union? ] [ 2drop t ] }
+ { [ 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 members ] [ right-union<= ] }
+ { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
+ { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
+ { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
+ [ 2drop f ]
+ } cond
+ ] if
+ ] if ;
+
+M: anonymous-union (classes-intersect?)
+ members>> [ classes-intersect? ] with any? ;
+
+M: anonymous-intersection (classes-intersect?)
+ participants>> [ classes-intersect? ] with all? ;
+
+M: anonymous-complement (classes-intersect?)
+ class>> class<= not ;
+
+: anonymous-union-and ( first second -- class )
+ members>> [ class-and ] with map <anonymous-union> ;
+
+: anonymous-intersection-and ( first second -- class )
+ participants>> swap suffix <anonymous-intersection> ;
+
+: (class-and) ( first second -- class )
+ {
+ { [ 2dup class<= ] [ drop ] }
+ { [ 2dup swap class<= ] [ nip ] }
+ { [ 2dup classes-intersect? not ] [ 2drop null ] }
+ [
+ [ 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 <anonymous-intersection> ]
+ } cond
+ ]
+ } cond ;
+
+: anonymous-union-or ( first second -- class )
+ members>> swap suffix <anonymous-union> ;
+
+: ((class-or)) ( first second -- class )
+ [ normalize-class ] bi@ {
+ { [ dup anonymous-union? ] [ anonymous-union-or ] }
+ { [ over anonymous-union? ] [ swap anonymous-union-or ] }
+ [ 2array <anonymous-union> ]
+ } 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-complement? ] [ anonymous-complement-or ] }
+ { [ over anonymous-complement? ] [ swap anonymous-complement-or ] }
+ [ ((class-or)) ]
+ } cond ;
+
+: (class-not) ( class -- complement )
+ {
+ { [ dup anonymous-complement? ] [ class>> ] }
+ { [ dup object eq? ] [ drop null ] }
+ { [ dup null eq? ] [ drop object ] }
+ [ <anonymous-complement> ]
+ } cond ;
+
+M: anonymous-union (flatten-class)
+ members>> [ (flatten-class) ] each ;
+
+PRIVATE>
+
+ERROR: topological-sort-failed ;
+
+: largest-class ( seq -- n elt )
+ dup [ [ class< ] with any? not ] curry find-last
+ [ topological-sort-failed ] unless* ;
+
+: sort-classes ( seq -- newseq )
+ [ name>> ] sort-with >vector
+ [ dup empty? not ]
+ [ dup largest-class [ swap remove-nth! ] dip ]
+ produce nip ;
+
+: smallest-class ( classes -- class/f )
+ [ f ] [
+ natural-sort <reversed>
+ [ ] [ [ class<= ] most ] map-reduce
+ ] if-empty ;
+
+: flatten-class ( class -- assoc )
+ [ (flatten-class) ] H{ } make-assoc ;
projects / factor.git / commitdiff