core/classes/algebra/algebra-tests.factor

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