Add some more interval operations
Slava Pestov
parent
ad47abfe90
commit
af09eae727
|
|
@ -14,6 +14,8 @@ ARTICLE: "math-intervals-new" "Creating intervals"
|
|||
{ $subsection [-inf,a) }
|
||||
{ $subsection [a,inf] }
|
||||
{ $subsection (a,inf] }
|
||||
"The set of all real numbers with infinities:"
|
||||
{ $subsection [-inf,inf] }
|
||||
"Another constructor:"
|
||||
{ $subsection points>interval } ;
|
||||
|
||||
|
|
@ -24,16 +26,23 @@ ARTICLE: "math-intervals-arithmetic" "Interval arithmetic"
|
|||
{ $subsection interval* }
|
||||
{ $subsection interval/ }
|
||||
{ $subsection interval/i }
|
||||
{ $subsection interval-shift }
|
||||
{ $subsection interval-mod }
|
||||
{ $subsection interval-rem }
|
||||
{ $subsection interval-min }
|
||||
{ $subsection interval-max }
|
||||
"Bitwise operations on intervals:"
|
||||
{ $subsection interval-shift }
|
||||
{ $subsection interval-bitand }
|
||||
{ $subsection interval-bitor }
|
||||
{ $subsection interval-bitxor }
|
||||
"Unary operations on intervals:"
|
||||
{ $subsection interval-1+ }
|
||||
{ $subsection interval-1- }
|
||||
{ $subsection interval-neg }
|
||||
{ $subsection interval-bitnot }
|
||||
{ $subsection interval-recip }
|
||||
{ $subsection interval-2/ } ;
|
||||
{ $subsection interval-2/ }
|
||||
{ $subsection interval-abs } ;
|
||||
|
||||
ARTICLE: "math-intervals-sets" "Set-theoretic operations on intervals"
|
||||
{ $subsection interval-contains? }
|
||||
|
|
|
|||
|
|
@ -84,9 +84,9 @@ IN: math.intervals.tests
|
|||
1 0 1 (a,b) interval-contains?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ -1 1 (a,b) -1 1 (a,b) interval/ ] unit-test
|
||||
[ t ] [ -1 1 (a,b) -1 1 (a,b) interval/ [-inf,inf] = ] unit-test
|
||||
|
||||
[ f ] [ -1 1 (a,b) 0 1 (a,b) interval/ ] unit-test
|
||||
[ t ] [ -1 1 (a,b) 0 1 (a,b) interval/ [-inf,inf] = ] unit-test
|
||||
|
||||
"math.ratios.private" vocab [
|
||||
[ t ] [
|
||||
|
|
@ -156,7 +156,7 @@ IN: math.intervals.tests
|
|||
interval-contains?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ 1 100 [a,b] -1 1 [a,b] interval/i ] unit-test
|
||||
[ t ] [ 1 100 [a,b] -1 1 [a,b] interval/i [-inf,inf] = ] unit-test
|
||||
|
||||
! Interval random tester
|
||||
: random-element ( interval -- n )
|
||||
|
|
@ -177,12 +177,43 @@ IN: math.intervals.tests
|
|||
{ 3 [ (a,b] ] }
|
||||
} case ;
|
||||
|
||||
: random-op ( -- pair )
|
||||
: random-unary-op ( -- pair )
|
||||
{
|
||||
{ bitnot interval-bitnot }
|
||||
{ abs interval-abs }
|
||||
{ 2/ interval-2/ }
|
||||
{ 1+ interval-1+ }
|
||||
{ 1- interval-1- }
|
||||
{ neg interval-neg }
|
||||
}
|
||||
"math.ratios.private" vocab [
|
||||
{ recip interval-recip } suffix
|
||||
] when
|
||||
random ;
|
||||
|
||||
: unary-test ( -- ? )
|
||||
random-interval random-unary-op ! 2dup . .
|
||||
0 pick interval-contains? over first \ recip eq? and [
|
||||
2drop t
|
||||
] [
|
||||
[ >r random-element ! dup .
|
||||
r> first execute ] 2keep
|
||||
second execute interval-contains?
|
||||
] if ;
|
||||
|
||||
[ t ] [ 80000 [ drop unary-test ] all? ] unit-test
|
||||
|
||||
: random-binary-op ( -- pair )
|
||||
{
|
||||
{ + interval+ }
|
||||
{ - interval- }
|
||||
{ * interval* }
|
||||
{ /i interval/i }
|
||||
{ mod interval-mod }
|
||||
{ rem interval-rem }
|
||||
{ bitand interval-bitand }
|
||||
{ bitor interval-bitor }
|
||||
{ bitxor interval-bitxor }
|
||||
{ shift interval-shift }
|
||||
{ min interval-min }
|
||||
{ max interval-max }
|
||||
|
|
@ -192,8 +223,8 @@ IN: math.intervals.tests
|
|||
] when
|
||||
random ;
|
||||
|
||||
: interval-test ( -- ? )
|
||||
random-interval random-interval random-op ! 3dup . . .
|
||||
: binary-test ( -- ? )
|
||||
random-interval random-interval random-binary-op ! 3dup . . .
|
||||
0 pick interval-contains? over first { / /i } member? and [
|
||||
3drop t
|
||||
] [
|
||||
|
|
@ -202,7 +233,7 @@ IN: math.intervals.tests
|
|||
second execute interval-contains?
|
||||
] if ;
|
||||
|
||||
[ t ] [ 40000 [ drop interval-test ] all? ] unit-test
|
||||
[ t ] [ 80000 [ drop binary-test ] all? ] unit-test
|
||||
|
||||
: random-comparison ( -- pair )
|
||||
{
|
||||
|
|
@ -215,11 +246,7 @@ IN: math.intervals.tests
|
|||
: comparison-test ( -- ? )
|
||||
random-interval random-interval random-comparison
|
||||
[ >r [ random-element ] bi@ r> first execute ] 3keep
|
||||
second execute dup incomparable eq? [
|
||||
2drop t
|
||||
] [
|
||||
=
|
||||
] if ;
|
||||
second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
|
||||
|
||||
[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -36,6 +36,8 @@ C: <interval> interval
|
|||
|
||||
: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
|
||||
|
||||
: [-inf,inf] ( -- interval ) -1./0. 1./0. [a,b] ; foldable
|
||||
|
||||
: compare-endpoints ( p1 p2 quot -- ? )
|
||||
>r over first over first r> call [
|
||||
2drop t
|
||||
|
|
@ -154,7 +156,7 @@ C: <interval> interval
|
|||
|
||||
: interval-shift-safe ( i1 i2 -- i3 )
|
||||
dup to>> first 100 > [
|
||||
2drop f
|
||||
2drop [-inf,inf]
|
||||
] [
|
||||
interval-shift
|
||||
] if ;
|
||||
|
|
@ -172,7 +174,7 @@ C: <interval> interval
|
|||
|
||||
: interval-division-op ( i1 i2 quot -- i3 )
|
||||
>r 0 over interval-closure interval-contains?
|
||||
[ 2drop f ] r> if ; inline
|
||||
[ 2drop [-inf,inf] ] r> if ; inline
|
||||
|
||||
: interval/ ( i1 i2 -- i3 )
|
||||
[ [ / ] interval-op ] interval-division-op ;
|
||||
|
|
@ -187,6 +189,25 @@ C: <interval> interval
|
|||
[ [ /i ] interval-op ] interval-integer-op
|
||||
] interval-division-op interval-closure ;
|
||||
|
||||
: interval/f ( i1 i2 -- i3 )
|
||||
[ [ /f ] interval-op ] interval-division-op ;
|
||||
|
||||
: interval-abs ( i1 -- i2 )
|
||||
interval>points [ first2 [ abs ] dip 2array ] bi@ 2array
|
||||
points>interval ;
|
||||
|
||||
: interval-mod ( i1 i2 -- i3 )
|
||||
#! Inaccurate.
|
||||
[
|
||||
nip interval-abs to>> first [ neg ] keep (a,b)
|
||||
] interval-division-op ;
|
||||
|
||||
: interval-rem ( i1 i2 -- i3 )
|
||||
#! Inaccurate.
|
||||
[
|
||||
nip interval-abs to>> first 0 swap [a,b)
|
||||
] interval-division-op ;
|
||||
|
||||
: interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
|
||||
|
||||
: interval-2/ ( i1 -- i2 ) -1 [a,a] interval-shift ;
|
||||
|
|
@ -194,16 +215,16 @@ C: <interval> interval
|
|||
SYMBOL: incomparable
|
||||
|
||||
: left-endpoint-< ( i1 i2 -- ? )
|
||||
[ swap interval-subset? ] 2keep
|
||||
[ nip interval-singleton? ] 2keep
|
||||
[ from>> ] bi@ =
|
||||
and and ;
|
||||
[ swap interval-subset? ]
|
||||
[ nip interval-singleton? ]
|
||||
[ [ from>> ] bi@ = ]
|
||||
2tri and and ;
|
||||
|
||||
: right-endpoint-< ( i1 i2 -- ? )
|
||||
[ interval-subset? ] 2keep
|
||||
[ drop interval-singleton? ] 2keep
|
||||
[ to>> ] bi@ =
|
||||
and and ;
|
||||
[ interval-subset? ]
|
||||
[ drop interval-singleton? ]
|
||||
[ [ to>> ] bi@ = ]
|
||||
2tri and and ;
|
||||
|
||||
: (interval<) ( i1 i2 -- i1 i2 ? )
|
||||
over from>> over from>> endpoint< ;
|
||||
|
|
@ -235,6 +256,27 @@ SYMBOL: incomparable
|
|||
: interval>= ( i1 i2 -- ? )
|
||||
swap interval<= ;
|
||||
|
||||
: interval-bitand ( i1 i2 -- i3 )
|
||||
dup 1 [a,a] interval>= [
|
||||
1 [a,a] interval- interval-rem
|
||||
] [
|
||||
2drop [-inf,inf]
|
||||
] if ;
|
||||
|
||||
: interval-bitor ( i1 i2 -- i3 )
|
||||
#! Inaccurate.
|
||||
2dup [ 0 [a,a] interval>= ] both?
|
||||
[ to>> first 0 swap [a,b] interval-intersect ]
|
||||
[ 2drop [-inf,inf] ]
|
||||
if ;
|
||||
|
||||
: interval-bitxor ( i1 i2 -- i3 )
|
||||
#! Inaccurate.
|
||||
2dup [ 0 [a,a] interval>= ] both?
|
||||
[ nip to>> first 0 swap [a,b] ]
|
||||
[ 2drop [-inf,inf] ]
|
||||
if ;
|
||||
|
||||
: assume< ( i1 i2 -- i3 )
|
||||
to>> first [-inf,a) interval-intersect ;
|
||||
|
||||
|
|
|
|||
|
|
@ -130,38 +130,27 @@ HELP: /
|
|||
{ $see-also "division-by-zero" } ;
|
||||
|
||||
HELP: /i
|
||||
{ $values { "x" real } { "y" real } { "z" real } }
|
||||
{ $values { "x" real } { "y" real } { "z" integer } }
|
||||
{ $description
|
||||
"Divides " { $snippet "x" } " by " { $snippet "y" } ", truncating the result to an integer."
|
||||
{ $list
|
||||
"Integer division of fixnums may overflow and yield a bignum."
|
||||
"Integer division of bignums always yields a bignum."
|
||||
"Integer division of floats always yields a float."
|
||||
"Integer division of ratios and complex numbers proceeds using the relevant mathematical rules."
|
||||
}
|
||||
}
|
||||
{ $see-also "division-by-zero" } ;
|
||||
|
||||
HELP: /f
|
||||
{ $values { "x" real } { "y" real } { "z" real } }
|
||||
{ $values { "x" real } { "y" real } { "z" float } }
|
||||
{ $description
|
||||
"Divides " { $snippet "x" } " by " { $snippet "y" } ", representing the result as a floating point number."
|
||||
{ $list
|
||||
"Integer division of fixnums may overflow and yield a bignum."
|
||||
"Integer division of bignums always yields a bignum."
|
||||
"Integer division of floats always yields a float."
|
||||
"Integer division of ratios and complex numbers proceeds using the relevant mathematical rules."
|
||||
}
|
||||
}
|
||||
{ $see-also "division-by-zero" } ;
|
||||
|
||||
HELP: mod
|
||||
{ $values { "x" integer } { "y" integer } { "z" integer } }
|
||||
{ $values { "x" rational } { "y" rational } { "z" rational } }
|
||||
{ $description
|
||||
"Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder being negative if " { $snippet "x" } " is negative."
|
||||
{ $list
|
||||
"Modulus of fixnums always yields a fixnum."
|
||||
"Modulus of bignums always yields a bignum."
|
||||
"Modulus of bignums always yields a bignum."
|
||||
{ "Modulus of rationals always yields a rational. In this case, the remainder is computed using the formula " { $snippet "x - (x mod y) * y" } "." }
|
||||
}
|
||||
}
|
||||
{ $see-also "division-by-zero" rem } ;
|
||||
|
|
@ -254,12 +243,13 @@ HELP: recip
|
|||
{ $errors "Throws an error if " { $snippet "x" } " is the integer 0." } ;
|
||||
|
||||
HELP: rem
|
||||
{ $values { "x" integer } { "y" integer } { "z" integer } }
|
||||
{ $values { "x" rational } { "y" rational } { "z" rational } }
|
||||
{ $description
|
||||
"Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder always positive."
|
||||
{ $list
|
||||
"Modulus of fixnums always yields a fixnum."
|
||||
"Modulus of bignums always yields a bignum."
|
||||
"Given fixnums, always yields a fixnum."
|
||||
"Given bignums, always yields a bignum."
|
||||
"Given rationals, always yields a rational."
|
||||
}
|
||||
}
|
||||
{ $see-also "division-by-zero" mod } ;
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@ PRIVATE>
|
|||
|
||||
: ?1+ [ 1+ ] [ 0 ] if* ; inline
|
||||
|
||||
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
|
||||
: rem ( x y -- z ) abs tuck mod over + swap mod ; foldable
|
||||
|
||||
: 2^ ( n -- 2^n ) 1 swap shift ; inline
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue