Add empty interval handling

diff --git a/core/math/intervals/intervals-docs.factor b/core/math/intervals/intervals-docs.factor
index 077ffd6d281926f17800610a4a752e2ee6817976..b5cd23140235bf4e4fd1b9ee0ae4663524877795 100644 (file)
--- a/core/math/intervals/intervals-docs.factor
+++ b/core/math/intervals/intervals-docs.factor
@@ -16,6 +16,8 @@ ARTICLE: "math-intervals-new" "Creating intervals"
 { $subsection (a,inf] }
 "The set of all real numbers with infinities:"
 { $subsection [-inf,inf] }
+"The empty set:"
+{ $subsection empty-interval }
 "Another constructor:"
 { $subsection points>interval } ;
 

diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor
index f8dce14a062f74ae975f46bc9393446c81033e9a..7aa8ae0679b63a266096083bcfbc97b598bc0031 100755 (executable)
--- a/core/math/intervals/intervals-tests.factor
+++ b/core/math/intervals/intervals-tests.factor
@@ -1,7 +1,16 @@
 USING: math.intervals kernel sequences words math math.order
-arrays prettyprint tools.test random vocabs combinators ;
+arrays prettyprint tools.test random vocabs combinators
+accessors ;
 IN: math.intervals.tests
 
+[ empty-interval ] [ 2 2 (a,b) ] unit-test
+
+[ empty-interval ] [ 2 2 [a,b) ] unit-test
+
+[ empty-interval ] [ 2 2 (a,b] ] unit-test
+
+[ empty-interval ] [ 3 2 [a,b] ] unit-test
+
 [ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test
 
 [ T{ interval f { 1 t } { 2 f } } ] [ 1 2 [a,b) ] unit-test
@@ -18,6 +27,10 @@ IN: math.intervals.tests
 [ t ] [ { 4 f } { 3 t } endpoint> ] unit-test
 [ f ] [ { 3 f } { 3 t } endpoint> ] unit-test
 
+[ empty-interval ] [ 1 2 [a,b] empty-interval interval+ ] unit-test
+
+[ empty-interval ] [ empty-interval 1 2 [a,b] interval+ ] unit-test
+
 [ t ] [
     1 2 [a,b] -3 3 [a,b] interval+ -2 5 [a,b] =
 ] unit-test
@@ -26,10 +39,18 @@ IN: math.intervals.tests
     1 2 [a,b] -3 3 (a,b) interval+ -2 5 (a,b) =
 ] unit-test
 
+[ empty-interval ] [ 1 2 [a,b] empty-interval interval- ] unit-test
+
+[ empty-interval ] [ empty-interval 1 2 [a,b] interval- ] unit-test
+
 [ t ] [
     1 2 [a,b] 0 1 [a,b] interval- 0 2 [a,b] =
 ] unit-test
 
+[ empty-interval ] [ 1 2 [a,b] empty-interval interval* ] unit-test
+
+[ empty-interval ] [ empty-interval 1 2 [a,b] interval* ] unit-test
+
 [ t ] [
     1 2 [a,b] 0 4 [a,b] interval* 0 8 [a,b] =
 ] unit-test
@@ -50,6 +71,10 @@ IN: math.intervals.tests
     -1 1 [a,b] -1 1 (a,b] interval* -1 1 [a,b] =
 ] unit-test
 
+[ t ] [ 1 2 [a,b] dup empty-interval interval-union = ] unit-test
+
+[ t ] [ empty-interval 1 2 [a,b] tuck interval-union = ] unit-test
+
 [ t ] [
     0 1 (a,b) 0 1 [a,b] interval-union 0 1 [a,b] =
 ] unit-test
@@ -64,9 +89,21 @@ IN: math.intervals.tests
     0 1 (a,b) 0 1 [a,b] interval-intersect 0 1 (a,b) =
 ] unit-test
 
-[ f ] [ 0 5 [a,b] -1 [a,a] interval-intersect ] unit-test
+[ empty-interval ] [ 0 5 [a,b] -1 [a,a] interval-intersect ] unit-test
+
+[ empty-interval ] [ 0 5 (a,b] 0 [a,a] interval-intersect ] unit-test
 
-[ f ] [ 0 5 (a,b] 0 [a,a] interval-intersect ] unit-test
+[ empty-interval ] [ empty-interval -1 [a,a] interval-intersect ] unit-test
+
+[ empty-interval ] [ 0 5 (a,b] empty-interval interval-intersect ] unit-test
+
+[ t ] [
+    empty-interval empty-interval interval-subset?
+] unit-test
+
+[ t ] [
+    empty-interval 0 1 [a,b] interval-subset?
+] unit-test
 
 [ t ] [
     0 1 (a,b) 0 1 [a,b] interval-subset?
@@ -84,6 +121,8 @@ IN: math.intervals.tests
     1 0 1 (a,b) interval-contains?
 ] unit-test
 
