math.intervals: more exact interval-bitor operation

Addresses #2170

- fixed: `interval-bitor` caused bit-growth
- improved: `interval-bitor` more exact about lower bounds

The added utility words could be used as a basis to make the other bitwise
interval operations more exact also.

diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor
index bb1e657710fe8f62ac60710ff24c97ec02424a0d..f7ae5dc9c00acb58b54f7150bb6cc56a923740d1 100644 (file)
--- a/basis/math/intervals/intervals-tests.factor
+++ b/basis/math/intervals/intervals-tests.factor
@@ -1,8 +1,10 @@
-USING: math.intervals kernel sequences words math math.order
-arrays prettyprint tools.test random vocabs combinators
-accessors math.constants fry ;
+USING: accessors combinators fry kernel literals math math.intervals
+math.intervals.private math.order math.statistics random sequences
+sequences.deep tools.test vocabs ;
 IN: math.intervals.tests
 
+FROM: math.ranges => <range> ;
+
 { empty-interval } [ 2 2 (a,b) ] unit-test
 
 { empty-interval } [ 2 2.0 (a,b) ] unit-test
@@ -385,7 +387,7 @@ commutative-ops [
     ] unit-test
 ] each
 
-! Test singleton behavior
+! test singleton behavior
 { f } [ full-interval interval-nonnegative? ] unit-test
 
 { t } [ empty-interval interval-nonnegative? ] unit-test
@@ -397,3 +399,39 @@ commutative-ops [
 { f } [ -1/0. 1/0. [ empty-interval interval-contains? ] bi@ or ] unit-test
 
 { t } [ -1/0. 1/0. [ full-interval interval-contains? ] bi@ and ] unit-test
+
+! Interval bitor
+
+{ 1/0. } [ 1/0. bit-weight ] unit-test
+{ 1/0. } [ -1/0. bit-weight ] unit-test
+
+{ t } [
+    16 <iota> dup [ bitor ] cartesian-map flatten
+    [ 0 15 [a,b] interval-contains? ] all?
+] unit-test
+
+: cartesian-bounds ( range range quot -- min max )
+    cartesian-map flatten minmax ; inline
+
+{ 0 15 } [ 16 <iota> dup [ bitor ] cartesian-bounds ] unit-test
+{ 0 15 } [ 16 <iota> dup [ bitxor ] cartesian-bounds ] unit-test
+
+{ -8 7 } [ -8 7 1 <range> dup [ bitor ] cartesian-bounds ] unit-test
+{ -8 7 } [ -8 7 1 <range> dup [ bitxor ] cartesian-bounds ] unit-test
+
+{ 6 15 } [ 5 15 1 <range> 6 15 1 <range> [ bitor ] cartesian-bounds ] unit-test
+
+{ -12 -1 } [ -16 -12 1 <range> -12 -2 1 <range> [ bitor ] cartesian-bounds ] unit-test
+
+{ -16 15 } [ -16 4 1 <range> -1 15 1 <range> [ bitor ] cartesian-bounds ] unit-test
+
+{ $[ 0 255 [a,b] ] } [ 0 255 [a,b] dup interval-bitor ] unit-test
+{ $[ 0 511 [a,b] ] } [ 0 256 [a,b] dup interval-bitor ] unit-test
+
+{ $[ -128 127 [a,b] ] } [ -128 127 [a,b] dup interval-bitor ] unit-test
+{ $[ -256 255 [a,b] ] } [ -128 128 [a,b] dup interval-bitor ] unit-test
+
+{ full-interval } [ full-interval -128 127 [a,b] interval-bitor ] unit-test
+{ $[ 0 [a,inf] ] } [ 0 [a,inf] dup interval-bitor ] unit-test
+{ full-interval } [ 0 [-inf,a] dup interval-bitor ] unit-test
+{ $[ 4 [a,inf] ] } [ 4 [a,inf] 3 [a,inf] interval-bitor ] unit-test

diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor
index a12b1d6e2fa66b685adfd4424b9d72ef577dc2fd..2d5a02825c2b3be164a77fee9dbf5c5e6e2bf9a7 100644 (file)
--- a/basis/math/intervals/intervals.factor
+++ b/basis/math/intervals/intervals.factor
@@ -384,6 +384,9 @@ SYMBOL: incomparable
 : interval-nonnegative? ( i -- ? )
     from>> first 0 >= ;
 
+: interval-negative? ( interval -- ? )
+    to>> first 0 < ;
+
 : interval-bitand ( i1 i2 -- i3 )
     ! Inaccurate.
     [
@@ -400,7 +403,53 @@ SYMBOL: incomparable
         } cond
     ] do-empty-interval ;
 
+<PRIVATE
+! 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 ;
+
+: max-lower-bound ( i1 i2 -- n )
+    [ from>> first ] bi@ max ;
+
+: max-upper-bound ( i1 i2 -- n )
+    [ to>> first ] bi@ max ;
+
+: interval-bit-weight ( i1 -- n )
+    bounds [ bit-weight ] bi@ max ;
+PRIVATE>
+
+! 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
+! the operands.
+! In case both intervals are positive:
+! lower(i1 bitor i2) = max(lower(i1),lower(i2))
+! upper(i1 bitor i2) = 2 ^ max(bit-length(upper(i1)), bit-length(upper(i2))) - 1
+! In case both intervals are negative:
+! lower(i1 bitor i2) = max(lower(i1),lower(i2))
+! upper(i1 bitor i2) = -1
+! In case one is negative and the other positive, simply assume the whole
+! bit-range.  This case is not accurate though.
 : interval-bitor ( i1 i2 -- i3 )
+    [
+        { { [ 2dup [ interval-nonnegative? ] both? ]
+            [ [ max-lower-bound ] [ max-upper-bound ] 2bi bit-weight 1 - [a,b] ] }
+          { [ 2dup [ interval-negative? ] both? ]
+            [ max-lower-bound -1 [a,b] ] }
+          [ interval-union interval-bit-weight [ neg ] [ 1 - ] bi [a,b] ]
+        } cond
+    ] do-empty-interval ;
+
+: interval-bitxor ( i1 i2 -- i3 )
     ! Inaccurate.
     [
         2dup [ interval-nonnegative? ] both?
@@ -410,10 +459,6 @@ SYMBOL: incomparable
         ] [ 2drop [-inf,inf] ] if
     ] do-empty-interval ;
 
-: interval-bitxor ( i1 i2 -- i3 )
-    ! Inaccurate.
-    interval-bitor ;
-
 GENERIC: interval-log2 ( i1 -- i2 )
 M: empty-interval interval-log2 ;
 M: full-interval interval-log2 drop [0,inf] ;