Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2009-08-11 18:16:30 -05:00
commit c12d6fe543
3 changed files with 46 additions and 31 deletions

View File

@ -391,6 +391,17 @@ DEFER: loop-bbb
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
! Interval inference issue
[ f ] [
10 70
[
dup 70 >=
[ dup 700 <= [ swap 1024 rem rem ] [ 2drop 70 ] if ]
[ 2drop 70 ] if
70 >=
] compile-call
] unit-test
! Modular arithmetic bug
: modular-arithmetic-bug ( a -- b ) >integer 256 mod ;

View File

@ -1,6 +1,6 @@
USING: math.intervals kernel sequences words math math.order
arrays prettyprint tools.test random vocabs combinators
accessors math.constants ;
accessors math.constants fry ;
IN: math.intervals.tests
[ empty-interval ] [ 2 2 (a,b) ] unit-test
@ -246,7 +246,7 @@ IN: math.intervals.tests
} case
] if ;
: random-unary-op ( -- pair )
: unary-ops ( -- alist )
{
{ bitnot interval-bitnot }
{ abs interval-abs }
@ -257,11 +257,10 @@ IN: math.intervals.tests
}
"math.ratios.private" vocab [
{ recip interval-recip } suffix
] when
random ;
] when ;
: unary-test ( -- ? )
random-interval random-unary-op ! 2dup . .
: unary-test ( op -- ? )
[ random-interval ] dip
0 pick interval-contains? over first \ recip eq? and [
2drop t
] [
@ -269,9 +268,11 @@ IN: math.intervals.tests
second execute( a -- b ) interval-contains?
] if ;
[ t ] [ 80000 iota [ drop unary-test ] all? ] unit-test
unary-ops [
[ [ t ] ] dip '[ 8000 iota [ drop _ unary-test ] all? ] unit-test
] each
: random-binary-op ( -- pair )
: binary-ops ( -- alist )
{
{ + interval+ }
{ - interval- }
@ -282,17 +283,15 @@ IN: math.intervals.tests
{ bitand interval-bitand }
{ bitor interval-bitor }
{ bitxor interval-bitxor }
! { shift interval-shift }
{ min interval-min }
{ max interval-max }
}
"math.ratios.private" vocab [
{ / interval/ } suffix
] when
random ;
] when ;
: binary-test ( -- ? )
random-interval random-interval random-binary-op ! 3dup . . .
: binary-test ( op -- ? )
[ random-interval random-interval ] dip
0 pick interval-contains? over first { / /i mod rem } member? and [
3drop t
] [
@ -300,22 +299,26 @@ IN: math.intervals.tests
second execute( a b -- c ) interval-contains?
] if ;
[ t ] [ 80000 iota [ drop binary-test ] all? ] unit-test
binary-ops [
[ [ t ] ] dip '[ 8000 iota [ drop _ binary-test ] all? ] unit-test
] each
: random-comparison ( -- pair )
: comparison-ops ( -- alist )
{
{ < interval< }
{ <= interval<= }
{ > interval> }
{ >= interval>= }
} random ;
} ;
: comparison-test ( -- ? )
random-interval random-interval random-comparison
: comparison-test ( op -- ? )
[ random-interval random-interval ] dip
[ [ [ random-element ] bi@ ] dip first execute( a b -- ? ) ] 3keep
second execute( a b -- ? ) dup incomparable eq? [ 2drop t ] [ = ] if ;
[ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test
comparison-ops [
[ [ t ] ] dip '[ 8000 iota [ drop _ comparison-test ] all? ] unit-test
] each
[ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test
@ -335,18 +338,19 @@ IN: math.intervals.tests
: random-interval-or-empty ( -- obj )
10 random 0 = [ empty-interval ] [ random-interval ] if ;
: random-commutative-op ( -- op )
: commutative-ops ( -- seq )
{
interval+ interval*
interval-bitor interval-bitand interval-bitxor
interval-max interval-min
} random ;
} ;
[ t ] [
80000 iota [
drop
random-interval-or-empty random-interval-or-empty
random-commutative-op
[ execute ] [ swapd execute ] 3bi =
] all?
] unit-test
commutative-ops [
[ [ t ] ] dip '[
8000 iota [
drop
random-interval-or-empty random-interval-or-empty _
[ execute ] [ swapd execute ] 3bi =
] all?
] unit-test
] each

View File

@ -340,8 +340,8 @@ SYMBOL: incomparable
{
{ [ over empty-interval eq? ] [ drop ] }
{ [ dup empty-interval eq? ] [ nip ] }
{ [ dup full-interval eq? ] [ nip ] }
[ (rem-range) 2dup interval-subset? [ drop ] [ nip ] if ]
{ [ dup full-interval eq? ] [ 2drop [0,inf] ] }
[ nip (rem-range) ]
} cond ;
: interval->fixnum ( i1 -- i2 )