Data/Interval.hs

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