core/classes/algebra/algebra-tests.factor

   1 USING: alien arrays definitions generic assocs hashtables io\r
   2 kernel math namespaces parser prettyprint sequences strings\r
   3 tools.test vectors words quotations classes classes.algebra\r
   4 classes.private classes.union classes.mixin classes.predicate\r
   5 vectors definitions source-files compiler.units growable\r
   6 random stack-checker effects kernel.private sbufs math.order\r
   7 classes.tuple accessors ;\r
   8 IN: classes.algebra.tests\r
   9 \r
  10 \ class< must-infer\r
  11 \ class-and must-infer\r
  12 \ class-or must-infer\r
  13 \ flatten-class must-infer\r
  14 \ flatten-builtin-class must-infer\r
  15 \r
  16 : class-and* ( cls1 cls2 cls3 -- ? ) >r class-and r> class= ;\r
  17 \r
  18 : class-or* ( cls1 cls2 cls3 -- ? ) >r class-or r> class= ;\r
  19 \r
  20 [ t ] [ object  object  object class-and* ] unit-test\r
  21 [ t ] [ fixnum  object  fixnum class-and* ] unit-test\r
  22 [ t ] [ object  fixnum  fixnum class-and* ] unit-test\r
  23 [ t ] [ fixnum  fixnum  fixnum class-and* ] unit-test\r
  24 [ t ] [ fixnum  integer fixnum class-and* ] unit-test\r
  25 [ t ] [ integer fixnum  fixnum class-and* ] unit-test\r
  26 \r
  27 [ t ] [ vector    fixnum   null   class-and* ] unit-test\r
  28 [ t ] [ number    object   number class-and* ] unit-test\r
  29 [ t ] [ object    number   number class-and* ] unit-test\r
  30 [ t ] [ slice     reversed null   class-and* ] unit-test\r
  31 [ t ] [ \ f class-not \ f      null   class-and* ] unit-test\r
  32 [ t ] [ \ f class-not \ f      object class-or*  ] unit-test\r
  33 \r
  34 TUPLE: first-one ;\r
  35 TUPLE: second-one ;\r
  36 UNION: both first-one union-class ;\r
  37 \r
  38 [ t ] [ both tuple classes-intersect? ] unit-test\r
  39 [ t ] [ vector virtual-sequence null class-and* ] unit-test\r
  40 [ f ] [ vector virtual-sequence classes-intersect? ] unit-test\r
  41 \r
  42 [ t ] [ number vector class-or sequence classes-intersect? ] unit-test\r
  43 \r
  44 [ f ] [ number vector class-and sequence classes-intersect? ] unit-test\r
  45 \r
  46 [ t ] [ \ fixnum \ integer class<= ] unit-test\r
  47 [ t ] [ \ fixnum \ fixnum class<= ] unit-test\r
  48 [ f ] [ \ integer \ fixnum class<= ] unit-test\r
  49 [ t ] [ \ integer \ object class<= ] unit-test\r
  50 [ f ] [ \ integer \ null class<= ] unit-test\r
  51 [ t ] [ \ null \ object class<= ] unit-test\r
  52 \r
  53 [ t ] [ \ generic \ word class<= ] unit-test\r
  54 [ f ] [ \ word \ generic class<= ] unit-test\r
  55 \r
  56 [ f ] [ \ reversed \ slice class<= ] unit-test\r
  57 [ f ] [ \ slice \ reversed class<= ] unit-test\r
  58 \r
  59 PREDICATE: no-docs < word "documentation" word-prop not ;\r
  60 \r
  61 UNION: no-docs-union no-docs integer ;\r
  62 \r
  63 [ t ] [ no-docs no-docs-union class<= ] unit-test\r
  64 [ f ] [ no-docs-union no-docs class<= ] unit-test\r
  65 \r
  66 TUPLE: a ;\r
  67 TUPLE: b ;\r
  68 UNION: c a b ;\r
  69 \r
  70 [ t ] [ \ c \ tuple class<= ] unit-test\r
  71 [ f ] [ \ tuple \ c class<= ] unit-test\r
  72 \r
  73 [ t ] [ \ tuple-class \ class class<= ] unit-test\r
  74 [ f ] [ \ class \ tuple-class class<= ] unit-test\r
  75 \r
  76 TUPLE: tuple-example ;\r
  77 \r
  78 [ t ] [ \ null \ tuple-example class<= ] unit-test\r
  79 [ f ] [ \ object \ tuple-example class<= ] unit-test\r
  80 [ f ] [ \ object \ tuple-example class<= ] unit-test\r
  81 [ t ] [ \ tuple-example \ tuple class<= ] unit-test\r
  82 [ f ] [ \ tuple \ tuple-example class<= ] unit-test\r
  83 \r
  84 TUPLE: a1 ;\r
  85 TUPLE: b1 ;\r
  86 TUPLE: c1 ;\r
  87 \r
  88 UNION: x1 a1 b1 ;\r
  89 UNION: y1 a1 c1 ;\r
  90 UNION: z1 b1 c1 ;\r
  91 \r
  92 [ f ] [ z1 x1 y1 class-and class<= ] unit-test\r
  93 \r
  94 [ t ] [ x1 y1 class-and a1 class<= ] unit-test\r
  95 \r
  96 [ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test\r
  97 \r
  98 [ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test\r
  99 \r
 100 [ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test\r
 101 \r
 102 [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test\r
 103 \r
 104 [ f ] [ growable \ hi-tag classes-intersect? ] unit-test\r
 105 \r
 106 [ t ] [\r
 107     growable tuple sequence class-and class<=\r
 108 ] unit-test\r
 109 \r
 110 [ t ] [\r
 111     growable assoc class-and tuple class<=\r
 112 ] unit-test\r
 113 \r
 114 [ t ] [ object \ f \ f class-not class-or class<= ] unit-test\r
 115 \r
 116 [ t ] [ fixnum class-not integer class-and bignum class= ] unit-test\r
 117 \r
 118 [ f ] [ integer integer class-not classes-intersect? ] unit-test\r
 119 \r
 120 [ t ] [ array number class-not class<= ] unit-test\r
 121 \r
 122 [ f ] [ bignum number class-not class<= ] unit-test\r
 123 \r
 124 [ vector ] [ vector class-not class-not ] unit-test\r
 125 \r
 126 [ t ] [ fixnum fixnum bignum class-or class<= ] unit-test\r
 127 \r
 128 [ f ] [ fixnum class-not integer class-and array class<= ] unit-test\r
 129 \r
 130 [ f ] [ fixnum class-not integer class<= ] unit-test\r
 131 \r
 132 [ f ] [ number class-not array class<= ] unit-test\r
 133 \r
 134 [ f ] [ fixnum class-not array class<= ] unit-test\r
 135 \r
 136 [ t ] [ number class-not integer class-not class<= ] unit-test\r
 137 \r
 138 [ t ] [ vector array class-not class-and vector class= ] unit-test\r
 139 \r
 140 [ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test\r
 141 \r
 142 [ f ] [ fixnum class-not integer class<= ] unit-test\r
 143 \r
 144 [ t ] [ null class-not object class= ] unit-test\r
 145 \r
 146 [ t ] [ object class-not null class= ] unit-test\r
 147 \r
 148 [ f ] [ object class-not object class= ] unit-test\r
 149 \r
 150 [ f ] [ null class-not null class= ] unit-test\r
 151 \r
 152 [ t ] [\r
 153     fixnum class-not\r
 154     fixnum fixnum class-not class-or\r
 155     class<=\r
 156 ] unit-test\r
 157 \r
 158 ! Test method inlining\r
 159 [ f ] [ fixnum { } min-class ] unit-test\r
 160 \r
 161 [ string ] [\r
 162     \ string\r
 163     [ integer string array reversed sbuf\r
 164     slice vector quotation ]\r
 165     sort-classes min-class\r
 166 ] unit-test\r
 167 \r
 168 [ fixnum ] [\r
 169     \ fixnum\r
 170     [ fixnum integer object ]\r
 171     sort-classes min-class\r
 172 ] unit-test\r
 173 \r
 174 [ integer ] [\r
 175     \ fixnum\r
 176     [ integer float object ]\r
 177     sort-classes min-class\r
 178 ] unit-test\r
 179 \r
 180 [ object ] [\r
 181     \ word\r
 182     [ integer float object ]\r
 183     sort-classes min-class\r
 184 ] unit-test\r
 185 \r
 186 [ reversed ] [\r
 187     \ reversed\r
 188     [ integer reversed slice ]\r
 189     sort-classes min-class\r
 190 ] unit-test\r
 191 \r
 192 [ f ] [ null { number fixnum null } min-class ] unit-test\r
 193 \r
 194 ! Test for hangs?\r
 195 : random-class ( -- class ) classes random ;\r
 196 \r
 197 : random-op ( -- word )\r
 198     {\r
 199         class-and\r
 200         class-or\r
 201         class-not\r
 202     } random ;\r
 203 \r
 204 10 [\r
 205     [ ] [\r
 206         20 [ random-op ] [ ] replicate-as\r
 207         [ infer in>> [ random-class ] times ] keep\r
 208         call\r
 209         drop\r
 210     ] unit-test\r
 211 ] times\r
 212 \r
 213 : random-boolean ( -- ? )\r
 214     { t f } random ;\r
 215 \r
 216 : boolean>class ( ? -- class )\r
 217     object null ? ;\r
 218 \r
 219 : random-boolean-op ( -- word )\r
 220     {\r
 221         and\r
 222         or\r
 223         not\r
 224         xor\r
 225     } random ;\r
 226 \r
 227 : class-xor ( cls1 cls2 -- cls3 )\r
 228     [ class-or ] 2keep class-and class-not class-and ;\r
 229 \r
 230 : boolean-op>class-op ( word -- word' )\r
 231     {\r
 232         { and class-and }\r
 233         { or class-or }\r
 234         { not class-not }\r
 235         { xor class-xor }\r
 236     } at ;\r
 237 \r
 238 20 [\r
 239     [ t ] [\r
 240         20 [ random-boolean-op ] [ ] replicate-as dup .\r
 241         [ infer in>> [ random-boolean ] replicate dup . ] keep\r
 242         \r
 243         [ >r [ ] each r> call ] 2keep\r
 244         \r
 245         >r [ boolean>class ] each r> [ boolean-op>class-op ] map call object class=\r
 246         \r
 247         =\r
 248     ] unit-test\r
 249 ] times\r
 250 \r
 251 SINGLETON: xxx\r
 252 UNION: yyy xxx ;\r
 253 \r
 254 [ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test\r
 255 [ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test\r
 256 \r
 257 [ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test\r
 258 [ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test\r
 259 \r
 260 TUPLE: xa ;\r
 261 TUPLE: xb ;\r
 262 TUPLE: xc < xa ;\r
 263 TUPLE: xd < xb ;\r
 264 TUPLE: xe ;\r
 265 TUPLE: xf < xb ;\r
 266 TUPLE: xg < xb ;\r
 267 TUPLE: xh < xb ;\r
 268 \r
 269 [ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test\r
 270 \r
 271 INTERSECTION: generic-class generic class ;\r
 272 \r
 273 [ t ] [ generic-class generic class<= ] unit-test\r
 274 [ t ] [ generic-class \ class class<= ] unit-test\r
 275 \r
 276 ! Later\r
 277 [\r
 278     [ t ] [ \ class generic class-and generic-class class<= ] unit-test\r
 279     [ t ] [ \ class generic class-and generic-class swap class<= ] unit-test\r
 280 ] drop\r
 281 \r
 282 [ t ] [ \ word generic-class classes-intersect? ] unit-test\r
 283 [ f ] [ number generic-class classes-intersect? ] unit-test\r
 284 \r
 285 [ H{ { word word } } ] [ \r
 286     generic-class flatten-class\r
 287 ] unit-test\r
 288 \r
 289 [ \ + flatten-class ] must-fail\r
 290 \r
 291 INTERSECTION: empty-intersection ;\r
 292 \r
 293 [ t ] [ object empty-intersection class<= ] unit-test\r
 294 [ t ] [ empty-intersection object class<= ] unit-test\r
 295 [ t ] [ \ f class-not empty-intersection class<= ] unit-test\r
 296 [ f ] [ empty-intersection \ f class-not class<= ] unit-test\r
 297 [ t ] [ \ number empty-intersection class<= ] unit-test\r
 298 [ t ] [ empty-intersection class-not null class<= ] unit-test\r
 299 [ t ] [ null empty-intersection class-not class<= ] unit-test\r
 300 \r
 301 [ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test\r
 302 [ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test\r
 303 \r
 304 [ t ] [ object \ f class-not \ f class-or class<= ] unit-test\r
 305 \r
 306 [ ] [ object flatten-builtin-class drop ] unit-test\r
 307 \r
 308 SINGLETON: sa\r
 309 SINGLETON: sb\r
 310 SINGLETON: sc\r
 311 \r
 312 [ sa ] [ sa { sa sb sc } min-class ] unit-test\r
 313 \r
 314 [ +lt+ ] [ integer sequence class<=> ] unit-test\r
 315 [ +lt+ ] [ sequence object class<=> ] unit-test\r
 316 [ +gt+ ] [ object sequence class<=> ] unit-test\r
 317 [ +eq+ ] [ integer integer class<=> ] unit-test\r