math.intervals: more exact interval-bitxor operation

- fixed: `interval-bitxor` caused bit-growth
- improved: `interval-bitxor` more exact case for negative intervals

basis/math/intervals/intervals-tests.factor

@@ -414,10 +414,8 @@ commutative-ops [
     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
 
@@ -435,3 +433,25 @@ commutative-ops [
 { $[ 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
+
+! interval-bitxor
+{ 0 15 } [ 16 <iota> dup [ bitxor ] cartesian-bounds ] unit-test
+
+{ -8 7 } [ -8 7 1 <range> dup [ bitxor ] cartesian-bounds ] unit-test
+
+{ 0 15 } [ -16 -1 1 <range> dup [ bitxor ] cartesian-bounds ] unit-test
+
+{ -16 15 } [ -16 0 1 <range> dup [ bitxor ] cartesian-bounds ] unit-test
+
+{ $[ 0 255 [a,b] ] } [ 0 255 [a,b] dup interval-bitxor ] unit-test
+{ $[ 0 511 [a,b] ] } [ 0 256 [a,b] dup interval-bitxor ] unit-test
+
+{ $[ -128 127 [a,b] ] } [ -128 127 [a,b] dup interval-bitxor ] unit-test
+{ $[ -256 255 [a,b] ] } [ -128 128 [a,b] dup interval-bitxor ] unit-test
+{ $[ 0 127 [a,b] ] } [ -128 -1 [a,b] dup interval-bitxor ] unit-test
+
+{ full-interval } [ full-interval -128 127 [a,b] interval-bitxor ] unit-test
+{ $[ 0 [a,inf] ] } [ 0 [a,inf] dup interval-bitxor ] unit-test
+{ $[ 0 [a,inf] ] } [ -1 [-inf,a] dup interval-bitxor ] unit-test
+{ $[ 0 [a,inf] ] } [ 4 [a,inf] 3 [a,inf] interval-bitxor ] unit-test
+{ full-interval } [ 4 [a,inf] -3 [a,inf] interval-bitxor ] unit-test

basis/math/intervals/intervals.factor

@@ -417,6 +417,9 @@ SYMBOL: incomparable
         [ interval>points [ first ] bi@ ]
     } case ;
 
+: min-lower-bound ( i1 i2 -- n )
+    [ from>> first ] bi@ min ;
+
 : max-lower-bound ( i1 i2 -- n )
     [ from>> first ] bi@ max ;
 
@@ -449,14 +452,18 @@ PRIVATE>
         } cond
     ] do-empty-interval ;
 
+! Basic Property of bitxor: can always produce 0,  can never increase
+! significant range
+! If both operands are known to be negative, the sign bit(s) will be zero,
+! always resulting in a positive number
 : interval-bitxor ( i1 i2 -- i3 )
-    ! Inaccurate.
     [
-        2dup [ interval-nonnegative? ] both?
+        { { [ 2dup [ interval-nonnegative? ] both? ]
-        [
+            [ max-upper-bound bit-weight 1 - 0 swap [a,b] ] }
-            [ interval>points [ first ] bi@ ] bi@
+          { [ 2dup [ interval-negative? ] both? ]
-            4array supremum 0 swap >integer next-power-of-2 [a,b]
+            [ min-lower-bound bit-weight 1 - 0 swap [a,b] ] }
-        ] [ 2drop [-inf,inf] ] if
+          [ interval-union interval-bit-weight [ neg ] [ 1 - ] bi [a,b] ]
+        } cond
     ] do-empty-interval ;
 
 GENERIC: interval-log2 ( i1 -- i2 )