Add some more interval operations

core/math/intervals/intervals-docs.factor

@@ -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? }

core/math/intervals/intervals-tests.factor

@@ -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 ( -- ? )
+: binary-test ( -- ? )
-    random-interval random-interval random-op ! 3dup . . .
+    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? [
+    second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
-        2drop t
-    ] [
-        =
-    ] if ;
 
 [ t ] [ 40000 [ drop comparison-test ] all? ] unit-test
 

core/math/intervals/intervals.factor

@@ -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
+    [ swap interval-subset? ]
-    [ nip interval-singleton? ] 2keep
+    [ nip interval-singleton? ]
-    [ from>> ] bi@ =
+    [ [ from>> ] bi@ = ]
-    and and ;
+    2tri and and ;
 
 : right-endpoint-< ( i1 i2 -- ? )
-    [ interval-subset? ] 2keep
+    [ interval-subset? ]
-    [ drop interval-singleton? ] 2keep
+    [ drop interval-singleton? ]
-    [ to>> ] bi@ =
+    [ [ to>> ] bi@ = ]
-    and and ;
+    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 ;
 

core/math/math-docs.factor

@@ -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 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."
+        "Given fixnums, always yields a fixnum."
-        "Modulus of bignums always yields a bignum."            
+        "Given bignums, always yields a bignum."
+        "Given rationals, always yields a rational."    
     }
 }
 { $see-also "division-by-zero" mod } ;

core/math/math.factor

@@ -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