Add empty interval handling
Slava Pestov
parent
19f1621862
commit
5d7cb635ad
|
|
@ -16,6 +16,8 @@ ARTICLE: "math-intervals-new" "Creating intervals"
|
|||
{ $subsection (a,inf] }
|
||||
"The set of all real numbers with infinities:"
|
||||
{ $subsection [-inf,inf] }
|
||||
"The empty set:"
|
||||
{ $subsection empty-interval }
|
||||
"Another constructor:"
|
||||
{ $subsection points>interval } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,16 @@
|
|||
USING: math.intervals kernel sequences words math math.order
|
||||
arrays prettyprint tools.test random vocabs combinators ;
|
||||
arrays prettyprint tools.test random vocabs combinators
|
||||
accessors ;
|
||||
IN: math.intervals.tests
|
||||
|
||||
[ empty-interval ] [ 2 2 (a,b) ] unit-test
|
||||
|
||||
[ empty-interval ] [ 2 2 [a,b) ] unit-test
|
||||
|
||||
[ empty-interval ] [ 2 2 (a,b] ] unit-test
|
||||
|
||||
[ empty-interval ] [ 3 2 [a,b] ] unit-test
|
||||
|
||||
[ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test
|
||||
|
||||
[ T{ interval f { 1 t } { 2 f } } ] [ 1 2 [a,b) ] unit-test
|
||||
|
|
@ -18,6 +27,10 @@ IN: math.intervals.tests
|
|||
[ t ] [ { 4 f } { 3 t } endpoint> ] unit-test
|
||||
[ f ] [ { 3 f } { 3 t } endpoint> ] unit-test
|
||||
|
||||
[ empty-interval ] [ 1 2 [a,b] empty-interval interval+ ] unit-test
|
||||
|
||||
[ empty-interval ] [ empty-interval 1 2 [a,b] interval+ ] unit-test
|
||||
|
||||
[ t ] [
|
||||
1 2 [a,b] -3 3 [a,b] interval+ -2 5 [a,b] =
|
||||
] unit-test
|
||||
|
|
@ -26,10 +39,18 @@ IN: math.intervals.tests
|
|||
1 2 [a,b] -3 3 (a,b) interval+ -2 5 (a,b) =
|
||||
] unit-test
|
||||
|
||||
[ empty-interval ] [ 1 2 [a,b] empty-interval interval- ] unit-test
|
||||
|
||||
[ empty-interval ] [ empty-interval 1 2 [a,b] interval- ] unit-test
|
||||
|
||||
[ t ] [
|
||||
1 2 [a,b] 0 1 [a,b] interval- 0 2 [a,b] =
|
||||
] unit-test
|
||||
|
||||
[ empty-interval ] [ 1 2 [a,b] empty-interval interval* ] unit-test
|
||||
|
||||
[ empty-interval ] [ empty-interval 1 2 [a,b] interval* ] unit-test
|
||||
|
||||
[ t ] [
|
||||
1 2 [a,b] 0 4 [a,b] interval* 0 8 [a,b] =
|
||||
] unit-test
|
||||
|
|
@ -50,6 +71,10 @@ IN: math.intervals.tests
|
|||
-1 1 [a,b] -1 1 (a,b] interval* -1 1 [a,b] =
|
||||
] unit-test
|
||||
|
||||
[ t ] [ 1 2 [a,b] dup empty-interval interval-union = ] unit-test
|
||||
|
||||
[ t ] [ empty-interval 1 2 [a,b] tuck interval-union = ] unit-test
|
||||
|
||||
[ t ] [
|
||||
0 1 (a,b) 0 1 [a,b] interval-union 0 1 [a,b] =
|
||||
] unit-test
|
||||
|
|
@ -64,9 +89,21 @@ IN: math.intervals.tests
|
|||
0 1 (a,b) 0 1 [a,b] interval-intersect 0 1 (a,b) =
|
||||
] unit-test
|
||||
|
||||
[ f ] [ 0 5 [a,b] -1 [a,a] interval-intersect ] unit-test
|
||||
[ empty-interval ] [ 0 5 [a,b] -1 [a,a] interval-intersect ] unit-test
|
||||
|
||||
[ f ] [ 0 5 (a,b] 0 [a,a] interval-intersect ] unit-test
|
||||
[ empty-interval ] [ 0 5 (a,b] 0 [a,a] interval-intersect ] unit-test
|
||||
|
||||
[ empty-interval ] [ empty-interval -1 [a,a] interval-intersect ] unit-test
|
||||
|
||||
[ empty-interval ] [ 0 5 (a,b] empty-interval interval-intersect ] unit-test
|
||||
|
||||
[ t ] [
|
||||
empty-interval empty-interval interval-subset?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
empty-interval 0 1 [a,b] interval-subset?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
0 1 (a,b) 0 1 [a,b] interval-subset?
|
||||
|
|
@ -84,6 +121,8 @@ IN: math.intervals.tests
|
|||
1 0 1 (a,b) interval-contains?
|
||||
] unit-test
|
||||
|
||||
[ empty-interval ] [ -1 1 (a,b) empty-interval interval/ ] unit-test
|
||||
|
||||
[ t ] [ -1 1 (a,b) -1 1 (a,b) interval/ [-inf,inf] = ] unit-test
|
||||
|
||||
[ t ] [ -1 1 (a,b) 0 1 (a,b) interval/ [-inf,inf] = ] unit-test
|
||||
|
|
@ -94,6 +133,8 @@ IN: math.intervals.tests
|
|||
] unit-test
|
||||
] when
|
||||
|
||||
[ f ] [ empty-interval interval-singleton? ] unit-test
|
||||
|
||||
[ t ] [ 1 [a,a] interval-singleton? ] unit-test
|
||||
|
||||
[ f ] [ 1 1 [a,b) interval-singleton? ] unit-test
|
||||
|
|
@ -104,10 +145,14 @@ IN: math.intervals.tests
|
|||
|
||||
[ 2 ] [ 1 3 [a,b) interval-length ] unit-test
|
||||
|
||||
[ 0 ] [ f interval-length ] unit-test
|
||||
[ 0 ] [ empty-interval interval-length ] unit-test
|
||||
|
||||
[ t ] [ 0 5 [a,b] 5 [a,a] interval<= ] unit-test
|
||||
|
||||
[ incomparable ] [ empty-interval 5 [a,a] interval< ] unit-test
|
||||
|
||||
[ incomparable ] [ 5 [a,a] empty-interval interval< ] unit-test
|
||||
|
||||
[ incomparable ] [ 0 5 [a,b] 5 [a,a] interval< ] unit-test
|
||||
|
||||
[ t ] [ 0 5 [a,b) 5 [a,a] interval< ] unit-test
|
||||
|
|
@ -128,6 +173,10 @@ IN: math.intervals.tests
|
|||
|
||||
[ t ] [ -1 1 (a,b] 1 2 [a,b] interval<= ] unit-test
|
||||
|
||||
[ incomparable ] [ -1 1 (a,b] empty-interval interval>= ] unit-test
|
||||
|
||||
[ incomparable ] [ empty-interval -1 1 (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
|
||||
|
|
@ -160,7 +209,7 @@ IN: math.intervals.tests
|
|||
|
||||
! Interval random tester
|
||||
: random-element ( interval -- n )
|
||||
dup interval-to first over interval-from first tuck - random +
|
||||
dup to>> first over from>> first tuck - random +
|
||||
2dup swap interval-contains? [
|
||||
nip
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -5,9 +5,19 @@ USING: accessors kernel sequences arrays math math.order
|
|||
combinators generic ;
|
||||
IN: math.intervals
|
||||
|
||||
SYMBOL: empty-interval
|
||||
|
||||
TUPLE: interval { from read-only } { to read-only } ;
|
||||
|
||||
C: <interval> interval
|
||||
: <interval> ( from to -- int )
|
||||
over first over first {
|
||||
{ [ 2dup > ] [ 2drop 2drop empty-interval ] }
|
||||
{ [ 2dup = ] [
|
||||
2drop over second over second and
|
||||
[ interval boa ] [ 2drop empty-interval ] if
|
||||
] }
|
||||
[ 2drop interval boa ]
|
||||
} cond ;
|
||||
|
||||
: open-point ( n -- endpoint ) f 2array ;
|
||||
|
||||
|
|
@ -71,9 +81,9 @@ C: <interval> interval
|
|||
[ endpoint-max ] reduce <interval> ;
|
||||
|
||||
: (interval-op) ( p1 p2 quot -- p3 )
|
||||
2over >r >r
|
||||
>r [ first ] bi@ r> call
|
||||
r> r> [ second ] both? 2array ; inline
|
||||
[ [ first ] [ first ] [ ] tri* call ]
|
||||
[ drop [ second ] both? ]
|
||||
3bi 2array ; inline
|
||||
|
||||
: interval-op ( i1 i2 quot -- i3 )
|
||||
{
|
||||
|
|
@ -83,16 +93,21 @@ C: <interval> interval
|
|||
[ [ from>> ] [ to>> ] [ ] tri* (interval-op) ]
|
||||
} 3cleave 4array points>interval ; inline
|
||||
|
||||
: interval+ ( i1 i2 -- i3 ) [ + ] interval-op ;
|
||||
: do-empty-interval ( i1 i2 quot -- i3 )
|
||||
{
|
||||
{ [ pick empty-interval eq? ] [ drop drop ] }
|
||||
{ [ over empty-interval eq? ] [ drop nip ] }
|
||||
[ call ]
|
||||
} cond ; inline
|
||||
|
||||
: interval- ( i1 i2 -- i3 ) [ - ] interval-op ;
|
||||
: interval+ ( i1 i2 -- i3 )
|
||||
[ [ + ] interval-op ] do-empty-interval ;
|
||||
|
||||
: interval* ( i1 i2 -- i3 ) [ * ] interval-op ;
|
||||
: interval- ( i1 i2 -- i3 )
|
||||
[ [ - ] interval-op ] do-empty-interval ;
|
||||
|
||||
: interval-integer-op ( i1 i2 quot -- i3 )
|
||||
>r 2dup
|
||||
[ interval>points [ first integer? ] both? ] both?
|
||||
r> [ 2drop f ] if ; inline
|
||||
: interval* ( i1 i2 -- i3 )
|
||||
[ [ * ] interval-op ] do-empty-interval ;
|
||||
|
||||
: interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ;
|
||||
|
||||
|
|
@ -104,32 +119,34 @@ C: <interval> interval
|
|||
|
||||
: interval-sq ( i1 -- i2 ) dup interval* ;
|
||||
|
||||
: make-interval ( from to -- int )
|
||||
over first over first {
|
||||
{ [ 2dup > ] [ 2drop 2drop f ] }
|
||||
{ [ 2dup = ] [
|
||||
2drop over second over second and
|
||||
[ <interval> ] [ 2drop f ] if
|
||||
] }
|
||||
[ 2drop <interval> ]
|
||||
: interval-intersect ( i1 i2 -- i3 )
|
||||
{
|
||||
{ [ dup empty-interval eq? ] [ nip ] }
|
||||
{ [ over empty-interval eq? ] [ drop ] }
|
||||
[
|
||||
2dup and [
|
||||
[ interval>points ] bi@ swapd
|
||||
[ [ swap endpoint< ] most ]
|
||||
[ [ swap endpoint> ] most ] 2bi*
|
||||
<interval>
|
||||
] [
|
||||
or
|
||||
] if
|
||||
]
|
||||
} cond ;
|
||||
|
||||
: interval-intersect ( i1 i2 -- i3 )
|
||||
2dup and [
|
||||
[ interval>points ] bi@ swapd
|
||||
[ swap endpoint> ] most
|
||||
>r [ swap endpoint< ] most r>
|
||||
make-interval
|
||||
] [
|
||||
or
|
||||
] if ;
|
||||
|
||||
: interval-union ( i1 i2 -- i3 )
|
||||
2dup and [
|
||||
[ interval>points 2array ] bi@ append points>interval
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
{
|
||||
{ [ dup empty-interval eq? ] [ drop ] }
|
||||
{ [ over empty-interval eq? ] [ nip ] }
|
||||
[
|
||||
2dup and [
|
||||
[ interval>points 2array ] bi@ append points>interval
|
||||
] [
|
||||
2drop f
|
||||
] if
|
||||
]
|
||||
} cond ;
|
||||
|
||||
: interval-subset? ( i1 i2 -- ? )
|
||||
dupd interval-intersect = ;
|
||||
|
|
@ -138,47 +155,67 @@ C: <interval> interval
|
|||
>r [a,a] r> interval-subset? ;
|
||||
|
||||
: interval-singleton? ( int -- ? )
|
||||
interval>points
|
||||
2dup [ second ] bi@ and
|
||||
[ [ first ] bi@ = ]
|
||||
[ 2drop f ] if ;
|
||||
dup empty-interval eq? [
|
||||
drop f
|
||||
] [
|
||||
interval>points
|
||||
2dup [ second ] bi@ and
|
||||
[ [ first ] bi@ = ]
|
||||
[ 2drop f ] if
|
||||
] if ;
|
||||
|
||||
: interval-length ( int -- n )
|
||||
dup
|
||||
[ interval>points [ first ] bi@ swap - ]
|
||||
[ drop 0 ] if ;
|
||||
{
|
||||
{ [ dup empty-interval eq? ] [ drop 0 ] }
|
||||
{ [ dup not ] [ drop 0 ] }
|
||||
[ interval>points [ first ] bi@ swap - ]
|
||||
} cond ;
|
||||
|
||||
: interval-closure ( i1 -- i2 )
|
||||
dup [ interval>points [ first ] bi@ [a,b] ] when ;
|
||||
|
||||
: interval-integer-op ( i1 i2 quot -- i3 )
|
||||
>r 2dup
|
||||
[ interval>points [ first integer? ] both? ] both?
|
||||
r> [ 2drop [-inf,inf] ] if ; inline
|
||||
|
||||
: interval-shift ( i1 i2 -- i3 )
|
||||
#! Inaccurate; could be tighter
|
||||
[ [ shift ] interval-op ] interval-integer-op interval-closure ;
|
||||
[
|
||||
[
|
||||
[ interval-closure ] bi@
|
||||
[ shift ] interval-op
|
||||
] interval-integer-op
|
||||
] do-empty-interval ;
|
||||
|
||||
: interval-shift-safe ( i1 i2 -- i3 )
|
||||
dup to>> first 100 > [
|
||||
2drop [-inf,inf]
|
||||
] [
|
||||
interval-shift
|
||||
] if ;
|
||||
[
|
||||
dup to>> first 100 > [
|
||||
2drop [-inf,inf]
|
||||
] [
|
||||
interval-shift
|
||||
] if
|
||||
] do-empty-interval ;
|
||||
|
||||
: interval-max ( i1 i2 -- i3 )
|
||||
#! Inaccurate; could be tighter
|
||||
[ max ] interval-op interval-closure ;
|
||||
[ [ interval-closure ] bi@ [ max ] interval-op ] do-empty-interval ;
|
||||
|
||||
: interval-min ( i1 i2 -- i3 )
|
||||
#! Inaccurate; could be tighter
|
||||
[ min ] interval-op interval-closure ;
|
||||
[ [ interval-closure ] bi@ [ min ] interval-op ] do-empty-interval ;
|
||||
|
||||
: interval-interior ( i1 -- i2 )
|
||||
interval>points [ first ] bi@ (a,b) ;
|
||||
dup empty-interval eq? [
|
||||
interval>points [ first ] bi@ (a,b)
|
||||
] unless ;
|
||||
|
||||
: interval-division-op ( i1 i2 quot -- i3 )
|
||||
>r 0 over interval-closure interval-contains?
|
||||
[ 2drop [-inf,inf] ] r> if ; inline
|
||||
|
||||
: interval/ ( i1 i2 -- i3 )
|
||||
[ [ / ] interval-op ] interval-division-op ;
|
||||
[ [ [ / ] interval-op ] interval-division-op ] do-empty-interval ;
|
||||
|
||||
: interval/-safe ( i1 i2 -- i3 )
|
||||
#! Just a hack to make the compiler work if bootstrap.math
|
||||
|
|
@ -187,27 +224,38 @@ C: <interval> interval
|
|||
|
||||
: interval/i ( i1 i2 -- i3 )
|
||||
[
|
||||
[ [ /i ] interval-op ] interval-integer-op
|
||||
] interval-division-op interval-closure ;
|
||||
[
|
||||
[
|
||||
[ interval-closure ] bi@
|
||||
[ /i ] interval-op
|
||||
] interval-integer-op
|
||||
] interval-division-op
|
||||
] do-empty-interval ;
|
||||
|
||||
: interval/f ( i1 i2 -- i3 )
|
||||
[ [ /f ] interval-op ] interval-division-op ;
|
||||
[ [ [ /f ] interval-op ] interval-division-op ] do-empty-interval ;
|
||||
|
||||
: interval-abs ( i1 -- i2 )
|
||||
interval>points [ first2 [ abs ] dip 2array ] bi@ 2array
|
||||
points>interval ;
|
||||
dup empty-interval eq? [
|
||||
interval>points [ first2 [ abs ] dip 2array ] bi@ 2array
|
||||
points>interval
|
||||
] unless ;
|
||||
|
||||
: interval-mod ( i1 i2 -- i3 )
|
||||
#! Inaccurate.
|
||||
[
|
||||
nip interval-abs to>> first [ neg ] keep (a,b)
|
||||
] interval-division-op ;
|
||||
[
|
||||
nip interval-abs to>> first [ neg ] keep (a,b)
|
||||
] interval-division-op
|
||||
] do-empty-interval ;
|
||||
|
||||
: interval-rem ( i1 i2 -- i3 )
|
||||
#! Inaccurate.
|
||||
[
|
||||
nip interval-abs to>> first 0 swap [a,b)
|
||||
] interval-division-op ;
|
||||
[
|
||||
nip interval-abs to>> first 0 swap [a,b)
|
||||
] interval-division-op
|
||||
] do-empty-interval ;
|
||||
|
||||
: interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
|
||||
|
||||
|
|
@ -232,7 +280,8 @@ SYMBOL: incomparable
|
|||
|
||||
: interval< ( i1 i2 -- ? )
|
||||
{
|
||||
{ [ 2dup interval-intersect not ] [ (interval<) ] }
|
||||
{ [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
|
||||
{ [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
|
||||
{ [ 2dup left-endpoint-< ] [ f ] }
|
||||
{ [ 2dup right-endpoint-< ] [ f ] }
|
||||
[ incomparable ]
|
||||
|
|
@ -246,7 +295,8 @@ SYMBOL: incomparable
|
|||
|
||||
: interval<= ( i1 i2 -- ? )
|
||||
{
|
||||
{ [ 2dup interval-intersect not ] [ (interval<) ] }
|
||||
{ [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
|
||||
{ [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
|
||||
{ [ 2dup right-endpoint-<= ] [ t ] }
|
||||
[ incomparable ]
|
||||
} cond 2nip ;
|
||||
|
|
@ -266,31 +316,45 @@ SYMBOL: incomparable
|
|||
|
||||
: interval-bitor ( i1 i2 -- i3 )
|
||||
#! Inaccurate.
|
||||
2dup [ 0 [a,a] interval>= ] both?
|
||||
[ to>> first 0 swap [a,b] interval-intersect ]
|
||||
[ 2drop [-inf,inf] ]
|
||||
if ;
|
||||
[
|
||||
2dup [ 0 [a,a] interval>= ] both?
|
||||
[ to>> first 0 swap [a,b] interval-intersect ]
|
||||
[ 2drop [-inf,inf] ]
|
||||
if
|
||||
] do-empty-interval ;
|
||||
|
||||
: interval-bitxor ( i1 i2 -- i3 )
|
||||
#! Inaccurate.
|
||||
2dup [ 0 [a,a] interval>= ] both?
|
||||
[ nip to>> first 0 swap [a,b] ]
|
||||
[ 2drop [-inf,inf] ]
|
||||
if ;
|
||||
[
|
||||
2dup [ 0 [a,a] interval>= ] both?
|
||||
[ nip to>> first 0 swap [a,b] ]
|
||||
[ 2drop [-inf,inf] ]
|
||||
if
|
||||
] do-empty-interval ;
|
||||
|
||||
: assume< ( i1 i2 -- i3 )
|
||||
to>> first [-inf,a) interval-intersect ;
|
||||
dup empty-interval eq? [ drop ] [
|
||||
to>> first [-inf,a) interval-intersect
|
||||
] if ;
|
||||
|
||||
: assume<= ( i1 i2 -- i3 )
|
||||
to>> first [-inf,a] interval-intersect ;
|
||||
dup empty-interval eq? [ drop ] [
|
||||
to>> first [-inf,a] interval-intersect
|
||||
] if ;
|
||||
|
||||
: assume> ( i1 i2 -- i3 )
|
||||
from>> first (a,inf] interval-intersect ;
|
||||
dup empty-interval eq? [ drop ] [
|
||||
from>> first (a,inf] interval-intersect
|
||||
] if ;
|
||||
|
||||
: assume>= ( i1 i2 -- i3 )
|
||||
from>> first [a,inf] interval-intersect ;
|
||||
dup empty-interval eq? [ drop ] [
|
||||
from>> first [a,inf] interval-intersect
|
||||
] if ;
|
||||
|
||||
: integral-closure ( i1 -- i2 )
|
||||
[ from>> first2 [ 1+ ] unless ]
|
||||
[ to>> first2 [ 1- ] unless ]
|
||||
bi [a,b] ;
|
||||
dup empty-interval eq? [
|
||||
[ from>> first2 [ 1+ ] unless ]
|
||||
[ to>> first2 [ 1- ] unless ]
|
||||
bi [a,b]
|
||||
] unless ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue