1 ! Copyright (C) 2007, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 ! Based on Slate's src/unfinished/interval.slate by Brian Rice.
4 USING: accessors kernel sequences arrays math math.order
10 TUPLE: interval { from read-only } { to read-only } ;
12 : <interval> ( from to -- int )
13 over first over first {
14 { [ 2dup > ] [ 2drop 2drop empty-interval ] }
16 2drop over second over second and
17 [ interval boa ] [ 2drop empty-interval ] if
19 [ 2drop interval boa ]
22 : open-point ( n -- endpoint ) f 2array ;
24 : closed-point ( n -- endpoint ) t 2array ;
26 : [a,b] ( a b -- interval )
27 >r closed-point r> closed-point <interval> ; foldable
29 : (a,b) ( a b -- interval )
30 >r open-point r> open-point <interval> ; foldable
32 : [a,b) ( a b -- interval )
33 >r closed-point r> open-point <interval> ; foldable
35 : (a,b] ( a b -- interval )
36 >r open-point r> closed-point <interval> ; foldable
38 : [a,a] ( a -- interval )
39 closed-point dup <interval> ; foldable
41 : [-inf,a] ( a -- interval ) -1./0. swap [a,b] ; inline
43 : [-inf,a) ( a -- interval ) -1./0. swap [a,b) ; inline
45 : [a,inf] ( a -- interval ) 1./0. [a,b] ; inline
47 : (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
49 : [-inf,inf] ( -- interval )
50 T{ interval f { -1./0. t } { 1./0. t } } ; inline
52 : compare-endpoints ( p1 p2 quot -- ? )
53 >r over first over first r> call [
56 over first over first = [
57 swap second swap second not or
63 : endpoint< ( p1 p2 -- ? ) [ < ] compare-endpoints ;
65 : endpoint<= ( p1 p2 -- ? ) [ endpoint< ] 2keep = or ;
67 : endpoint> ( p1 p2 -- ? ) [ > ] compare-endpoints ;
69 : endpoint>= ( p1 p2 -- ? ) [ endpoint> ] 2keep = or ;
71 : endpoint-min ( p1 p2 -- p3 ) [ endpoint< ] most ;
73 : endpoint-max ( p1 p2 -- p3 ) [ endpoint> ] most ;
75 : interval>points ( int -- from to )
76 [ from>> ] [ to>> ] bi ;
78 : points>interval ( seq -- interval )
79 dup [ first fp-nan? ] contains?
82 [ [ endpoint-min ] reduce ]
83 [ [ endpoint-max ] reduce ]
87 : (interval-op) ( p1 p2 quot -- p3 )
88 [ [ first ] [ first ] [ ] tri* call ]
89 [ drop [ second ] both? ]
92 : interval-op ( i1 i2 quot -- i3 )
94 [ [ from>> ] [ from>> ] [ ] tri* (interval-op) ]
95 [ [ to>> ] [ from>> ] [ ] tri* (interval-op) ]
96 [ [ to>> ] [ to>> ] [ ] tri* (interval-op) ]
97 [ [ from>> ] [ to>> ] [ ] tri* (interval-op) ]
98 } 3cleave 4array points>interval ; inline
100 : do-empty-interval ( i1 i2 quot -- i3 )
102 { [ pick empty-interval eq? ] [ drop drop ] }
103 { [ over empty-interval eq? ] [ drop nip ] }
107 : interval+ ( i1 i2 -- i3 )
108 [ [ + ] interval-op ] do-empty-interval ;
110 : interval- ( i1 i2 -- i3 )
111 [ [ - ] interval-op ] do-empty-interval ;
113 : interval-intersect ( i1 i2 -- i3 )
115 { [ dup empty-interval eq? ] [ nip ] }
116 { [ over empty-interval eq? ] [ drop ] }
119 [ interval>points ] bi@ swapd
120 [ [ swap endpoint< ] most ]
121 [ [ swap endpoint> ] most ] 2bi*
129 : intervals-intersect? ( i1 i2 -- ? )
130 interval-intersect empty-interval eq? not ;
132 : interval-union ( i1 i2 -- i3 )
134 { [ dup empty-interval eq? ] [ drop ] }
135 { [ over empty-interval eq? ] [ nip ] }
138 [ interval>points 2array ] bi@ append points>interval
145 : interval-subset? ( i1 i2 -- ? )
146 dupd interval-intersect = ;
148 : interval-contains? ( x int -- ? )
149 dup empty-interval eq? [ 2drop f ] [
150 [ from>> first2 [ >= ] [ > ] if ]
151 [ to>> first2 [ <= ] [ < ] if ]
155 : interval-zero? ( int -- ? )
156 0 swap interval-contains? ;
158 : interval* ( i1 i2 -- i3 )
159 [ [ [ * ] interval-op ] do-empty-interval ]
160 [ [ interval-zero? ] either? ]
161 2bi [ 0 [a,a] interval-union ] when ;
163 : interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ;
165 : interval-1- ( i1 -- i2 ) -1 [a,a] interval+ ;
167 : interval-neg ( i1 -- i2 ) -1 [a,a] interval* ;
169 : interval-bitnot ( i1 -- i2 ) interval-neg interval-1- ;
171 : interval-sq ( i1 -- i2 ) dup interval* ;
173 : interval-singleton? ( int -- ? )
174 dup empty-interval eq? [
178 2dup [ second ] bi@ and
183 : interval-length ( int -- n )
185 { [ dup empty-interval eq? ] [ drop 0 ] }
186 { [ dup not ] [ drop 0 ] }
187 [ interval>points [ first ] bi@ swap - ]
190 : interval-closure ( i1 -- i2 )
191 dup [ interval>points [ first ] bi@ [a,b] ] when ;
193 : interval-integer-op ( i1 i2 quot -- i3 )
195 [ interval>points [ first integer? ] both? ] both?
196 r> [ 2drop [-inf,inf] ] if ; inline
198 : interval-shift ( i1 i2 -- i3 )
199 #! Inaccurate; could be tighter
202 [ interval-closure ] bi@
203 [ shift ] interval-op
204 ] interval-integer-op
205 ] do-empty-interval ;
207 : interval-shift-safe ( i1 i2 -- i3 )
209 dup to>> first 100 > [
214 ] do-empty-interval ;
216 : interval-max ( i1 i2 -- i3 )
217 #! Inaccurate; could be tighter
218 [ [ interval-closure ] bi@ [ max ] interval-op ] do-empty-interval ;
220 : interval-min ( i1 i2 -- i3 )
221 #! Inaccurate; could be tighter
222 [ [ interval-closure ] bi@ [ min ] interval-op ] do-empty-interval ;
224 : interval-interior ( i1 -- i2 )
225 dup empty-interval eq? [
226 interval>points [ first ] bi@ (a,b)
229 : interval-division-op ( i1 i2 quot -- i3 )
231 { [ 0 pick interval-closure interval-contains? ] [ 3drop [-inf,inf] ] }
232 { [ pick interval-zero? ] [ call 0 [a,a] interval-union ] }
236 : interval/ ( i1 i2 -- i3 )
237 [ [ [ / ] interval-op ] interval-division-op ] do-empty-interval ;
239 : interval/-safe ( i1 i2 -- i3 )
240 #! Just a hack to make the compiler work if bootstrap.math
242 \ integer \ / method [ interval/ ] [ 2drop f ] if ;
244 : interval/i ( i1 i2 -- i3 )
248 [ interval-closure ] bi@
250 ] interval-integer-op
251 ] interval-division-op
252 ] do-empty-interval ;
254 : interval/f ( i1 i2 -- i3 )
255 [ [ [ /f ] interval-op ] interval-division-op ] do-empty-interval ;
257 : (interval-abs) ( i1 -- i2 )
258 interval>points [ first2 [ abs ] dip 2array ] bi@ 2array ;
260 : interval-abs ( i1 -- i2 )
262 { [ dup empty-interval eq? ] [ ] }
263 { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
264 [ (interval-abs) points>interval ]
267 : interval-mod ( i1 i2 -- i3 )
271 nip interval-abs to>> first [ neg ] keep (a,b)
272 ] interval-division-op
273 ] do-empty-interval ;
275 : interval-rem ( i1 i2 -- i3 )
279 nip interval-abs to>> first 0 swap [a,b)
280 ] interval-division-op
281 ] do-empty-interval ;
283 : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
285 : interval-2/ ( i1 -- i2 ) -1 [a,a] interval-shift ;
289 : left-endpoint-< ( i1 i2 -- ? )
290 [ swap interval-subset? ]
291 [ nip interval-singleton? ]
295 : right-endpoint-< ( i1 i2 -- ? )
297 [ drop interval-singleton? ]
301 : (interval<) ( i1 i2 -- i1 i2 ? )
302 over from>> over from>> endpoint< ;
304 : interval< ( i1 i2 -- ? )
306 { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
307 { [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
308 { [ 2dup left-endpoint-< ] [ f ] }
309 { [ 2dup right-endpoint-< ] [ f ] }
313 : left-endpoint-<= ( i1 i2 -- ? )
314 >r from>> r> to>> = ;
316 : right-endpoint-<= ( i1 i2 -- ? )
317 >r to>> r> from>> = ;
319 : interval<= ( i1 i2 -- ? )
321 { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
322 { [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
323 { [ 2dup right-endpoint-<= ] [ t ] }
327 : interval> ( i1 i2 -- ? )
330 : interval>= ( i1 i2 -- ? )
333 : interval-bitand-pos ( i1 i2 -- ? )
334 [ to>> first ] bi@ min 0 swap [a,b] ;
336 : interval-bitand-neg ( i1 i2 -- ? )
337 dup from>> first 0 < [ drop ] [ nip ] if
338 0 swap to>> first [a,b] ;
340 : interval-nonnegative? ( i -- ? )
343 : interval-bitand ( i1 i2 -- i3 )
348 [ 2dup [ interval-nonnegative? ] both? ]
349 [ interval-bitand-pos ]
352 [ 2dup [ interval-nonnegative? ] either? ]
353 [ interval-bitand-neg ]
357 ] do-empty-interval ;
359 : interval-bitor ( i1 i2 -- i3 )
362 2dup [ interval-nonnegative? ] both?
364 [ interval>points [ first ] bi@ ] bi@
365 4array supremum 0 swap next-power-of-2 [a,b]
366 ] [ 2drop [-inf,inf] ] if
367 ] do-empty-interval ;
369 : interval-bitxor ( i1 i2 -- i3 )
373 : assume< ( i1 i2 -- i3 )
374 dup empty-interval eq? [ drop ] [
375 to>> first [-inf,a) interval-intersect
378 : assume<= ( i1 i2 -- i3 )
379 dup empty-interval eq? [ drop ] [
380 to>> first [-inf,a] interval-intersect
383 : assume> ( i1 i2 -- i3 )
384 dup empty-interval eq? [ drop ] [
385 from>> first (a,inf] interval-intersect
388 : assume>= ( i1 i2 -- i3 )
389 dup empty-interval eq? [ drop ] [
390 from>> first [a,inf] interval-intersect
393 : integral-closure ( i1 -- i2 )
394 dup empty-interval eq? [
395 [ from>> first2 [ 1+ ] unless ]
396 [ to>> first2 [ 1- ] unless ]