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