+[ empty-interval ] [ -1 1 (a,b) empty-interval interval/ ] unit-test
+
 [ t ] [ -1 1 (a,b) -1 1 (a,b) interval/ [-inf,inf] = ] unit-test
 
 [ t ] [ -1 1 (a,b) 0 1 (a,b) interval/ [-inf,inf] = ] unit-test
@@ -94,6 +133,8 @@ IN: math.intervals.tests
     ] unit-test
 ] when
 
+[ f ] [ empty-interval interval-singleton? ] unit-test
+
 [ t ] [ 1 [a,a] interval-singleton? ] unit-test
 
 [ f ] [ 1 1 [a,b) interval-singleton? ] unit-test
@@ -104,10 +145,14 @@ IN: math.intervals.tests
 
 [ 2 ] [ 1 3 [a,b) interval-length ] unit-test
 
-[ 0 ] [ f interval-length ] unit-test
+[ 0 ] [ empty-interval interval-length ] unit-test
 
 [ t ] [ 0 5 [a,b] 5 [a,a] interval<= ] unit-test
 
+[ incomparable ] [ empty-interval 5 [a,a] interval< ] unit-test
+
+[ incomparable ] [ 5 [a,a] empty-interval interval< ] unit-test
+
 [ incomparable ] [ 0 5 [a,b] 5 [a,a] interval< ] unit-test
 
 [ t ] [ 0 5 [a,b) 5 [a,a] interval< ] unit-test
@@ -128,6 +173,10 @@ IN: math.intervals.tests
 
 [ t ] [ -1 1 (a,b] 1 2 [a,b] interval<= ] unit-test
 
+[ incomparable ] [ -1 1 (a,b] empty-interval interval>= ] unit-test
+
+[ incomparable ] [ empty-interval -1 1 (a,b] interval>= ] unit-test
+
 [ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval>= ] unit-test
 
 [ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval> ] unit-test
@@ -160,7 +209,7 @@ IN: math.intervals.tests
 
 ! Interval random tester
 : random-element ( interval -- n )
