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? [ drop [-inf,inf] ] [
81 [ [ endpoint-min ] reduce ] 2keep
82 [ endpoint-max ] reduce <interval>
85 : (interval-op) ( p1 p2 quot -- p3 )
86 [ [ first ] [ first ] [ ] tri* call ]
87 [ drop [ second ] both? ]
90 : interval-op ( i1 i2 quot -- i3 )
92 [ [ from>> ] [ from>> ] [ ] tri* (interval-op) ]
93 [ [ to>> ] [ from>> ] [ ] tri* (interval-op) ]
94 [ [ to>> ] [ to>> ] [ ] tri* (interval-op) ]
95 [ [ from>> ] [ to>> ] [ ] tri* (interval-op) ]
96 } 3cleave 4array points>interval ; inline
98 : do-empty-interval ( i1 i2 quot -- i3 )
100 { [ pick empty-interval eq? ] [ drop drop ] }
101 { [ over empty-interval eq? ] [ drop nip ] }
105 : interval+ ( i1 i2 -- i3 )
106 [ [ + ] interval-op ] do-empty-interval ;
108 : interval- ( i1 i2 -- i3 )
109 [ [ - ] interval-op ] do-empty-interval ;
111 : interval* ( i1 i2 -- i3 )
112 [ [ * ] interval-op ] do-empty-interval ;
114 : interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ;
116 : interval-1- ( i1 -- i2 ) -1 [a,a] interval+ ;
118 : interval-neg ( i1 -- i2 ) -1 [a,a] interval* ;
120 : interval-bitnot ( i1 -- i2 ) interval-neg interval-1- ;
122 : interval-sq ( i1 -- i2 ) dup interval* ;
124 : interval-intersect ( i1 i2 -- i3 )
126 { [ dup empty-interval eq? ] [ nip ] }
127 { [ over empty-interval eq? ] [ drop ] }
130 [ interval>points ] bi@ swapd
131 [ [ swap endpoint< ] most ]
132 [ [ swap endpoint> ] most ] 2bi*
140 : intervals-intersect? ( i1 i2 -- ? )
141 interval-intersect empty-interval eq? not ;
143 : interval-union ( i1 i2 -- i3 )
145 { [ dup empty-interval eq? ] [ drop ] }
146 { [ over empty-interval eq? ] [ nip ] }
149 [ interval>points 2array ] bi@ append points>interval
156 : interval-subset? ( i1 i2 -- ? )
157 dupd interval-intersect = ;
159 : interval-contains? ( x int -- ? )
160 >r [a,a] r> interval-subset? ;
162 : interval-singleton? ( int -- ? )
163 dup empty-interval eq? [
167 2dup [ second ] bi@ and
172 : interval-length ( int -- n )
174 { [ dup empty-interval eq? ] [ drop 0 ] }
175 { [ dup not ] [ drop 0 ] }
176 [ interval>points [ first ] bi@ swap - ]
179 : interval-closure ( i1 -- i2 )
180 dup [ interval>points [ first ] bi@ [a,b] ] when ;
182 : interval-integer-op ( i1 i2 quot -- i3 )
184 [ interval>points [ first integer? ] both? ] both?
185 r> [ 2drop [-inf,inf] ] if ; inline
187 : interval-shift ( i1 i2 -- i3 )
188 #! Inaccurate; could be tighter
191 [ interval-closure ] bi@
192 [ shift ] interval-op
193 ] interval-integer-op
194 ] do-empty-interval ;
196 : interval-shift-safe ( i1 i2 -- i3 )
198 dup to>> first 100 > [
203 ] do-empty-interval ;
205 : interval-max ( i1 i2 -- i3 )
206 #! Inaccurate; could be tighter
207 [ [ interval-closure ] bi@ [ max ] interval-op ] do-empty-interval ;
209 : interval-min ( i1 i2 -- i3 )
210 #! Inaccurate; could be tighter
211 [ [ interval-closure ] bi@ [ min ] interval-op ] do-empty-interval ;
213 : interval-interior ( i1 -- i2 )
214 dup empty-interval eq? [
215 interval>points [ first ] bi@ (a,b)
218 : interval-division-op ( i1 i2 quot -- i3 )
219 >r 0 over interval-closure interval-contains?
220 [ 2drop [-inf,inf] ] r> if ; inline
222 : interval/ ( i1 i2 -- i3 )
223 [ [ [ / ] interval-op ] interval-division-op ] do-empty-interval ;
225 : interval/-safe ( i1 i2 -- i3 )
226 #! Just a hack to make the compiler work if bootstrap.math
228 \ integer \ / method [ interval/ ] [ 2drop f ] if ;
230 : interval/i ( i1 i2 -- i3 )
234 [ interval-closure ] bi@
236 ] interval-integer-op
237 ] interval-division-op
238 ] do-empty-interval ;
240 : interval/f ( i1 i2 -- i3 )
241 [ [ [ /f ] interval-op ] interval-division-op ] do-empty-interval ;
243 : (interval-abs) ( i1 -- i2 )
244 interval>points [ first2 [ abs ] dip 2array ] bi@ 2array ;
246 : interval-abs ( i1 -- i2 )
248 { [ dup empty-interval eq? ] [ ] }
249 { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
250 [ (interval-abs) points>interval ]
253 : interval-mod ( i1 i2 -- i3 )
257 nip interval-abs to>> first [ neg ] keep (a,b)
258 ] interval-division-op
259 ] do-empty-interval ;
261 : interval-rem ( i1 i2 -- i3 )
265 nip interval-abs to>> first 0 swap [a,b)
266 ] interval-division-op
267 ] do-empty-interval ;
269 : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
271 : interval-2/ ( i1 -- i2 ) -1 [a,a] interval-shift ;
275 : left-endpoint-< ( i1 i2 -- ? )
276 [ swap interval-subset? ]
277 [ nip interval-singleton? ]
281 : right-endpoint-< ( i1 i2 -- ? )
283 [ drop interval-singleton? ]
287 : (interval<) ( i1 i2 -- i1 i2 ? )
288 over from>> over from>> endpoint< ;
290 : interval< ( i1 i2 -- ? )
292 { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
293 { [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
294 { [ 2dup left-endpoint-< ] [ f ] }
295 { [ 2dup right-endpoint-< ] [ f ] }
299 : left-endpoint-<= ( i1 i2 -- ? )
300 >r from>> r> to>> = ;
302 : right-endpoint-<= ( i1 i2 -- ? )
303 >r to>> r> from>> = ;
305 : interval<= ( i1 i2 -- ? )
307 { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
308 { [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
309 { [ 2dup right-endpoint-<= ] [ t ] }
313 : interval> ( i1 i2 -- ? )
316 : interval>= ( i1 i2 -- ? )
319 : interval-bitand-pos ( i1 i2 -- ? )
320 [ to>> first ] bi@ min 0 swap [a,b] ;
322 : interval-bitand-neg ( i1 i2 -- ? )
323 dup from>> first 0 < [ drop ] [ nip ] if
324 0 swap to>> first [a,b] ;
326 : interval-nonnegative? ( i -- ? )
329 : interval-bitand ( i1 i2 -- i3 )
334 [ 2dup [ interval-nonnegative? ] both? ]
335 [ interval-bitand-pos ]
338 [ 2dup [ interval-nonnegative? ] either? ]
339 [ interval-bitand-neg ]
343 ] do-empty-interval ;
345 : interval-bitor ( i1 i2 -- i3 )
348 2dup [ interval-nonnegative? ] both?
350 [ interval>points [ first ] bi@ ] bi@
351 4array supremum 0 swap next-power-of-2 [a,b]
352 ] [ 2drop [-inf,inf] ] if
353 ] do-empty-interval ;
355 : interval-bitxor ( i1 i2 -- i3 )
359 : assume< ( i1 i2 -- i3 )
360 dup empty-interval eq? [ drop ] [
361 to>> first [-inf,a) interval-intersect
364 : assume<= ( i1 i2 -- i3 )
365 dup empty-interval eq? [ drop ] [
366 to>> first [-inf,a] interval-intersect
369 : assume> ( i1 i2 -- i3 )
370 dup empty-interval eq? [ drop ] [
371 from>> first (a,inf] interval-intersect
374 : assume>= ( i1 i2 -- i3 )
375 dup empty-interval eq? [ drop ] [
376 from>> first [a,inf] interval-intersect
379 : integral-closure ( i1 -- i2 )
380 dup empty-interval eq? [
381 [ from>> first2 [ 1+ ] unless ]
382 [ to>> first2 [ 1- ] unless ]