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