-    dup interval-to first over interval-from first tuck - random +
+    dup to>> first over from>> first tuck - random +
     2dup swap interval-contains? [
         nip
     ] [

diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor
index 2d7596d126edd49ecbc1c8b870e60b7a5637766c..4aa86d772beb86a745cfd54da222fee60b7de006 100755 (executable)
--- a/core/math/intervals/intervals.factor
+++ b/core/math/intervals/intervals.factor
@@ -5,9 +5,19 @@ USING: accessors kernel sequences arrays math math.order
 combinators generic ;
 IN: math.intervals
 
+SYMBOL: empty-interval
+
 TUPLE: interval { from read-only } { to read-only } ;
 
-C: <interval> interval
+: <interval> ( from to -- int )
+    over first over first {
+        { [ 2dup > ] [ 2drop 2drop empty-interval ] }
+        { [ 2dup = ] [
+            2drop over second over second and
+            [ interval boa ] [ 2drop empty-interval ] if
+        ] }
+        [ 2drop interval boa ]
+    } cond ;
 
 : open-point ( n -- endpoint ) f 2array ;
 
@@ -71,9 +81,9 @@ C: <interval> interval
     [ endpoint-max ] reduce <interval> ;
 
 : (interval-op) ( p1 p2 quot -- p3 )
-    2over >r >r
-    >r [ first ] bi@ r> call
-    r> r> [ second ] both? 2array ; inline
+    [ [ first ] [ first ] [ ] tri* call ]
+    [ drop [ second ] both? ]
+    3bi 2array ; inline
 
 : interval-op ( i1 i2 quot -- i3 )
     {
@@ -83,16 +93,21 @@ C: <interval> interval
         [ [ from>> ] [ to>>   ] [ ] tri* (interval-op) ]
     } 3cleave 4array points>interval ; inline
 
-: interval+ ( i1 i2 -- i3 ) [ + ] interval-op ;
+: do-empty-interval ( i1 i2 quot -- i3 )
+    {
+        { [ pick empty-interval eq? ] [ drop drop ] }
+        { [ over empty-interval eq? ] [ drop nip ] }
+        [ call ]
+    } cond ; inline
 
-: interval- ( i1 i2 -- i3 ) [ - ] interval-op ;
+: interval+ ( i1 i2 -- i3 )
+    [ [ + ] interval-op ] do-empty-interval ;
 
-: interval* ( i1 i2 -- i3 ) [ * ] interval-op ;
+: interval- ( i1 i2 -- i3 )
+    [ [ - ] interval-op ] do-empty-interval ;
 
-: interval-integer-op ( i1 i2 quot -- i3 )
-    >r 2dup
-    [ interval>points [ first integer? ] both? ] both?
-    r> [ 2drop f ] if ; inline
+: interval* ( i1 i2 -- i3 )
+    [ [ * ] interval-op ] do-empty-interval ;
 
 : interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ;
 
@@ -104,32 +119,34 @@ C: <interval> interval
 
 : interval-sq ( i1 -- i2 ) dup interval* ;
 
-: make-interval ( from to -- int )
-    over first over first {
-        { [ 2dup > ] [ 2drop 2drop f ] }
-        { [ 2dup = ] [
-            2drop over second over second and
-            [ <interval> ] [ 2drop f ] if
-        ] }
-        [ 2drop <interval> ]
-    } cond ;
-
 : interval-intersect ( i1 i2 -- i3 )
-    2dup and [
-        [ interval>points ] bi@ swapd
-        [ swap endpoint> ] most
-        >r [ swap endpoint< ] most r>
-        make-interval
-    ] [
-        or
-    ] if ;
+    {
+        { [ dup empty-interval eq? ] [ nip ] }
+        { [ over empty-interval eq? ] [ drop ] }
+        [
+            2dup and [
+                [ interval>points ] bi@ swapd
+                [ [ swap endpoint< ] most ]
+                [ [ swap endpoint> ] most ] 2bi*
+                <interval>
+            ] [
+                or
+            ] if
+        ]
+    } cond ;
 
 : interval-union ( i1 i2 -- i3 )
-    2dup and [
-        [ interval>points 2array ] bi@ append points>interval
-    ] [
-        2drop f
-    ] if ;
+    {
+        { [ dup empty-interval eq? ] [ drop ] }
+        { [ over empty-interval eq? ] [ nip ] }
+        [
+            2dup and [
+                [ interval>points 2array ] bi@ append points>interval
+            ] [
+                2drop f
+            ] if
+        ]
+    } cond ;
 
 : interval-subset? ( i1 i2 -- ? )
     dupd interval-intersect = ;
@@ -138,47 +155,67 @@ C: <interval> interval
     >r [a,a] r> interval-subset? ;
 
 : interval-singleton? ( int -- ? )
-    interval>points
-    2dup [ second ] bi@ and
-    [ [ first ] bi@ = ]
-    [ 2drop f ] if ;
+    dup empty-interval eq? [
+        drop f
+    ] [
+        interval>points
+        2dup [ second ] bi@ and
+        [ [ first ] bi@ = ]
+        [ 2drop f ] if
+    ] if ;
 
 : interval-length ( int -- n )
-    dup
-    [ interval>points [ first ] bi@ swap - ]
-    [ drop 0 ] if ;
+    {
+        { [ dup empty-interval eq? ] [ drop 0 ] }
+        { [ dup not ] [ drop 0 ] }
+        [ interval>points [ first ] bi@ swap - ]
+    } cond ;
 
 : interval-closure ( i1 -- i2 )
     dup [ interval>points [ first ] bi@ [a,b] ] when ;
 
+: interval-integer-op ( i1 i2 quot -- i3 )
+    >r 2dup
+    [ interval>points [ first integer? ] both? ] both?
+    r> [ 2drop [-inf,inf] ] if ; inline
+
 : interval-shift ( i1 i2 -- i3 )
     #! Inaccurate; could be tighter
-    [ [ shift ] interval-op ] interval-integer-op interval-closure ;
+    [
+        [
+            [ interval-closure ] bi@
+            [ shift ] interval-op
+        ] interval-integer-op
+    ] do-empty-interval ;
 
 : interval-shift-safe ( i1 i2 -- i3 )
-    dup to>> first 100 > [
-        2drop [-inf,inf]
-    ] [
-        interval-shift
-    ] if ;
+    [
+        dup to>> first 100 > [
+            2drop [-inf,inf]
+        ] [
+            interval-shift
+        ] if
+    ] do-empty-interval ;
 
 : interval-max ( i1 i2 -- i3 )
     #! Inaccurate; could be tighter
-    [ max ] interval-op interval-closure ;
+    [ [ interval-closure ] bi@ [ max ] interval-op ] do-empty-interval ;
 
 : interval-min ( i1 i2 -- i3 )
     #! Inaccurate; could be tighter
-    [ min ] interval-op interval-closure ;
+    [ [ interval-closure ] bi@ [ min ] interval-op ] do-empty-interval ;
 
 : interval-interior ( i1 -- i2 )
-    interval>points [ first ] bi@ (a,b) ;
+    dup empty-interval eq? [
+        interval>points [ first ] bi@ (a,b)
+    ] unless ;
 
 : interval-division-op ( i1 i2 quot -- i3 )
     >r 0 over interval-closure interval-contains?
     [ 2drop [-inf,inf] ] r> if ; inline
 
 : interval/ ( i1 i2 -- i3 )
-    [ [ / ] interval-op ] interval-division-op ;
+    [ [ [ / ] interval-op ] interval-division-op ] do-empty-interval ;
 
 : interval/-safe ( i1 i2 -- i3 )
     #! Just a hack to make the compiler work if bootstrap.math
@@ -187,27 +224,38 @@ C: <interval> interval
 
 : interval/i ( i1 i2 -- i3 )
     [
-        [ [ /i ] interval-op ] interval-integer-op
-    ] interval-division-op interval-closure ;
+        [
+            [
+                [ interval-closure ] bi@
+                [ /i ] interval-op
+            ] interval-integer-op
+        ] interval-division-op
+    ] do-empty-interval ;
 
 : interval/f ( i1 i2 -- i3 )
