From 43335d9c36e4b74e7e4dd30e0afd69aa07cf5b61 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Nov 2008 08:30:14 -0600 Subject: [PATCH] Intervals now use a special singleton for the full interval to eliminate FP math in the common case; fix a bug in value-info<= --- .../tree/propagation/info/info-tests.factor | 4 ++ .../tree/propagation/info/info.factor | 6 +-- basis/math/intervals/intervals-tests.factor | 36 +++++++++----- basis/math/intervals/intervals.factor | 48 ++++++++++++------- 4 files changed, 61 insertions(+), 33 deletions(-) diff --git a/basis/compiler/tree/propagation/info/info-tests.factor b/basis/compiler/tree/propagation/info/info-tests.factor index 24f4ca59dc..2c3314994b 100644 --- a/basis/compiler/tree/propagation/info/info-tests.factor +++ b/basis/compiler/tree/propagation/info/info-tests.factor @@ -70,3 +70,7 @@ TUPLE: test-tuple { x read-only } ; f f 3 3array test-tuple dup object-info value-info-intersect = ] unit-test + +[ t ] [ + null-info 3 value-info<= +] unit-test diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index d1d8189f7a..11111fd11e 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -34,7 +34,7 @@ slots ; : null-info T{ value-info f null empty-interval } ; inline -: object-info T{ value-info f object T{ interval f { -1.0/0.0 t } { 1.0/0.0 t } } } ; inline +: object-info T{ value-info f object full-interval } ; inline : class-interval ( class -- interval ) dup real class<= @@ -43,7 +43,7 @@ slots ; : interval>literal ( class interval -- literal literal? ) #! If interval has zero length and the class is sufficiently #! precise, we can turn it into a literal - dup empty-interval eq? [ + dup special-interval? [ 2drop f f ] [ dup from>> first { @@ -243,7 +243,7 @@ DEFER: (value-info-union) : literals<= ( info1 info2 -- ? ) { { [ dup literal?>> not ] [ 2drop t ] } - { [ over literal?>> not ] [ 2drop f ] } + { [ over literal?>> not ] [ drop class>> null-class? ] } [ [ literal>> ] bi@ eql? ] } cond ; diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 0fdcb51291..8c29171a57 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -95,6 +95,10 @@ IN: math.intervals.tests [ empty-interval ] [ 0 5 (a,b] empty-interval interval-intersect ] unit-test +[ t ] [ + 0 1 (a,b) full-interval interval-intersect 0 1 (a,b) = +] unit-test + [ t ] [ empty-interval empty-interval interval-subset? ] unit-test @@ -209,22 +213,28 @@ IN: math.intervals.tests ! Interval random tester : random-element ( interval -- n ) - dup to>> first over from>> first tuck - random + - 2dup swap interval-contains? [ - nip + dup full-interval eq? [ + drop 32 random-bits 31 2^ - ] [ - drop random-element + dup to>> first over from>> first tuck - random + + 2dup swap interval-contains? [ + nip + ] [ + drop random-element + ] if ] if ; : random-interval ( -- interval ) - 2000 random 1000 - dup 2 1000 random + + - 1 random zero? [ [ neg ] bi@ swap ] when - 4 random { - { 0 [ [a,b] ] } - { 1 [ [a,b) ] } - { 2 [ (a,b) ] } - { 3 [ (a,b] ] } - } case ; + 10 random 0 = [ full-interval ] [ + 2000 random 1000 - dup 2 1000 random + + + 1 random zero? [ [ neg ] bi@ swap ] when + 4 random { + { 0 [ [a,b] ] } + { 1 [ [a,b) ] } + { 2 [ (a,b) ] } + { 3 [ (a,b] ] } + } case + ] if ; : random-unary-op ( -- pair ) { @@ -263,7 +273,7 @@ IN: math.intervals.tests { bitand interval-bitand } { bitor interval-bitor } { bitxor interval-bitxor } - { shift interval-shift } + ! { shift interval-shift } { min interval-min } { max interval-max } } diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 33430e83c3..54ee0ac894 100644 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -7,6 +7,8 @@ IN: math.intervals SYMBOL: empty-interval +SYMBOL: full-interval + TUPLE: interval { from read-only } { to read-only } ; : ( from to -- int ) @@ -46,8 +48,7 @@ TUPLE: interval { from read-only } { to read-only } ; : (a,inf] ( a -- interval ) 1./0. (a,b] ; inline -: [-inf,inf] ( -- interval ) - T{ interval f { -1./0. t } { 1./0. t } } ; inline +: [-inf,inf] ( -- interval ) full-interval ; inline : compare-endpoints ( p1 p2 quot -- ? ) >r over first over first r> call [ @@ -99,8 +100,10 @@ TUPLE: interval { from read-only } { to read-only } ; : do-empty-interval ( i1 i2 quot -- i3 ) { - { [ pick empty-interval eq? ] [ drop drop ] } + { [ pick empty-interval eq? ] [ 2drop ] } { [ over empty-interval eq? ] [ drop nip ] } + { [ pick full-interval eq? ] [ 2drop ] } + { [ over full-interval eq? ] [ drop nip ] } [ call ] } cond ; inline @@ -112,8 +115,10 @@ TUPLE: interval { from read-only } { to read-only } ; : interval-intersect ( i1 i2 -- i3 ) { - { [ dup empty-interval eq? ] [ nip ] } { [ over empty-interval eq? ] [ drop ] } + { [ dup empty-interval eq? ] [ nip ] } + { [ over full-interval eq? ] [ nip ] } + { [ dup full-interval eq? ] [ drop ] } [ [ interval>points ] bi@ swapd [ [ swap endpoint< ] most ] @@ -127,8 +132,10 @@ TUPLE: interval { from read-only } { to read-only } ; : interval-union ( i1 i2 -- i3 ) { - { [ dup empty-interval eq? ] [ drop ] } { [ over empty-interval eq? ] [ nip ] } + { [ dup empty-interval eq? ] [ drop ] } + { [ over full-interval eq? ] [ drop ] } + { [ dup full-interval eq? ] [ nip ] } [ [ interval>points 2array ] bi@ append points>interval ] } cond ; @@ -137,9 +144,11 @@ TUPLE: interval { from read-only } { to read-only } ; : interval-contains? ( x int -- ? ) dup empty-interval eq? [ 2drop f ] [ - [ from>> first2 [ >= ] [ > ] if ] - [ to>> first2 [ <= ] [ < ] if ] - 2bi and + dup full-interval eq? [ 2drop t ] [ + [ from>> first2 [ >= ] [ > ] if ] + [ to>> first2 [ <= ] [ < ] if ] + 2bi and + ] if ] if ; : interval-zero? ( int -- ? ) @@ -160,8 +169,11 @@ TUPLE: interval { from read-only } { to read-only } ; : interval-sq ( i1 -- i2 ) dup interval* ; +: special-interval? ( interval -- ? ) + { empty-interval full-interval } memq? ; + : interval-singleton? ( int -- ? ) - dup empty-interval eq? [ + dup special-interval? [ drop f ] [ interval>points @@ -173,6 +185,7 @@ TUPLE: interval { from read-only } { to read-only } ; : interval-length ( int -- n ) { { [ dup empty-interval eq? ] [ drop 0 ] } + { [ dup full-interval eq? ] [ drop 1/0. ] } [ interval>points [ first ] bi@ swap - ] } cond ; @@ -211,7 +224,7 @@ TUPLE: interval { from read-only } { to read-only } ; [ [ interval-closure ] bi@ [ min ] interval-op ] do-empty-interval ; : interval-interior ( i1 -- i2 ) - dup empty-interval eq? [ + dup special-interval? [ interval>points [ first ] bi@ (a,b) ] unless ; @@ -249,6 +262,7 @@ TUPLE: interval { from read-only } { to read-only } ; : interval-abs ( i1 -- i2 ) { { [ dup empty-interval eq? ] [ ] } + { [ dup full-interval eq? ] [ drop 0 [a,inf] ] } { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] } [ (interval-abs) points>interval ] } cond ; @@ -292,7 +306,7 @@ SYMBOL: incomparable : interval< ( i1 i2 -- ? ) { - { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] } + { [ 2dup [ special-interval? ] either? ] [ incomparable ] } { [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] } { [ 2dup left-endpoint-< ] [ f ] } { [ 2dup right-endpoint-< ] [ f ] } @@ -307,7 +321,7 @@ SYMBOL: incomparable : interval<= ( i1 i2 -- ? ) { - { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] } + { [ 2dup [ special-interval? ] either? ] [ incomparable ] } { [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] } { [ 2dup right-endpoint-<= ] [ t ] } [ incomparable ] @@ -360,27 +374,27 @@ SYMBOL: incomparable interval-bitor ; : assume< ( i1 i2 -- i3 ) - dup empty-interval eq? [ drop ] [ + dup special-interval? [ drop ] [ to>> first [-inf,a) interval-intersect ] if ; : assume<= ( i1 i2 -- i3 ) - dup empty-interval eq? [ drop ] [ + dup special-interval? [ drop ] [ to>> first [-inf,a] interval-intersect ] if ; : assume> ( i1 i2 -- i3 ) - dup empty-interval eq? [ drop ] [ + dup special-interval? [ drop ] [ from>> first (a,inf] interval-intersect ] if ; : assume>= ( i1 i2 -- i3 ) - dup empty-interval eq? [ drop ] [ + dup special-interval? [ drop ] [ from>> first [a,inf] interval-intersect ] if ; : integral-closure ( i1 -- i2 ) - dup empty-interval eq? [ + dup special-interval? [ [ from>> first2 [ 1+ ] unless ] [ to>> first2 [ 1- ] unless ] bi [a,b]