core/classes/algebra/algebra-tests.factor

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