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 ;
   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 [ f ] [ 0 1 (a,b) f interval-union ] 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     empty-interval empty-interval interval-subset?
 102 ] unit-test
 103
 104 [ t ] [
 105     empty-interval 0 1 [a,b] interval-subset?
 106 ] unit-test
 107
 108 [ t ] [
 109     0 1 (a,b) 0 1 [a,b] interval-subset?
 110 ] unit-test
 111
 112 [ f ] [
 113     0 0 1 (a,b) interval-contains?
 114 ] unit-test
 115
 116 [ t ] [
 117     0.5 0 1 (a,b) interval-contains?
 118 ] unit-test
 119
 120 [ f ] [
 121     1 0 1 (a,b) interval-contains?
 122 ] unit-test
 123
 124 [ empty-interval ] [ -1 1 (a,b) empty-interval interval/ ] unit-test
 125
 126 [ t ] [ 0 0 331 [a,b) -1775 -953 (a,b) interval/ interval-contains? ] unit-test
 127
 128 [ t ] [ -1 1 (a,b) -1 1 (a,b) interval/ [-inf,inf] = ] unit-test
 129
 130 [ t ] [ -1 1 (a,b) 0 1 (a,b) interval/ [-inf,inf] = ] unit-test
 131
 132 "math.ratios.private" vocab [
 133     [ t ] [
 134         -1 1 (a,b) 0.5 1 (a,b) interval/ -2.0 2.0 (a,b) =
 135     ] unit-test
 136 ] when
 137
 138 [ f ] [ empty-interval interval-singleton? ] unit-test
 139
 140 [ t ] [ 1 [a,a] interval-singleton? ] unit-test
 141
 142 [ f ] [ 1 1 [a,b) interval-singleton? ] unit-test
 143
 144 [ f ] [ 1 3 [a,b) interval-singleton? ] unit-test
 145
 146 [ f ] [ 1 1 (a,b) interval-singleton? ] unit-test
 147
 148 [ 2 ] [ 1 3 [a,b) interval-length ] unit-test
 149
 150 [ 0 ] [ empty-interval interval-length ] unit-test
 151
 152 [ t ] [ 0 5 [a,b] 5 [a,a] interval<= ] unit-test
 153
 154 [ incomparable ] [ empty-interval 5 [a,a] interval< ] unit-test
 155
 156 [ incomparable ] [ 5 [a,a] empty-interval interval< ] unit-test
 157
 158 [ incomparable ] [ 0 5 [a,b] 5 [a,a] interval< ] unit-test
 159
 160 [ t ] [ 0 5 [a,b) 5 [a,a] interval< ] unit-test
 161
 162 [ f ] [ 0 5 [a,b] -1 [a,a] interval< ] unit-test
 163
 164 [ incomparable ] [ 0 5 [a,b] 1 [a,a] interval< ] unit-test
 165
 166 [ t ] [ -1 1 (a,b) -1 [a,a] interval> ] unit-test
 167
 168 [ t ] [ -1 1 (a,b) -1 [a,a] interval>= ] unit-test
 169
 170 [ f ] [ -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 [ t ] [ -1 1 (a,b] 1 [a,a] interval<= ] unit-test
 175
 176 [ t ] [ -1 1 (a,b] 1 2 [a,b] interval<= ] unit-test
 177
 178 [ incomparable ] [ -1 1 (a,b] empty-interval interval>= ] unit-test
 179
 180 [ incomparable ] [ empty-interval -1 1 (a,b] interval>= ] unit-test
 181
 182 [ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval>= ] unit-test
 183
 184 [ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval> ] unit-test
 185
 186 [ t ] [ -1 1 (a,b] 1 2 (a,b] interval<= ] unit-test
 187
 188 [ f ] [ 0 10 [a,b] 0 [a,a] interval< ] unit-test
 189
 190 [ f ] [ 0 10 [a,b] 10 [a,a] interval> ] unit-test
 191
 192 [ incomparable ] [ 0 [a,a] 0 10 [a,b] interval< ] unit-test
 193
 194 [ incomparable ] [ 10 [a,a] 0 10 [a,b] interval> ] unit-test
 195
 196 [ t ] [ 0 [a,a] 0 10 [a,b] interval<= ] unit-test
 197
 198 [ incomparable ] [ 0 [a,a] 0 10 [a,b] interval>= ] unit-test
 199
 200 [ t ] [ 0 10 [a,b] 0 [a,a] interval>= ] unit-test
 201
 202 [ t ] [
 203     418
 204     418 423 [a,b)
 205     79 893 (a,b]
 206     interval-max
 207     interval-contains?
 208 ] unit-test
 209
 210 [ t ] [ 1 100 [a,b] -1 1 [a,b] interval/i [-inf,inf] = ] unit-test
 211
 212 ! Interval random tester
 213 : random-element ( interval -- n )
 214     dup to>> first over from>> first tuck - random +
 215     2dup swap interval-contains? [
 216         nip
 217     ] [
 218         drop random-element
 219     ] if ;
 220
 221 : random-interval ( -- interval )
 222     2000 random 1000 - dup 2 1000 random + +
 223     1 random zero? [ [ neg ] bi@ swap ] when
 224     4 random {
 225         { 0 [ [a,b] ] }
 226         { 1 [ [a,b) ] }
 227         { 2 [ (a,b) ] }
 228         { 3 [ (a,b] ] }
 229     } case ;
 230
 231 : random-unary-op ( -- pair )
 232     {
 233         { bitnot interval-bitnot }
 234         { abs interval-abs }
 235         { 2/ interval-2/ }
 236         { 1+ interval-1+ }
 237         { 1- interval-1- }
 238         { neg interval-neg }
 239     }
 240     "math.ratios.private" vocab [
 241         { recip interval-recip } suffix
 242     ] when
 243     random ;
 244
 245 : unary-test ( -- ? )
 246     random-interval random-unary-op ! 2dup . .
 247     0 pick interval-contains? over first \ recip eq? and [
 248         2drop t
 249     ] [
 250         [ >r random-element ! dup .
 251         r> first execute ] 2keep
 252         second execute interval-contains?
 253     ] if ;
 254
 255 [ t ] [ 80000 [ drop unary-test ] all? ] unit-test
 256
 257 : random-binary-op ( -- pair )
 258     {
 259         { + interval+ }
 260         { - interval- }
 261         { * interval* }
 262         { /i interval/i }
 263         { mod interval-mod }
 264         { rem interval-rem }
 265         { bitand interval-bitand }
 266         { bitor interval-bitor }
 267         { bitxor interval-bitxor }
 268         { shift interval-shift }
 269         { min interval-min }
 270         { max interval-max }
 271     }
 272     "math.ratios.private" vocab [
 273         { / interval/ } suffix
 274     ] when
 275     random ;
 276
 277 : binary-test ( -- ? )
 278     random-interval random-interval random-binary-op ! 3dup . . .
 279     0 pick interval-contains? over first { / /i mod rem } member? and [
 280         3drop t
 281     ] [
 282         [ >r [ random-element ] bi@ ! 2dup . .
 283         r> first execute ] 3keep
 284         second execute interval-contains?
 285     ] if ;
 286
 287 [ t ] [ 80000 [ drop binary-test ] all? ] unit-test
 288
 289 : random-comparison ( -- pair )
 290     {
 291         { < interval< }
 292         { <= interval<= }
 293         { > interval> }
 294         { >= interval>= }
 295     } random ;
 296
 297 : comparison-test ( -- ? )
 298     random-interval random-interval random-comparison
 299     [ >r [ random-element ] bi@ r> first execute ] 3keep
 300     second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
 301
 302 [ t ] [ 40000 [ drop comparison-test ] all? ] unit-test
 303
 304 [ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test
 305
 306 [ t ] [ -10 10 [a,b] 0 100 [a,b] assume>= 0 10 [a,b] = ] unit-test
 307
 308 [ t ] [ -10 10 [a,b] 0 100 [a,b] assume< -10 10 [a,b] = ] unit-test
 309
 310 [ t ] [ -10 10 [a,b] -100 0 [a,b] assume< -10 0 [a,b) = ] unit-test
 311
 312 [ t ] [ -10 10 [a,b] -100 0 [a,b] assume<= -10 0 [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] interval-abs 0 10 [a,b] = ] unit-test
 317
 318 ! Test that commutative interval ops really are
 319 : random-interval-or-empty ( -- )
 320     10 random 0 = [ empty-interval ] [ random-interval ] if ;
 321
 322 : random-commutative-op ( -- op )
 323     {
 324         interval+ interval*
 325         interval-bitor interval-bitand interval-bitxor
 326         interval-max interval-min
 327     } random ;
 328
 329 [ t ] [
 330     80000 [
 331         drop
 332         random-interval-or-empty random-interval-or-empty
 333         random-commutative-op
 334         [ execute ] [ swapd execute ] 3bi =
 335     ] all?
 336 ] unit-test