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