basis/math/intervals/intervals-tests.factor

   1 USING: accessors combinators fry kernel literals math math.intervals
   2 math.intervals.private math.order math.statistics random sequences
   3 sequences.deep tools.test vocabs ;
   4 IN: math.intervals.tests
   5
   6 { empty-interval } [ 2 2 (a,b) ] unit-test
   7
   8 { empty-interval } [ 2 2.0 (a,b) ] unit-test
   9
  10 { empty-interval } [ 2 2 [a,b) ] unit-test
  11
  12 { empty-interval } [ 2 2 (a,b] ] unit-test
  13
  14 { empty-interval } [ 3 2 [a,b] ] unit-test
  15
  16 { T{ interval f { 1 t } { 2 t } } } [ 1 2 [a,b] ] unit-test
  17
  18 { T{ interval f { 1 t } { 2 f } } } [ 1 2 [a,b) ] unit-test
  19
  20 { T{ interval f { 1 f } { 2 f } } } [ 1 2 (a,b) ] unit-test
  21
  22 { T{ interval f { 1 f } { 2 t } } } [ 1 2 (a,b] ] unit-test
  23
  24 { T{ interval f { 1 t } { 1 t } } } [ 1 [a,a] ] unit-test
  25
  26 { T{ interval f { 0 t } { 42 t } } } [ 42 [0,b] ] unit-test
  27
  28 { T{ interval f { 0 t } { 42 f } } } [ 42 [0,b) ] unit-test
  29
  30 ! Not sure how to handle NaNs yet...
  31 ! [ 1 0/0. [a,b] ] must-fail
  32 ! [ 0/0. 1 [a,b] ] must-fail
  33
  34 { t } [ { 3 t } { 3 f } endpoint< ] unit-test
  35 { t } [ { 2 f } { 3 f } endpoint< ] unit-test
  36 { f } [ { 3 f } { 3 t } endpoint< ] unit-test
  37 { t } [ { 4 f } { 3 t } endpoint> ] unit-test
  38 { f } [ { 3 f } { 3 t } endpoint> ] unit-test
  39
  40 { empty-interval } [ 1 2 [a,b] empty-interval interval+ ] unit-test
  41
  42 { empty-interval } [ empty-interval 1 2 [a,b] interval+ ] unit-test
  43
  44 { t } [
  45     1 2 [a,b] -3 3 [a,b] interval+ -2 5 [a,b] =
  46 ] unit-test
  47
  48 { t } [
  49     1 2 [a,b] -3 3 (a,b) interval+ -2 5 (a,b) =
  50 ] unit-test
  51
  52 { empty-interval } [ 1 2 [a,b] empty-interval interval- ] unit-test
  53
  54 { empty-interval } [ empty-interval 1 2 [a,b] interval- ] unit-test
  55
  56 { t } [
  57     1 2 [a,b] 0 1 [a,b] interval- 0 2 [a,b] =
  58 ] unit-test
  59
  60 { empty-interval } [ 1 2 [a,b] empty-interval interval* ] unit-test
  61
  62 { empty-interval } [ empty-interval 1 2 [a,b] interval* ] unit-test
  63
  64 { t } [
  65     1 2 [a,b] 0 4 [a,b] interval* 0 8 [a,b] =
  66 ] unit-test
  67
  68 { t } [
  69     1 2 [a,b] -4 4 [a,b] interval* -8 8 [a,b] =
  70 ] unit-test
  71
  72 { t } [
  73     1 2 [a,b] -0.5 0.5 [a,b] interval* -1.0 1.0 [a,b] =
  74 ] unit-test
  75
  76 { t } [
  77     1 2 [a,b] -0.5 0.5 (a,b] interval* -1.0 1.0 (a,b] =
  78 ] unit-test
  79
  80 { t } [
  81     -1 1 [a,b] -1 1 (a,b] interval* -1 1 [a,b] =
  82 ] unit-test
  83
  84 { t } [ 1 2 [a,b] dup empty-interval interval-union = ] unit-test
  85
  86 { t } [ 1 2 [a,b] empty-interval over interval-union = ] unit-test
  87
  88 { t } [
  89     0 1 (a,b) 0 1 [a,b] interval-union 0 1 [a,b] =
  90 ] unit-test
  91
  92 { t } [
  93     0 1 (a,b) 1 2 [a,b] interval-union 0 2 (a,b] =
  94 ] unit-test
  95
  96 { t } [
  97     0 1 (a,b) 0 1 [a,b] interval-intersect 0 1 (a,b) =
  98 ] unit-test
  99
 100 { empty-interval } [ 0 5 [a,b] -1 [a,a] interval-intersect ] unit-test
 101
 102 { empty-interval } [ 0 5 (a,b] 0 [a,a] interval-intersect ] unit-test
 103
 104 { empty-interval } [ empty-interval -1 [a,a] interval-intersect ] unit-test
 105
 106 { empty-interval } [ 0 5 (a,b] empty-interval interval-intersect ] unit-test
 107
 108 { t } [
 109     0 1 (a,b) full-interval interval-intersect 0 1 (a,b) =
 110 ] unit-test
 111
 112 { t } [
 113     empty-interval empty-interval interval-subset?
 114 ] unit-test
 115
 116 { t } [
 117     empty-interval 0 1 [a,b] interval-subset?
 118 ] unit-test
 119
 120 { t } [
 121     0 1 (a,b) 0 1 [a,b] interval-subset?
 122 ] unit-test
 123
 124 { t } [
 125     full-interval -1/0. 1/0. [a,b] interval-subset?
 126 ] unit-test
 127
 128 { t } [
 129     -1/0. 1/0. [a,b] full-interval interval-subset?
 130 ] unit-test
 131
 132 { f } [
 133     full-interval 0 1/0. [a,b] interval-subset?
 134 ] unit-test
 135
 136 { t } [
 137     0 1/0. [a,b] full-interval interval-subset?
 138 ] unit-test
 139
 140 { f } [
 141     0 0 1 (a,b) interval-contains?
 142 ] unit-test
 143
 144 { t } [
 145     0.5 0 1 (a,b) interval-contains?
 146 ] unit-test
 147
 148 { f } [
 149     1 0 1 (a,b) interval-contains?
 150 ] unit-test
 151
 152 { empty-interval } [ -1 1 (a,b) empty-interval interval/ ] unit-test
 153
 154 { t } [ 0 0 331 [a,b) -1775 -953 (a,b) interval/ interval-contains? ] unit-test
 155
 156 { t } [ -1 1 (a,b) -1 1 (a,b) interval/ [-inf,inf] = ] unit-test
 157
 158 { t } [ -1 1 (a,b) 0 1 (a,b) interval/ [-inf,inf] = ] unit-test
 159
 160 "math.ratios.private" lookup-vocab [
 161     [ t ] [
 162         -1 1 (a,b) 0.5 1 (a,b) interval/ -2.0 2.0 (a,b) =
 163     ] unit-test
 164 ] when
 165
 166 { f } [ empty-interval interval-singleton? ] unit-test
 167
 168 { t } [ 1 [a,a] interval-singleton? ] unit-test
 169
 170 { f } [ 1 1 [a,b) interval-singleton? ] unit-test
 171
 172 { f } [ 1 3 [a,b) interval-singleton? ] unit-test
 173
 174 { f } [ 1 1 (a,b) interval-singleton? ] unit-test
 175
 176 { 2 } [ 1 3 [a,b) interval-length ] unit-test
 177
 178 { 0 } [ empty-interval interval-length ] unit-test
 179
 180 { t } [ 0 5 [a,b] 5 [a,a] interval<= ] unit-test
 181
 182 { incomparable } [ empty-interval 5 [a,a] interval< ] unit-test
 183
 184 { incomparable } [ 5 [a,a] empty-interval interval< ] unit-test
 185
 186 { incomparable } [ 0 5 [a,b] 5 [a,a] interval< ] unit-test
 187
 188 { t } [ 0 5 [a,b) 5 [a,a] interval< ] unit-test
 189
 190 { f } [ 0 5 [a,b] -1 [a,a] interval< ] unit-test
 191
 192 { incomparable } [ 0 5 [a,b] 1 [a,a] interval< ] unit-test
 193
 194 { t } [ -1 1 (a,b) -1 [a,a] interval> ] unit-test
 195
 196 { t } [ -1 1 (a,b) -1 [a,a] interval>= ] unit-test
 197
 198 { f } [ -1 1 (a,b) -1 [a,a] interval< ] unit-test
 199
 200 { f } [ -1 1 (a,b) -1 [a,a] interval<= ] unit-test
 201
 202 { t } [ -1 1 (a,b] 1 [a,a] interval<= ] unit-test
 203
 204 { t } [ -1 1 (a,b] 1 2 [a,b] interval<= ] unit-test
 205
 206 { incomparable } [ -1 1 (a,b] empty-interval interval>= ] unit-test
 207
 208 { incomparable } [ empty-interval -1 1 (a,b] interval>= ] unit-test
 209
 210 { incomparable } [ -1 1 (a,b] 1 2 [a,b] interval>= ] unit-test
 211
 212 { incomparable } [ -1 1 (a,b] 1 2 [a,b] interval> ] unit-test
 213
 214 { t } [ -1 1 (a,b] 1 2 (a,b] interval<= ] unit-test
 215
 216 { f } [ 0 10 [a,b] 0 [a,a] interval< ] unit-test
 217
 218 { f } [ 0 10 [a,b] 0.0 [a,a] interval< ] unit-test
 219
 220 { f } [ 0.0 10 [a,b] 0 [a,a] interval< ] unit-test
 221
 222 { f } [ 0 10 [a,b] 10 [a,a] interval> ] unit-test
 223
 224 { incomparable } [ 0 [a,a] 0 10 [a,b] interval< ] unit-test
 225
 226 { incomparable } [ 10 [a,a] 0 10 [a,b] interval> ] unit-test
 227
 228 { t } [ 0 [a,a] 0 10 [a,b] interval<= ] unit-test
 229
 230 { incomparable } [ 0 [a,a] 0 10 [a,b] interval>= ] unit-test
 231
 232 { t } [ 0 10 [a,b] 0 [a,a] interval>= ] unit-test
 233
 234 { t } [
 235     418
 236     418 423 [a,b)
 237     79 893 (a,b]
 238     interval-max
 239     interval-contains?
 240 ] unit-test
 241
 242 { t } [ full-interval 10 10 [a,b] interval-max 10 1/0. [a,b] = ] unit-test
 243
 244 { t } [ full-interval 10 10 [a,b] interval-min -1/0. 10 [a,b] = ] unit-test
 245
 246 { t } [ 1 100 [a,b] -1 1 [a,b] interval/i [-inf,inf] = ] unit-test
 247
 248 ! Accuracy of interval-mod
 249 { t } [ full-interval 40 40 [a,b] interval-mod -40 40 (a,b) interval-subset?
 250 ] unit-test
 251
 252 ! Interval random tester
 253 : random-element ( interval -- n )
 254     dup full-interval eq? [
 255         drop 32 random-bits 31 2^ -
 256     ] [
 257         [ ] [ from>> first ] [ to>> first ] tri over - random +
 258         2dup swap interval-contains? [
 259             nip
 260         ] [
 261             drop random-element
 262         ] if
 263     ] if ;
 264
 265 : random-interval ( -- interval )
 266     10 random 0 = [ full-interval ] [
 267         2000 random 1000 - dup 2 1000 random + +
 268         1 random zero? [ [ neg ] bi@ swap ] when
 269         4 random {
 270             { 0 [ [a,b] ] }
 271             { 1 [ [a,b) ] }
 272             { 2 [ (a,b) ] }
 273             { 3 [ (a,b] ] }
 274         } case
 275     ] if ;
 276
 277 : unary-ops ( -- alist )
 278     {
 279         { bitnot interval-bitnot }
 280         { abs interval-abs }
 281         { 2/ interval-2/ }
 282         { neg interval-neg }
 283     }
 284     "math.ratios.private" lookup-vocab [
 285         { recip interval-recip } suffix
 286     ] when ;
 287
 288 : unary-test ( op -- ? )
 289     [ random-interval ] dip
 290     0 pick interval-contains? over first \ recip eq? and [
 291         2drop t
 292     ] [
 293         [ [ random-element ] dip first execute( a -- b ) ] 2keep
 294         second execute( a -- b ) interval-contains?
 295     ] if ;
 296
 297 unary-ops [
 298     [ [ t ] ] dip '[ 8000 [ drop _ unary-test ] all-integers? ] unit-test
 299 ] each
 300
 301 : binary-ops ( -- alist )
 302     {
 303         { + interval+ }
 304         { - interval- }
 305         { * interval* }
 306         { /i interval/i }
 307         { mod interval-mod }
 308         { rem interval-rem }
 309         { bitand interval-bitand }
 310         { bitor interval-bitor }
 311         { bitxor interval-bitxor }
 312         { min interval-min }
 313         { max interval-max }
 314     }
 315     "math.ratios.private" lookup-vocab [
 316         { / interval/ } suffix
 317     ] when ;
 318
 319 : binary-test ( op -- ? )
 320     [ random-interval random-interval ] dip
 321     0 pick interval-contains? over first { / /i mod rem } member? and [
 322         3drop t
 323     ] [
 324         [ [ [ random-element ] bi@ ] dip first execute( a b -- c ) ] 3keep
 325         second execute( a b -- c ) interval-contains?
 326     ] if ;
 327
 328 binary-ops [
 329     [ [ t ] ] dip '[ 8000 <iota> [ drop _ binary-test ] all? ] unit-test
 330 ] each
 331
 332 : comparison-ops ( -- alist )
 333     {
 334         { < interval< }
 335         { <= interval<= }
 336         { > interval> }
 337         { >= interval>= }
 338     } ;
 339
 340 : comparison-test ( op -- ? )
 341     [ random-interval random-interval ] dip
 342     [ [ [ random-element ] bi@ ] dip first execute( a b -- ? ) ] 3keep
 343     second execute( a b -- ? ) dup incomparable eq? [ 2drop t ] [ = ] if ;
 344
 345 comparison-ops [
 346     [ [ t ] ] dip '[ 8000 <iota> [ drop _ comparison-test ] all? ] unit-test
 347 ] each
 348
 349 { t } [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test
 350
 351 { t } [ -10 10 [a,b] 0 100 [a,b] assume>= 0 10 [a,b] = ] unit-test
 352
 353 { t } [ -10 10 [a,b] 0 100 [a,b] assume< -10 10 [a,b] = ] unit-test
 354
 355 { t } [ -10 10 [a,b] -100 0 [a,b] assume< -10 0 [a,b) = ] unit-test
 356
 357 { t } [ -10 10 [a,b] -100 0 [a,b] assume<= -10 0 [a,b] = ] unit-test
 358
 359 { t } [ -10 10 [a,b] 0 100 [a,b] assume<= -10 10 [a,b] = ] unit-test
 360
 361 { t } [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test
 362
 363 { t } [ full-interval interval-abs [0,inf] = ] unit-test
 364
 365 { t } [ [0,inf] interval-abs [0,inf] = ] unit-test
 366
 367 { t } [ empty-interval interval-abs empty-interval = ] unit-test
 368
 369 { t } [ [0,inf] interval-sq [0,inf] = ] unit-test
 370
 371 ! Test that commutative interval ops really are
 372 : random-interval-or-empty ( -- obj )
 373     10 random 0 = [ empty-interval ] [ random-interval ] if ;
 374
 375 : commutative-ops ( -- seq )
 376     {
 377         interval+ interval*
 378         interval-bitor interval-bitand interval-bitxor
 379         interval-max interval-min
 380     } ;
 381
 382 commutative-ops [
 383     [ [ t ] ] dip '[
 384         8000 <iota> [
 385             drop
 386             random-interval-or-empty random-interval-or-empty _
 387             [ execute ] [ swapd execute ] 3bi =
 388         ] all?
 389     ] unit-test
 390 ] each
 391
 392 ! Test singleton behavior
 393 { f } [ full-interval interval-nonnegative? ] unit-test
 394
 395 { t } [ empty-interval interval-nonnegative? ] unit-test
 396
 397 { t } [ full-interval interval-zero? ] unit-test
 398
 399 { f } [ empty-interval interval-zero? ] unit-test
 400
 401 { f f } [ -1/0. 1/0. [ empty-interval interval-contains? ] bi@ ] unit-test
 402
 403 { t t } [ -1/0. 1/0. [ full-interval interval-contains? ] bi@ ] unit-test
 404
 405 ! Interval bitand
 406 ${ 0 0xaf [a,b] } [ 0 0xff [a,b] 0 0xaf [a,b] interval-bitand ] unit-test
 407 ${ -0x100 -10 [a,b] } [ -0xff -1 [a,b] -0xaf -10 [a,b] interval-bitand ] unit-test
 408 ${ -0x100 10 [a,b] } [ -0xff 1 [a,b] -0xaf 10 [a,b] interval-bitand ] unit-test
 409 ${ 0 0xff [a,b] } [ -0xff -1 [a,b] 0 0xff [a,b] interval-bitand ] unit-test
 410
 411 ! Interval bitor
 412 { 1/0. } [ 1/0. bit-weight ] unit-test
 413 { 1/0. } [ -1/0. bit-weight ] unit-test
 414
 415 { t } [
 416     16 <iota> dup [ bitor ] cartesian-map flatten
 417     [ 0 15 [a,b] interval-contains? ] all?
 418 ] unit-test
 419
 420 ${ 0 255 [a,b] } [ 0 255 [a,b] dup interval-bitor ] unit-test
 421 ${ 0 511 [a,b] } [ 0 256 [a,b] dup interval-bitor ] unit-test
 422
 423 ${ -128 127 [a,b] } [ -128 127 [a,b] dup interval-bitor ] unit-test
 424 ${ -256 255 [a,b] } [ -128 128 [a,b] dup interval-bitor ] unit-test
 425
 426 { full-interval } [ full-interval -128 127 [a,b] interval-bitor ] unit-test
 427 ${ 0 [a,inf] } [ 0 [a,inf] dup interval-bitor ] unit-test
 428 { full-interval } [ 0 [-inf,a] dup interval-bitor ] unit-test
 429 ${ 4 [a,inf] } [ 4 [a,inf] 3 [a,inf] interval-bitor ] unit-test
 430
 431 ! Interval bitxor
 432 ${ 0 255 [a,b] } [ 0 255 [a,b] dup interval-bitxor ] unit-test
 433 ${ 0 511 [a,b] } [ 0 256 [a,b] dup interval-bitxor ] unit-test
 434
 435 ${ -128 127 [a,b] } [ -128 127 [a,b] dup interval-bitxor ] unit-test
 436 ${ -256 255 [a,b] } [ -128 128 [a,b] dup interval-bitxor ] unit-test
 437 ${ 0 127 [a,b] } [ -128 -1 [a,b] dup interval-bitxor ] unit-test
 438
 439 { full-interval } [ full-interval -128 127 [a,b] interval-bitxor ] unit-test
 440 ${ 0 [a,inf] } [ 0 [a,inf] dup interval-bitxor ] unit-test
 441 ${ 0 [a,inf] } [ -1 [-inf,a] dup interval-bitxor ] unit-test
 442 ${ 0 [a,inf] } [ 4 [a,inf] 3 [a,inf] interval-bitxor ] unit-test
 443 { full-interval } [ 4 [a,inf] -3 [a,inf] interval-bitxor ] unit-test