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