steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fixing interval comparison

db4
Slava Pestov 2008-03-07 21:27:00 -06:00
parent 2fa5f34a71
commit 7ffd9c95ba
3 changed files with 166 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

107
core/math/intervals/intervals-tests.factor
View File

@ -1,5 +1,5 @@
USING: math.intervals kernel sequences words math arrays
prettyprint tools.test random vocabs ;
prettyprint tools.test random vocabs combinators ;
IN: math.intervals.tests
[ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test
@ -94,33 +94,86 @@ IN: math.intervals.tests
] unit-test
] when
[ t ] [ 0 5 [a,b] 5 interval<= ] unit-test
[ t ] [ 1 [a,a] interval-singleton? ] unit-test
[ incomparable ] [ 0 5 [a,b] 5 interval< ] unit-test
[ f ] [ 1 1 [a,b) interval-singleton? ] unit-test
[ t ] [ 0 5 [a,b) 5 interval< ] unit-test
[ f ] [ 1 3 [a,b) interval-singleton? ] unit-test
[ f ] [ 0 5 [a,b] -1 interval< ] unit-test
[ f ] [ 1 1 (a,b) interval-singleton? ] unit-test
[ incomparable ] [ 0 5 [a,b] 1 interval< ] unit-test
[ 2 ] [ 1 3 [a,b) interval-length ] unit-test
[ t ] [ -1 1 (a,b) -1 interval> ] unit-test
[ 0 ] [ f interval-length ] unit-test
[ t ] [ -1 1 (a,b) -1 interval>= ] unit-test
[ t ] [ 0 5 [a,b] 5 [a,a] interval<= ] unit-test
[ f ] [ -1 1 (a,b) -1 interval< ] unit-test
[ incomparable ] [ 0 5 [a,b] 5 [a,a] interval< ] unit-test
[ f ] [ -1 1 (a,b) -1 interval<= ] unit-test
[ t ] [ 0 5 [a,b) 5 [a,a] interval< ] unit-test
[ t ] [ -1 1 (a,b] 1 interval<= ] unit-test
[ f ] [ 0 5 [a,b] -1 [a,a] interval< ] unit-test
[ incomparable ] [ 0 5 [a,b] 1 [a,a] interval< ] unit-test
[ t ] [ -1 1 (a,b) -1 [a,a] interval> ] unit-test
[ t ] [ -1 1 (a,b) -1 [a,a] interval>= ] unit-test
[ f ] [ -1 1 (a,b) -1 [a,a] interval< ] unit-test
[ f ] [ -1 1 (a,b) -1 [a,a] interval<= ] unit-test
[ t ] [ -1 1 (a,b] 1 [a,a] interval<= ] unit-test
[ t ] [ -1 1 (a,b] 1 2 [a,b] interval<= ] unit-test
[ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval>= ] unit-test
[ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval> ] unit-test
[ t ] [ -1 1 (a,b] 1 2 (a,b] interval<= ] unit-test
[ f ] [ 0 10 [a,b] 0 [a,a] interval< ] unit-test
[ f ] [ 0 10 [a,b] 10 [a,a] interval> ] unit-test
[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval< ] unit-test
[ incomparable ] [ 10 [a,a] 0 10 [a,b] interval> ] unit-test
[ t ] [ 0 [a,a] 0 10 [a,b] interval<= ] unit-test
[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval>= ] unit-test
[ t ] [ 0 10 [a,b] 0 [a,a] interval>= ] unit-test
[ t ] [
418
418 423 [a,b)
79 893 (a,b]
interval-max
interval-contains?
] unit-test
! Interval random tester
: random-element ( interval -- n )
dup interval-to first swap interval-from first tuck -
random + ;
dup interval-to first over interval-from first tuck - random +
2dup swap interval-contains? [
nip
] [
drop random-element
] if ;
: random-interval ( -- interval )
1000 random dup 1 1000 random + + [a,b] ;
1000 random dup 2 1000 random + +
1 random zero? [ [ neg ] 2apply swap ] when
4 random {
{ 0 [ [a,b] ] }
{ 1 [ [a,b) ] }
{ 2 [ (a,b) ] }
{ 3 [ (a,b] ] }
} case ;
: random-op
{
@ -138,12 +191,32 @@ IN: math.intervals.tests
random ;
: interval-test
random-interval random-interval random-op
random-interval random-interval random-op ! 3dup . . .
0 pick interval-contains? over first { / /i } member? and [
3drop t
] [
[ >r [ random-element ] 2apply r> first execute ] 3keep
[ >r [ random-element ] 2apply ! 2dup . .
r> first execute ] 3keep
second execute interval-contains?
] if ;
[ t ] [ 1000 [ drop interval-test ] all? ] unit-test
[ t ] [ 4000 [ drop interval-test ] all? ] unit-test
: random-comparison
{
{ < interval< }
{ <= interval<= }
{ > interval> }
{ >= interval>= }
} random ;
: comparison-test
random-interval random-interval random-comparison
[ >r [ random-element ] 2apply r> first execute ] 3keep
second execute dup incomparable eq? [
2drop t
] [
=
] if ;
[ t ] [ 4000 [ drop comparison-test ] all? ] unit-test

99
core/math/intervals/intervals.factor
View File

@ -88,20 +88,6 @@ C: <interval> interval
[ interval>points [ first integer? ] both? ] both?
r> [ 2drop f ] if ; inline
: interval-shift ( i1 i2 -- i3 )
[ [ shift ] interval-op ] interval-integer-op ;
: interval-shift-safe ( i1 i2 -- i3 )
dup interval-to first 100 > [
2drop f
] [
interval-shift
] if ;
: interval-max ( i1 i2 -- i3 ) [ max ] interval-op ;
: interval-min ( i1 i2 -- i3 ) [ min ] interval-op ;
: interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ;
: interval-1- ( i1 -- i2 ) -1 [a,a] interval+ ;
@ -143,9 +129,42 @@ C: <interval> interval
: interval-contains? ( x int -- ? )
>r [a,a] r> interval-subset? ;
: interval-singleton? ( int -- ? )
interval>points
2dup [ second ] 2apply and
[ [ first ] 2apply = ]
[ 2drop f ] if ;
: interval-length ( int -- n )
dup
[ interval>points [ first ] 2apply swap - ]
[ drop 0 ] if ;
: interval-closure ( i1 -- i2 )
interval>points [ first ] 2apply [a,b] ;
: interval-shift ( i1 i2 -- i3 )
#! Inaccurate; could be tighter
[ [ shift ] interval-op ] interval-integer-op interval-closure ;
: interval-shift-safe ( i1 i2 -- i3 )
dup interval-to first 100 > [
2drop f
] [
interval-shift
] if ;
: interval-max ( i1 i2 -- i3 )
#! Inaccurate; could be tighter
[ max ] interval-op interval-closure ;
: interval-min ( i1 i2 -- i3 )
#! Inaccurate; could be tighter
[ min ] interval-op interval-closure ;
: interval-interior ( i1 -- i2 )
interval>points [ first ] 2apply (a,b) ;
: interval-division-op ( i1 i2 quot -- i3 )
>r 0 over interval-closure interval-contains?
[ 2drop f ] r> if ; inline
@ -156,7 +175,7 @@ C: <interval> interval
: interval/i ( i1 i2 -- i3 )
[
[ [ /i ] interval-op ] interval-integer-op
] interval-division-op ;
] interval-division-op interval-closure ;
: interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
@ -164,24 +183,46 @@ C: <interval> interval
SYMBOL: incomparable
: interval-compare ( int n quot -- ? )
>r dupd r> call interval-intersect dup [
= t incomparable ?
] [
2drop f
] if ; inline
: left-endpoint-< ( i1 i2 -- ? )
[ swap interval-subset? ] 2keep
[ nip interval-singleton? ] 2keep
[ interval-from ] 2apply =
and and ;
: interval< ( int n -- ? )
[ [-inf,a) ] interval-compare ; inline
: right-endpoint-< ( i1 i2 -- ? )
[ interval-subset? ] 2keep
[ drop interval-singleton? ] 2keep
[ interval-to ] 2apply =
and and ;
: interval<= ( int n -- ? )
[ [-inf,a] ] interval-compare ; inline
: (interval<) over interval-from over interval-from endpoint< ;
: interval> ( int n -- ? )
[ (a,inf] ] interval-compare ; inline
: interval< ( i1 i2 -- ? )
{
{ [ 2dup interval-intersect not ] [ (interval<) ] }
{ [ 2dup left-endpoint-< ] [ f ] }
{ [ 2dup right-endpoint-< ] [ f ] }
{ [ t ] [ incomparable ] }
} cond 2nip ;
: interval>= ( int n -- ? )
[ [a,inf] ] interval-compare ; inline
: left-endpoint-<= ( i1 i2 -- ? )
>r interval-from r> interval-to = ;
: right-endpoint-<= ( i1 i2 -- ? )
>r interval-to r> interval-from = ;
: interval<= ( i1 i2 -- ? )
{
{ [ 2dup interval-intersect not ] [ (interval<) ] }
{ [ 2dup right-endpoint-<= ] [ t ] }
{ [ t ] [ incomparable ] }
} cond 2nip ;
: interval> ( i1 i2 -- ? )
swap interval< ;
: interval>= ( i1 i2 -- ? )
swap interval<= ;
: assume< ( i1 i2 -- i3 )
interval-to first [-inf,a) interval-intersect ;

10
core/optimizer/math/math.factor
View File

@ -371,13 +371,15 @@ most-negative-fixnum most-positive-fixnum [a,b]
] assoc-each
! Remove redundant comparisons
: known-comparison? ( #call -- ? )
: intervals-first2 ( #call -- first second )
dup dup node-in-d first node-interval
swap dup node-in-d second node-literal real? and ;
swap dup node-in-d second node-interval ;
: known-comparison? ( #call -- ? )
intervals-first2 and ;
: perform-comparison ( #call word -- result )
>r dup dup node-in-d first node-interval
swap dup node-in-d second node-literal r> execute ; inline
>r intervals-first2 r> execute ; inline
: foldable-comparison? ( #call word -- ? )
>r dup known-comparison? [