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

math.intervals: Consistent handling of special intervals 

Make both `empty-interval` and `full-interval` singletons, use generic functions
and methods where they are special-cased.

All words which work with interval points should also now work with the special
intervals.
clean-linux-x86-64
timor 2019-09-09 10:31:33 +02:00 committed by John Benediktsson
parent a8c73064d8
commit 14d75bbbcb
4 changed files with 83 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -83,7 +83,7 @@ UNION: fixed-length array byte-array string ;
: empty-set? ( info -- ? ) : empty-set? ( info -- ? )
{ {
[ class>> null-class? ] [ class>> null-class? ]
[ [ interval>> empty-interval eq? ] [ class>> real class<= ] bi and ] [ [ interval>> empty-interval? ] [ class>> real class<= ] bi and ]
} 1|| ; } 1|| ;
! Hardcoding classes is kind of a hack. ! Hardcoding classes is kind of a hack.

2
basis/compiler/tree/propagation/recursive/recursive.factor
View File

@ -27,7 +27,7 @@ IN: compiler.tree.propagation.recursive
interval class counter-class :> class interval class counter-class :> class
{ {
{ [ interval initial-interval interval-subset? ] [ initial-interval ] } { [ interval initial-interval interval-subset? ] [ initial-interval ] }
{ [ interval empty-interval eq? ] [ initial-interval ] } { [ interval empty-interval? ] [ initial-interval ] }
{ {
[ interval initial-interval interval>= t eq? ] [ interval initial-interval interval>= t eq? ]
[ class max-value [a,a] initial-interval interval-union ] [ class max-value [a,a] initial-interval interval-union ]

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

@ -384,3 +384,16 @@ commutative-ops [
] all? ] all?
] unit-test ] unit-test
] each ] each
! Test singleton behavior
{ f } [ full-interval interval-nonnegative? ] unit-test
{ t } [ empty-interval interval-nonnegative? ] unit-test
{ t } [ full-interval interval-zero? ] unit-test
{ f } [ empty-interval interval-zero? ] unit-test
{ f } [ -1/0. 1/0. [ empty-interval interval-contains? ] bi@ or ] unit-test
{ t } [ -1/0. 1/0. [ full-interval interval-contains? ] bi@ and ] unit-test

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

