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