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

math.intervals: using short-circuit logic.

db4
John Benediktsson 2012-07-17 20:08:12 -07:00
parent c8221b9f2a
commit 0359a4e823
1 changed files with 27 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice. ! Based on Slate's src/unfinished/interval.slate by Brian Rice.
USING: accessors kernel sequences arrays math math.order USING: accessors kernel sequences arrays math math.order
combinators generic layouts memoize ; combinators combinators.short-circuit generic layouts memoize ;
IN: math.intervals IN: math.intervals
SYMBOL: empty-interval SYMBOL: empty-interval
@ -66,26 +66,26 @@ MEMO: array-capacity-interval ( -- interval )
: [-inf,inf] ( -- interval ) full-interval ; inline : [-inf,inf] ( -- interval ) full-interval ; inline
: compare-endpoints ( p1 p2 quot -- ? ) : compare-endpoints ( p1 p2 quot -- ? )
[ 2dup [ first ] bi@ ] dip call [ [ 2dup [ first ] bi@ 2dup ] dip call [
2drop t 2drop 2drop t
] [ ] [
2dup [ first ] bi@ number= [ number= [ [ second ] bi@ not or ] [ 2drop f ] if
[ second ] bi@ not or
] [
2drop f
] if
] if ; inline ] if ; inline
: endpoint= ( p1 p2 -- ? ) : endpoint= ( p1 p2 -- ? )
[ [ first ] bi@ number= ] [ [ second ] bi@ eq? ] 2bi and ; { [ [ first ] bi@ number= ] [ [ second ] bi@ eq? ] } 2&& ;
: endpoint< ( p1 p2 -- ? ) [ < ] compare-endpoints ; : endpoint< ( p1 p2 -- ? )
[ < ] compare-endpoints ;
: endpoint<= ( p1 p2 -- ? ) [ endpoint< ] [ endpoint= ] 2bi or ; : endpoint<= ( p1 p2 -- ? )
{ [ endpoint< ] [ endpoint= ] } 2|| ;
: endpoint> ( p1 p2 -- ? ) [ > ] compare-endpoints ; : endpoint> ( p1 p2 -- ? )
[ > ] compare-endpoints ;
: endpoint>= ( p1 p2 -- ? ) [ endpoint> ] [ endpoint= ] 2bi or ; : endpoint>= ( p1 p2 -- ? )
{ [ endpoint> ] [ endpoint= ] } 2|| ;
: endpoint-min ( p1 p2 -- p3 ) [ endpoint< ] most ; : endpoint-min ( p1 p2 -- p3 ) [ endpoint< ] most ;
@ -167,9 +167,10 @@ MEMO: array-capacity-interval ( -- interval )
: interval-contains? ( x int -- ? ) : interval-contains? ( x int -- ? )
dup empty-interval eq? [ 2drop f ] [ dup empty-interval eq? [ 2drop f ] [
dup full-interval eq? [ 2drop t ] [ dup full-interval eq? [ 2drop t ] [
{
[ from>> first2 [ >= ] [ > ] if ] [ from>> first2 [ >= ] [ > ] if ]
[ to>> first2 [ <= ] [ < ] if ] [ to>> first2 [ <= ] [ < ] if ]
2bi and } 2&&
] if ] if
] if ; ] if ;
@ -311,16 +312,18 @@ MEMO: array-capacity-interval ( -- interval )
SYMBOL: incomparable SYMBOL: incomparable
: left-endpoint-< ( i1 i2 -- ? ) : left-endpoint-< ( i1 i2 -- ? )
{
[ swap interval-subset? ] [ swap interval-subset? ]
[ nip interval-singleton? ] [ nip interval-singleton? ]
[ [ from>> ] bi@ endpoint= ] [ [ from>> ] bi@ endpoint= ]
2tri and and ; } 2&& ;
: right-endpoint-< ( i1 i2 -- ? ) : right-endpoint-< ( i1 i2 -- ? )
{
[ interval-subset? ] [ interval-subset? ]
[ drop interval-singleton? ] [ drop interval-singleton? ]
[ [ to>> ] bi@ endpoint= ] [ [ to>> ] bi@ endpoint= ]
2tri and and ; } 2&& ;
: (interval<) ( i1 i2 -- i1 i2 ? ) : (interval<) ( i1 i2 -- i1 i2 ? )
2dup [ from>> ] bi@ endpoint< ; 2dup [ from>> ] bi@ endpoint< ;