From ef1e8ee8f63888d0def837c00962af4a2858619a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 23 Jul 2008 20:11:43 -0500
Subject: [PATCH] More interval debugging

---
 core/math/intervals/intervals-tests.factor | 26 +++++++++-
 core/math/intervals/intervals.factor       | 57 ++++++++++++++--------
 2 files changed, 62 insertions(+), 21 deletions(-)

diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor
index 7aa8ae0679..5234f03ecf 100755
--- a/core/math/intervals/intervals-tests.factor
+++ b/core/math/intervals/intervals-tests.factor
@@ -217,7 +217,7 @@ IN: math.intervals.tests
     ] if ;
 
 : random-interval ( -- interval )
-    1000 random dup 2 1000 random + +
+    2000 random 1000 - dup 2 1000 random + +
     1 random zero? [ [ neg ] bi@ swap ] when
     4 random {
         { 0 [ [a,b] ] }
@@ -274,7 +274,7 @@ IN: math.intervals.tests
 
 : binary-test ( -- ? )
     random-interval random-interval random-binary-op ! 3dup . . .
-    0 pick interval-contains? over first { / /i } member? and [
+    0 pick interval-contains? over first { / /i mod rem } member? and [
         3drop t
     ] [
         [ >r [ random-element ] bi@ ! 2dup . .
@@ -310,3 +310,25 @@ IN: math.intervals.tests
 [ t ] [ -10 10 [a,b] -100 0 [a,b] assume<= -10 0 [a,b] = ] unit-test
 
 [ t ] [ -10 10 [a,b] 0 100 [a,b] assume<= -10 10 [a,b] = ] unit-test
+
+[ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test
+
+! Test that commutative interval ops really are
+: random-interval-or-empty ( -- )
+    10 random 0 = [ empty-interval ] [ random-interval ] if ;
+
+: random-commutative-op ( -- op )
+    {
+        interval+ interval*
+        interval-bitor interval-bitand interval-bitxor
+        interval-max interval-min
+    } random ;
+
+[ t ] [
+    80000 [
+        drop
+        random-interval-or-empty random-interval-or-empty
+        random-commutative-op
+        [ execute ] [ swapd execute ] 3bi =
+    ] all?
+] unit-test
diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor
index 4aa86d772b..1896943a71 100755
--- a/core/math/intervals/intervals.factor
+++ b/core/math/intervals/intervals.factor
@@ -235,11 +235,15 @@ TUPLE: interval { from read-only } { to read-only } ;
 : interval/f ( i1 i2 -- i3 )
     [ [ [ /f ] interval-op ] interval-division-op ] do-empty-interval ;
 
+: (interval-abs) ( i1 -- i2 )
+    interval>points [ first2 [ abs ] dip 2array ] bi@ 2array ;
+
 : interval-abs ( i1 -- i2 )
-    dup empty-interval eq? [
-        interval>points [ first2 [ abs ] dip 2array ] bi@ 2array
-        points>interval
-    ] unless ;
+    {
+        { [ dup empty-interval eq? ] [ ] }
+        { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
+        [ (interval-abs) points>interval ]
+    } cond ;
 
 : interval-mod ( i1 i2 -- i3 )
     #! Inaccurate.
@@ -307,30 +311,45 @@ SYMBOL: incomparable
 : interval>= ( i1 i2 -- ? )
     swap interval<= ;
 
+: 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-bitand ( i1 i2 -- i3 )
-    dup 1 [a,a] interval>= [
-        1 [a,a] interval- interval-rem
-    ] [
-        2drop [-inf,inf]
-    ] if ;
+    #! Inaccurate.
+    [
+        {
+            {
+                [ 2dup [ interval-nonnegative? ] both? ]
+                [ interval-bitand-pos ]
+            }
+            {
+                [ 2dup [ interval-nonnegative? ] either? ]
+                [ interval-bitand-neg ]
+            }
+            [ 2drop [-inf,inf] ]
+        } cond
+    ] do-empty-interval ;
 
 : interval-bitor ( i1 i2 -- i3 )
     #! Inaccurate.
     [
-        2dup [ 0 [a,a] interval>= ] both?
-        [ to>> first 0 swap [a,b] interval-intersect ]
-        [ 2drop [-inf,inf] ]
-        if
+        2dup [ interval-nonnegative? ] both?
+        [
+            [ interval>points [ first ] bi@ ] bi@
+            4array supremum 0 swap next-power-of-2 [a,b]
+        ] [ 2drop [-inf,inf] ] if
     ] do-empty-interval ;
 
 : interval-bitxor ( i1 i2 -- i3 )
     #! Inaccurate.
-    [
-        2dup [ 0 [a,a] interval>= ] both?
-        [ nip to>> first 0 swap [a,b] ]
-        [ 2drop [-inf,inf] ]
-        if
-    ] do-empty-interval ;
+    interval-bitor ;
 
 : assume< ( i1 i2 -- i3 )
     dup empty-interval eq? [ drop ] [