]> Git — Sourcephile - haskell/interval.git/blob - Data/Interval.hs
5a3b67c36a7dd104303c45746800180f9bdb4d87
[haskell/interval.git] / Data / Interval.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE TupleSections #-}
5 module Data.Interval where
6
7 import Control.DeepSeq (NFData(..))
8 import Data.Bool
9 import Data.Data (Data(..))
10 import Data.Eq (Eq(..))
11 import Data.Foldable (concat)
12 import Data.Function (($), flip)
13 import Data.Functor (Functor(..))
14 import qualified Data.Functor as Functor
15 import Data.Maybe (Maybe(..))
16 import Data.Ord (Ord(..), Ordering(..))
17 import Data.Tuple
18 import Data.Typeable (Typeable)
19 import Prelude (Bounded(..), seq)
20 import Text.Show (Show(..))
21
22 -- * Type 'Limit'
23
24 data Limit x
25 = Limit
26 { adherence :: Adherence
27 , limit :: x }
28 deriving (Eq, Data, Show, Typeable)
29
30 instance Functor Limit where
31 fmap f (Limit a x) = Limit a (f x)
32 instance NFData x => NFData (Limit x) where
33 rnf (Limit _a l) = rnf l
34
35 data Adherence = Out | In
36 deriving (Eq, Data, Show, Typeable)
37
38 -- | Return given 'Limit' with its 'adherence' set to the opposite one.
39 flip_limit :: Limit x -> Limit x
40 flip_limit (Limit a x) = Limit (case a of { In -> Out; Out -> In }) x
41
42 -- ** Comparing 'Limit's
43
44 -- | Compare two 'low' 'Limit's.
45 newtype LL x = LL { unLL :: x }
46 deriving (Eq)
47 instance Ord x => Ord (LL (Limit x)) where
48 compare (LL x) (LL y) =
49 case compare (limit x) (limit y) of
50 EQ ->
51 case (adherence x, adherence y) of
52 (Out, In ) -> GT
53 (In , Out) -> LT
54 _ -> EQ
55 o -> o
56
57 -- | Compare two 'high' 'Limit's.
58 newtype HH x = HH { unHH :: x }
59 deriving (Eq)
60 instance Ord x => Ord (HH (Limit x)) where
61 compare (HH x) (HH y) =
62 case compare (limit x) (limit y) of
63 EQ ->
64 case (adherence x, adherence y) of
65 (Out, In ) -> LT
66 (In , Out) -> GT
67 _ -> EQ
68 o -> o
69
70 -- * Type 'Interval'
71
72 newtype Ord x
73 => Interval x
74 = Interval (Limit x, Limit x)
75 deriving (Eq, Show, Data, Typeable)
76 instance (NFData x, Ord x) => NFData (Interval x) where
77 rnf (Interval (x, y)) = rnf x `seq` rnf y
78
79 low :: Ord x => Interval x -> Limit x
80 low (Interval t) = fst t
81
82 high :: Ord x => Interval x -> Limit x
83 high (Interval t) = snd t
84
85 -- | Return 'Interval' with given 'low' then 'high' 'Limit's,
86 -- if they form a valid 'Interval'.
87 interval :: Ord x => Limit x -> Limit x -> Maybe (Interval x)
88 interval x y =
89 case compare_without_adherence x y of
90 LT -> Just $ Interval (x, y)
91 EQ ->
92 case (adherence x, adherence y) of
93 (In, In) -> Just $ Interval (x, y)
94 _ -> Nothing
95 GT -> Nothing
96
97 -- | Like 'Functor.fmap', but may return 'Nothing', if mapped 'Interval' is not valid.
98 fmap :: (Ord x, Ord y) => (x -> y) -> Interval x -> Maybe (Interval y)
99 fmap f (Interval (il, ih)) = interval (Functor.fmap f il) (Functor.fmap f ih)
100
101 -- | Like 'Functor.fmap', but only safe if given map preserves 'Ordering'.
102 fmap_unsafe :: (Ord x, Ord y) => (x -> y) -> Interval x -> Interval y
103 fmap_unsafe f (Interval (il, ih)) = Interval (Functor.fmap f il, Functor.fmap f ih)
104
105 {-
106 -- | Like 'Functor.fmap', but on 'Limit's,
107 -- and may return 'Nothing', if mapped 'Interval' is not valid.
108 fmap_limits :: (Ord x, Ord y) => (Limit x -> Limit y) -> Interval x -> Maybe (Interval y)
109 fmap_limits f (Interval (il, ih)) = interval (f il) (f ih)
110
111 -- | Like 'Functor.fmap', but on 'Limit's
112 -- and only safe if given map preserves 'Ordering'.
113 fmap_limits_unsafe :: (Ord x, Ord y) => (Limit x -> Limit y) -> Interval x -> Interval y
114 fmap_limits_unsafe f (Interval (il, ih)) = Interval (f il, f ih)
115 -}
116
117 -- | Lexicographical order, handling 'Adherence' correctly.
118 instance Ord x => Ord (Interval x) where
119 compare (Interval (il, ih)) (Interval (jl, jh)) =
120 case compare (LL il) (LL jl) of
121 EQ -> compare (HH ih) (HH jh)
122 o -> o
123
124 -- | Return 'limit's of given 'Interval' as a tuple.
125 limits :: Ord x => Interval x -> (Limit x, Limit x)
126 limits (Interval t) = t
127
128 -- | Return an 'Interval' spanning over a single 'limit'.
129 point :: Ord x => x -> Interval x
130 point x = Interval (Limit In x, Limit In x)
131
132 -- | Return given 'Interval' with 'flip_limit' applied to its 'limit's.
133 flip_limits :: Ord x => Interval x -> Interval x
134 flip_limits (Interval (l, h)) = Interval (flip_limit l, flip_limit h)
135
136 -- | Return 'Ordering' comparing given 'Interval's according to their 'limit's.
137 compare_without_adherence :: Ord x => Limit x -> Limit x -> Ordering
138 compare_without_adherence (Limit _ x) (Limit _ y) = compare x y
139
140 -- | Return:
141 --
142 -- * 'LT': if given value is lower than all values in given 'Interval'.
143 -- * 'EQ': if given value is into the given 'Interval'.
144 -- * 'GT': if given value is higher than all values in given 'Interval'.
145 locate :: Ord x => x -> Interval x -> Ordering
146 locate x (Interval (l, h)) =
147 case compare x (limit l) of
148 LT -> LT
149 EQ | adherence l == In -> EQ
150 EQ -> LT
151 GT ->
152 case compare x (limit h) of
153 LT -> EQ
154 EQ | adherence h == In -> EQ
155 EQ -> GT
156 GT -> GT
157
158 -- | Return 'True' iif. given value is into the given 'Interval'.
159 within :: Ord x => x -> Interval x -> Bool
160 within x i = locate x i == EQ
161
162 -- | Return 'True' iif. every value of the first 'Interval' is into the second 'Interval'.
163 into :: Ord x => Interval x -> Interval x -> Bool
164 into i j =
165 case position i j of
166 (Prefix , LT) -> True
167 (Suffixed, GT) -> True
168 (Include , GT) -> True
169 (Equal , _) -> True
170 _ -> False
171
172 -- | Return 'True' iif. every value of the second 'Interval' is into the first 'Interval'.
173 onto :: Ord x => Interval x -> Interval x -> Bool
174 onto = flip into
175
176 infix 5 <=..<=
177 (<=..<=) :: Ord x => x -> x -> Maybe (Interval x)
178 (<=..<=) x y =
179 case compare x y of
180 LT -> Just $ Interval (Limit In x, Limit In y)
181 EQ -> Just $ Interval (Limit In x, Limit In y)
182 GT -> Nothing
183
184 infix 5 <..<=
185 (<..<=) :: Ord x => x -> x -> Maybe (Interval x)
186 (<..<=) x y =
187 case compare x y of
188 LT -> Just $ Interval (Limit Out x, Limit In y)
189 EQ -> Nothing
190 GT -> Nothing
191
192 infix 5 <=..<
193 (<=..<) :: Ord x => x -> x -> Maybe (Interval x)
194 (<=..<) x y =
195 case compare x y of
196 LT -> Just $ Interval (Limit In x, Limit Out y)
197 EQ -> Nothing
198 GT -> Nothing
199
200 infix 5 <..<
201 (<..<) :: Ord x => x -> x -> Maybe (Interval x)
202 (<..<) x y =
203 case compare x y of
204 LT -> Just $ Interval (Limit Out x, Limit Out y)
205 EQ -> Nothing
206 GT -> Nothing
207
208 -- * Type 'Position'
209
210 data Position
211 = Away -- ^ @-_|@ ('LT') or @|_-@ ('GT')
212 | Adjacent -- ^ @-|@ ('LT') or @|-@ ('GT')
213 | Overlap -- ^ @-+|@ ('LT') or @|+-@ ('GT')
214 | Prefix -- ^ @+|@ ('LT') or @+-@ ('GT')
215 | Suffixed -- ^ @-+@ ('LT') or @|+@ ('GT')
216 | Include -- ^ @-+-@ ('LT') or @|+|@ ('GT')
217 | Equal -- ^ @+@ ('EQ')
218 deriving (Eq, Show)
219
220 position :: Ord x => Interval x -> Interval x -> (Position, Ordering)
221 position (Interval (il, ih)) (Interval (jl, jh)) =
222 case compare (LL il) (LL jl) of
223 LT -> (, LT) $
224 case compare_without_adherence ih jl of
225 LT -> Away -- PATTERN: -_|
226 EQ ->
227 case (adherence ih, adherence jl) of
228 (In , In) -> Overlap -- PATTERN: -+|
229 (Out, Out) -> Away -- PATTERN: -_|
230 _ -> Adjacent -- PATTERN: -|
231 GT ->
232 case compare (HH ih) (HH jh) of
233 LT -> Overlap -- PATTERN: -+|
234 EQ -> Suffixed -- PATTERN: -+
235 GT -> Include -- PATTERN: -+-
236 EQ ->
237 case compare (HH ih) (HH jh) of
238 LT -> (Prefix, LT) -- PATTERN: +|
239 EQ -> (Equal , EQ) -- PATTERN: +
240 GT -> (Prefix, GT) -- PATTERN: +-
241 GT -> (, GT) $
242 case compare_without_adherence il jh of
243 LT ->
244 case compare (HH ih) (HH jh) of
245 LT -> Include -- PATTERN: |+|
246 EQ -> Suffixed -- PATTERN: |+
247 GT -> Overlap -- PATTERN: |+-
248 EQ ->
249 case (adherence il, adherence jh) of
250 (In , In) -> Overlap -- PATTERN: |+-
251 (Out, Out) -> Away -- PATTERN: |_-
252 _ -> Adjacent -- PATTERN: |-
253 GT -> Away -- PATTERN: |_-
254
255 infix 4 ..<<..
256 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'LT').
257 (..<<..) :: Ord x => Interval x -> Interval x -> Bool
258 (..<<..) i j = case position i j of
259 (Away, LT) -> True
260 _ -> False
261
262 infix 4 ..>>..
263 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'GT').
264 (..>>..) :: Ord x => Interval x -> Interval x -> Bool
265 (..>>..) i j = case position i j of
266 (Away, GT) -> True
267 _ -> False
268
269 infix 4 ..<..
270 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'LT') or ('Adjacent', 'LT').
271 (..<..) :: Ord x => Interval x -> Interval x -> Bool
272 (..<..) i j = case position i j of
273 (Away , LT) -> True
274 (Adjacent, LT) -> True
275 _ -> False
276 infix 4 ..>..
277 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'GT') or ('Adjacent', 'GT').
278 (..>..) :: Ord x => Interval x -> Interval x -> Bool
279 (..>..) i j = case position i j of
280 (Away , GT) -> True
281 (Adjacent, GT) -> True
282 _ -> False
283
284 infix 4 ..<=..
285 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'LT'), ('Adjacent', 'LT'), ('Overlap', 'LT'), ('Prefix', 'LT'), ('Suffixed', 'LT'), ('Include', 'GT'), or ('Equal', _).
286 (..<=..) :: Ord x => Interval x -> Interval x -> Bool
287 (..<=..) i j = case position i j of
288 (Away , LT) -> True
289 (Adjacent, LT) -> True
290 (Overlap , LT) -> True
291 (Prefix , LT) -> True
292 (Suffixed, LT) -> True
293 (Include , GT) -> True
294 (Equal , _ ) -> True
295 _ -> False
296
297 infix 4 ..>=..
298 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'GT'), ('Adjacent', 'GT'), ('Overlap', 'GT'), ('Prefix', 'GT'), ('Suffixed', 'GT'), ('Include', 'LT'), or ('Equal', _).
299 (..>=..) :: Ord x => Interval x -> Interval x -> Bool
300 (..>=..) i j = case position i j of
301 (Away , GT) -> True
302 (Adjacent, GT) -> True
303 (Overlap , GT) -> True
304 (Prefix , GT) -> True
305 (Suffixed, GT) -> True
306 (Include , LT) -> True
307 (Equal , _ ) -> True
308 _ -> False
309
310 -- * Merge
311
312 union :: Ord x => Interval x -> Interval x -> Maybe (Interval x)
313 union i j =
314 case position i j of
315 (Away, _) -> -- PATTERN: -_| or |_-
316 Nothing
317 (Adjacent, o) ->
318 case o of
319 LT -> Just $ Interval (low i, high j) -- PATTERN: -|
320 EQ -> Nothing
321 GT -> Just $ Interval (low j, high i) -- PATTERN: |-
322 (Overlap, o) ->
323 case o of
324 LT -> Just $ Interval (low i, high j) -- PATTERN: -+|
325 EQ -> Nothing
326 GT -> Just $ Interval (low j, high i) -- PATTERN: |+-
327 (Prefix, o) ->
328 case o of
329 LT -> Just j -- PATTERN: +|
330 EQ -> Nothing
331 GT -> Just i -- PATTERN: +-
332 (Suffixed, o) ->
333 case o of
334 LT -> Just i -- PATTERN: -+
335 EQ -> Nothing
336 GT -> Just j -- PATTERN: |+
337 (Include, o) ->
338 case o of
339 LT -> Just i -- PATTERN: -+-
340 EQ -> Nothing
341 GT -> Just j -- PATTERN: |+|
342 (Equal, _) -> -- PATTERN: +
343 Just i
344
345 intersection :: Ord x => Interval x -> Interval x -> Maybe (Interval x)
346 intersection i j =
347 case position i j of
348 (Away, _) -> -- PATTERN: -_| or |_-
349 Nothing
350 (Adjacent, _) -> -- PATTERN: -| or |-
351 Nothing
352 (Overlap, o) ->
353 case o of
354 LT -> Just $ Interval (low j, high i) -- PATTERN: -+|
355 EQ -> Nothing
356 GT -> Just $ Interval (low i, high j) -- PATTERN: |+-
357 (Prefix, o) ->
358 case o of
359 LT -> Just i -- PATTERN: +|
360 EQ -> Nothing
361 GT -> Just j -- PATTERN: +-
362 (Suffixed, o) ->
363 case o of
364 LT -> Just j -- PATTERN: -+
365 EQ -> Nothing
366 GT -> Just i -- PATTERN: |+
367 (Include, o) ->
368 case o of
369 LT -> Just j -- PATTERN: -+-
370 EQ -> Nothing
371 GT -> Just i -- PATTERN: |+|
372 (Equal, _) -> -- PATTERN: +
373 Just i
374
375 span :: Ord x => Interval x -> Interval x -> Interval x
376 span i j =
377 Interval
378 ( unLL (min (LL $ low i) (LL $ low j))
379 , unHH (max (HH $ high i) (HH $ high j))
380 )
381
382 -- * Type 'Unlimitable'
383
384 data Unlimitable x
385 = Unlimited_low
386 | Limited { limited :: x }
387 | Unlimited_high
388 deriving (Eq, Ord, Show)
389 instance Functor Unlimitable where
390 fmap _f Unlimited_low = Unlimited_low
391 fmap _f Unlimited_high = Unlimited_high
392 fmap f (Limited x) = Limited (f x)
393 instance Bounded (Unlimitable x) where
394 minBound = Unlimited_low
395 maxBound = Unlimited_high
396 instance Bounded (Limit (Unlimitable x)) where
397 minBound = Limit In Unlimited_low
398 maxBound = Limit In Unlimited_high
399
400 unlimited :: Ord x => Interval (Unlimitable x)
401 unlimited = Interval ( Limit In Unlimited_low
402 , Limit In Unlimited_high )
403
404 unlimit :: Ord x => Interval x -> Interval (Unlimitable x)
405 unlimit = fmap_unsafe Limited
406
407 (<..) :: Ord x => x -> Interval (Unlimitable x)
408 (<..) x = Interval (Limit Out (Limited x), Limit In Unlimited_high)
409
410 (<=..) :: Ord x => x -> Interval (Unlimitable x)
411 (<=..) x = Interval (Limit In (Limited x), Limit In Unlimited_high)
412
413 (..<) :: Ord x => x -> Interval (Unlimitable x)
414 (..<) x = Interval (Limit In Unlimited_low, Limit Out (Limited x))
415
416 (..<=) :: Ord x => x -> Interval (Unlimitable x)
417 (..<=) x = Interval (Limit In Unlimited_low, Limit In (Limited x))
418
419 -- * Type 'Pretty'
420
421 newtype Pretty x = Pretty x
422 deriving (Eq, Ord)
423 instance (Ord x, Show x) => Show (Pretty (Interval x)) where
424 show (Pretty i) =
425 concat
426 [ case adherence (low i) of
427 In -> "["
428 Out -> "]"
429 , show (limit $ low i)
430 , ".."
431 , show (limit $ high i)
432 , case adherence (high i) of
433 In -> "]"
434 Out -> "["
435 ]
436 instance (Ord x, Show x) => Show (Pretty (Unlimitable x)) where
437 show (Pretty x) =
438 case x of
439 Unlimited_low -> "-oo"
440 Limited l -> show l
441 Unlimited_high -> "+oo"