1 USING: alien arrays definitions generic assocs hashtables io
2 kernel math namespaces parser prettyprint sequences strings
3 tools.test words quotations classes classes.algebra
4 classes.private classes.union classes.mixin classes.predicate
5 vectors source-files compiler.units growable random
6 stack-checker effects kernel.private sbufs math.order
7 classes.tuple accessors generic.private ;
8 IN: classes.algebra.tests
12 UNION: both first-one union-class ;
14 PREDICATE: no-docs < word "documentation" word-prop not ;
16 UNION: no-docs-union no-docs integer ;
22 TUPLE: tuple-example ;
36 INTERSECTION: empty-intersection ;
38 INTERSECTION: generic-class generic class ;
40 UNION: union-with-one-member a ;
42 MIXIN: mixin-with-one-member
43 INSTANCE: union-with-one-member mixin-with-one-member
46 { t } [ \ fixnum \ integer class<= ] unit-test
47 { t } [ \ fixnum \ fixnum class<= ] unit-test
48 { f } [ \ integer \ fixnum class<= ] unit-test
49 { t } [ \ integer \ object class<= ] unit-test
50 { f } [ \ integer \ null class<= ] unit-test
51 { t } [ \ null \ object class<= ] unit-test
53 { t } [ \ generic \ word class<= ] unit-test
54 { f } [ \ word \ generic class<= ] unit-test
56 { f } [ \ reversed \ slice class<= ] unit-test
57 { f } [ \ slice \ reversed class<= ] unit-test
59 { t } [ no-docs no-docs-union class<= ] unit-test
60 { f } [ no-docs-union no-docs class<= ] unit-test
62 { t } [ \ c \ tuple class<= ] unit-test
63 { f } [ \ tuple \ c class<= ] unit-test
65 { t } [ \ tuple-class \ class class<= ] unit-test
66 { f } [ \ class \ tuple-class class<= ] unit-test
68 { t } [ \ null \ tuple-example class<= ] unit-test
69 { f } [ \ object \ tuple-example class<= ] unit-test
70 { f } [ \ object \ tuple-example class<= ] unit-test
71 { t } [ \ tuple-example \ tuple class<= ] unit-test
72 { f } [ \ tuple \ tuple-example class<= ] unit-test
74 { f } [ z1 x1 y1 class-and class<= ] unit-test
76 { t } [ x1 y1 class-and a1 class<= ] unit-test
78 { f } [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test
80 { t } [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
82 { f } [ growable tuple sequence class-and class<= ] unit-test
84 { f } [ growable assoc class-and tuple class<= ] unit-test
86 { t } [ object \ f \ f class-not class-or class<= ] unit-test
88 { t } [ fixnum class-not integer class-and bignum class= ] unit-test
90 { t } [ array number class-not class<= ] unit-test
92 { f } [ bignum number class-not class<= ] unit-test
94 { t } [ fixnum fixnum bignum class-or class<= ] unit-test
96 { f } [ fixnum class-not integer class-and array class<= ] unit-test
98 { f } [ fixnum class-not integer class<= ] unit-test
100 { f } [ number class-not array class<= ] unit-test
102 { f } [ fixnum class-not array class<= ] unit-test
104 { t } [ number class-not integer class-not class<= ] unit-test
106 { f } [ fixnum class-not integer class<= ] unit-test
108 { t } [ object empty-intersection class<= ] unit-test
109 { t } [ empty-intersection object class<= ] unit-test
110 { t } [ \ f class-not empty-intersection class<= ] unit-test
111 { f } [ empty-intersection \ f class-not class<= ] unit-test
112 { t } [ \ number empty-intersection class<= ] unit-test
113 { t } [ empty-intersection class-not null class<= ] unit-test
114 { t } [ null empty-intersection class-not class<= ] unit-test
116 { t } [ \ f class-not \ f class-or empty-intersection class<= ] unit-test
117 { t } [ empty-intersection \ f class-not \ f class-or class<= ] unit-test
119 { t } [ object \ f class-not \ f class-or class<= ] unit-test
123 fixnum fixnum class-not class-or
127 { t } [ generic-class generic class<= ] unit-test
128 { t } [ generic-class \ class class<= ] unit-test
130 { t } [ a union-with-one-member class<= ] unit-test
131 { f } [ union-with-one-member class-not integer class<= ] unit-test
135 { f } [ empty-mixin class-not null class<= ] unit-test
136 { f } [ empty-mixin null class<= ] unit-test
138 { t } [ empty-mixin class-not object class<= ] unit-test
139 { t } [ empty-mixin object class<= ] unit-test
141 { t } [ empty-mixin class-not object class<= ] unit-test
142 { t } [ empty-mixin object class<= ] unit-test
144 { t } [ object empty-mixin class-not class<= ] unit-test
146 { t } [ array sequence vector class-not class-and class<= ] unit-test
147 { f } [ vector sequence vector class-not class-and class<= ] unit-test
150 : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
152 { t } [ object object object class-and* ] unit-test
153 { t } [ fixnum object fixnum class-and* ] unit-test
154 { t } [ object fixnum fixnum class-and* ] unit-test
155 { t } [ fixnum fixnum fixnum class-and* ] unit-test
156 { t } [ fixnum integer fixnum class-and* ] unit-test
157 { t } [ integer fixnum fixnum class-and* ] unit-test
159 { t } [ vector fixnum null class-and* ] unit-test
160 { t } [ number object number class-and* ] unit-test
161 { t } [ object number number class-and* ] unit-test
162 { t } [ slice reversed null class-and* ] unit-test
163 { t } [ \ f class-not \ f null class-and* ] unit-test
165 { t } [ vector array class-not vector class-and* ] unit-test
167 { object } [ object empty-mixin class-not class-and ] unit-test
168 { object } [ empty-mixin class-not object class-and ] unit-test
171 : class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;
173 { t } [ \ f class-not \ f object class-or* ] unit-test
175 { object } [ object empty-mixin class-not class-or ] unit-test
176 { object } [ empty-mixin class-not object class-or ] unit-test
179 { vector } [ vector class-not class-not ] unit-test
182 { t } [ both tuple classes-intersect? ] unit-test
183 { t } [ tuple both classes-intersect? ] unit-test
185 { f } [ vector virtual-sequence classes-intersect? ] unit-test
186 { f } [ virtual-sequence vector classes-intersect? ] unit-test
188 { t } [ number vector class-or sequence classes-intersect? ] unit-test
189 { t } [ sequence number vector class-or classes-intersect? ] unit-test
191 { f } [ number vector class-and sequence classes-intersect? ] unit-test
192 { f } [ sequence number vector class-and classes-intersect? ] unit-test
194 { f } [ y1 z1 class-and x1 classes-intersect? ] unit-test
195 { f } [ x1 y1 z1 class-and classes-intersect? ] unit-test
197 { f } [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
198 { f } [ a1 b1 class-or a1 c1 class-or b1 c1 class-or class-and classes-intersect? ] unit-test
200 { f } [ integer integer class-not classes-intersect? ] unit-test
201 { f } [ integer class-not integer classes-intersect? ] unit-test
203 { f } [ fixnum class-not number class-and array classes-intersect? ] unit-test
204 { f } [ array fixnum class-not number class-and classes-intersect? ] unit-test
206 { t } [ \ word generic-class classes-intersect? ] unit-test
207 { t } [ generic-class \ word classes-intersect? ] unit-test
208 { f } [ number generic-class classes-intersect? ] unit-test
209 { f } [ generic-class number classes-intersect? ] unit-test
211 { f } [ sa sb classes-intersect? ] unit-test
212 { f } [ sb sa classes-intersect? ] unit-test
214 { t } [ a union-with-one-member classes-intersect? ] unit-test
215 { f } [ fixnum union-with-one-member classes-intersect? ] unit-test
216 { t } [ object union-with-one-member classes-intersect? ] unit-test
218 { t } [ union-with-one-member a classes-intersect? ] unit-test
219 { f } [ union-with-one-member fixnum classes-intersect? ] unit-test
220 { t } [ union-with-one-member object classes-intersect? ] unit-test
222 { t } [ a mixin-with-one-member classes-intersect? ] unit-test
223 { f } [ fixnum mixin-with-one-member classes-intersect? ] unit-test
224 { t } [ object mixin-with-one-member classes-intersect? ] unit-test
226 { t } [ mixin-with-one-member a classes-intersect? ] unit-test
227 { f } [ mixin-with-one-member fixnum classes-intersect? ] unit-test
228 { t } [ mixin-with-one-member object classes-intersect? ] unit-test
230 { f } [ null object classes-intersect? ] unit-test
231 { f } [ object null classes-intersect? ] unit-test
233 { t } [ null class-not object class= ] unit-test
235 { t } [ object class-not null class= ] unit-test
237 { f } [ object class-not object class= ] unit-test
239 { f } [ null class-not null class= ] unit-test
242 { real } [ { real sequence } smallest-class ] unit-test
243 { real } [ { sequence real } smallest-class ] unit-test
245 : min-class ( class classes -- class/f )
246 interesting-classes smallest-class ;
248 { f } [ fixnum { } min-class ] unit-test
252 [ integer string array reversed sbuf
253 slice vector quotation ]
254 sort-classes min-class
259 [ fixnum integer object ]
260 sort-classes min-class
265 [ integer float object ]
266 sort-classes min-class
271 [ integer float object ]
272 sort-classes min-class
277 [ integer reversed slice ]
278 sort-classes min-class
281 { f } [ null { number fixnum null } min-class ] unit-test
284 : random-class ( -- class ) classes random ;
286 : random-op ( -- word )
295 20 [ random-op ] [ ] replicate-as
296 [ infer in>> length [ random-class ] times ] keep
302 : random-boolean ( -- ? )
305 : boolean>class ( ? -- class )
308 : random-boolean-op ( -- word )
316 : class-xor ( cls1 cls2 -- cls3 )
317 [ class-or ] 2keep class-and class-not class-and ;
319 : boolean-op>class-op ( word -- word' )
329 20 [ random-boolean-op ] [ ] replicate-as dup .
330 [ infer in>> length [ random-boolean ] replicate dup . ] keep
332 [ [ [ ] each ] dip call ] 2keep
334 [ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class=
343 { { yyy xxx } } [ { xxx yyy } sort-classes ] unit-test
344 { { yyy xxx } } [ { yyy xxx } sort-classes ] unit-test
346 { { number ratio integer } } [ { ratio number integer } sort-classes ] unit-test
347 { { sequence number ratio } } [ { ratio number sequence } sort-classes ] unit-test
358 { t } [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test
360 { H{ { word word } } } [
361 generic-class flatten-class
364 { sa } [ sa { sa sb sc } min-class ] unit-test
366 [ \ + flatten-class ] must-fail