steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2009-08-12 17:46:52 -05:00
parent 56b81a74ab 0df4436711
commit cd1bb8f4c8
3 changed files with 55 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
basis/compiler/tree/propagation/info/info.factor
View File

@ -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 ] }
{ 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

16
basis/math/intervals/intervals-tests.factor
View File

@ -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

28
basis/math/intervals/intervals.factor
View File

@ -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 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 ;
@ -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] ;