1 ! Copyright (C) 2004, 2008 Slava Pestov.
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 USING: kernel classes combinators accessors sequences arrays
\r
4 vectors assocs namespaces words sorting layouts math hashtables
\r
5 kernel.private sets math.order ;
\r
10 TUPLE: anonymous-union { members read-only } ;
\r
12 : <anonymous-union> ( members -- class )
\r
13 [ null eq? not ] filter prune
\r
14 dup length 1 = [ first ] [ anonymous-union boa ] if ;
\r
16 TUPLE: anonymous-intersection { participants read-only } ;
\r
18 : <anonymous-intersection> ( participants -- class )
\r
19 prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;
\r
21 TUPLE: anonymous-complement { class read-only } ;
\r
23 C: <anonymous-complement> anonymous-complement
\r
29 GENERIC: (classes-intersect?) ( first second -- ? )
\r
35 GENERIC: (flatten-class) ( class -- )
\r
37 : normalize-class ( class -- class' )
\r
39 { [ dup members ] [ members <anonymous-union> normalize-class ] }
\r
40 { [ dup participants ] [ participants <anonymous-intersection> normalize-class ] }
\r
46 GENERIC: valid-class? ( obj -- ? )
\r
48 M: class valid-class? drop t ;
\r
49 M: anonymous-union valid-class? members>> [ valid-class? ] all? ;
\r
50 M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ;
\r
51 M: anonymous-complement valid-class? class>> valid-class? ;
\r
52 M: word valid-class? drop f ;
\r
54 : class<= ( first second -- ? )
\r
55 class<=-cache get [ (class<=) ] 2cache ;
\r
57 : class< ( first second -- ? )
\r
59 { [ 2dup class<= not ] [ 2drop f ] }
\r
60 { [ 2dup swap class<= not ] [ 2drop t ] }
\r
61 [ [ rank-class ] bi@ < ]
\r
64 : class<=> ( first second -- ? )
\r
66 { [ 2dup class<= not ] [ 2drop +gt+ ] }
\r
67 { [ 2dup swap class<= not ] [ 2drop +lt+ ] }
\r
68 [ [ rank-class ] bi@ <=> ]
\r
71 : class= ( first second -- ? )
\r
72 [ class<= ] [ swap class<= ] 2bi and ;
\r
74 : class-not ( class -- complement )
\r
75 class-not-cache get [ (class-not) ] cache ;
\r
77 : classes-intersect? ( first second -- ? )
\r
78 classes-intersect-cache get [
\r
79 normalize-class (classes-intersect?)
\r
82 : class-and ( first second -- class )
\r
83 class-and-cache get [ (class-and) ] 2cache ;
\r
85 : class-or ( first second -- class )
\r
86 class-or-cache get [ (class-or) ] 2cache ;
\r
90 : superclass<= ( first second -- ? )
\r
91 swap superclass dup [ swap class<= ] [ 2drop f ] if ;
\r
93 : left-anonymous-union<= ( first second -- ? )
\r
94 [ members>> ] dip [ class<= ] curry all? ;
\r
96 : right-anonymous-union<= ( first second -- ? )
\r
97 members>> [ class<= ] with any? ;
\r
99 : left-anonymous-intersection<= ( first second -- ? )
\r
100 [ participants>> ] dip [ class<= ] curry any? ;
\r
102 : right-anonymous-intersection<= ( first second -- ? )
\r
103 participants>> [ class<= ] with all? ;
\r
105 : anonymous-complement<= ( first second -- ? )
\r
106 [ class>> ] bi@ swap class<= ;
\r
108 : normalize-complement ( class -- class' )
\r
109 class>> normalize-class {
\r
110 { [ dup anonymous-union? ] [
\r
112 [ class-not normalize-class ] map
\r
113 <anonymous-intersection>
\r
115 { [ dup anonymous-intersection? ] [
\r
117 [ class-not normalize-class ] map
\r
120 [ <anonymous-complement> ]
\r
123 : left-anonymous-complement<= ( first second -- ? )
\r
124 [ normalize-complement ] dip class<= ;
\r
126 PREDICATE: nontrivial-anonymous-complement < anonymous-complement
\r
128 [ anonymous-union? ]
\r
129 [ anonymous-intersection? ]
\r
132 } cleave or or or ;
\r
134 PREDICATE: empty-union < anonymous-union members>> empty? ;
\r
136 PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
\r
138 : (class<=) ( first second -- ? )
\r
139 2dup eq? [ 2drop t ] [
\r
140 [ normalize-class ] bi@
\r
141 2dup superclass<= [ 2drop t ] [
\r
143 { [ 2dup eq? ] [ 2drop t ] }
\r
144 { [ dup empty-intersection? ] [ 2drop t ] }
\r
145 { [ over empty-union? ] [ 2drop t ] }
\r
146 { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
\r
147 { [ over anonymous-union? ] [ left-anonymous-union<= ] }
\r
148 { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
\r
149 { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
\r
150 { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
\r
151 { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
\r
152 { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
\r
158 M: anonymous-union (classes-intersect?)
\r
159 members>> [ classes-intersect? ] with any? ;
\r
161 M: anonymous-intersection (classes-intersect?)
\r
162 participants>> [ classes-intersect? ] with all? ;
\r
164 M: anonymous-complement (classes-intersect?)
\r
165 class>> class<= not ;
\r
167 : anonymous-union-and ( first second -- class )
\r
168 members>> [ class-and ] with map <anonymous-union> ;
\r
170 : anonymous-intersection-and ( first second -- class )
\r
171 participants>> swap suffix <anonymous-intersection> ;
\r
173 : (class-and) ( first second -- class )
\r
175 { [ 2dup class<= ] [ drop ] }
\r
176 { [ 2dup swap class<= ] [ nip ] }
\r
177 { [ 2dup classes-intersect? not ] [ 2drop null ] }
\r
179 [ normalize-class ] bi@ {
\r
180 { [ dup anonymous-union? ] [ anonymous-union-and ] }
\r
181 { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] }
\r
182 { [ over anonymous-union? ] [ swap anonymous-union-and ] }
\r
183 { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] }
\r
184 [ 2array <anonymous-intersection> ]
\r
189 : anonymous-union-or ( first second -- class )
\r
190 members>> swap suffix <anonymous-union> ;
\r
192 : ((class-or)) ( first second -- class )
\r
193 [ normalize-class ] bi@ {
\r
194 { [ dup anonymous-union? ] [ anonymous-union-or ] }
\r
195 { [ over anonymous-union? ] [ swap anonymous-union-or ] }
\r
196 [ 2array <anonymous-union> ]
\r
199 : anonymous-complement-or ( first second -- class )
\r
200 2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ;
\r
202 : (class-or) ( first second -- class )
\r
204 { [ 2dup class<= ] [ nip ] }
\r
205 { [ 2dup swap class<= ] [ drop ] }
\r
206 { [ dup anonymous-complement? ] [ anonymous-complement-or ] }
\r
207 { [ over anonymous-complement? ] [ swap anonymous-complement-or ] }
\r
211 : (class-not) ( class -- complement )
\r
213 { [ dup anonymous-complement? ] [ class>> ] }
\r
214 { [ dup object eq? ] [ drop null ] }
\r
215 { [ dup null eq? ] [ drop object ] }
\r
216 [ <anonymous-complement> ]
\r
219 M: anonymous-union (flatten-class)
\r
220 members>> [ (flatten-class) ] each ;
\r
224 ERROR: topological-sort-failed ;
\r
226 : largest-class ( seq -- n elt )
\r
227 dup [ [ class< ] with any? not ] curry find-last
\r
228 [ topological-sort-failed ] unless* ;
\r
230 : sort-classes ( seq -- newseq )
\r
231 [ name>> ] sort-with >vector
\r
233 [ dup largest-class [ swap remove-nth! ] dip ]
\r
236 : smallest-class ( classes -- class/f )
\r
238 natural-sort <reversed>
\r
239 [ ] [ [ class<= ] most ] map-reduce
\r
242 : flatten-class ( class -- assoc )
\r
243 [ (flatten-class) ] H{ } make-assoc ;
\r