Merge branch 'master' of git://factorcode.org/git/factor

basis/compiler/tree/propagation/info/info.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs classes classes.algebra classes.tuple
 classes.tuple.private kernel accessors math math.intervals namespaces
-sequences sequences.private words combinators
+sequences sequences.private words combinators memoize
 combinators.short-circuit byte-arrays strings arrays layouts
 cpu.architecture compiler.tree.propagation.copy ;
 IN: compiler.tree.propagation.info
@@ -78,21 +78,37 @@ UNION: fixed-length array byte-array string ;
 : empty-set? ( info -- ? )
     {
         [ class>> null-class? ]
-        [ [ class>> real class<= ] [ interval>> empty-interval eq? ] bi and ]
+        [ [ interval>> empty-interval eq? ] [ class>> real class<= ] bi and ]
     } 1|| ;
 
-: min-value ( class -- n ) fixnum eq? [ most-negative-fixnum ] [ -1/0. ] if ;
+: min-value ( class -- n )
+    {
+        { fixnum [ most-negative-fixnum ] }
+        { array-capacity [ 0 ] }
+        [ drop -1/0. ]
+    } case ;
 
-: max-value ( class -- n ) fixnum eq? [ most-positive-fixnum ] [ 1/0. ] if ;
+: max-value ( class -- n )
+    {
+        { fixnum [ most-positive-fixnum ] }
+        { array-capacity [ max-array-capacity ] }
+        [ drop 1/0. ]
+    } case ;
 
-: class-interval ( class -- i ) fixnum eq? [ fixnum-interval ] [ full-interval ] if ;
+: class-interval ( class -- i )
+    {
+        { fixnum [ fixnum-interval ] }
+        { array-capacity [ array-capacity-interval ] }
+        [ drop full-interval ]
+    } case ;
 
 : wrap-interval ( interval class -- interval' )
     {
-        { fixnum [ interval->fixnum ] }
+        { [ over empty-interval eq? ] [ drop ] }
-        { array-capacity [ max-array-capacity [a,a] interval-rem ] }
+        { [ over full-interval eq? ] [ nip class-interval ] }
+        { [ 2dup class-interval interval-subset? not ] [ nip class-interval ] }
         [ drop ]
-    } case ;
+    } cond ;
 
 : init-interval ( info -- info )
     dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval

basis/math/intervals/intervals-tests.factor

@@ -113,6 +113,22 @@ IN: math.intervals.tests
     0 1 (a,b) 0 1 [a,b] interval-subset?
 ] unit-test
 
+[ t ] [
+    full-interval -1/0. 1/0. [a,b] interval-subset?
+] unit-test
+
+[ t ] [
+    -1/0. 1/0. [a,b] full-interval interval-subset?
+] unit-test
+
+[ f ] [
+    full-interval 0 1/0. [a,b] interval-subset?
+] unit-test
+
+[ t ] [
+    0 1/0. [a,b] full-interval interval-subset?
+] unit-test
+
 [ f ] [
     0 0 1 (a,b) interval-contains?
 ] unit-test

basis/math/intervals/intervals.factor

@@ -11,14 +11,21 @@ SYMBOL: full-interval
 
 TUPLE: interval { from read-only } { to read-only } ;
 
+: closed-point? ( from to -- ? )
+    2dup [ first ] bi@ number=
+    [ [ second ] both? ] [ 2drop f ] if ;
+
 : <interval> ( from to -- interval )
-    2dup [ first ] bi@ {
+    {
-        { [ 2dup > ] [ 2drop 2drop empty-interval ] }
+        { [ 2dup [ first ] bi@ > ] [ 2drop empty-interval ] }
-        { [ 2dup number= ] [
+        { [ 2dup [ first ] bi@ number= ] [
-            2drop 2dup [ second ] both?
+            2dup [ second ] both?
             [ interval boa ] [ 2drop empty-interval ] if
         ] }
-        [ 2drop interval boa ]
+        { [ 2dup [ { -1/0. t } = ] [ { 1/0. t } = ] bi* and ] [
+            2drop full-interval
+        ] }
+        [ interval boa ]
     } cond ;
 
 : open-point ( n -- endpoint ) f 2array ;
@@ -53,6 +60,9 @@ MEMO: [0,inf] ( -- interval ) 0 [a,inf] ; foldable
 MEMO: fixnum-interval ( -- interval )
     most-negative-fixnum most-positive-fixnum [a,b] ; inline
 
+MEMO: array-capacity-interval ( -- interval )
+    0 max-array-capacity [a,b] ; inline
+
 : [-inf,inf] ( -- interval ) full-interval ; inline
 
 : compare-endpoints ( p1 p2 quot -- ? )
@@ -344,14 +354,6 @@ SYMBOL: incomparable
         [ nip (rem-range) ]
     } cond ;
 
-: interval->fixnum ( i1 -- i2 )
-    {
-        { [ dup empty-interval eq? ] [ ] }
-        { [ dup full-interval eq? ] [ drop fixnum-interval ] }
-        { [ dup fixnum-interval interval-subset? not ] [ drop fixnum-interval ] }
-        [ ]
-    } cond ;
-
 : interval-bitand-pos ( i1 i2 -- ? )
     [ to>> first ] bi@ min 0 swap [a,b] ;