-    [ [ /f ] interval-op ] interval-division-op ;
+    [ [ [ /f ] interval-op ] interval-division-op ] do-empty-interval ;
 
 : interval-abs ( i1 -- i2 )
-    interval>points [ first2 [ abs ] dip 2array ] bi@ 2array
-    points>interval ;
+    dup empty-interval eq? [
+        interval>points [ first2 [ abs ] dip 2array ] bi@ 2array
+        points>interval
+    ] unless ;
 
 : interval-mod ( i1 i2 -- i3 )
     #! Inaccurate.
     [
-        nip interval-abs to>> first [ neg ] keep (a,b)
-    ] interval-division-op ;
+        [
+            nip interval-abs to>> first [ neg ] keep (a,b)
+        ] interval-division-op
+    ] do-empty-interval ;
 
 : interval-rem ( i1 i2 -- i3 )
     #! Inaccurate.
     [
-        nip interval-abs to>> first 0 swap [a,b)
-    ] interval-division-op ;
+        [
+            nip interval-abs to>> first 0 swap [a,b)
+        ] interval-division-op
+    ] do-empty-interval ;
 
 : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
 
@@ -232,7 +280,8 @@ SYMBOL: incomparable
 
 : interval< ( i1 i2 -- ? )
     {
-        { [ 2dup interval-intersect not ] [ (interval<) ] }
+        { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
+        { [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
         { [ 2dup left-endpoint-< ] [ f ] }
         { [ 2dup right-endpoint-< ] [ f ] }
         [ incomparable ]
@@ -246,7 +295,8 @@ SYMBOL: incomparable
 
 : interval<= ( i1 i2 -- ? )
     {
-        { [ 2dup interval-intersect not ] [ (interval<) ] }
+        { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
+        { [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
         { [ 2dup right-endpoint-<= ] [ t ] }
         [ incomparable ]
     } cond 2nip ;
@@ -266,31 +316,45 @@ SYMBOL: incomparable
 
 : 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 [ 0 [a,a] interval>= ] both?
+        [ to>> first 0 swap [a,b] interval-intersect ]
+        [ 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 ;
+    [
+        2dup [ 0 [a,a] interval>= ] both?
+        [ nip to>> first 0 swap [a,b] ]
+        [ 2drop [-inf,inf] ]
+        if
+    ] do-empty-interval ;
 
 : assume< ( i1 i2 -- i3 )
-    to>> first [-inf,a) interval-intersect ;
+    dup empty-interval eq? [ drop ] [
+        to>> first [-inf,a) interval-intersect
+    ] if ;
 
 : assume<= ( i1 i2 -- i3 )
-    to>> first [-inf,a] interval-intersect ;
+    dup empty-interval eq? [ drop ] [
+        to>> first [-inf,a] interval-intersect
+    ] if ;
 
 : assume> ( i1 i2 -- i3 )
-    from>> first (a,inf] interval-intersect ;
+    dup empty-interval eq? [ drop ] [
+        from>> first (a,inf] interval-intersect
+    ] if ;
 
 : assume>= ( i1 i2 -- i3 )
-    from>> first [a,inf] interval-intersect ;
+    dup empty-interval eq? [ drop ] [
+        from>> first [a,inf] interval-intersect
+    ] if ;
 
 : integral-closure ( i1 -- i2 )
-    [ from>> first2 [ 1+ ] unless ]
-    [ to>> first2 [ 1- ] unless ]
-    bi [a,b] ;
+    dup empty-interval eq? [
+        [ from>> first2 [ 1+ ] unless ]
+        [ to>> first2 [ 1- ] unless ]
+        bi [a,b]
+    ] unless ;