From 7ffd9c95baf0fa58de7a01711074c0823b424d04 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 21:27:00 -0600 Subject: [PATCH] Fixing interval comparison --- core/math/intervals/intervals-tests.factor | 107 +++++++++++++++++---- core/math/intervals/intervals.factor | 99 +++++++++++++------ core/optimizer/math/math.factor | 10 +- 3 files changed, 166 insertions(+), 50 deletions(-) diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index 8e2f47f72b..997b3453f2 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -1,5 +1,5 @@ USING: math.intervals kernel sequences words math arrays -prettyprint tools.test random vocabs ; +prettyprint tools.test random vocabs combinators ; IN: math.intervals.tests [ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test @@ -94,33 +94,86 @@ IN: math.intervals.tests ] unit-test ] when -[ t ] [ 0 5 [a,b] 5 interval<= ] unit-test +[ t ] [ 1 [a,a] interval-singleton? ] unit-test -[ incomparable ] [ 0 5 [a,b] 5 interval< ] unit-test +[ f ] [ 1 1 [a,b) interval-singleton? ] unit-test -[ t ] [ 0 5 [a,b) 5 interval< ] unit-test +[ f ] [ 1 3 [a,b) interval-singleton? ] unit-test -[ f ] [ 0 5 [a,b] -1 interval< ] unit-test +[ f ] [ 1 1 (a,b) interval-singleton? ] unit-test -[ incomparable ] [ 0 5 [a,b] 1 interval< ] unit-test +[ 2 ] [ 1 3 [a,b) interval-length ] unit-test -[ t ] [ -1 1 (a,b) -1 interval> ] unit-test +[ 0 ] [ f interval-length ] unit-test -[ t ] [ -1 1 (a,b) -1 interval>= ] unit-test +[ t ] [ 0 5 [a,b] 5 [a,a] interval<= ] unit-test -[ f ] [ -1 1 (a,b) -1 interval< ] unit-test +[ incomparable ] [ 0 5 [a,b] 5 [a,a] interval< ] unit-test -[ f ] [ -1 1 (a,b) -1 interval<= ] unit-test +[ t ] [ 0 5 [a,b) 5 [a,a] interval< ] unit-test -[ t ] [ -1 1 (a,b] 1 interval<= ] unit-test +[ f ] [ 0 5 [a,b] -1 [a,a] interval< ] unit-test + +[ incomparable ] [ 0 5 [a,b] 1 [a,a] interval< ] unit-test + +[ t ] [ -1 1 (a,b) -1 [a,a] interval> ] unit-test + +[ t ] [ -1 1 (a,b) -1 [a,a] interval>= ] unit-test + +[ f ] [ -1 1 (a,b) -1 [a,a] interval< ] unit-test + +[ f ] [ -1 1 (a,b) -1 [a,a] interval<= ] unit-test + +[ t ] [ -1 1 (a,b] 1 [a,a] interval<= ] unit-test + +[ t ] [ -1 1 (a,b] 1 2 [a,b] interval<= ] unit-test + +[ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval>= ] unit-test + +[ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval> ] unit-test + +[ t ] [ -1 1 (a,b] 1 2 (a,b] interval<= ] unit-test + +[ f ] [ 0 10 [a,b] 0 [a,a] interval< ] unit-test + +[ f ] [ 0 10 [a,b] 10 [a,a] interval> ] unit-test + +[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval< ] unit-test + +[ incomparable ] [ 10 [a,a] 0 10 [a,b] interval> ] unit-test + +[ t ] [ 0 [a,a] 0 10 [a,b] interval<= ] unit-test + +[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval>= ] unit-test + +[ t ] [ 0 10 [a,b] 0 [a,a] interval>= ] unit-test + +[ t ] [ + 418 + 418 423 [a,b) + 79 893 (a,b] + interval-max + interval-contains? +] unit-test ! Interval random tester : random-element ( interval -- n ) - dup interval-to first swap interval-from first tuck - - random + ; + dup interval-to first over interval-from first tuck - random + + 2dup swap interval-contains? [ + nip + ] [ + drop random-element + ] if ; : random-interval ( -- interval ) - 1000 random dup 1 1000 random + + [a,b] ; + 1000 random dup 2 1000 random + + + 1 random zero? [ [ neg ] 2apply swap ] when + 4 random { + { 0 [ [a,b] ] } + { 1 [ [a,b) ] } + { 2 [ (a,b) ] } + { 3 [ (a,b] ] } + } case ; : random-op { @@ -138,12 +191,32 @@ IN: math.intervals.tests random ; : interval-test - random-interval random-interval random-op + random-interval random-interval random-op ! 3dup . . . 0 pick interval-contains? over first { / /i } member? and [ 3drop t ] [ - [ >r [ random-element ] 2apply r> first execute ] 3keep + [ >r [ random-element ] 2apply ! 2dup . . + r> first execute ] 3keep second execute interval-contains? ] if ; -[ t ] [ 1000 [ drop interval-test ] all? ] unit-test +[ t ] [ 4000 [ drop interval-test ] all? ] unit-test + +: random-comparison + { + { < interval< } + { <= interval<= } + { > interval> } + { >= interval>= } + } random ; + +: comparison-test + random-interval random-interval random-comparison + [ >r [ random-element ] 2apply r> first execute ] 3keep + second execute dup incomparable eq? [ + 2drop t + ] [ + = + ] if ; + +[ t ] [ 4000 [ drop comparison-test ] all? ] unit-test diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index b7eb5be8c9..d4cb8d2dce 100644 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -88,20 +88,6 @@ C: interval [ interval>points [ first integer? ] both? ] both? r> [ 2drop f ] if ; inline -: interval-shift ( i1 i2 -- i3 ) - [ [ shift ] interval-op ] interval-integer-op ; - -: interval-shift-safe ( i1 i2 -- i3 ) - dup interval-to first 100 > [ - 2drop f - ] [ - interval-shift - ] if ; - -: interval-max ( i1 i2 -- i3 ) [ max ] interval-op ; - -: interval-min ( i1 i2 -- i3 ) [ min ] interval-op ; - : interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ; : interval-1- ( i1 -- i2 ) -1 [a,a] interval+ ; @@ -143,9 +129,42 @@ C: interval : interval-contains? ( x int -- ? ) >r [a,a] r> interval-subset? ; +: interval-singleton? ( int -- ? ) + interval>points + 2dup [ second ] 2apply and + [ [ first ] 2apply = ] + [ 2drop f ] if ; + +: interval-length ( int -- n ) + dup + [ interval>points [ first ] 2apply swap - ] + [ drop 0 ] if ; + : interval-closure ( i1 -- i2 ) interval>points [ first ] 2apply [a,b] ; +: interval-shift ( i1 i2 -- i3 ) + #! Inaccurate; could be tighter + [ [ shift ] interval-op ] interval-integer-op interval-closure ; + +: interval-shift-safe ( i1 i2 -- i3 ) + dup interval-to first 100 > [ + 2drop f + ] [ + interval-shift + ] if ; + +: interval-max ( i1 i2 -- i3 ) + #! Inaccurate; could be tighter + [ max ] interval-op interval-closure ; + +: interval-min ( i1 i2 -- i3 ) + #! Inaccurate; could be tighter + [ min ] interval-op interval-closure ; + +: interval-interior ( i1 -- i2 ) + interval>points [ first ] 2apply (a,b) ; + : interval-division-op ( i1 i2 quot -- i3 ) >r 0 over interval-closure interval-contains? [ 2drop f ] r> if ; inline @@ -156,7 +175,7 @@ C: interval : interval/i ( i1 i2 -- i3 ) [ [ [ /i ] interval-op ] interval-integer-op - ] interval-division-op ; + ] interval-division-op interval-closure ; : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ; @@ -164,24 +183,46 @@ C: interval SYMBOL: incomparable -: interval-compare ( int n quot -- ? ) - >r dupd r> call interval-intersect dup [ - = t incomparable ? - ] [ - 2drop f - ] if ; inline +: left-endpoint-< ( i1 i2 -- ? ) + [ swap interval-subset? ] 2keep + [ nip interval-singleton? ] 2keep + [ interval-from ] 2apply = + and and ; -: interval< ( int n -- ? ) - [ [-inf,a) ] interval-compare ; inline +: right-endpoint-< ( i1 i2 -- ? ) + [ interval-subset? ] 2keep + [ drop interval-singleton? ] 2keep + [ interval-to ] 2apply = + and and ; -: interval<= ( int n -- ? ) - [ [-inf,a] ] interval-compare ; inline +: (interval<) over interval-from over interval-from endpoint< ; -: interval> ( int n -- ? ) - [ (a,inf] ] interval-compare ; inline +: interval< ( i1 i2 -- ? ) + { + { [ 2dup interval-intersect not ] [ (interval<) ] } + { [ 2dup left-endpoint-< ] [ f ] } + { [ 2dup right-endpoint-< ] [ f ] } + { [ t ] [ incomparable ] } + } cond 2nip ; -: interval>= ( int n -- ? ) - [ [a,inf] ] interval-compare ; inline +: left-endpoint-<= ( i1 i2 -- ? ) + >r interval-from r> interval-to = ; + +: right-endpoint-<= ( i1 i2 -- ? ) + >r interval-to r> interval-from = ; + +: interval<= ( i1 i2 -- ? ) + { + { [ 2dup interval-intersect not ] [ (interval<) ] } + { [ 2dup right-endpoint-<= ] [ t ] } + { [ t ] [ incomparable ] } + } cond 2nip ; + +: interval> ( i1 i2 -- ? ) + swap interval< ; + +: interval>= ( i1 i2 -- ? ) + swap interval<= ; : assume< ( i1 i2 -- i3 ) interval-to first [-inf,a) interval-intersect ; diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index b7c82e402a..7afc177d10 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -371,13 +371,15 @@ most-negative-fixnum most-positive-fixnum [a,b] ] assoc-each ! Remove redundant comparisons -: known-comparison? ( #call -- ? ) +: intervals-first2 ( #call -- first second ) dup dup node-in-d first node-interval - swap dup node-in-d second node-literal real? and ; + swap dup node-in-d second node-interval ; + +: known-comparison? ( #call -- ? ) + intervals-first2 and ; : perform-comparison ( #call word -- result ) - >r dup dup node-in-d first node-interval - swap dup node-in-d second node-literal r> execute ; inline + >r intervals-first2 r> execute ; inline : foldable-comparison? ( #call word -- ? ) >r dup known-comparison? [