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