math.intervals: improve interval-bitand.

diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor
index 293f49b69a7127444c1d3fd59c8fa8c5f99c6e85..73706da34052576ea91438621a3f831ac60c3cb2 100644 (file)
--- a/basis/math/intervals/intervals-tests.factor
+++ b/basis/math/intervals/intervals-tests.factor
@@ -398,6 +398,12 @@ commutative-ops [
 
 { t } [ -1/0. 1/0. [ full-interval interval-contains? ] bi@ and ] unit-test
 
+! Interval bitand
+${ 0 0xaf [a,b] } [ 0 0xff [a,b] 0 0xaf [a,b] interval-bitand ] unit-test
+${ -0x100 -10 [a,b] } [ -0xff -1 [a,b] -0xaf -10 [a,b] interval-bitand ] unit-test
+${ -0x100 10 [a,b] } [ -0xff 1 [a,b] -0xaf 10 [a,b] interval-bitand ] unit-test
+${ 0 0xff [a,b] } [ -0xff -1 [a,b] 0 0xff [a,b] interval-bitand ] unit-test
+
 ! Interval bitor
 { 1/0. } [ 1/0. bit-weight ] unit-test
 { 1/0. } [ -1/0. bit-weight ] unit-test

diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor
index e9e6cdf2eefbf7e8d868afddffa541417afcf52f..8c4c1a8e343b369bbe4486b613c10d30da9d19ef 100644 (file)
--- a/basis/math/intervals/intervals.factor
+++ b/basis/math/intervals/intervals.factor
@@ -374,48 +374,23 @@ SYMBOL: incomparable
         [ nip (rem-range) ]
     } cond ;
 
-: interval-bitand-pos ( i1 i2 -- ? )
-    [ to>> first ] bi@ min 0 swap [a,b] ;
-
-: interval-bitand-neg ( i1 i2 -- ? )
-    dup from>> first 0 < [ drop ] [ nip ] if
-    0 swap to>> first [a,b] ;
-
 : interval-nonnegative? ( i -- ? )
     from>> first 0 >= ;
 
 : interval-negative? ( interval -- ? )
     to>> first 0 < ;
 
-: interval-bitand ( i1 i2 -- i3 )
-    ! Inaccurate.
-    [
-        {
-            {
-                [ 2dup [ interval-nonnegative? ] both? ]
-                [ interval-bitand-pos ]
-            }
-            {
-                [ 2dup [ interval-nonnegative? ] either? ]
-                [ interval-bitand-neg ]
-            }
-            [ 2drop [-inf,inf] ]
-        } cond
-    ] do-empty-interval ;
-
 <PRIVATE
-! Return the weight of the MSB.  For signed numbers, this does not mean the sign
-! bit.
+! Return the weight of the MSB.  For signed numbers, this does
+! not mean the sign bit.
 : bit-weight  ( n -- m )
     dup [ -1/0. = ] [ 1/0. = ] bi or
     [ drop 1/0. ]
     [ dup 0 > [ 1 + ] [ neg ] if next-power-of-2 ] if ;
 
-: bounds ( interval -- lower upper )
-    {
-        { full-interval [ -1/0. 1/0. ] }
-        [ interval>points [ first ] bi@ ]
-    } case ;
+GENERIC: interval-bounds ( interval -- lower upper )
+M: full-interval interval-bounds drop -1/0. 1/0. ;
+M: interval interval-bounds interval>points [ first ] bi@ ;
 
 : min-lower-bound ( i1 i2 -- n )
     [ from>> first ] bi@ min ;
@@ -423,13 +398,38 @@ SYMBOL: incomparable
 : max-lower-bound ( i1 i2 -- n )
     [ from>> first ] bi@ max ;
 
+: min-upper-bound ( i1 i2 -- n )
+    [ to>> first ] bi@ min ;
+
 : max-upper-bound ( i1 i2 -- n )
     [ to>> first ] bi@ max ;
 
 : interval-bit-weight ( i1 -- n )
-    bounds [ bit-weight ] bi@ max ;
+    interval-bounds [ bit-weight ] bi@ max ;
 PRIVATE>
 
+: interval-bitand ( i1 i2 -- i3 )
+    [
+        {
+            {
+                [ 2dup [ interval-nonnegative? ] both? ]
+                [ min-upper-bound 0 swap [a,b] ]
+            }
+            {
+                [ 2dup [ interval-nonnegative? ] either? ]
+                [
+                    dup interval-nonnegative? [ nip ] [ drop ] if
+                    to>> first 0 swap [a,b]
+                ]
+            }
+            {
+                [ 2dup [ interval-negative? ] both? ]
+                [ [ min-lower-bound bit-weight neg ] [ min-upper-bound ] 2bi [a,b] ]
+            }
+            [ [ min-lower-bound bit-weight neg ] [ max-upper-bound ] 2bi [a,b] ]
+        } cond
+    ] do-empty-interval ;
+
 ! Basic Property of bitor: bits can never be taken away.  For both signed and
 ! unsigned integers this means that the number can only grow towards positive
 ! infinity.  Also, the significant bit range can never be larger than either of