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

Fix problem in interval* and interval/ with zero

db4
Slava Pestov 2008-08-26 00:19:40 -05:00
parent a8560f0f57
commit 6f4af849e5
2 changed files with 27 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/math/intervals/intervals-tests.factor
View File

@ -123,6 +123,8 @@ IN: math.intervals.tests
[ empty-interval ] [ -1 1 (a,b) empty-interval interval/ ] unit-test
[ t ] [ 0 0 331 [a,b) -1775 -953 (a,b) interval/ interval-contains? ] 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

43
basis/math/intervals/intervals.factor
View File

@ -76,10 +76,12 @@ TUPLE: interval { from read-only } { to read-only } ;
[ from>> ] [ to>> ] bi ;
: points>interval ( seq -- interval )
dup [ first fp-nan? ] contains? [ drop [-inf,inf] ] [
dup [ first fp-nan? ] contains?
[ drop [-inf,inf] ] [
dup first
[ [ endpoint-min ] reduce ] 2keep
[ endpoint-max ] reduce <interval>
[ [ endpoint-min ] reduce ]
[ [ endpoint-max ] reduce ]
2bi <interval>
] if ;
: (interval-op) ( p1 p2 quot -- p3 )
@ -108,19 +110,6 @@ TUPLE: interval { from read-only } { to read-only } ;
: interval- ( i1 i2 -- i3 )
[ [ - ] interval-op ] do-empty-interval ;
: interval* ( i1 i2 -- i3 )
[ [ * ] interval-op ] do-empty-interval ;
: interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ;
: interval-1- ( i1 -- i2 ) -1 [a,a] interval+ ;
: interval-neg ( i1 -- i2 ) -1 [a,a] interval* ;
: interval-bitnot ( i1 -- i2 ) interval-neg interval-1- ;
: interval-sq ( i1 -- i2 ) dup interval* ;
: interval-intersect ( i1 i2 -- i3 )
{
{ [ dup empty-interval eq? ] [ nip ] }
@ -159,6 +148,21 @@ TUPLE: interval { from read-only } { to read-only } ;
: interval-contains? ( x int -- ? )
>r [a,a] r> interval-subset? ;
: interval* ( i1 i2 -- i3 )
[ [ [ * ] interval-op ] do-empty-interval ]
[ [ 0 swap interval-contains? ] either? ] 2bi
[ 0 [a,a] interval-union ] when ;
: interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ;
: interval-1- ( i1 -- i2 ) -1 [a,a] interval+ ;
: interval-neg ( i1 -- i2 ) -1 [a,a] interval* ;
: interval-bitnot ( i1 -- i2 ) interval-neg interval-1- ;
: interval-sq ( i1 -- i2 ) dup interval* ;
: interval-singleton? ( int -- ? )
dup empty-interval eq? [
drop f
@ -216,8 +220,11 @@ TUPLE: interval { from read-only } { to read-only } ;
] unless ;
: interval-division-op ( i1 i2 quot -- i3 )
>r 0 over interval-closure interval-contains?
[ 2drop [-inf,inf] ] r> if ; inline
{
{ [ 0 pick interval-closure interval-contains? ] [ 3drop [-inf,inf] ] }
{ [ pick 0 swap interval-contains? ] [ call 0 [a,a] interval-union ] }
[ call ]
} cond ; inline
: interval/ ( i1 i2 -- i3 )
[ [ [ / ] interval-op ] interval-division-op ] do-empty-interval ;