@ -5,12 +5,17 @@ USING: accessors kernel sequences arrays math math.order
combinators combinators.short-circuit generic layouts memoize ; combinators combinators.short-circuit generic layouts memoize ;
IN: math.intervals IN: math.intervals
SYMBOL: empty-interval SINGLETON: empty-interval
SINGLETON: full-interval SINGLETON: full-interval
UNION: special-interval empty-interval full-interval ;
TUPLE: interval { from read-only } { to read-only } ; TUPLE: interval { from read-only } { to read-only } ;
M: empty-interval from>> drop { 1/0. f } ;
M: empty-interval to>> drop { -1/0. f } ;
M: full-interval from>> drop { -1/0. t } ;
M: full-interval to>> drop { 1/0. t } ;
: closed-point? ( from to -- ? ) : closed-point? ( from to -- ? )
2dup [ first ] bi@ number= 2dup [ first ] bi@ number=
[ [ second ] both? ] [ 2drop f ] if ; [ [ second ] both? ] [ 2drop f ] if ;
@ -122,10 +127,10 @@ MEMO: array-capacity-interval ( -- interval )
: do-empty-interval ( i1 i2 quot -- i3 ) : do-empty-interval ( i1 i2 quot -- i3 )
{ {
{ [ pick empty-interval eq? ] [ 2drop ] } { [ pick empty-interval? ] [ 2drop ] }
{ [ over empty-interval eq? ] [ drop nip ] } { [ over empty-interval? ] [ drop nip ] }
{ [ pick full-interval eq? ] [ 2drop ] } { [ pick full-interval? ] [ 2drop ] }
{ [ over full-interval eq? ] [ drop nip ] } { [ over full-interval? ] [ drop nip ] }
[ call ] [ call ]
} cond ; inline } cond ; inline
@ -137,10 +142,10 @@ MEMO: array-capacity-interval ( -- interval )
: interval-intersect ( i1 i2 -- i3 ) : interval-intersect ( i1 i2 -- i3 )
{ {
{ [ over empty-interval eq? ] [ drop ] } { [ over empty-interval? ] [ drop ] }
{ [ dup empty-interval eq? ] [ nip ] } { [ dup empty-interval? ] [ nip ] }
{ [ over full-interval eq? ] [ nip ] } { [ over full-interval? ] [ nip ] }
{ [ dup full-interval eq? ] [ drop ] } { [ dup full-interval? ] [ drop ] }
[ [
[ interval>points ] bi@ [ interval>points ] bi@
[ [ swap endpoint< ] most ] [ [ swap endpoint< ] most ]
@ -150,29 +155,28 @@ MEMO: array-capacity-interval ( -- interval )
} cond ; } cond ;
: intervals-intersect? ( i1 i2 -- ? ) : intervals-intersect? ( i1 i2 -- ? )
interval-intersect empty-interval eq? not ; interval-intersect empty-interval? not ;
: interval-union ( i1 i2 -- i3 ) : interval-union ( i1 i2 -- i3 )
{ {
{ [ over empty-interval eq? ] [ nip ] } { [ over empty-interval? ] [ nip ] }
{ [ dup empty-interval eq? ] [ drop ] } { [ dup empty-interval? ] [ drop ] }
{ [ over full-interval eq? ] [ drop ] } { [ over full-interval? ] [ drop ] }
{ [ dup full-interval eq? ] [ nip ] } { [ dup full-interval? ] [ nip ] }
[ [ interval>points 2array ] bi@ append points>interval nan-not-ok ] [ [ interval>points 2array ] bi@ append points>interval nan-not-ok ]
} cond ; } cond ;
: interval-subset? ( i1 i2 -- ? ) : interval-subset? ( i1 i2 -- ? )
dupd interval-intersect = ; dupd interval-intersect = ;
: interval-contains? ( x int -- ? ) GENERIC: interval-contains? ( x int -- ? )
dup empty-interval eq? [ 2drop f ] [ M: empty-interval interval-contains? 2drop f ;
dup full-interval eq? [ 2drop t ] [ M: full-interval interval-contains? 2drop t ;
{ M: interval interval-contains?
[ from>> first2 [ >= ] [ > ] if ] {
[ to>> first2 [ <= ] [ < ] if ] [ from>> first2 [ >= ] [ > ] if ]
} 2&& [ to>> first2 [ <= ] [ < ] if ]
] if } 2&& ;
] if ;
: interval-zero? ( int -- ? ) : interval-zero? ( int -- ? )
0 swap interval-contains? ; 0 swap interval-contains? ;
@ -192,25 +196,19 @@ MEMO: array-capacity-interval ( -- interval )
: interval-sq ( i1 -- i2 ) dup interval* ; : interval-sq ( i1 -- i2 ) dup interval* ;
: special-interval? ( interval -- ? ) GENERIC: interval-singleton? ( int -- ? )
{ empty-interval full-interval } member-eq? ; M: special-interval interval-singleton? drop f ;
M: interval interval-singleton?
interval>points
2dup [ second ] both?
[ [ first ] bi@ number= ]
[ 2drop f ] if ;
: interval-singleton? ( int -- ? ) GENERIC: interval-length ( int -- n )
dup special-interval? [ M: empty-interval interval-length drop 0 ;
drop f M: full-interval interval-length drop 1/0. ;
] [ M: interval interval-length
interval>points interval>points [ first ] bi@ swap - ;
2dup [ second ] both?
[ [ first ] bi@ number= ]
[ 2drop f ] if
] if ;
: interval-length ( int -- n )
{
{ [ dup empty-interval eq? ] [ drop 0 ] }
{ [ dup full-interval eq? ] [ drop 1/0. ] }
[ interval>points [ first ] bi@ swap - ]
} cond ;
: interval-closure ( i1 -- i2 ) : interval-closure ( i1 -- i2 )
dup [ interval>points [ first ] bi@ [a,b] ] when ; dup [ interval>points [ first ] bi@ [a,b] ] when ;
@ -240,21 +238,21 @@ MEMO: array-capacity-interval ( -- interval )
: interval-max ( i1 i2 -- i3 ) : interval-max ( i1 i2 -- i3 )
{ {
{ [ over empty-interval eq? ] [ drop ] } { [ over empty-interval? ] [ drop ] }
{ [ dup empty-interval eq? ] [ nip ] } { [ dup empty-interval? ] [ nip ] }
{ [ 2dup [ full-interval eq? ] both? ] [ drop ] } { [ 2dup [ full-interval? ] both? ] [ drop ] }
{ [ over full-interval eq? ] [ nip from>> first [a,inf] ] } { [ over full-interval? ] [ nip from>> first [a,inf] ] }
{ [ dup full-interval eq? ] [ drop from>> first [a,inf] ] } { [ dup full-interval? ] [ drop from>> first [a,inf] ] }
[ [ interval-closure ] bi@ [ max ] interval-op nan-not-ok ] [ [ interval-closure ] bi@ [ max ] interval-op nan-not-ok ]
} cond ; } cond ;
: interval-min ( i1 i2 -- i3 ) : interval-min ( i1 i2 -- i3 )
{ {
{ [ over empty-interval eq? ] [ drop ] } { [ over empty-interval? ] [ drop ] }
{ [ dup empty-interval eq? ] [ nip ] } { [ dup empty-interval? ] [ nip ] }
{ [ 2dup [ full-interval eq? ] both? ] [ drop ] } { [ 2dup [ full-interval? ] both? ] [ drop ] }
{ [ over full-interval eq? ] [ nip to>> first [-inf,a] ] } { [ over full-interval? ] [ nip to>> first [-inf,a] ] }
{ [ dup full-interval eq? ] [ drop to>> first [-inf,a] ] } { [ dup full-interval? ] [ drop to>> first [-inf,a] ] }
[ [ interval-closure ] bi@ [ min ] interval-op nan-not-ok ] [ [ interval-closure ] bi@ [ min ] interval-op nan-not-ok ]
} cond ; } cond ;
@ -296,8 +294,8 @@ MEMO: array-capacity-interval ( -- interval )
: interval-abs ( i1 -- i2 ) : interval-abs ( i1 -- i2 )
{ {
{ [ dup empty-interval eq? ] [ ] } { [ dup empty-interval? ] [ ] }
{ [ dup full-interval eq? ] [ drop [0,inf] ] } { [ dup full-interval? ] [ drop [0,inf] ] }
{ [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval nan-not-ok ] } { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval nan-not-ok ] }
[ (interval-abs) points>interval nan-not-ok ] [ (interval-abs) points>interval nan-not-ok ]
} cond ; } cond ;
@ -331,7 +329,7 @@ SYMBOL: incomparable
: interval< ( i1 i2 -- ? ) : interval< ( i1 i2 -- ? )
{ {
{ [ 2dup [ special-interval? ] either? ] [ incomparable ] } { [ 2dup [ special-interval? ] either? ] [ incomparable ] }
{ [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] } { [ 2dup interval-intersect empty-interval? ] [ (interval<) ] }
{ [ 2dup left-endpoint-< ] [ f ] } { [ 2dup left-endpoint-< ] [ f ] }
{ [ 2dup right-endpoint-< ] [ f ] } { [ 2dup right-endpoint-< ] [ f ] }
[ incomparable ] [ incomparable ]
@ -346,7 +344,7 @@ SYMBOL: incomparable
: interval<= ( i1 i2 -- ? ) : interval<= ( i1 i2 -- ? )
{ {
{ [ 2dup [ special-interval? ] either? ] [ incomparable ] } { [ 2dup [ special-interval? ] either? ] [ incomparable ] }
{ [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] } { [ 2dup interval-intersect empty-interval? ] [ (interval<) ] }
{ [ 2dup right-endpoint-<= ] [ t ] } { [ 2dup right-endpoint-<= ] [ t ] }
[ incomparable ] [ incomparable ]
} cond 2nip ; } cond 2nip ;
@ -359,9 +357,9 @@ SYMBOL: incomparable
: interval-mod ( i1 i2 -- i3 ) : interval-mod ( i1 i2 -- i3 )
{ {
{ [ over empty-interval eq? ] [ swap ] } { [ over empty-interval? ] [ swap ] }
{ [ dup empty-interval eq? ] [ ] } { [ dup empty-interval? ] [ ] }
{ [ dup full-interval eq? ] [ ] } { [ dup full-interval? ] [ ] }
[ interval-abs to>> first [ neg ] keep (a,b) ] [ interval-abs to>> first [ neg ] keep (a,b) ]
} cond } cond
swap 0 [a,a] interval>= t eq? [ [0,inf] interval-intersect ] when ; swap 0 [a,a] interval>= t eq? [ [0,inf] interval-intersect ] when ;
@ -370,9 +368,9 @@ SYMBOL: incomparable
: interval-rem ( i1 i2 -- i3 ) : interval-rem ( i1 i2 -- i3 )
{ {
{ [ over empty-interval eq? ] [ drop ] } { [ over empty-interval? ] [ drop ] }
{ [ dup empty-interval eq? ] [ nip ] } { [ dup empty-interval? ] [ nip ] }
{ [ dup full-interval eq? ] [ 2drop [0,inf] ] } { [ dup full-interval? ] [ 2drop [0,inf] ] }
[ nip (rem-range) ] [ nip (rem-range) ]
} cond ; } cond ;
@ -416,17 +414,14 @@ SYMBOL: incomparable
! Inaccurate. ! Inaccurate.
interval-bitor ; interval-bitor ;
: interval-log2 ( i1 -- i2 ) GENERIC: interval-log2 ( i1 -- i2 )
{ M: empty-interval interval-log2 ;
{ empty-interval [ empty-interval ] } M: full-interval interval-log2 drop [0,inf] ;
{ full-interval [ [0,inf] ] } M: interval interval-log2
[ to>> first 1 max dup most-positive-fixnum >
to>> first 1 max dup most-positive-fixnum > [ drop full-interval interval-log2 ]
[ drop full-interval interval-log2 ] [ 1 + >integer log2 0 swap [a,b] ]
[ 1 + >integer log2 0 swap [a,b] ] if ;
if
]
} case ;
: assume< ( i1 i2 -- i3 ) : assume< ( i1 i2 -- i3 )
dup special-interval? [ drop ] [ dup special-interval? [ drop ] [