lib/Hcompta/Lib/Interval.hs

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