1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE MultiParamTypeClasses #-}
3 {-# LANGUAGE StandaloneDeriving #-}
4 {-# LANGUAGE TupleSections #-}
5 module Hcompta.Lib.Interval where
7 import qualified Data.Functor
13 { adherence :: Adherence
16 instance Functor Limit where
17 fmap f (Limit a x) = Limit a (f x)
19 data Adherence = Out | In
22 -- | Return given 'Limit' with its 'adherence' set to the opposite one.
23 flip_limit :: Limit x -> Limit x
24 flip_limit (Limit a x) = Limit (case a of { In -> Out; Out -> In }) x
26 -- ** Comparing 'Limit's
28 -- | Compare two 'low' 'Limit's.
31 instance Ord x => Ord (LL (Limit x)) where
32 compare (LL x) (LL y) =
33 case compare (limit x) (limit y) of
35 case (adherence x, adherence y) of
41 -- | Compare two 'high' 'Limit's.
44 instance Ord x => Ord (HH (Limit x)) where
45 compare (HH x) (HH y) =
46 case compare (limit x) (limit y) of
48 case (adherence x, adherence y) of
56 newtype Ord x => Interval x = Interval (Limit x, Limit x)
59 low :: Ord x => Interval x -> Limit x
60 low (Interval t) = fst t
62 high :: Ord x => Interval x -> Limit x
63 high (Interval t) = snd t
65 -- | Return 'Interval' with given 'low' then 'high' 'Limit's,
66 -- if they form a valid 'Interval'.
67 interval :: Ord x => Limit x -> Limit x -> Maybe (Interval x)
69 case compare_without_adherence x y of
70 LT -> Just $ Interval (x, y)
72 case (adherence x, adherence y) of
73 (In, In) -> Just $ Interval (x, y)
77 -- | Like 'Data.Functor.fmap', but may return 'Nothing', if mapped 'Interval' is not valid.
78 fmap :: (Ord x, Ord y) => (x -> y) -> Interval x -> Maybe (Interval y)
79 fmap f (Interval (il, ih)) = interval (Data.Functor.fmap f il) (Data.Functor.fmap f ih)
81 -- | Like 'Data.Functor.fmap', but only safe if given map preserves 'Ordering'.
82 fmap_unsafe :: (Ord x, Ord y) => (x -> y) -> Interval x -> Interval y
83 fmap_unsafe f (Interval (il, ih)) = Interval (Data.Functor.fmap f il, Data.Functor.fmap f ih)
86 -- | Like 'Data.Functor.fmap', but on 'Limit's,
87 -- and may return 'Nothing', if mapped 'Interval' is not valid.
88 fmap_limits :: (Ord x, Ord y) => (Limit x -> Limit y) -> Interval x -> Maybe (Interval y)
89 fmap_limits f (Interval (il, ih)) = interval (f il) (f ih)
91 -- | Like 'Data.Functor.fmap', but on 'Limit's
92 -- and only safe if given map preserves 'Ordering'.
93 fmap_limits_unsafe :: (Ord x, Ord y) => (Limit x -> Limit y) -> Interval x -> Interval y
94 fmap_limits_unsafe f (Interval (il, ih)) = Interval (f il, f ih)
97 -- | Lexicographical order, handling 'Adherence' correctly.
98 instance Ord x => Ord (Interval x) where
99 compare (Interval (il, ih)) (Interval (jl, jh)) =
100 case compare (LL il) (LL jl) of
101 EQ -> compare (HH ih) (HH jh)
104 -- | Return 'limit's of given 'Interval' as a tuple.
105 limits :: Ord x => Interval x -> (Limit x, Limit x)
106 limits (Interval t) = t
108 -- | Return an 'Interval' spanning over a single 'limit'.
109 point :: Ord x => x -> Interval x
110 point x = Interval (Limit In x, Limit In x)
112 -- | Return given 'Interval' with 'flip_limit' applied to its 'limit's.
113 flip_limits :: Ord x => Interval x -> Interval x
114 flip_limits (Interval (l, h)) = Interval (flip_limit l, flip_limit h)
116 -- | Return 'Ordering' comparing given 'Interval's according to their 'limit's.
117 compare_without_adherence :: Ord x => Limit x -> Limit x -> Ordering
118 compare_without_adherence (Limit _ x) (Limit _ y) = compare x y
122 -- * 'LT': if given value is lower than all values in given 'Interval'.
123 -- * 'EQ': if given value is into the given 'Interval'.
124 -- * 'GT': if given value is higher than all values in given 'Interval'.
125 locate :: Ord x => x -> Interval x -> Ordering
126 locate x (Interval (l, h)) =
127 case compare x (limit l) of
129 EQ | adherence l == In -> EQ
132 case compare x (limit h) of
134 EQ | adherence h == In -> EQ
138 -- | Return 'True' iif. given value is into the given 'Interval'.
139 within :: Ord x => x -> Interval x -> Bool
140 within x i = locate x i == EQ
142 -- | Return 'True' iif. every value of the first 'Interval' is into the second 'Interval'.
143 into :: Ord x => Interval x -> Interval x -> Bool
146 (Prefix , LT) -> True
147 (Suffixed, GT) -> True
148 (Include , GT) -> True
152 -- | Return 'True' iif. every value of the second 'Interval' is into the first 'Interval'.
153 onto :: Ord x => Interval x -> Interval x -> Bool
157 (<=..<=) :: Ord x => x -> x -> Maybe (Interval x)
160 LT -> Just $ Interval (Limit In x, Limit In y)
161 EQ -> Just $ Interval (Limit In x, Limit In y)
165 (<..<=) :: Ord x => x -> x -> Maybe (Interval x)
168 LT -> Just $ Interval (Limit Out x, Limit In y)
173 (<=..<) :: Ord x => x -> x -> Maybe (Interval x)
176 LT -> Just $ Interval (Limit In x, Limit Out y)
181 (<..<) :: Ord x => x -> x -> Maybe (Interval x)
184 LT -> Just $ Interval (Limit Out x, Limit Out y)
191 = Away -- ^ @-_|@ ('LT') or @|_-@ ('GT')
192 | Adjacent -- ^ @-|@ ('LT') or @|-@ ('GT')
193 | Overlap -- ^ @-+|@ ('LT') or @|+-@ ('GT')
194 | Prefix -- ^ @+|@ ('LT') or @+-@ ('GT')
195 | Suffixed -- ^ @-+@ ('LT') or @|+@ ('GT')
196 | Include -- ^ @-+-@ ('LT') or @|+|@ ('GT')
197 | Equal -- ^ @+@ ('EQ')
200 position :: Ord x => Interval x -> Interval x -> (Position, Ordering)
201 position (Interval (il, ih)) (Interval (jl, jh)) =
202 case compare (LL il) (LL jl) of
204 case compare_without_adherence ih jl of
205 LT -> Away -- PATTERN: -_|
207 case (adherence ih, adherence jl) of
208 (In , In) -> Overlap -- PATTERN: -+|
209 (Out, Out) -> Away -- PATTERN: -_|
210 _ -> Adjacent -- PATTERN: -|
212 case compare (HH ih) (HH jh) of
213 LT -> Overlap -- PATTERN: -+|
214 EQ -> Suffixed -- PATTERN: -+
215 GT -> Include -- PATTERN: -+-
217 case compare (HH ih) (HH jh) of
218 LT -> (Prefix, LT) -- PATTERN: +|
219 EQ -> (Equal , EQ) -- PATTERN: +
220 GT -> (Prefix, GT) -- PATTERN: +-
222 case compare_without_adherence il jh of
224 case compare (HH ih) (HH jh) of
225 LT -> Include -- PATTERN: |+|
226 EQ -> Suffixed -- PATTERN: |+
227 GT -> Overlap -- PATTERN: |+-
229 case (adherence il, adherence jh) of
230 (In , In) -> Overlap -- PATTERN: |+-
231 (Out, Out) -> Away -- PATTERN: |_-
232 _ -> Adjacent -- PATTERN: |-
233 GT -> Away -- PATTERN: |_-
236 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'LT').
237 (..<<..) :: Ord x => Interval x -> Interval x -> Bool
238 (..<<..) i j = case position i j of
243 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'GT').
244 (..>>..) :: Ord x => Interval x -> Interval x -> Bool
245 (..>>..) i j = case position i j of
250 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'LT') or ('Adjacent', 'LT').
251 (..<..) :: Ord x => Interval x -> Interval x -> Bool
252 (..<..) i j = case position i j of
254 (Adjacent, LT) -> True
257 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'GT') or ('Adjacent', 'GT').
258 (..>..) :: Ord x => Interval x -> Interval x -> Bool
259 (..>..) i j = case position i j of
261 (Adjacent, GT) -> True
265 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'LT'), ('Adjacent', 'LT'), ('Overlap', 'LT'), ('Prefix', 'LT'), ('Suffixed', 'LT'), ('Include', 'GT'), or ('Equal', _).
266 (..<=..) :: Ord x => Interval x -> Interval x -> Bool
267 (..<=..) i j = case position i j of
269 (Adjacent, LT) -> True
270 (Overlap , LT) -> True
271 (Prefix , LT) -> True
272 (Suffixed, LT) -> True
273 (Include , GT) -> True
278 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'GT'), ('Adjacent', 'GT'), ('Overlap', 'GT'), ('Prefix', 'GT'), ('Suffixed', 'GT'), ('Include', 'LT'), or ('Equal', _).
279 (..>=..) :: Ord x => Interval x -> Interval x -> Bool
280 (..>=..) i j = case position i j of
282 (Adjacent, GT) -> True
283 (Overlap , GT) -> True
284 (Prefix , GT) -> True
285 (Suffixed, GT) -> True
286 (Include , LT) -> True
292 union :: Ord x => Interval x -> Interval x -> Maybe (Interval x)
295 (Away, _) -> -- PATTERN: -_| or |_-
299 LT -> Just $ Interval (low i, high j) -- PATTERN: -|
301 GT -> Just $ Interval (low j, high i) -- PATTERN: |-
304 LT -> Just $ Interval (low i, high j) -- PATTERN: -+|
306 GT -> Just $ Interval (low j, high i) -- PATTERN: |+-
309 LT -> Just $ j -- PATTERN: +|
311 GT -> Just $ i -- PATTERN: +-
314 LT -> Just $ i -- PATTERN: -+
316 GT -> Just $ j -- PATTERN: |+
319 LT -> Just $ i -- PATTERN: -+-
321 GT -> Just $ j -- PATTERN: |+|
322 (Equal, _) -> -- PATTERN: +
325 intersection :: Ord x => Interval x -> Interval x -> Maybe (Interval x)
328 (Away, _) -> -- PATTERN: -_| or |_-
330 (Adjacent, _) -> -- PATTERN: -| or |-
334 LT -> Just $ Interval (low j, high i) -- PATTERN: -+|
336 GT -> Just $ Interval (low i, high j) -- PATTERN: |+-
339 LT -> Just $ i -- PATTERN: +|
341 GT -> Just $ j -- PATTERN: +-
344 LT -> Just $ j -- PATTERN: -+
346 GT -> Just $ i -- PATTERN: |+
349 LT -> Just $ j -- PATTERN: -+-
351 GT -> Just $ i -- PATTERN: |+|
352 (Equal, _) -> -- PATTERN: +
355 -- * Type 'Unlimitable'
359 | Limited { limited :: x }
361 deriving (Eq, Ord, Show)
362 instance Functor Unlimitable where
363 fmap _f Unlimited_low = Unlimited_low
364 fmap _f Unlimited_high = Unlimited_high
365 fmap f (Limited x) = Limited (f x)
366 instance Bounded (Unlimitable x) where
367 minBound = Unlimited_low
368 maxBound = Unlimited_high
369 instance Bounded (Limit (Unlimitable x)) where
370 minBound = Limit In Unlimited_low
371 maxBound = Limit In Unlimited_high
373 unlimited :: Ord x => Interval (Unlimitable x)
374 unlimited = Interval ( Limit In Unlimited_low
375 , Limit In Unlimited_high )
377 unlimit :: Ord x => Interval x -> Interval (Unlimitable x)
378 unlimit = fmap_unsafe Limited
380 (<..) :: Ord x => x -> Interval (Unlimitable x)
381 (<..) x = Interval (Limit Out (Limited x), Limit In Unlimited_high)
383 (<=..) :: Ord x => x -> Interval (Unlimitable x)
384 (<=..) x = Interval (Limit In (Limited x), Limit In Unlimited_high)
386 (..<) :: Ord x => x -> Interval (Unlimitable x)
387 (..<) x = Interval (Limit In Unlimited_low, Limit Out (Limited x))
389 (..<=) :: Ord x => x -> Interval (Unlimitable x)
390 (..<=) x = Interval (Limit In Unlimited_low, Limit In (Limited x))
394 newtype Pretty x = Pretty x
396 instance (Ord x, Show x) => Show (Pretty (Interval x)) where
399 [ case adherence (low i) of
402 , show (limit $ low i)
404 , show (limit $ high i)
405 , case adherence (high i) of
409 instance (Ord x, Show x) => Show (Pretty (Unlimitable x)) where
412 Unlimited_low -> "-oo"
414 Unlimited_high -> "+oo"