-USING: alien arrays definitions generic assocs hashtables io\r
-kernel math namespaces parser prettyprint sequences strings\r
-tools.test words quotations classes classes.algebra\r
-classes.private classes.union classes.mixin classes.predicate\r
-vectors source-files compiler.units growable random\r
-stack-checker effects kernel.private sbufs math.order\r
-classes.tuple accessors generic.private ;\r
-IN: classes.algebra.tests\r
-\r
-TUPLE: first-one ;\r
-TUPLE: second-one ;\r
-UNION: both first-one union-class ;\r
-\r
-PREDICATE: no-docs < word "documentation" word-prop not ;\r
-\r
-UNION: no-docs-union no-docs integer ;\r
-\r
-TUPLE: a ;\r
-TUPLE: b ;\r
-UNION: c a b ;\r
-\r
-TUPLE: tuple-example ;\r
-\r
-TUPLE: a1 ;\r
-TUPLE: b1 ;\r
-TUPLE: c1 ;\r
-\r
-UNION: x1 a1 b1 ;\r
-UNION: y1 a1 c1 ;\r
-UNION: z1 b1 c1 ;\r
-\r
-SINGLETON: sa\r
-SINGLETON: sb\r
-SINGLETON: sc\r
-\r
-INTERSECTION: empty-intersection ;\r
-\r
-INTERSECTION: generic-class generic class ;\r
-\r
-UNION: union-with-one-member a ;\r
-\r
-MIXIN: mixin-with-one-member\r
-INSTANCE: union-with-one-member mixin-with-one-member\r
-\r
-! class<=\r
-[ t ] [ \ fixnum \ integer class<= ] unit-test\r
-[ t ] [ \ fixnum \ fixnum class<= ] unit-test\r
-[ f ] [ \ integer \ fixnum class<= ] unit-test\r
-[ t ] [ \ integer \ object class<= ] unit-test\r
-[ f ] [ \ integer \ null class<= ] unit-test\r
-[ t ] [ \ null \ object class<= ] unit-test\r
-\r
-[ t ] [ \ generic \ word class<= ] unit-test\r
-[ f ] [ \ word \ generic class<= ] unit-test\r
-\r
-[ f ] [ \ reversed \ slice class<= ] unit-test\r
-[ f ] [ \ slice \ reversed class<= ] unit-test\r
-\r
-[ t ] [ no-docs no-docs-union class<= ] unit-test\r
-[ f ] [ no-docs-union no-docs class<= ] unit-test\r
-\r
-[ t ] [ \ c \ tuple class<= ] unit-test\r
-[ f ] [ \ tuple \ c class<= ] unit-test\r
-\r
-[ t ] [ \ tuple-class \ class class<= ] unit-test\r
-[ f ] [ \ class \ tuple-class class<= ] unit-test\r
-\r
-[ t ] [ \ null \ tuple-example class<= ] unit-test\r
-[ f ] [ \ object \ tuple-example class<= ] unit-test\r
-[ f ] [ \ object \ tuple-example class<= ] unit-test\r
-[ t ] [ \ tuple-example \ tuple class<= ] unit-test\r
-[ f ] [ \ tuple \ tuple-example class<= ] unit-test\r
-\r
-[ f ] [ z1 x1 y1 class-and class<= ] unit-test\r
-\r
-[ t ] [ x1 y1 class-and a1 class<= ] unit-test\r
-\r
-[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test\r
-\r
-[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test\r
-\r
-[ f ] [ growable tuple sequence class-and class<= ] unit-test\r
-\r
-[ f ] [ growable assoc class-and tuple class<= ] unit-test\r
-\r
-[ t ] [ object \ f \ f class-not class-or class<= ] unit-test\r
-\r
-[ t ] [ fixnum class-not integer class-and bignum class= ] unit-test\r
-\r
-[ t ] [ array number class-not class<= ] unit-test\r
-\r
-[ f ] [ bignum number class-not class<= ] unit-test\r
-\r
-[ t ] [ fixnum fixnum bignum class-or class<= ] unit-test\r
-\r
-[ f ] [ fixnum class-not integer class-and array class<= ] unit-test\r
-\r
-[ f ] [ fixnum class-not integer class<= ] unit-test\r
-\r
-[ f ] [ number class-not array class<= ] unit-test\r
-\r
-[ f ] [ fixnum class-not array class<= ] unit-test\r
-\r
-[ t ] [ number class-not integer class-not class<= ] unit-test\r
-\r
-[ f ] [ fixnum class-not integer class<= ] unit-test\r
-\r
-[ t ] [ object empty-intersection class<= ] unit-test\r
-[ t ] [ empty-intersection object class<= ] unit-test\r
-[ t ] [ \ f class-not empty-intersection class<= ] unit-test\r
-[ f ] [ empty-intersection \ f class-not class<= ] unit-test\r
-[ t ] [ \ number empty-intersection class<= ] unit-test\r
-[ t ] [ empty-intersection class-not null class<= ] unit-test\r
-[ t ] [ null empty-intersection class-not class<= ] unit-test\r
-\r
-[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test\r
-[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test\r
-\r
-[ t ] [ object \ f class-not \ f class-or class<= ] unit-test\r
-\r
-[ t ] [\r
- fixnum class-not\r
- fixnum fixnum class-not class-or\r
- class<=\r
-] unit-test\r
-\r
-[ t ] [ generic-class generic class<= ] unit-test\r
-[ t ] [ generic-class \ class class<= ] unit-test\r
-\r
-[ t ] [ a union-with-one-member class<= ] unit-test\r
-[ f ] [ union-with-one-member class-not integer class<= ] unit-test\r
-\r
-MIXIN: empty-mixin\r
-\r
-[ f ] [ empty-mixin class-not null class<= ] unit-test\r
-[ f ] [ empty-mixin null class<= ] unit-test\r
-\r
-[ t ] [ array sequence vector class-not class-and class<= ] unit-test\r
-[ f ] [ vector sequence vector class-not class-and class<= ] unit-test\r
-\r
-! class-and\r
-: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
-\r
-[ t ] [ object object object class-and* ] unit-test\r
-[ t ] [ fixnum object fixnum class-and* ] unit-test\r
-[ t ] [ object fixnum fixnum class-and* ] unit-test\r
-[ t ] [ fixnum fixnum fixnum class-and* ] unit-test\r
-[ t ] [ fixnum integer fixnum class-and* ] unit-test\r
-[ t ] [ integer fixnum fixnum class-and* ] unit-test\r
-\r
-[ t ] [ vector fixnum null class-and* ] unit-test\r
-[ t ] [ number object number class-and* ] unit-test\r
-[ t ] [ object number number class-and* ] unit-test\r
-[ t ] [ slice reversed null class-and* ] unit-test\r
-[ t ] [ \ f class-not \ f null class-and* ] unit-test\r
-\r
-[ t ] [ vector array class-not vector class-and* ] unit-test\r
-\r
-! class-or\r
-: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;\r
-\r
-[ t ] [ \ f class-not \ f object class-or* ] unit-test\r
-\r
-! class-not\r
-[ vector ] [ vector class-not class-not ] unit-test\r
-\r
-! classes-intersect?\r
-[ t ] [ both tuple classes-intersect? ] unit-test\r
-\r
-[ f ] [ vector virtual-sequence classes-intersect? ] unit-test\r
-\r
-[ t ] [ number vector class-or sequence classes-intersect? ] unit-test\r
-\r
-[ f ] [ number vector class-and sequence classes-intersect? ] unit-test\r
-\r
-[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test\r
-\r
-[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test\r
-\r
-[ f ] [ integer integer class-not classes-intersect? ] unit-test\r
-\r
-[ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test\r
-\r
-[ t ] [ \ word generic-class classes-intersect? ] unit-test\r
-[ f ] [ number generic-class classes-intersect? ] unit-test\r
-\r
-[ f ] [ sa sb classes-intersect? ] unit-test\r
-\r
-[ t ] [ a union-with-one-member classes-intersect? ] unit-test\r
-[ f ] [ fixnum union-with-one-member classes-intersect? ] unit-test\r
-[ t ] [ object union-with-one-member classes-intersect? ] unit-test\r
-\r
-[ t ] [ union-with-one-member a classes-intersect? ] unit-test\r
-[ f ] [ union-with-one-member fixnum classes-intersect? ] unit-test\r
-[ t ] [ union-with-one-member object classes-intersect? ] unit-test\r
-\r
-[ t ] [ a mixin-with-one-member classes-intersect? ] unit-test\r
-[ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test\r
-[ t ] [ object mixin-with-one-member classes-intersect? ] unit-test\r
-\r
-[ t ] [ mixin-with-one-member a classes-intersect? ] unit-test\r
-[ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test\r
-[ t ] [ mixin-with-one-member object classes-intersect? ] unit-test\r
-\r
-! class=\r
-[ t ] [ null class-not object class= ] unit-test\r
-\r
-[ t ] [ object class-not null class= ] unit-test\r
-\r
-[ f ] [ object class-not object class= ] unit-test\r
-\r
-[ f ] [ null class-not null class= ] unit-test\r
-\r
-! class<=>\r
-\r
-[ +lt+ ] [ sequence object class<=> ] unit-test\r
-[ +gt+ ] [ object sequence class<=> ] unit-test\r
-[ +eq+ ] [ integer integer class<=> ] unit-test\r
-\r
-! smallest-class etc\r
-[ real ] [ { real sequence } smallest-class ] unit-test\r
-[ real ] [ { sequence real } smallest-class ] unit-test\r
-\r
-: min-class ( class classes -- class/f )\r
- interesting-classes smallest-class ;\r
-\r
-[ f ] [ fixnum { } min-class ] unit-test\r
-\r
-[ string ] [\r
- \ string\r
- [ integer string array reversed sbuf\r
- slice vector quotation ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ fixnum ] [\r
- \ fixnum\r
- [ fixnum integer object ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ integer ] [\r
- \ fixnum\r
- [ integer float object ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ object ] [\r
- \ word\r
- [ integer float object ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ reversed ] [\r
- \ reversed\r
- [ integer reversed slice ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ f ] [ null { number fixnum null } min-class ] unit-test\r
-\r
-! Test for hangs?\r
-: random-class ( -- class ) classes random ;\r
-\r
-: random-op ( -- word )\r
- {\r
- class-and\r
- class-or\r
- class-not\r
- } random ;\r
-\r
-10 [\r
- [ ] [\r
- 20 [ random-op ] [ ] replicate-as\r
- [ infer in>> length [ random-class ] times ] keep\r
- call\r
- drop\r
- ] unit-test\r
-] times\r
-\r
-: random-boolean ( -- ? )\r
- { t f } random ;\r
-\r
-: boolean>class ( ? -- class )\r
- object null ? ;\r
-\r
-: random-boolean-op ( -- word )\r
- {\r
- and\r
- or\r
- not\r
- xor\r
- } random ;\r
-\r
-: class-xor ( cls1 cls2 -- cls3 )\r
- [ class-or ] 2keep class-and class-not class-and ;\r
-\r
-: boolean-op>class-op ( word -- word' )\r
- {\r
- { and class-and }\r
- { or class-or }\r
- { not class-not }\r
- { xor class-xor }\r
- } at ;\r
-\r
-20 [\r
- [ t ] [\r
- 20 [ random-boolean-op ] [ ] replicate-as dup .\r
- [ infer in>> length [ random-boolean ] replicate dup . ] keep\r
- \r
- [ [ [ ] each ] dip call ] 2keep\r
- \r
- [ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class=\r
- \r
- =\r
- ] unit-test\r
-] times\r
-\r
-SINGLETON: xxx\r
-UNION: yyy xxx ;\r
-\r
-[ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test\r
-[ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test\r
-\r
-[ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test\r
-[ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test\r
-\r
-TUPLE: xa ;\r
-TUPLE: xb ;\r
-TUPLE: xc < xa ;\r
-TUPLE: xd < xb ;\r
-TUPLE: xe ;\r
-TUPLE: xf < xb ;\r
-TUPLE: xg < xb ;\r
-TUPLE: xh < xb ;\r
-\r
-[ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test\r
-\r
-[ H{ { word word } } ] [ \r
- generic-class flatten-class\r
-] unit-test\r
-\r
-[ sa ] [ sa { sa sb sc } min-class ] unit-test\r
-\r
-[ \ + flatten-class ] must-fail\r
+USING: alien arrays definitions generic assocs hashtables io
+kernel math namespaces parser prettyprint sequences strings
+tools.test words quotations classes classes.algebra
+classes.private classes.union classes.mixin classes.predicate
+vectors source-files compiler.units growable random
+stack-checker effects kernel.private sbufs math.order
+classes.tuple accessors generic.private ;
+IN: classes.algebra.tests
+
+TUPLE: first-one ;
+TUPLE: second-one ;
+UNION: both first-one union-class ;
+
+PREDICATE: no-docs < word "documentation" word-prop not ;
+
+UNION: no-docs-union no-docs integer ;
+
+TUPLE: a ;
+TUPLE: b ;
+UNION: c a b ;
+
+TUPLE: tuple-example ;
+
+TUPLE: a1 ;
+TUPLE: b1 ;
+TUPLE: c1 ;
+
+UNION: x1 a1 b1 ;
+UNION: y1 a1 c1 ;
+UNION: z1 b1 c1 ;
+
+SINGLETON: sa
+SINGLETON: sb
+SINGLETON: sc
+
+INTERSECTION: empty-intersection ;
+
+INTERSECTION: generic-class generic class ;
+
+UNION: union-with-one-member a ;
+
+MIXIN: mixin-with-one-member
+INSTANCE: union-with-one-member mixin-with-one-member
+
+! class<=
+[ t ] [ \ fixnum \ integer class<= ] unit-test
+[ t ] [ \ fixnum \ fixnum class<= ] unit-test
+[ f ] [ \ integer \ fixnum class<= ] unit-test
+[ t ] [ \ integer \ object class<= ] unit-test
+[ f ] [ \ integer \ null class<= ] unit-test
+[ t ] [ \ null \ object class<= ] unit-test
+
+[ t ] [ \ generic \ word class<= ] unit-test
+[ f ] [ \ word \ generic class<= ] unit-test
+
+[ f ] [ \ reversed \ slice class<= ] unit-test
+[ f ] [ \ slice \ reversed class<= ] unit-test
+
+[ t ] [ no-docs no-docs-union class<= ] unit-test
+[ f ] [ no-docs-union no-docs class<= ] unit-test
+
+[ t ] [ \ c \ tuple class<= ] unit-test
+[ f ] [ \ tuple \ c class<= ] unit-test
+
+[ t ] [ \ tuple-class \ class class<= ] unit-test
+[ f ] [ \ class \ tuple-class class<= ] unit-test
+
+[ t ] [ \ null \ tuple-example class<= ] unit-test
+[ f ] [ \ object \ tuple-example class<= ] unit-test
+[ f ] [ \ object \ tuple-example class<= ] unit-test
+[ t ] [ \ tuple-example \ tuple class<= ] unit-test
+[ f ] [ \ tuple \ tuple-example class<= ] unit-test
+
+[ f ] [ z1 x1 y1 class-and class<= ] unit-test
+
+[ t ] [ x1 y1 class-and a1 class<= ] unit-test
+
+[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test
+
+[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
+
+[ f ] [ growable tuple sequence class-and class<= ] unit-test
+
+[ f ] [ growable assoc class-and tuple class<= ] unit-test
+
+[ t ] [ object \ f \ f class-not class-or class<= ] unit-test
+
+[ t ] [ fixnum class-not integer class-and bignum class= ] unit-test
+
+[ t ] [ array number class-not class<= ] unit-test
+
+[ f ] [ bignum number class-not class<= ] unit-test
+
+[ t ] [ fixnum fixnum bignum class-or class<= ] unit-test
+
+[ f ] [ fixnum class-not integer class-and array class<= ] unit-test
+
+[ f ] [ fixnum class-not integer class<= ] unit-test
+
+[ f ] [ number class-not array class<= ] unit-test
+
+[ f ] [ fixnum class-not array class<= ] unit-test
+
+[ t ] [ number class-not integer class-not class<= ] unit-test
+
+[ f ] [ fixnum class-not integer class<= ] unit-test
+
+[ t ] [ object empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection object class<= ] unit-test
+[ t ] [ \ f class-not empty-intersection class<= ] unit-test
+[ f ] [ empty-intersection \ f class-not class<= ] unit-test
+[ t ] [ \ number empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection class-not null class<= ] unit-test
+[ t ] [ null empty-intersection class-not class<= ] unit-test
+
+[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test
+
+[ t ] [ object \ f class-not \ f class-or class<= ] unit-test
+
+[ t ] [
+ fixnum class-not
+ fixnum fixnum class-not class-or
+ class<=
+] unit-test
+
+[ t ] [ generic-class generic class<= ] unit-test
+[ t ] [ generic-class \ class class<= ] unit-test
+
+[ t ] [ a union-with-one-member class<= ] unit-test
+[ f ] [ union-with-one-member class-not integer class<= ] unit-test
+
+MIXIN: empty-mixin
+
+[ f ] [ empty-mixin class-not null class<= ] unit-test
+[ f ] [ empty-mixin null class<= ] unit-test
+
+[ t ] [ array sequence vector class-not class-and class<= ] unit-test
+[ f ] [ vector sequence vector class-not class-and class<= ] unit-test
+
+! class-and
+: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
+
+[ t ] [ object object object class-and* ] unit-test
+[ t ] [ fixnum object fixnum class-and* ] unit-test
+[ t ] [ object fixnum fixnum class-and* ] unit-test
+[ t ] [ fixnum fixnum fixnum class-and* ] unit-test
+[ t ] [ fixnum integer fixnum class-and* ] unit-test
+[ t ] [ integer fixnum fixnum class-and* ] unit-test
+
+[ t ] [ vector fixnum null class-and* ] unit-test
+[ t ] [ number object number class-and* ] unit-test
+[ t ] [ object number number class-and* ] unit-test
+[ t ] [ slice reversed null class-and* ] unit-test
+[ t ] [ \ f class-not \ f null class-and* ] unit-test
+
+[ t ] [ vector array class-not vector class-and* ] unit-test
+
+! class-or
+: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;
+
+[ t ] [ \ f class-not \ f object class-or* ] unit-test
+
+! class-not
+[ vector ] [ vector class-not class-not ] unit-test
+
+! classes-intersect?
+[ t ] [ both tuple classes-intersect? ] unit-test
+
+[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
+
+[ t ] [ number vector class-or sequence classes-intersect? ] unit-test
+
+[ f ] [ number vector class-and sequence classes-intersect? ] unit-test
+
+[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test
+
+[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
+
+[ f ] [ integer integer class-not classes-intersect? ] unit-test
+
+[ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test
+
+[ t ] [ \ word generic-class classes-intersect? ] unit-test
+[ f ] [ number generic-class classes-intersect? ] unit-test
+
+[ f ] [ sa sb classes-intersect? ] unit-test
+
+[ t ] [ a union-with-one-member classes-intersect? ] unit-test
+[ f ] [ fixnum union-with-one-member classes-intersect? ] unit-test
+[ t ] [ object union-with-one-member classes-intersect? ] unit-test
+
+[ t ] [ union-with-one-member a classes-intersect? ] unit-test
+[ f ] [ union-with-one-member fixnum classes-intersect? ] unit-test
+[ t ] [ union-with-one-member object classes-intersect? ] unit-test
+
+[ t ] [ a mixin-with-one-member classes-intersect? ] unit-test
+[ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test
+[ t ] [ object mixin-with-one-member classes-intersect? ] unit-test
+
+[ t ] [ mixin-with-one-member a classes-intersect? ] unit-test
+[ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test
+[ t ] [ mixin-with-one-member object classes-intersect? ] unit-test
+
+! class=
+[ t ] [ null class-not object class= ] unit-test
+
+[ t ] [ object class-not null class= ] unit-test
+
+[ f ] [ object class-not object class= ] unit-test
+
+[ f ] [ null class-not null class= ] unit-test
+
+! class<=>
+
+[ +lt+ ] [ sequence object class<=> ] unit-test
+[ +gt+ ] [ object sequence class<=> ] unit-test
+[ +eq+ ] [ integer integer class<=> ] unit-test
+
+! smallest-class etc
+[ real ] [ { real sequence } smallest-class ] unit-test
+[ real ] [ { sequence real } smallest-class ] unit-test
+
+: min-class ( class classes -- class/f )
+ interesting-classes smallest-class ;
+
+[ f ] [ fixnum { } min-class ] unit-test
+
+[ string ] [
+ \ string
+ [ integer string array reversed sbuf
+ slice vector quotation ]
+ sort-classes min-class
+] unit-test
+
+[ fixnum ] [
+ \ fixnum
+ [ fixnum integer object ]
+ sort-classes min-class
+] unit-test
+
+[ integer ] [
+ \ fixnum
+ [ integer float object ]
+ sort-classes min-class
+] unit-test
+
+[ object ] [
+ \ word
+ [ integer float object ]
+ sort-classes min-class
+] unit-test
+
+[ reversed ] [
+ \ reversed
+ [ integer reversed slice ]
+ sort-classes min-class
+] unit-test
+
+[ f ] [ null { number fixnum null } min-class ] unit-test
+
+! Test for hangs?
+: random-class ( -- class ) classes random ;
+
+: random-op ( -- word )
+ {
+ class-and
+ class-or
+ class-not
+ } random ;
+
+10 [
+ [ ] [
+ 20 [ random-op ] [ ] replicate-as
+ [ infer in>> length [ random-class ] times ] keep
+ call
+ drop
+ ] unit-test
+] times
+
+: random-boolean ( -- ? )
+ { t f } random ;
+
+: boolean>class ( ? -- class )
+ object null ? ;
+
+: random-boolean-op ( -- word )
+ {
+ and
+ or
+ not
+ xor
+ } random ;
+
+: class-xor ( cls1 cls2 -- cls3 )
+ [ class-or ] 2keep class-and class-not class-and ;
+
+: boolean-op>class-op ( word -- word' )
+ {
+ { and class-and }
+ { or class-or }
+ { not class-not }
+ { xor class-xor }
+ } at ;
+
+20 [
+ [ t ] [
+ 20 [ random-boolean-op ] [ ] replicate-as dup .
+ [ infer in>> length [ random-boolean ] replicate dup . ] keep
+
+ [ [ [ ] each ] dip call ] 2keep
+
+ [ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class=
+
+ =
+ ] unit-test
+] times
+
+SINGLETON: xxx
+UNION: yyy xxx ;
+
+[ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test
+[ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test
+
+[ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test
+[ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test
+
+TUPLE: xa ;
+TUPLE: xb ;
+TUPLE: xc < xa ;
+TUPLE: xd < xb ;
+TUPLE: xe ;
+TUPLE: xf < xb ;
+TUPLE: xg < xb ;
+TUPLE: xh < xb ;
+
+[ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test
+
+[ H{ { word word } } ] [
+ generic-class flatten-class
+] unit-test
+
+[ sa ] [ sa { sa sb sc } min-class ] unit-test
+
+[ \ + flatten-class ] must-fail
projects / factor.git / blobdiff