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