{ $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 } ;
{ $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? }
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 ] [
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 )
{ 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 }
] 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
] [
second execute interval-contains?
] if ;
-[ t ] [ 40000 [ drop interval-test ] all? ] unit-test
+[ t ] [ 80000 [ drop binary-test ] all? ] unit-test
: random-comparison ( -- pair )
{
: 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
: (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
: interval-shift-safe ( i1 i2 -- i3 )
dup to>> first 100 > [
- 2drop f
+ 2drop [-inf,inf]
] [
interval-shift
] if ;
: 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 ;
[ [ /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 ;
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< ;
: 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 ;
{ $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 } ;
{ $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 } ;
: ?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
projects / factor.git / commitdiff