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

Add empty interval handling

db4
Slava Pestov 2008-07-22 21:04:22 -05:00
parent 19f1621862
commit 5d7cb635ad
3 changed files with 197 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/math/intervals/intervals-docs.factor
View File

@ -16,6 +16,8 @@ ARTICLE: "math-intervals-new" "Creating intervals"
{ $subsection (a,inf] } { $subsection (a,inf] }
"The set of all real numbers with infinities:" "The set of all real numbers with infinities:"
{ $subsection [-inf,inf] } { $subsection [-inf,inf] }
"The empty set:"
{ $subsection empty-interval }
"Another constructor:" "Another constructor:"
{ $subsection points>interval } ; { $subsection points>interval } ;

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

@ -1,7 +1,16 @@
USING: math.intervals kernel sequences words math math.order 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 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 t } } ] [ 1 2 [a,b] ] unit-test
[ T{ interval f { 1 t } { 2 f } } ] [ 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 [ t ] [ { 4 f } { 3 t } endpoint> ] unit-test
[ f ] [ { 3 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 ] [ [ t ] [
1 2 [a,b] -3 3 [a,b] interval+ -2 5 [a,b] = 1 2 [a,b] -3 3 [a,b] interval+ -2 5 [a,b] =
] unit-test ] unit-test
@ -26,10 +39,18 @@ IN: math.intervals.tests
1 2 [a,b] -3 3 (a,b) interval+ -2 5 (a,b) = 1 2 [a,b] -3 3 (a,b) interval+ -2 5 (a,b) =
] unit-test ] 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 ] [ [ t ] [
1 2 [a,b] 0 1 [a,b] interval- 0 2 [a,b] = 1 2 [a,b] 0 1 [a,b] interval- 0 2 [a,b] =
] unit-test ] 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 ] [ [ t ] [
1 2 [a,b] 0 4 [a,b] interval* 0 8 [a,b] = 1 2 [a,b] 0 4 [a,b] interval* 0 8 [a,b] =
] unit-test ] unit-test
@ -50,6 +71,10 @@ IN: math.intervals.tests
-1 1 [a,b] -1 1 (a,b] interval* -1 1 [a,b] = -1 1 [a,b] -1 1 (a,b] interval* -1 1 [a,b] =
] unit-test ] 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 ] [ [ t ] [
0 1 (a,b) 0 1 [a,b] interval-union 0 1 [a,b] = 0 1 (a,b) 0 1 [a,b] interval-union 0 1 [a,b] =
] unit-test ] unit-test
@ -64,9 +89,21 @@ IN: math.intervals.tests
0 1 (a,b) 0 1 [a,b] interval-intersect 0 1 (a,b) = 0 1 (a,b) 0 1 [a,b] interval-intersect 0 1 (a,b) =
] unit-test ] 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 ] [ [ t ] [
0 1 (a,b) 0 1 [a,b] interval-subset? 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? 1 0 1 (a,b) interval-contains?
] unit-test ] 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) -1 1 (a,b) interval/ [-inf,inf] = ] unit-test
[ t ] [ -1 1 (a,b) 0 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 ] unit-test
] when ] when
[ f ] [ empty-interval interval-singleton? ] unit-test
[ t ] [ 1 [a,a] interval-singleton? ] unit-test [ t ] [ 1 [a,a] interval-singleton? ] unit-test
[ f ] [ 1 1 [a,b) 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 [ 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 [ 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 [ incomparable ] [ 0 5 [a,b] 5 [a,a] interval< ] unit-test
[ t ] [ 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 [ 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
[ 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 ! Interval random tester
: random-element ( interval -- n ) : 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? [ 2dup swap interval-contains? [
nip nip
] [ ] [

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

@ -5,9 +5,19 @@ USING: accessors kernel sequences arrays math math.order
combinators generic ; combinators generic ;
IN: math.intervals IN: math.intervals
SYMBOL: empty-interval
TUPLE: interval { from read-only } { to read-only } ; 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 ; : open-point ( n -- endpoint ) f 2array ;
@ -71,9 +81,9 @@ C: <interval> interval
[ endpoint-max ] reduce <interval> ; [ endpoint-max ] reduce <interval> ;
: (interval-op) ( p1 p2 quot -- p3 ) : (interval-op) ( p1 p2 quot -- p3 )
2over >r >r [ [ first ] [ first ] [ ] tri* call ]
>r [ first ] bi@ r> call [ drop [ second ] both? ]
r> r> [ second ] both? 2array ; inline 3bi 2array ; inline
: interval-op ( i1 i2 quot -- i3 ) : interval-op ( i1 i2 quot -- i3 )
{ {
@ -83,16 +93,21 @@ C: <interval> interval
[ [ from>> ] [ to>> ] [ ] tri* (interval-op) ] [ [ from>> ] [ to>> ] [ ] tri* (interval-op) ]
} 3cleave 4array points>interval ; inline } 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 ) : interval* ( i1 i2 -- i3 )
>r 2dup [ [ * ] interval-op ] do-empty-interval ;
[ interval>points [ first integer? ] both? ] both?
r> [ 2drop f ] if ; inline
: interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ; : interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ;
@ -104,32 +119,34 @@ C: <interval> interval
: interval-sq ( i1 -- i2 ) dup 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> ]
} cond ;
: interval-intersect ( i1 i2 -- i3 ) : interval-intersect ( i1 i2 -- i3 )
{
{ [ dup empty-interval eq? ] [ nip ] }
{ [ over empty-interval eq? ] [ drop ] }
[
2dup and [ 2dup and [
[ interval>points ] bi@ swapd [ interval>points ] bi@ swapd
[ swap endpoint> ] most [ [ swap endpoint< ] most ]
>r [ swap endpoint< ] most r> [ [ swap endpoint> ] most ] 2bi*
make-interval <interval>
] [ ] [
or or
] if ; ] if
]
} cond ;
: interval-union ( i1 i2 -- i3 ) : interval-union ( i1 i2 -- i3 )
{
{ [ dup empty-interval eq? ] [ drop ] }
{ [ over empty-interval eq? ] [ nip ] }
[
2dup and [ 2dup and [
[ interval>points 2array ] bi@ append points>interval [ interval>points 2array ] bi@ append points>interval
] [ ] [
2drop f 2drop f
] if ; ] if
]
} cond ;
: interval-subset? ( i1 i2 -- ? ) : interval-subset? ( i1 i2 -- ? )
dupd interval-intersect = ; dupd interval-intersect = ;
@ -138,47 +155,67 @@ C: <interval> interval
>r [a,a] r> interval-subset? ; >r [a,a] r> interval-subset? ;
: interval-singleton? ( int -- ? ) : interval-singleton? ( int -- ? )
dup empty-interval eq? [
drop f
] [
interval>points interval>points
2dup [ second ] bi@ and 2dup [ second ] bi@ and
[ [ first ] bi@ = ] [ [ first ] bi@ = ]
[ 2drop f ] if ; [ 2drop f ] if
] if ;
: interval-length ( int -- n ) : interval-length ( int -- n )
dup {
{ [ dup empty-interval eq? ] [ drop 0 ] }
{ [ dup not ] [ drop 0 ] }
[ interval>points [ first ] bi@ swap - ] [ interval>points [ first ] bi@ swap - ]
[ drop 0 ] if ; } cond ;
: interval-closure ( i1 -- i2 ) : interval-closure ( i1 -- i2 )
dup [ interval>points [ first ] bi@ [a,b] ] when ; 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 ) : interval-shift ( i1 i2 -- i3 )
#! Inaccurate; could be tighter #! 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 ) : interval-shift-safe ( i1 i2 -- i3 )
[
dup to>> first 100 > [ dup to>> first 100 > [
2drop [-inf,inf] 2drop [-inf,inf]
] [ ] [
interval-shift interval-shift
] if ; ] if
] do-empty-interval ;
: interval-max ( i1 i2 -- i3 ) : interval-max ( i1 i2 -- i3 )
#! Inaccurate; could be tighter #! Inaccurate; could be tighter
[ max ] interval-op interval-closure ; [ [ interval-closure ] bi@ [ max ] interval-op ] do-empty-interval ;
: interval-min ( i1 i2 -- i3 ) : interval-min ( i1 i2 -- i3 )
#! Inaccurate; could be tighter #! Inaccurate; could be tighter
[ min ] interval-op interval-closure ; [ [ interval-closure ] bi@ [ min ] interval-op ] do-empty-interval ;
: interval-interior ( i1 -- i2 ) : 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 ) : interval-division-op ( i1 i2 quot -- i3 )
>r 0 over interval-closure interval-contains? >r 0 over interval-closure interval-contains?
[ 2drop [-inf,inf] ] r> if ; inline [ 2drop [-inf,inf] ] r> if ; inline
: interval/ ( i1 i2 -- i3 ) : interval/ ( i1 i2 -- i3 )
[ [ / ] interval-op ] interval-division-op ; [ [ [ / ] interval-op ] interval-division-op ] do-empty-interval ;
: interval/-safe ( i1 i2 -- i3 ) : interval/-safe ( i1 i2 -- i3 )
#! Just a hack to make the compiler work if bootstrap.math #! Just a hack to make the compiler work if bootstrap.math
@ -187,27 +224,38 @@ C: <interval> interval
: interval/i ( i1 i2 -- i3 ) : 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 ) : 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-abs ( i1 -- i2 )
dup empty-interval eq? [
interval>points [ first2 [ abs ] dip 2array ] bi@ 2array interval>points [ first2 [ abs ] dip 2array ] bi@ 2array
points>interval ; points>interval
] unless ;
: interval-mod ( i1 i2 -- i3 ) : interval-mod ( i1 i2 -- i3 )
#! Inaccurate. #! Inaccurate.
[
[ [
nip interval-abs to>> first [ neg ] keep (a,b) nip interval-abs to>> first [ neg ] keep (a,b)
] interval-division-op ; ] interval-division-op
] do-empty-interval ;
: interval-rem ( i1 i2 -- i3 ) : interval-rem ( i1 i2 -- i3 )
#! Inaccurate. #! Inaccurate.
[
[ [
nip interval-abs to>> first 0 swap [a,b) nip interval-abs to>> first 0 swap [a,b)
] interval-division-op ; ] interval-division-op
] do-empty-interval ;
: interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ; : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
@ -232,7 +280,8 @@ SYMBOL: incomparable
: interval< ( i1 i2 -- ? ) : 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 left-endpoint-< ] [ f ] }
{ [ 2dup right-endpoint-< ] [ f ] } { [ 2dup right-endpoint-< ] [ f ] }
[ incomparable ] [ incomparable ]
@ -246,7 +295,8 @@ SYMBOL: incomparable
: interval<= ( i1 i2 -- ? ) : 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 ] } { [ 2dup right-endpoint-<= ] [ t ] }
[ incomparable ] [ incomparable ]
} cond 2nip ; } cond 2nip ;
@ -266,31 +316,45 @@ SYMBOL: incomparable
: interval-bitor ( i1 i2 -- i3 ) : interval-bitor ( i1 i2 -- i3 )
#! Inaccurate. #! Inaccurate.
[
2dup [ 0 [a,a] interval>= ] both? 2dup [ 0 [a,a] interval>= ] both?
[ to>> first 0 swap [a,b] interval-intersect ] [ to>> first 0 swap [a,b] interval-intersect ]
[ 2drop [-inf,inf] ] [ 2drop [-inf,inf] ]
if ; if
] do-empty-interval ;
: interval-bitxor ( i1 i2 -- i3 ) : interval-bitxor ( i1 i2 -- i3 )
#! Inaccurate. #! Inaccurate.
[
2dup [ 0 [a,a] interval>= ] both? 2dup [ 0 [a,a] interval>= ] both?
[ nip to>> first 0 swap [a,b] ] [ nip to>> first 0 swap [a,b] ]
[ 2drop [-inf,inf] ] [ 2drop [-inf,inf] ]
if ; if
] do-empty-interval ;
: assume< ( i1 i2 -- i3 ) : 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 ) : 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 ) : 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 ) : 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 ) : integral-closure ( i1 -- i2 )
dup empty-interval eq? [
[ from>> first2 [ 1+ ] unless ] [ from>> first2 [ 1+ ] unless ]
[ to>> first2 [ 1- ] unless ] [ to>> first2 [ 1- ] unless ]
bi [a,b] ; bi [a,b]
] unless ;