lib/Hcompta/Lib/Interval.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE MultiParamTypeClasses #-}
   3 {-# LANGUAGE StandaloneDeriving #-}
   4 {-# LANGUAGE TupleSections #-}
   5 module Hcompta.Lib.Interval where
   6
   7 import qualified Data.Functor
   8
   9 -- * Type 'Limit'
  10
  11 data Limit x
  12  = Limit
  13  { adherence :: Adherence
  14  , limit     :: x }
  15  deriving (Eq, Show)
  16 instance Functor Limit where
  17         fmap f (Limit a x) = Limit a (f x)
  18
  19 data Adherence = Out | In
  20  deriving (Eq, Show)
  21
  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
  25
  26 -- ** Comparing 'Limit's
  27
  28 -- | Compare two 'low' 'Limit's.
  29 newtype LL x = LL x
  30  deriving (Eq)
  31 instance Ord x => Ord (LL (Limit x)) where
  32         compare (LL x) (LL y) =
  33                 case compare (limit x) (limit y) of
  34                  EQ ->
  35                         case (adherence x, adherence y) of
  36                          (Out, In ) -> GT
  37                          (In , Out) -> LT
  38                          _          -> EQ
  39                  o -> o
  40
  41 -- | Compare two 'high' 'Limit's.
  42 newtype HH x = HH x
  43  deriving (Eq)
  44 instance Ord x => Ord (HH (Limit x)) where
  45         compare (HH x) (HH y) =
  46                 case compare (limit x) (limit y) of
  47                  EQ ->
  48                         case (adherence x, adherence y) of
  49                          (Out, In ) -> LT
  50                          (In , Out) -> GT
  51                          _          -> EQ
  52                  o -> o
  53
  54 -- * Type 'Interval'
  55
  56 newtype Ord x => Interval x = Interval (Limit x, Limit x)
  57  deriving (Eq, Show)
  58
  59 low :: Ord x => Interval x -> Limit x
  60 low (Interval t)  = fst t
  61
  62 high :: Ord x => Interval x -> Limit x
  63 high (Interval t) = snd t
  64
  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)
  68 interval x y =
  69         case compare_without_adherence x y of
  70          LT -> Just $ Interval (x, y)
  71          EQ ->
  72                 case (adherence x, adherence y) of
  73                  (In, In) -> Just $ Interval (x, y)
  74                  _        -> Nothing
  75          GT -> Nothing
  76
  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)
  80
  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)
  84
  85 {-
  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)
  90
  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)
  95 -}
  96
  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)
 102                  o  -> o
 103
 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
 107
 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)
 111
 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)
 115
 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
 119
 120 -- | Return:
 121 --
 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
 128          LT -> LT
 129          EQ | adherence l == In -> EQ
 130          EQ -> LT
 131          GT ->
 132                 case compare x (limit h) of
 133                  LT -> EQ
 134                  EQ | adherence h == In -> EQ
 135                  EQ -> GT
 136                  GT -> GT
 137
 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
 141
 142 -- | Return 'True' iif. every value of the first 'Interval' is into the second 'Interval'.
 143 into :: Ord x => Interval x -> Interval x -> Bool
 144 into i j =
 145         case position i j of
 146          (Prefix  , LT) -> True
 147          (Suffixed, GT) -> True
 148          (Include , GT) -> True
 149          (Equal   , _)  -> True
 150          _              -> False
 151
 152 -- | Return 'True' iif. every value of the second 'Interval' is into the first 'Interval'.
 153 onto :: Ord x => Interval x -> Interval x -> Bool
 154 onto = flip into
 155
 156 infix 5 <=..<=
 157 (<=..<=) :: Ord x => x -> x -> Maybe (Interval x)
 158 (<=..<=) x y =
 159         case compare x y of
 160          LT -> Just $ Interval (Limit In x, Limit In y)
 161          EQ -> Just $ Interval (Limit In x, Limit In y)
 162          GT -> Nothing
 163
 164 infix 5 <..<=
 165 (<..<=) :: Ord x => x -> x -> Maybe (Interval x)
 166 (<..<=) x y =
 167         case compare x y of
 168          LT -> Just $ Interval (Limit Out x, Limit In y)
 169          EQ -> Nothing
 170          GT -> Nothing
 171
 172 infix 5 <=..<
 173 (<=..<) :: Ord x => x -> x -> Maybe (Interval x)
 174 (<=..<) x y =
 175         case compare x y of
 176          LT -> Just $ Interval (Limit In x, Limit Out y)
 177          EQ -> Nothing
 178          GT -> Nothing
 179
 180 infix 5 <..<
 181 (<..<) :: Ord x => x -> x -> Maybe (Interval x)
 182 (<..<) x y =
 183         case compare x y of
 184          LT -> Just $ Interval (Limit Out x, Limit Out y)
 185          EQ -> Nothing
 186          GT -> Nothing
 187
 188 -- * Type 'Position'
 189
 190 data Position
 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')
 198  deriving (Eq, Show)
 199
 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
 203          LT -> (, LT) $
 204                 case compare_without_adherence ih jl of
 205                  LT -> Away -- PATTERN: -_|
 206                  EQ ->
 207                         case (adherence ih, adherence jl) of
 208                          (In , In)  -> Overlap  -- PATTERN: -+|
 209                          (Out, Out) -> Away     -- PATTERN: -_|
 210                          _          -> Adjacent -- PATTERN: -|
 211                  GT ->
 212                         case compare (HH ih) (HH jh) of
 213                          LT -> Overlap  -- PATTERN: -+|
 214                          EQ -> Suffixed -- PATTERN: -+
 215                          GT -> Include  -- PATTERN: -+-
 216          EQ ->
 217                 case compare (HH ih) (HH jh) of
 218                  LT -> (Prefix, LT) -- PATTERN: +|
 219                  EQ -> (Equal , EQ) -- PATTERN: +
 220                  GT -> (Prefix, GT) -- PATTERN: +-
 221          GT -> (, GT) $
 222                 case compare_without_adherence il jh of
 223                  LT ->
 224                         case compare (HH ih) (HH jh) of
 225                          LT -> Include  -- PATTERN: |+|
 226                          EQ -> Suffixed -- PATTERN: |+
 227                          GT -> Overlap  -- PATTERN: |+-
 228                  EQ ->
 229                         case (adherence il, adherence jh) of
 230                          (In , In)  -> Overlap  -- PATTERN: |+-
 231                          (Out, Out) -> Away     -- PATTERN: |_-
 232                          _          -> Adjacent -- PATTERN: |-
 233                  GT -> Away -- PATTERN: |_-
 234
 235 infix 4 ..<<..
 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
 239          (Away, LT) -> True
 240          _          -> False
 241
 242 infix 4 ..>>..
 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
 246          (Away, GT) -> True
 247          _          -> False
 248
 249 infix 4 ..<..
 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
 253          (Away    , LT) -> True
 254          (Adjacent, LT) -> True
 255          _              -> False
 256 infix 4 ..>..
 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
 260          (Away    , GT) -> True
 261          (Adjacent, GT) -> True
 262          _              -> False
 263
 264 infix 4 ..<=..
 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
 268          (Away    , LT) -> True
 269          (Adjacent, LT) -> True
 270          (Overlap , LT) -> True
 271          (Prefix  , LT) -> True
 272          (Suffixed, LT) -> True
 273          (Include , GT) -> True
 274          (Equal   , _ ) -> True
 275          _              -> False
 276
 277 infix 4 ..>=..
 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
 281          (Away    , GT) -> True
 282          (Adjacent, GT) -> True
 283          (Overlap , GT) -> True
 284          (Prefix  , GT) -> True
 285          (Suffixed, GT) -> True
 286          (Include , LT) -> True
 287          (Equal   , _ ) -> True
 288          _              -> False
 289
 290 -- * Merge
 291
 292 union :: Ord x => Interval x -> Interval x -> Maybe (Interval x)
 293 union i j =
 294         case position i j of
 295          (Away, _) -> -- PATTERN: -_| or |_-
 296                 Nothing
 297          (Adjacent, o) ->
 298                 case o of
 299                  LT -> Just $ Interval (low i, high j) -- PATTERN: -|
 300                  EQ -> Nothing
 301                  GT -> Just $ Interval (low j, high i) -- PATTERN: |-
 302          (Overlap, o)  ->
 303                 case o of
 304                  LT -> Just $ Interval (low i, high j) -- PATTERN: -+|
 305                  EQ -> Nothing
 306                  GT -> Just $ Interval (low j, high i) -- PATTERN: |+-
 307          (Prefix, o) ->
 308                 case o of
 309                  LT -> Just $ j -- PATTERN: +|
 310                  EQ -> Nothing
 311                  GT -> Just $ i -- PATTERN: +-
 312          (Suffixed, o)  ->
 313                 case o of
 314                  LT -> Just $ i -- PATTERN: -+
 315                  EQ -> Nothing
 316                  GT -> Just $ j -- PATTERN: |+
 317          (Include, o) ->
 318                 case o of
 319                  LT -> Just $ i -- PATTERN: -+-
 320                  EQ -> Nothing
 321                  GT -> Just $ j -- PATTERN: |+|
 322          (Equal, _)    -> -- PATTERN: +
 323                 Just i
 324
 325 intersection :: Ord x => Interval x -> Interval x -> Maybe (Interval x)
 326 intersection i j =
 327         case position i j of
 328          (Away, _) -> -- PATTERN: -_| or |_-
 329                 Nothing
 330          (Adjacent, _) -> -- PATTERN: -| or |-
 331                 Nothing
 332          (Overlap, o)  ->
 333                 case o of
 334                  LT -> Just $ Interval (low j, high i) -- PATTERN: -+|
 335                  EQ -> Nothing
 336                  GT -> Just $ Interval (low i, high j) -- PATTERN: |+-
 337          (Prefix, o) ->
 338                 case o of
 339                  LT -> Just $ i -- PATTERN: +|
 340                  EQ -> Nothing
 341                  GT -> Just $ j -- PATTERN: +-
 342          (Suffixed, o)  ->
 343                 case o of
 344                  LT -> Just $ j -- PATTERN: -+
 345                  EQ -> Nothing
 346                  GT -> Just $ i -- PATTERN: |+
 347          (Include, o) ->
 348                 case o of
 349                  LT -> Just $ j -- PATTERN: -+-
 350                  EQ -> Nothing
 351                  GT -> Just $ i -- PATTERN: |+|
 352          (Equal, _)    -> -- PATTERN: +
 353                 Just i
 354
 355 -- * Type 'Unlimitable'
 356
 357 data Unlimitable x
 358  = Unlimited_low
 359  | Limited { limited :: x }
 360  | Unlimited_high
 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
 372
 373 unlimited :: Ord x => Interval (Unlimitable x)
 374 unlimited = Interval ( Limit In Unlimited_low
 375                      , Limit In Unlimited_high )
 376
 377 unlimit :: Ord x => Interval x -> Interval (Unlimitable x)
 378 unlimit = fmap_unsafe Limited
 379
 380 (<..) :: Ord x => x -> Interval (Unlimitable x)
 381 (<..) x = Interval (Limit Out (Limited x), Limit In Unlimited_high)
 382
 383 (<=..) :: Ord x => x -> Interval (Unlimitable x)
 384 (<=..) x = Interval (Limit In (Limited x), Limit In Unlimited_high)
 385
 386 (..<) :: Ord x => x -> Interval (Unlimitable x)
 387 (..<) x = Interval (Limit In Unlimited_low, Limit Out (Limited x))
 388
 389 (..<=) :: Ord x => x -> Interval (Unlimitable x)
 390 (..<=) x = Interval (Limit In Unlimited_low, Limit In (Limited x))
 391
 392 -- * Type 'Pretty'
 393
 394 newtype Pretty x = Pretty x
 395  deriving (Eq, Ord)
 396 instance (Ord x, Show x) => Show (Pretty (Interval x)) where
 397         show (Pretty i) =
 398                 concat
 399                  [ case adherence (low i) of
 400                          In -> "["
 401                          Out -> "]"
 402                  , show (limit $ low i)
 403                  , ".."
 404                  , show (limit $ high i)
 405                  , case adherence (high i) of
 406                          In -> "]"
 407                          Out -> "["
 408                  ]
 409 instance (Ord x, Show x) => Show (Pretty (Unlimitable x)) where
 410         show (Pretty x) =
 411                 case x of
 412                  Unlimited_low  -> "-oo"
 413                  Limited l      -> show l
 414                  Unlimited_high -> "+oo"