basis/math/intervals/intervals-tests.factor

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