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 ] [ array sequence vector class-not class-and class<= ] unit-test
139 [ f ] [ vector sequence vector class-not class-and class<= ] unit-test
142 : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
144 [ t ] [ object object object class-and* ] unit-test
145 [ t ] [ fixnum object fixnum class-and* ] unit-test
146 [ t ] [ object fixnum fixnum class-and* ] unit-test
147 [ t ] [ fixnum fixnum fixnum class-and* ] unit-test
148 [ t ] [ fixnum integer fixnum class-and* ] unit-test
149 [ t ] [ integer fixnum fixnum class-and* ] unit-test
151 [ t ] [ vector fixnum null class-and* ] unit-test
152 [ t ] [ number object number class-and* ] unit-test
153 [ t ] [ object number number class-and* ] unit-test
154 [ t ] [ slice reversed null class-and* ] unit-test
155 [ t ] [ \ f class-not \ f null class-and* ] unit-test
157 [ t ] [ vector array class-not vector class-and* ] unit-test
160 : class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;
162 [ t ] [ \ f class-not \ f object class-or* ] unit-test
165 [ vector ] [ vector class-not class-not ] unit-test
168 [ t ] [ both tuple classes-intersect? ] unit-test
170 [ f ] [ vector virtual-sequence classes-intersect? ] unit-test
172 [ t ] [ number vector class-or sequence classes-intersect? ] unit-test
174 [ f ] [ number vector class-and sequence classes-intersect? ] unit-test
176 [ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test
178 [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
180 [ f ] [ integer integer class-not classes-intersect? ] unit-test
182 [ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test
184 [ t ] [ \ word generic-class classes-intersect? ] unit-test
185 [ f ] [ number generic-class classes-intersect? ] unit-test
187 [ f ] [ sa sb classes-intersect? ] unit-test
189 [ t ] [ a union-with-one-member classes-intersect? ] unit-test
190 [ f ] [ fixnum union-with-one-member classes-intersect? ] unit-test
191 [ t ] [ object union-with-one-member classes-intersect? ] unit-test
193 [ t ] [ union-with-one-member a classes-intersect? ] unit-test
194 [ f ] [ union-with-one-member fixnum classes-intersect? ] unit-test
195 [ t ] [ union-with-one-member object classes-intersect? ] unit-test
197 [ t ] [ a mixin-with-one-member classes-intersect? ] unit-test
198 [ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test
199 [ t ] [ object mixin-with-one-member classes-intersect? ] unit-test
201 [ t ] [ mixin-with-one-member a classes-intersect? ] unit-test
202 [ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test
203 [ t ] [ mixin-with-one-member object classes-intersect? ] unit-test
206 [ t ] [ null class-not object class= ] unit-test
208 [ t ] [ object class-not null class= ] unit-test
210 [ f ] [ object class-not object class= ] unit-test
212 [ f ] [ null class-not null class= ] unit-test
216 [ +lt+ ] [ sequence object class<=> ] unit-test
217 [ +gt+ ] [ object sequence class<=> ] unit-test
218 [ +eq+ ] [ integer integer class<=> ] unit-test
221 [ real ] [ { real sequence } smallest-class ] unit-test
222 [ real ] [ { sequence real } smallest-class ] unit-test
224 : min-class ( class classes -- class/f )
225 interesting-classes smallest-class ;
227 [ f ] [ fixnum { } min-class ] unit-test
231 [ integer string array reversed sbuf
232 slice vector quotation ]
233 sort-classes min-class
238 [ fixnum integer object ]
239 sort-classes min-class
244 [ integer float object ]
245 sort-classes min-class
250 [ integer float object ]
251 sort-classes min-class
256 [ integer reversed slice ]
257 sort-classes min-class
260 [ f ] [ null { number fixnum null } min-class ] unit-test
263 : random-class ( -- class ) classes random ;
265 : random-op ( -- word )
274 20 [ random-op ] [ ] replicate-as
275 [ infer in>> length [ random-class ] times ] keep
281 : random-boolean ( -- ? )
284 : boolean>class ( ? -- class )
287 : random-boolean-op ( -- word )
295 : class-xor ( cls1 cls2 -- cls3 )
296 [ class-or ] 2keep class-and class-not class-and ;
298 : boolean-op>class-op ( word -- word' )
308 20 [ random-boolean-op ] [ ] replicate-as dup .
309 [ infer in>> length [ random-boolean ] replicate dup . ] keep
311 [ [ [ ] each ] dip call ] 2keep
313 [ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class=
322 [ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test
323 [ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test
325 [ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test
326 [ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test
337 [ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test
339 [ H{ { word word } } ] [
340 generic-class flatten-class
343 [ sa ] [ sa { sa sb sc } min-class ] unit-test
345 [ \ + flatten-class ] must-fail