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

Cleanup math.intervals and eliminate >r r> usage

db4
Aaron Schaefer 2008-11-17 17:20:56 -05:00
parent abf4700af8
commit 5d8b3c3fb1
1 changed files with 17 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -12,10 +12,10 @@ SYMBOL: full-interval
TUPLE: interval { from read-only } { to read-only } ; TUPLE: interval { from read-only } { to read-only } ;
: <interval> ( from to -- int ) : <interval> ( from to -- int )
over first over first { 2dup [ first ] bi@ {
{ [ 2dup > ] [ 2drop 2drop empty-interval ] } { [ 2dup > ] [ 2drop 2drop empty-interval ] }
{ [ 2dup = ] [ { [ 2dup = ] [
2drop over second over second and 2drop 2dup [ second ] both?
[ interval boa ] [ 2drop empty-interval ] if [ interval boa ] [ 2drop empty-interval ] if
] } ] }
[ 2drop interval boa ] [ 2drop interval boa ]
@ -26,16 +26,16 @@ TUPLE: interval { from read-only } { to read-only } ;
: closed-point ( n -- endpoint ) t 2array ; : closed-point ( n -- endpoint ) t 2array ;
: [a,b] ( a b -- interval ) : [a,b] ( a b -- interval )
>r closed-point r> closed-point <interval> ; foldable [ closed-point ] dip closed-point <interval> ; foldable
: (a,b) ( a b -- interval ) : (a,b) ( a b -- interval )
>r open-point r> open-point <interval> ; foldable [ open-point ] dip open-point <interval> ; foldable
: [a,b) ( a b -- interval ) : [a,b) ( a b -- interval )
>r closed-point r> open-point <interval> ; foldable [ closed-point ] dip open-point <interval> ; foldable
: (a,b] ( a b -- interval ) : (a,b] ( a b -- interval )
>r open-point r> closed-point <interval> ; foldable [ open-point ] dip closed-point <interval> ; foldable
: [a,a] ( a -- interval ) : [a,a] ( a -- interval )
closed-point dup <interval> ; foldable closed-point dup <interval> ; foldable
@ -51,11 +51,11 @@ TUPLE: interval { from read-only } { to read-only } ;
: [-inf,inf] ( -- interval ) full-interval ; inline : [-inf,inf] ( -- interval ) full-interval ; inline
: compare-endpoints ( p1 p2 quot -- ? ) : compare-endpoints ( p1 p2 quot -- ? )
>r over first over first r> call [ [ 2dup [ first ] bi@ ] dip call [
2drop t 2drop t
] [ ] [
over first over first = [ 2dup [ first ] bi@ = [
swap second swap second not or [ second ] bi@ not or
] [ ] [
2drop f 2drop f
] if ] if
@ -86,7 +86,7 @@ TUPLE: interval { from read-only } { to read-only } ;
] if ; ] if ;
: (interval-op) ( p1 p2 quot -- p3 ) : (interval-op) ( p1 p2 quot -- p3 )
[ [ first ] [ first ] [ ] tri* call ] [ [ first ] [ first ] [ call ] tri* ]
[ drop [ second ] both? ] [ drop [ second ] both? ]
3bi 2array ; inline 3bi 2array ; inline
@ -177,7 +177,7 @@ TUPLE: interval { from read-only } { to read-only } ;
drop f drop f
] [ ] [
interval>points interval>points
2dup [ second ] bi@ and 2dup [ second ] both?
[ [ first ] bi@ = ] [ [ first ] bi@ = ]
[ 2drop f ] if [ 2drop f ] if
] if ; ] if ;
@ -193,9 +193,9 @@ TUPLE: interval { from read-only } { to read-only } ;
dup [ interval>points [ first ] bi@ [a,b] ] when ; dup [ interval>points [ first ] bi@ [a,b] ] when ;
: interval-integer-op ( i1 i2 quot -- i3 ) : interval-integer-op ( i1 i2 quot -- i3 )
>r 2dup [
[ interval>points [ first integer? ] both? ] both? 2dup [ interval>points [ first integer? ] both? ] both?
r> [ 2drop [-inf,inf] ] if ; inline ] dip [ 2drop [-inf,inf] ] if ; inline
: interval-shift ( i1 i2 -- i3 ) : interval-shift ( i1 i2 -- i3 )
#! Inaccurate; could be tighter #! Inaccurate; could be tighter
@ -302,7 +302,7 @@ SYMBOL: incomparable
2tri and and ; 2tri and and ;
: (interval<) ( i1 i2 -- i1 i2 ? ) : (interval<) ( i1 i2 -- i1 i2 ? )
over from>> over from>> endpoint< ; 2dup [ from>> ] bi@ endpoint< ;
: interval< ( i1 i2 -- ? ) : interval< ( i1 i2 -- ? )
{ {
@ -314,10 +314,10 @@ SYMBOL: incomparable
} cond 2nip ; } cond 2nip ;
: left-endpoint-<= ( i1 i2 -- ? ) : left-endpoint-<= ( i1 i2 -- ? )
>r from>> r> to>> = ; [ from>> ] dip to>> = ;
: right-endpoint-<= ( i1 i2 -- ? ) : right-endpoint-<= ( i1 i2 -- ? )
>r to>> r> from>> = ; [ to>> ] dip from>> = ;
: interval<= ( i1 i2 -- ? ) : interval<= ( i1 i2 -- ? )
{ {