1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE TupleSections #-}
5 module Hcompta.Lib.Interval where
8 import Data.Data (Data(..))
9 import Data.Foldable (concat)
10 import Data.Functor (Functor(..))
11 import qualified Data.Functor
12 import Data.Maybe (Maybe(..))
13 import Data.Ord (Ord(..), Ordering(..))
15 import Data.Typeable (Typeable)
27 { adherence :: Adherence
29 deriving (Eq, Data, Show, Typeable)
31 instance Functor Limit where
32 fmap f (Limit a x) = Limit a (f x)
34 data Adherence = Out | In
35 deriving (Eq, Data, Show, Typeable)
37 -- | Return given 'Limit' with its 'adherence' set to the opposite one.
38 flip_limit :: Limit x -> Limit x
39 flip_limit (Limit a x) = Limit (case a of { In -> Out; Out -> In }) x
41 -- ** Comparing 'Limit's
43 -- | Compare two 'low' 'Limit's.
44 newtype LL x = LL { unLL :: x }
46 instance Ord x => Ord (LL (Limit x)) where
47 compare (LL x) (LL y) =
48 case compare (limit x) (limit y) of
50 case (adherence x, adherence y) of
56 -- | Compare two 'high' 'Limit's.
57 newtype HH x = HH { unHH :: x }
59 instance Ord x => Ord (HH (Limit x)) where
60 compare (HH x) (HH y) =
61 case compare (limit x) (limit y) of
63 case (adherence x, adherence y) of
71 newtype Ord x => Interval x = Interval (Limit x, Limit x)
72 deriving (Eq, Show, Data, Typeable)
74 low :: Ord x => Interval x -> Limit x
75 low (Interval t) = fst t
77 high :: Ord x => Interval x -> Limit x
78 high (Interval t) = snd t
80 -- | Return 'Interval' with given 'low' then 'high' 'Limit's,
81 -- if they form a valid 'Interval'.
82 interval :: Ord x => Limit x -> Limit x -> Maybe (Interval x)
84 case compare_without_adherence x y of
85 LT -> Just $ Interval (x, y)
87 case (adherence x, adherence y) of
88 (In, In) -> Just $ Interval (x, y)
92 -- | Like 'Data.Functor.fmap', but may return 'Nothing', if mapped 'Interval' is not valid.
93 fmap :: (Ord x, Ord y) => (x -> y) -> Interval x -> Maybe (Interval y)
94 fmap f (Interval (il, ih)) = interval (Data.Functor.fmap f il) (Data.Functor.fmap f ih)
96 -- | Like 'Data.Functor.fmap', but only safe if given map preserves 'Ordering'.
97 fmap_unsafe :: (Ord x, Ord y) => (x -> y) -> Interval x -> Interval y
98 fmap_unsafe f (Interval (il, ih)) = Interval (Data.Functor.fmap f il, Data.Functor.fmap f ih)
101 -- | Like 'Data.Functor.fmap', but on 'Limit's,
102 -- and may return 'Nothing', if mapped 'Interval' is not valid.
103 fmap_limits :: (Ord x, Ord y) => (Limit x -> Limit y) -> Interval x -> Maybe (Interval y)
104 fmap_limits f (Interval (il, ih)) = interval (f il) (f ih)
106 -- | Like 'Data.Functor.fmap', but on 'Limit's
107 -- and only safe if given map preserves 'Ordering'.
108 fmap_limits_unsafe :: (Ord x, Ord y) => (Limit x -> Limit y) -> Interval x -> Interval y
109 fmap_limits_unsafe f (Interval (il, ih)) = Interval (f il, f ih)
112 -- | Lexicographical order, handling 'Adherence' correctly.
113 instance Ord x => Ord (Interval x) where
114 compare (Interval (il, ih)) (Interval (jl, jh)) =
115 case compare (LL il) (LL jl) of
116 EQ -> compare (HH ih) (HH jh)
119 -- | Return 'limit's of given 'Interval' as a tuple.
120 limits :: Ord x => Interval x -> (Limit x, Limit x)
121 limits (Interval t) = t
123 -- | Return an 'Interval' spanning over a single 'limit'.
124 point :: Ord x => x -> Interval x
125 point x = Interval (Limit In x, Limit In x)
127 -- | Return given 'Interval' with 'flip_limit' applied to its 'limit's.
128 flip_limits :: Ord x => Interval x -> Interval x
129 flip_limits (Interval (l, h)) = Interval (flip_limit l, flip_limit h)
131 -- | Return 'Ordering' comparing given 'Interval's according to their 'limit's.
132 compare_without_adherence :: Ord x => Limit x -> Limit x -> Ordering
133 compare_without_adherence (Limit _ x) (Limit _ y) = compare x y
137 -- * 'LT': if given value is lower than all values in given 'Interval'.
138 -- * 'EQ': if given value is into the given 'Interval'.
139 -- * 'GT': if given value is higher than all values in given 'Interval'.
140 locate :: Ord x => x -> Interval x -> Ordering
141 locate x (Interval (l, h)) =
142 case compare x (limit l) of
144 EQ | adherence l == In -> EQ
147 case compare x (limit h) of
149 EQ | adherence h == In -> EQ
153 -- | Return 'True' iif. given value is into the given 'Interval'.
154 within :: Ord x => x -> Interval x -> Bool
155 within x i = locate x i == EQ
157 -- | Return 'True' iif. every value of the first 'Interval' is into the second 'Interval'.
158 into :: Ord x => Interval x -> Interval x -> Bool
161 (Prefix , LT) -> True
162 (Suffixed, GT) -> True
163 (Include , GT) -> True
167 -- | Return 'True' iif. every value of the second 'Interval' is into the first 'Interval'.
168 onto :: Ord x => Interval x -> Interval x -> Bool
172 (<=..<=) :: Ord x => x -> x -> Maybe (Interval x)
175 LT -> Just $ Interval (Limit In x, Limit In y)
176 EQ -> Just $ Interval (Limit In x, Limit In y)
180 (<..<=) :: Ord x => x -> x -> Maybe (Interval x)
183 LT -> Just $ Interval (Limit Out x, Limit In y)
188 (<=..<) :: Ord x => x -> x -> Maybe (Interval x)
191 LT -> Just $ Interval (Limit In x, Limit Out y)
196 (<..<) :: Ord x => x -> x -> Maybe (Interval x)
199 LT -> Just $ Interval (Limit Out x, Limit Out y)
206 = Away -- ^ @-_|@ ('LT') or @|_-@ ('GT')
207 | Adjacent -- ^ @-|@ ('LT') or @|-@ ('GT')
208 | Overlap -- ^ @-+|@ ('LT') or @|+-@ ('GT')
209 | Prefix -- ^ @+|@ ('LT') or @+-@ ('GT')
210 | Suffixed -- ^ @-+@ ('LT') or @|+@ ('GT')
211 | Include -- ^ @-+-@ ('LT') or @|+|@ ('GT')
212 | Equal -- ^ @+@ ('EQ')
215 position :: Ord x => Interval x -> Interval x -> (Position, Ordering)
216 position (Interval (il, ih)) (Interval (jl, jh)) =
217 case compare (LL il) (LL jl) of
219 case compare_without_adherence ih jl of
220 LT -> Away -- PATTERN: -_|
222 case (adherence ih, adherence jl) of
223 (In , In) -> Overlap -- PATTERN: -+|
224 (Out, Out) -> Away -- PATTERN: -_|
225 _ -> Adjacent -- PATTERN: -|
227 case compare (HH ih) (HH jh) of
228 LT -> Overlap -- PATTERN: -+|
229 EQ -> Suffixed -- PATTERN: -+
230 GT -> Include -- PATTERN: -+-
232 case compare (HH ih) (HH jh) of
233 LT -> (Prefix, LT) -- PATTERN: +|
234 EQ -> (Equal , EQ) -- PATTERN: +
235 GT -> (Prefix, GT) -- PATTERN: +-
237 case compare_without_adherence il jh of
239 case compare (HH ih) (HH jh) of
240 LT -> Include -- PATTERN: |+|
241 EQ -> Suffixed -- PATTERN: |+
242 GT -> Overlap -- PATTERN: |+-
244 case (adherence il, adherence jh) of
245 (In , In) -> Overlap -- PATTERN: |+-
246 (Out, Out) -> Away -- PATTERN: |_-
247 _ -> Adjacent -- PATTERN: |-
248 GT -> Away -- PATTERN: |_-
251 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'LT').
252 (..<<..) :: Ord x => Interval x -> Interval x -> Bool
253 (..<<..) i j = case position i j of
258 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'GT').
259 (..>>..) :: Ord x => Interval x -> Interval x -> Bool
260 (..>>..) i j = case position i j of
265 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'LT') or ('Adjacent', 'LT').
266 (..<..) :: Ord x => Interval x -> Interval x -> Bool
267 (..<..) i j = case position i j of
269 (Adjacent, LT) -> True
272 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'GT') or ('Adjacent', 'GT').
273 (..>..) :: Ord x => Interval x -> Interval x -> Bool
274 (..>..) i j = case position i j of
276 (Adjacent, GT) -> True
280 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'LT'), ('Adjacent', 'LT'), ('Overlap', 'LT'), ('Prefix', 'LT'), ('Suffixed', 'LT'), ('Include', 'GT'), or ('Equal', _).
281 (..<=..) :: Ord x => Interval x -> Interval x -> Bool
282 (..<=..) i j = case position i j of
284 (Adjacent, LT) -> True
285 (Overlap , LT) -> True
286 (Prefix , LT) -> True
287 (Suffixed, LT) -> True
288 (Include , GT) -> True
293 -- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'GT'), ('Adjacent', 'GT'), ('Overlap', 'GT'), ('Prefix', 'GT'), ('Suffixed', 'GT'), ('Include', 'LT'), or ('Equal', _).
294 (..>=..) :: Ord x => Interval x -> Interval x -> Bool
295 (..>=..) i j = case position i j of
297 (Adjacent, GT) -> True
298 (Overlap , GT) -> True
299 (Prefix , GT) -> True
300 (Suffixed, GT) -> True
301 (Include , LT) -> True
307 union :: Ord x => Interval x -> Interval x -> Maybe (Interval x)
310 (Away, _) -> -- PATTERN: -_| or |_-
314 LT -> Just $ Interval (low i, high j) -- PATTERN: -|
316 GT -> Just $ Interval (low j, high i) -- PATTERN: |-
319 LT -> Just $ Interval (low i, high j) -- PATTERN: -+|
321 GT -> Just $ Interval (low j, high i) -- PATTERN: |+-
324 LT -> Just $ j -- PATTERN: +|
326 GT -> Just $ i -- PATTERN: +-
329 LT -> Just $ i -- PATTERN: -+
331 GT -> Just $ j -- PATTERN: |+
334 LT -> Just $ i -- PATTERN: -+-
336 GT -> Just $ j -- PATTERN: |+|
337 (Equal, _) -> -- PATTERN: +
340 intersection :: Ord x => Interval x -> Interval x -> Maybe (Interval x)
343 (Away, _) -> -- PATTERN: -_| or |_-
345 (Adjacent, _) -> -- PATTERN: -| or |-
349 LT -> Just $ Interval (low j, high i) -- PATTERN: -+|
351 GT -> Just $ Interval (low i, high j) -- PATTERN: |+-
354 LT -> Just $ i -- PATTERN: +|
356 GT -> Just $ j -- PATTERN: +-
359 LT -> Just $ j -- PATTERN: -+
361 GT -> Just $ i -- PATTERN: |+
364 LT -> Just $ j -- PATTERN: -+-
366 GT -> Just $ i -- PATTERN: |+|
367 (Equal, _) -> -- PATTERN: +
370 span :: Ord x => Interval x -> Interval x -> Interval x
373 ( unLL (min (LL $ low i) (LL $ low j))
374 , unHH (max (HH $ high i) (HH $ high j))
377 -- * Type 'Unlimitable'
381 | Limited { limited :: x }
383 deriving (Eq, Ord, Show)
384 instance Functor Unlimitable where
385 fmap _f Unlimited_low = Unlimited_low
386 fmap _f Unlimited_high = Unlimited_high
387 fmap f (Limited x) = Limited (f x)
388 instance Bounded (Unlimitable x) where
389 minBound = Unlimited_low
390 maxBound = Unlimited_high
391 instance Bounded (Limit (Unlimitable x)) where
392 minBound = Limit In Unlimited_low
393 maxBound = Limit In Unlimited_high
395 unlimited :: Ord x => Interval (Unlimitable x)
396 unlimited = Interval ( Limit In Unlimited_low
397 , Limit In Unlimited_high )
399 unlimit :: Ord x => Interval x -> Interval (Unlimitable x)
400 unlimit = fmap_unsafe Limited
402 (<..) :: Ord x => x -> Interval (Unlimitable x)
403 (<..) x = Interval (Limit Out (Limited x), Limit In Unlimited_high)
405 (<=..) :: Ord x => x -> Interval (Unlimitable x)
406 (<=..) x = Interval (Limit In (Limited x), Limit In Unlimited_high)
408 (..<) :: Ord x => x -> Interval (Unlimitable x)
409 (..<) x = Interval (Limit In Unlimited_low, Limit Out (Limited x))
411 (..<=) :: Ord x => x -> Interval (Unlimitable x)
412 (..<=) x = Interval (Limit In Unlimited_low, Limit In (Limited x))
416 newtype Pretty x = Pretty x
418 instance (Ord x, Show x) => Show (Pretty (Interval x)) where
421 [ case adherence (low i) of
424 , show (limit $ low i)
426 , show (limit $ high i)
427 , case adherence (high i) of
431 instance (Ord x, Show x) => Show (Pretty (Unlimitable x)) where
434 Unlimited_low -> "-oo"
436 Unlimited_high -> "+oo"