lib/Hcompta/Lib/Interval.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE TupleSections #-}
   5 module Hcompta.Lib.Interval where
   6
   7 import           Data.Bool
   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(..))
  14 import           Data.Tuple
  15 import           Data.Typeable (Typeable)
  16 import           Prelude ( ($)
  17                          , Bounded(..)
  18                          , Eq(..)
  19                          , Show(..)
  20                          , flip
  21                          )
  22
  23 -- * Type 'Limit'
  24
  25 data Limit x
  26  = Limit
  27  { adherence :: Adherence
  28  , limit     :: x }
  29  deriving (Eq, Data, Show, Typeable)
  30
  31 instance Functor Limit where
  32         fmap f (Limit a x) = Limit a (f x)
  33
  34 data Adherence = Out | In
  35  deriving (Eq, Data, Show, Typeable)
  36
  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
  40
  41 -- ** Comparing 'Limit's
  42
  43 -- | Compare two 'low' 'Limit's.
  44 newtype LL x = LL { unLL :: x }
  45  deriving (Eq)
  46 instance Ord x => Ord (LL (Limit x)) where
  47         compare (LL x) (LL y) =
  48                 case compare (limit x) (limit y) of
  49                  EQ ->
  50                         case (adherence x, adherence y) of
  51                          (Out, In ) -> GT
  52                          (In , Out) -> LT
  53                          _          -> EQ
  54                  o -> o
  55
  56 -- | Compare two 'high' 'Limit's.
  57 newtype HH x = HH { unHH :: x }
  58  deriving (Eq)
  59 instance Ord x => Ord (HH (Limit x)) where
  60         compare (HH x) (HH y) =
  61                 case compare (limit x) (limit y) of
  62                  EQ ->
  63                         case (adherence x, adherence y) of
  64                          (Out, In ) -> LT
  65                          (In , Out) -> GT
  66                          _          -> EQ
  67                  o -> o
  68
  69 -- * Type 'Interval'
  70
  71 newtype Ord x => Interval x = Interval (Limit x, Limit x)
  72  deriving (Eq, Show, Data, Typeable)
  73
  74 low :: Ord x => Interval x -> Limit x
  75 low (Interval t)  = fst t
  76
  77 high :: Ord x => Interval x -> Limit x
  78 high (Interval t) = snd t
  79
  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)
  83 interval x y =
  84         case compare_without_adherence x y of
  85          LT -> Just $ Interval (x, y)
  86          EQ ->
  87                 case (adherence x, adherence y) of
  88                  (In, In) -> Just $ Interval (x, y)
  89                  _        -> Nothing
  90          GT -> Nothing
  91
  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)
  95
  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)
  99
 100 {-
 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)
 105
 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)
 110 -}
 111
 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)
 117                  o  -> o
 118
 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
 122
 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)
 126
 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)
 130
 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
 134
 135 -- | Return:
 136 --
 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
 143          LT -> LT
 144          EQ | adherence l == In -> EQ
 145          EQ -> LT
 146          GT ->
 147                 case compare x (limit h) of
 148                  LT -> EQ
 149                  EQ | adherence h == In -> EQ
 150                  EQ -> GT
 151                  GT -> GT
 152
 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
 156
 157 -- | Return 'True' iif. every value of the first 'Interval' is into the second 'Interval'.
 158 into :: Ord x => Interval x -> Interval x -> Bool
 159 into i j =
 160         case position i j of
 161          (Prefix  , LT) -> True
 162          (Suffixed, GT) -> True
 163          (Include , GT) -> True
 164          (Equal   , _)  -> True
 165          _              -> False
 166
 167 -- | Return 'True' iif. every value of the second 'Interval' is into the first 'Interval'.
 168 onto :: Ord x => Interval x -> Interval x -> Bool
 169 onto = flip into
 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 In y)
 176          EQ -> Just $ Interval (Limit In x, Limit In y)
 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 In y)
 184          EQ -> Nothing
 185          GT -> Nothing
 186
 187 infix 5 <=..<
 188 (<=..<) :: Ord x => x -> x -> Maybe (Interval x)
 189 (<=..<) x y =
 190         case compare x y of
 191          LT -> Just $ Interval (Limit In x, Limit Out y)
 192          EQ -> Nothing
 193          GT -> Nothing
 194
 195 infix 5 <..<
 196 (<..<) :: Ord x => x -> x -> Maybe (Interval x)
 197 (<..<) x y =
 198         case compare x y of
 199          LT -> Just $ Interval (Limit Out x, Limit Out y)
 200          EQ -> Nothing
 201          GT -> Nothing
 202
 203 -- * Type 'Position'
 204
 205 data Position
 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')
 213  deriving (Eq, Show)
 214
 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
 218          LT -> (, LT) $
 219                 case compare_without_adherence ih jl of
 220                  LT -> Away -- PATTERN: -_|
 221                  EQ ->
 222                         case (adherence ih, adherence jl) of
 223                          (In , In)  -> Overlap  -- PATTERN: -+|
 224                          (Out, Out) -> Away     -- PATTERN: -_|
 225                          _          -> Adjacent -- PATTERN: -|
 226                  GT ->
 227                         case compare (HH ih) (HH jh) of
 228                          LT -> Overlap  -- PATTERN: -+|
 229                          EQ -> Suffixed -- PATTERN: -+
 230                          GT -> Include  -- PATTERN: -+-
 231          EQ ->
 232                 case compare (HH ih) (HH jh) of
 233                  LT -> (Prefix, LT) -- PATTERN: +|
 234                  EQ -> (Equal , EQ) -- PATTERN: +
 235                  GT -> (Prefix, GT) -- PATTERN: +-
 236          GT -> (, GT) $
 237                 case compare_without_adherence il jh of
 238                  LT ->
 239                         case compare (HH ih) (HH jh) of
 240                          LT -> Include  -- PATTERN: |+|
 241                          EQ -> Suffixed -- PATTERN: |+
 242                          GT -> Overlap  -- PATTERN: |+-
 243                  EQ ->
 244                         case (adherence il, adherence jh) of
 245                          (In , In)  -> Overlap  -- PATTERN: |+-
 246                          (Out, Out) -> Away     -- PATTERN: |_-
 247                          _          -> Adjacent -- PATTERN: |-
 248                  GT -> Away -- PATTERN: |_-
 249
 250 infix 4 ..<<..
 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
 254          (Away, LT) -> True
 255          _          -> False
 256
 257 infix 4 ..>>..
 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
 261          (Away, GT) -> True
 262          _          -> False
 263
 264 infix 4 ..<..
 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
 268          (Away    , LT) -> True
 269          (Adjacent, LT) -> True
 270          _              -> False
 271 infix 4 ..>..
 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
 275          (Away    , GT) -> True
 276          (Adjacent, GT) -> True
 277          _              -> False
 278
 279 infix 4 ..<=..
 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
 283          (Away    , LT) -> True
 284          (Adjacent, LT) -> True
 285          (Overlap , LT) -> True
 286          (Prefix  , LT) -> True
 287          (Suffixed, LT) -> True
 288          (Include , GT) -> True
 289          (Equal   , _ ) -> True
 290          _              -> False
 291
 292 infix 4 ..>=..
 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
 296          (Away    , GT) -> True
 297          (Adjacent, GT) -> True
 298          (Overlap , GT) -> True
 299          (Prefix  , GT) -> True
 300          (Suffixed, GT) -> True
 301          (Include , LT) -> True
 302          (Equal   , _ ) -> True
 303          _              -> False
 304
 305 -- * Merge
 306
 307 union :: Ord x => Interval x -> Interval x -> Maybe (Interval x)
 308 union i j =
 309         case position i j of
 310          (Away, _) -> -- PATTERN: -_| or |_-
 311                 Nothing
 312          (Adjacent, o) ->
 313                 case o of
 314                  LT -> Just $ Interval (low i, high j) -- PATTERN: -|
 315                  EQ -> Nothing
 316                  GT -> Just $ Interval (low j, high i) -- PATTERN: |-
 317          (Overlap, 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          (Prefix, o) ->
 323                 case o of
 324                  LT -> Just $ j -- PATTERN: +|
 325                  EQ -> Nothing
 326                  GT -> Just $ i -- PATTERN: +-
 327          (Suffixed, o)  ->
 328                 case o of
 329                  LT -> Just $ i -- PATTERN: -+
 330                  EQ -> Nothing
 331                  GT -> Just $ j -- PATTERN: |+
 332          (Include, o) ->
 333                 case o of
 334                  LT -> Just $ i -- PATTERN: -+-
 335                  EQ -> Nothing
 336                  GT -> Just $ j -- PATTERN: |+|
 337          (Equal, _)    -> -- PATTERN: +
 338                 Just i
 339
 340 intersection :: Ord x => Interval x -> Interval x -> Maybe (Interval x)
 341 intersection i j =
 342         case position i j of
 343          (Away, _) -> -- PATTERN: -_| or |_-
 344                 Nothing
 345          (Adjacent, _) -> -- PATTERN: -| or |-
 346                 Nothing
 347          (Overlap, o)  ->
 348                 case o of
 349                  LT -> Just $ Interval (low j, high i) -- PATTERN: -+|
 350                  EQ -> Nothing
 351                  GT -> Just $ Interval (low i, high j) -- PATTERN: |+-
 352          (Prefix, o) ->
 353                 case o of
 354                  LT -> Just $ i -- PATTERN: +|
 355                  EQ -> Nothing
 356                  GT -> Just $ j -- PATTERN: +-
 357          (Suffixed, o)  ->
 358                 case o of
 359                  LT -> Just $ j -- PATTERN: -+
 360                  EQ -> Nothing
 361                  GT -> Just $ i -- PATTERN: |+
 362          (Include, o) ->
 363                 case o of
 364                  LT -> Just $ j -- PATTERN: -+-
 365                  EQ -> Nothing
 366                  GT -> Just $ i -- PATTERN: |+|
 367          (Equal, _)    -> -- PATTERN: +
 368                 Just i
 369
 370 span :: Ord x => Interval x -> Interval x -> Interval x
 371 span i j =
 372         Interval
 373          ( unLL (min (LL $ low  i) (LL $ low  j))
 374          , unHH (max (HH $ high i) (HH $ high j))
 375          )
 376
 377 -- * Type 'Unlimitable'
 378
 379 data Unlimitable x
 380  = Unlimited_low
 381  | Limited { limited :: x }
 382  | Unlimited_high
 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
 394
 395 unlimited :: Ord x => Interval (Unlimitable x)
 396 unlimited = Interval ( Limit In Unlimited_low
 397                      , Limit In Unlimited_high )
 398
 399 unlimit :: Ord x => Interval x -> Interval (Unlimitable x)
 400 unlimit = fmap_unsafe Limited
 401
 402 (<..) :: Ord x => x -> Interval (Unlimitable x)
 403 (<..) x = Interval (Limit Out (Limited x), Limit In Unlimited_high)
 404
 405 (<=..) :: Ord x => x -> Interval (Unlimitable x)
 406 (<=..) x = Interval (Limit In (Limited x), Limit In Unlimited_high)
 407
 408 (..<) :: Ord x => x -> Interval (Unlimitable x)
 409 (..<) x = Interval (Limit In Unlimited_low, Limit Out (Limited x))
 410
 411 (..<=) :: Ord x => x -> Interval (Unlimitable x)
 412 (..<=) x = Interval (Limit In Unlimited_low, Limit In (Limited x))
 413
 414 -- * Type 'Pretty'
 415
 416 newtype Pretty x = Pretty x
 417  deriving (Eq, Ord)
 418 instance (Ord x, Show x) => Show (Pretty (Interval x)) where
 419         show (Pretty i) =
 420                 concat
 421                  [ case adherence (low i) of
 422                          In  -> "["
 423                          Out -> "]"
 424                  , show (limit $ low i)
 425                  , ".."
 426                  , show (limit $ high i)
 427                  , case adherence (high i) of
 428                          In  -> "]"
 429                          Out -> "["
 430                  ]
 431 instance (Ord x, Show x) => Show (Pretty (Unlimitable x)) where
 432         show (Pretty x) =
 433                 case x of
 434                  Unlimited_low  -> "-oo"
 435                  Limited l      -> show l
 436                  Unlimited_high -> "+oo"