! 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
: 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 ] }
- { array-capacity [ max-array-capacity [a,a] interval-rem ] }
+ { [ over empty-interval eq? ] [ drop ] }
+ { [ 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
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
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 number= ] [
- 2drop 2dup [ second ] both?
+ {
+ { [ 2dup [ first ] bi@ > ] [ 2drop empty-interval ] }
+ { [ 2dup [ first ] bi@ number= ] [
+ 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 ;
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 -- ? )
[ 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] ;