1 USING: alien arrays definitions generic assocs hashtables io
\r
2 kernel math namespaces parser prettyprint sequences strings
\r
3 tools.test words quotations classes classes.algebra
\r
4 classes.private classes.union classes.mixin classes.predicate
\r
5 vectors source-files compiler.units growable random
\r
6 stack-checker effects kernel.private sbufs math.order
\r
7 classes.tuple accessors ;
\r
8 IN: classes.algebra.tests
\r
10 : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
\r
12 : class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;
\r
14 [ t ] [ object object object class-and* ] unit-test
\r
15 [ t ] [ fixnum object fixnum class-and* ] unit-test
\r
16 [ t ] [ object fixnum fixnum class-and* ] unit-test
\r
17 [ t ] [ fixnum fixnum fixnum class-and* ] unit-test
\r
18 [ t ] [ fixnum integer fixnum class-and* ] unit-test
\r
19 [ t ] [ integer fixnum fixnum class-and* ] unit-test
\r
21 [ t ] [ vector fixnum null class-and* ] unit-test
\r
22 [ t ] [ number object number class-and* ] unit-test
\r
23 [ t ] [ object number number class-and* ] unit-test
\r
24 [ t ] [ slice reversed null class-and* ] unit-test
\r
25 [ t ] [ \ f class-not \ f null class-and* ] unit-test
\r
26 [ t ] [ \ f class-not \ f object class-or* ] unit-test
\r
30 UNION: both first-one union-class ;
\r
32 [ t ] [ both tuple classes-intersect? ] unit-test
\r
33 [ t ] [ vector virtual-sequence null class-and* ] unit-test
\r
34 [ f ] [ vector virtual-sequence classes-intersect? ] unit-test
\r
36 [ t ] [ number vector class-or sequence classes-intersect? ] unit-test
\r
38 [ f ] [ number vector class-and sequence classes-intersect? ] unit-test
\r
40 [ t ] [ \ fixnum \ integer class<= ] unit-test
\r
41 [ t ] [ \ fixnum \ fixnum class<= ] unit-test
\r
42 [ f ] [ \ integer \ fixnum class<= ] unit-test
\r
43 [ t ] [ \ integer \ object class<= ] unit-test
\r
44 [ f ] [ \ integer \ null class<= ] unit-test
\r
45 [ t ] [ \ null \ object class<= ] unit-test
\r
47 [ t ] [ \ generic \ word class<= ] unit-test
\r
48 [ f ] [ \ word \ generic class<= ] unit-test
\r
50 [ f ] [ \ reversed \ slice class<= ] unit-test
\r
51 [ f ] [ \ slice \ reversed class<= ] unit-test
\r
53 PREDICATE: no-docs < word "documentation" word-prop not ;
\r
55 UNION: no-docs-union no-docs integer ;
\r
57 [ t ] [ no-docs no-docs-union class<= ] unit-test
\r
58 [ f ] [ no-docs-union no-docs class<= ] unit-test
\r
64 [ t ] [ \ c \ tuple class<= ] unit-test
\r
65 [ f ] [ \ tuple \ c class<= ] unit-test
\r
67 [ t ] [ \ tuple-class \ class class<= ] unit-test
\r
68 [ f ] [ \ class \ tuple-class class<= ] unit-test
\r
70 TUPLE: tuple-example ;
\r
72 [ t ] [ \ null \ tuple-example class<= ] unit-test
\r
73 [ f ] [ \ object \ tuple-example class<= ] unit-test
\r
74 [ f ] [ \ object \ tuple-example class<= ] unit-test
\r
75 [ t ] [ \ tuple-example \ tuple class<= ] unit-test
\r
76 [ f ] [ \ tuple \ tuple-example class<= ] unit-test
\r
86 [ f ] [ z1 x1 y1 class-and class<= ] unit-test
\r
88 [ t ] [ x1 y1 class-and a1 class<= ] unit-test
\r
90 [ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test
\r
92 [ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test
\r
94 [ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
\r
96 [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
\r
98 [ f ] [ growable \ hi-tag classes-intersect? ] unit-test
\r
101 growable tuple sequence class-and class<=
\r
105 growable assoc class-and tuple class<=
\r
108 [ t ] [ object \ f \ f class-not class-or class<= ] unit-test
\r
110 [ t ] [ fixnum class-not integer class-and bignum class= ] unit-test
\r
112 [ f ] [ integer integer class-not classes-intersect? ] unit-test
\r
114 [ t ] [ array number class-not class<= ] unit-test
\r
116 [ f ] [ bignum number class-not class<= ] unit-test
\r
118 [ vector ] [ vector class-not class-not ] unit-test
\r
120 [ t ] [ fixnum fixnum bignum class-or class<= ] unit-test
\r
122 [ f ] [ fixnum class-not integer class-and array class<= ] unit-test
\r
124 [ f ] [ fixnum class-not integer class<= ] unit-test
\r
126 [ f ] [ number class-not array class<= ] unit-test
\r
128 [ f ] [ fixnum class-not array class<= ] unit-test
\r
130 [ t ] [ number class-not integer class-not class<= ] unit-test
\r
132 [ t ] [ vector array class-not class-and vector class= ] unit-test
\r
134 [ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test
\r
136 [ f ] [ fixnum class-not integer class<= ] unit-test
\r
138 [ t ] [ null class-not object class= ] unit-test
\r
140 [ t ] [ object class-not null class= ] unit-test
\r
142 [ f ] [ object class-not object class= ] unit-test
\r
144 [ f ] [ null class-not null class= ] unit-test
\r
148 fixnum fixnum class-not class-or
\r
152 ! Test method inlining
\r
153 [ f ] [ fixnum { } min-class ] unit-test
\r
157 [ integer string array reversed sbuf
\r
158 slice vector quotation ]
\r
159 sort-classes min-class
\r
164 [ fixnum integer object ]
\r
165 sort-classes min-class
\r
170 [ integer float object ]
\r
171 sort-classes min-class
\r
176 [ integer float object ]
\r
177 sort-classes min-class
\r
182 [ integer reversed slice ]
\r
183 sort-classes min-class
\r
186 [ f ] [ null { number fixnum null } min-class ] unit-test
\r
189 : random-class ( -- class ) classes random ;
\r
191 : random-op ( -- word )
\r
200 20 [ random-op ] [ ] replicate-as
\r
201 [ infer in>> [ random-class ] times ] keep
\r
207 : random-boolean ( -- ? )
\r
210 : boolean>class ( ? -- class )
\r
213 : random-boolean-op ( -- word )
\r
221 : class-xor ( cls1 cls2 -- cls3 )
\r
222 [ class-or ] 2keep class-and class-not class-and ;
\r
224 : boolean-op>class-op ( word -- word' )
\r
234 20 [ random-boolean-op ] [ ] replicate-as dup .
\r
235 [ infer in>> [ random-boolean ] replicate dup . ] keep
\r
237 [ [ [ ] each ] dip call ] 2keep
\r
239 [ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class=
\r
248 [ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test
\r
249 [ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test
\r
251 [ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test
\r
252 [ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test
\r
263 [ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test
\r
265 INTERSECTION: generic-class generic class ;
\r
267 [ t ] [ generic-class generic class<= ] unit-test
\r
268 [ t ] [ generic-class \ class class<= ] unit-test
\r
272 [ t ] [ \ class generic class-and generic-class class<= ] unit-test
\r
273 [ t ] [ \ class generic class-and generic-class swap class<= ] unit-test
\r
276 [ t ] [ \ word generic-class classes-intersect? ] unit-test
\r
277 [ f ] [ number generic-class classes-intersect? ] unit-test
\r
279 [ H{ { word word } } ] [
\r
280 generic-class flatten-class
\r
283 [ \ + flatten-class ] must-fail
\r
285 INTERSECTION: empty-intersection ;
\r
287 [ t ] [ object empty-intersection class<= ] unit-test
\r
288 [ t ] [ empty-intersection object class<= ] unit-test
\r
289 [ t ] [ \ f class-not empty-intersection class<= ] unit-test
\r
290 [ f ] [ empty-intersection \ f class-not class<= ] unit-test
\r
291 [ t ] [ \ number empty-intersection class<= ] unit-test
\r
292 [ t ] [ empty-intersection class-not null class<= ] unit-test
\r
293 [ t ] [ null empty-intersection class-not class<= ] unit-test
\r
295 [ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test
\r
296 [ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test
\r
298 [ t ] [ object \ f class-not \ f class-or class<= ] unit-test
\r
300 [ ] [ object flatten-builtin-class drop ] unit-test
\r
306 [ sa ] [ sa { sa sb sc } min-class ] unit-test
\r
308 [ f ] [ sa sb classes-intersect? ] unit-test
\r
310 [ +lt+ ] [ integer sequence class<=> ] unit-test
\r
311 [ +lt+ ] [ sequence object class<=> ] unit-test
\r
312 [ +gt+ ] [ object sequence class<=> ] unit-test
\r
313 [ +eq+ ] [ integer integer class<=> ] unit-test
\r
317 ! UNION: u1 sa sb ;
\r
320 ! [ f ] [ u1 u2 classes-intersect? ] unit-test
\r