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