1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes classes.private
4 combinators kernel make math math.order namespaces sequences
12 TUPLE: anonymous-union { members read-only } ;
14 INSTANCE: anonymous-union classoid
16 : <anonymous-union> ( members -- classoid )
17 [ classoid check-instance ] map [ null eq? ] reject
18 members dup length 1 =
19 [ first ] [ sort-classes f like anonymous-union boa ] if ;
21 M: anonymous-union rank-class drop 6 ;
23 TUPLE: anonymous-intersection { participants read-only } ;
25 INSTANCE: anonymous-intersection classoid
27 : <anonymous-intersection> ( participants -- classoid )
28 [ classoid check-instance ] map
29 members dup length 1 =
30 [ first ] [ sort-classes f like anonymous-intersection boa ] if ;
32 M: anonymous-intersection rank-class drop 4 ;
34 TUPLE: anonymous-complement { class read-only } ;
36 INSTANCE: anonymous-complement classoid
38 : <anonymous-complement> ( object -- classoid )
39 classoid check-instance anonymous-complement boa ;
41 M: anonymous-complement rank-class drop 3 ;
43 M: anonymous-complement predicate-def
44 class>> [ over [ instance? not ] [ 2drop t ] if ] curry ;
46 M: anonymous-complement instance?
47 over [ class>> instance? not ] [ 2drop t ] if ;
49 M: anonymous-complement class-name
56 GENERIC: (classes-intersect?) ( first second -- ? )
62 GENERIC: (flatten-class) ( class -- )
64 GENERIC: normalize-class ( class -- class' )
66 M: object normalize-class ;
68 : symmetric-class-op ( first second cache quot -- result )
69 [ 2dup [ rank-class ] bi@ > [ swap ] when ] 2dip 2cache ; inline
73 : only-classoid? ( obj -- ? )
74 dup classoid? [ class? not ] [ drop f ] if ;
76 : class<= ( first second -- ? )
77 class<=-cache get [ (class<=) ] 2cache ;
79 : class< ( first second -- ? )
81 { [ 2dup class<= not ] [ 2drop f ] }
82 { [ 2dup swap class<= not ] [ 2drop t ] }
83 [ [ rank-class ] bi@ < ]
86 : class= ( first second -- ? )
87 2dup class<= [ swap class<= ] [ 2drop f ] if ;
89 : class-not ( class -- complement )
90 class-not-cache get [ (class-not) ] cache ;
92 : classes-intersect? ( first second -- ? )
93 [ normalize-class ] bi@
94 classes-intersect-cache get [ (classes-intersect?) ] symmetric-class-op ;
96 : class-and ( first second -- class )
97 class-and-cache get [ (class-and) ] symmetric-class-op ;
99 : class-or ( first second -- class )
100 class-or-cache get [ (class-or) ] symmetric-class-op ;
102 SYMBOL: +incomparable+
104 : compare-classes ( first second -- <=> )
105 [ swap class<= ] [ class<= ] 2bi
106 [ +eq+ +lt+ ] [ +gt+ +incomparable+ ] if ? ;
108 : evaluate-class-predicate ( class1 class2 -- ? )
110 { [ 2dup class<= ] [ t ] }
111 { [ 2dup classes-intersect? not ] [ f ] }
117 : superclass<= ( first second -- ? )
118 swap superclass-of [ swap class<= ] [ drop f ] if* ;
120 : left-anonymous-union<= ( first second -- ? )
121 [ members>> ] dip [ class<= ] curry all? ;
123 : right-union<= ( first second -- ? )
124 class-members [ class<= ] with any? ;
126 : right-anonymous-union<= ( first second -- ? )
127 members>> [ class<= ] with any? ;
129 : left-anonymous-intersection<= ( first second -- ? )
130 [ participants>> ] dip [ class<= ] curry any? ;
132 PREDICATE: nontrivial-anonymous-intersection < anonymous-intersection
133 participants>> empty? not ;
135 : right-anonymous-intersection<= ( first second -- ? )
136 participants>> [ class<= ] with all? ;
138 : anonymous-complement<= ( first second -- ? )
139 [ class>> ] bi@ swap class<= ;
141 : normalize-complement ( class -- class' )
142 class>> normalize-class {
143 { [ dup anonymous-union? ] [
145 [ class-not normalize-class ] map
146 <anonymous-intersection>
148 { [ dup anonymous-intersection? ] [
150 [ class-not normalize-class ] map
156 : left-anonymous-complement<= ( first second -- ? )
157 [ normalize-complement ] dip class<= ;
159 PREDICATE: nontrivial-anonymous-complement < anonymous-complement
160 class>> dup anonymous-union? [ drop t ] [
161 dup anonymous-intersection? [ drop t ] [
162 dup class-members [ drop t ] [
168 PREDICATE: empty-union < anonymous-union members>> empty? ;
170 PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
172 : (class<=) ( first second -- ? )
173 2dup eq? [ 2drop t ] [
174 [ normalize-class ] bi@
175 2dup superclass<= [ 2drop t ] [
177 { [ 2dup eq? ] [ 2drop t ] }
178 { [ dup empty-intersection? ] [ 2drop t ] }
179 { [ over empty-union? ] [ 2drop t ] }
180 { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
181 { [ over anonymous-union? ] [ left-anonymous-union<= ] }
182 { [ over nontrivial-anonymous-intersection? ] [ left-anonymous-intersection<= ] }
183 { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
184 { [ dup class-members ] [ right-union<= ] }
185 { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
186 { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
187 { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
193 M: anonymous-union (classes-intersect?)
194 members>> [ classes-intersect? ] with any? ;
196 M: anonymous-intersection (classes-intersect?)
197 participants>> [ classes-intersect? ] with all? ;
199 M: anonymous-complement (classes-intersect?)
200 class>> class<= not ;
202 : anonymous-union-and ( first second -- class )
203 members>> [ class-and ] with map <anonymous-union> ;
205 : anonymous-intersection-and ( first second -- class )
206 participants>> swap suffix <anonymous-intersection> ;
208 : (class-and) ( first second -- class )
209 2dup compare-classes {
214 2dup classes-intersect? [
215 [ normalize-class ] bi@ {
216 { [ dup anonymous-union? ] [ anonymous-union-and ] }
217 { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] }
218 { [ over anonymous-union? ] [ swap anonymous-union-and ] }
219 { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] }
220 [ 2array <anonymous-intersection> ]
226 : anonymous-union-or ( first second -- class )
227 members>> swap suffix <anonymous-union> ;
229 : classes>anonymous-union ( first second -- class )
230 [ normalize-class ] bi@ {
231 { [ dup anonymous-union? ] [ anonymous-union-or ] }
232 { [ over anonymous-union? ] [ swap anonymous-union-or ] }
233 [ 2array <anonymous-union> ]
236 : anonymous-complement-or ( first second -- class )
237 2dup class>> swap class<= [ 2drop object ] [ classes>anonymous-union ] if ;
239 : (class-or) ( first second -- class )
240 2dup compare-classes {
246 { [ dup anonymous-complement? ] [ anonymous-complement-or ] }
247 { [ over anonymous-complement? ] [ swap anonymous-complement-or ] }
248 [ classes>anonymous-union ]
253 : (class-not) ( class -- complement )
255 { [ dup anonymous-complement? ] [ class>> ] }
256 { [ dup object eq? ] [ drop null ] }
257 { [ dup null eq? ] [ drop object ] }
258 [ <anonymous-complement> ]
261 M: anonymous-union (flatten-class)
262 members>> [ (flatten-class) ] each ;
266 ERROR: topological-sort-failed ;
268 : largest-class ( seq -- n elt )
269 dup [ [ class< ] with none? ] curry find-last
270 [ topological-sort-failed ] unless* ;
272 : sort-classes ( seq -- newseq )
273 [ class-name ] sort-with >vector
275 [ dup largest-class [ swap remove-nth! ] dip ]
278 : smallest-class ( classes -- class/f )
280 natural-sort <reversed>
281 [ ] [ [ class<= ] most ] map-reduce
284 : flatten-class ( class -- seq )
285 [ (flatten-class) ] { } make members ;