-- | This module provides types and functions for defining intervals and
-- determining how they relate to each other. This can be useful to determine
-- if an event happened during a certain time frame, or if two time frames
-- overlap (and if so, how exactly they overlap).
--
-- There are many other packages on Hackage that deal with intervals, notably
-- [data-interval](https://hackage.haskell.org/package/data-interval) and
-- [intervals](https://hackage.haskell.org/package/intervals). You may prefer
-- one of them for more general interval operations. This module is more
-- focused on how intervals relate to each other.
--
-- This module was inspired by James F. Allen's report,
-- /Maintaining Knowledge About Temporal Intervals/. It also uses terminology
-- from that report. You should not need to read the report in order to
-- understand this module, but if you want to read it you can find it here:
-- <https://hdl.handle.net/1802/10574>.
module Rampart
  ( Interval
  , toInterval
  , fromInterval
  , lesser
  , greater
  , isEmpty
  , isNonEmpty
  , Relation(..)
  , relate
  , invert
  ) where

-- | This type represents an interval bounded by two values, the 'lesser' and
-- the 'greater'. These values can be anything with an 'Ord' instance: numbers,
-- times, strings — you name it.
--
-- Use 'toInterval' to construct an interval and 'fromInterval' to deconstruct
-- one. Use 'relate' to determine how two intervals relate to each other.
newtype Interval a = Interval (a, a) deriving (Interval a -> Interval a -> Bool
(Interval a -> Interval a -> Bool)
-> (Interval a -> Interval a -> Bool) -> Eq (Interval a)
forall a. Eq a => Interval a -> Interval a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Interval a -> Interval a -> Bool
$c/= :: forall a. Eq a => Interval a -> Interval a -> Bool
== :: Interval a -> Interval a -> Bool
$c== :: forall a. Eq a => Interval a -> Interval a -> Bool
Eq)

instance Show a => Show (Interval a) where
  show :: Interval a -> String
show Interval a
x = String
"toInterval " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (a, a) -> String
forall a. Show a => a -> String
show (Interval a -> (a, a)
forall a. Interval a -> (a, a)
fromInterval Interval a
x)

-- | Converts a tuple into an 'Interval'. Note that this requires an 'Ord'
-- constraint so that the 'Interval' can be sorted on construction.
--
-- Use 'fromInterval' to go in the other direction.
toInterval :: Ord a => (a, a) -> Interval a
toInterval :: (a, a) -> Interval a
toInterval (a
x, a
y) = if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
y then (a, a) -> Interval a
forall a. (a, a) -> Interval a
Interval (a
y, a
x) else (a, a) -> Interval a
forall a. (a, a) -> Interval a
Interval (a
x, a
y)

-- | Converts an 'Interval' into a tuple. Generally you can think of this as
-- the inverse of 'toInterval'. However the tuple returned by this function may
-- be swapped compared to the one originally passed to 'toInterval'.
--
-- @
-- fromInterval ('toInterval' (1, 2)) '==' (1, 2)
-- fromInterval ('toInterval' (2, 1)) '==' (1, 2)
-- @
--
-- prop> fromInterval (toInterval (x, y)) == (min x y, max x y)
fromInterval :: Interval a -> (a, a)
fromInterval :: Interval a -> (a, a)
fromInterval (Interval (a, a)
x) = (a, a)
x

-- | Gets the lesser value from an 'Interval'.
--
-- @
-- lesser ('toInterval' (1, 2)) '==' 1
-- lesser ('toInterval' (2, 1)) '==' 1
-- @
--
-- prop> lesser (toInterval (x, y)) == min x y
lesser :: Interval a -> a
lesser :: Interval a -> a
lesser = (a, a) -> a
forall a b. (a, b) -> a
fst ((a, a) -> a) -> (Interval a -> (a, a)) -> Interval a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interval a -> (a, a)
forall a. Interval a -> (a, a)
fromInterval

-- | Gets the greater value from an 'Interval'.
--
-- @
-- greater ('toInterval' (1, 2)) '==' 2
-- greater ('toInterval' (2, 1)) '==' 2
-- @
--
-- prop> greater (toInterval (x, y)) == max x y
greater :: Interval a -> a
greater :: Interval a -> a
greater = (a, a) -> a
forall a b. (a, b) -> b
snd ((a, a) -> a) -> (Interval a -> (a, a)) -> Interval a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interval a -> (a, a)
forall a. Interval a -> (a, a)
fromInterval

-- | Returns 'True' if the given 'Interval' is empty, 'False' otherwise. An
-- 'Interval' is empty if its 'lesser' equals its 'greater'.
--
-- @
-- isEmpty ('toInterval' (1, 1)) '==' 'True'
-- isEmpty ('toInterval' (1, 2)) '==' 'False'
-- @
--
-- See 'isNonEmpty' for the opposite check.
isEmpty :: Eq a => Interval a -> Bool
isEmpty :: Interval a -> Bool
isEmpty = (a -> a -> Bool) -> (a, a) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((a, a) -> Bool) -> (Interval a -> (a, a)) -> Interval a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interval a -> (a, a)
forall a. Interval a -> (a, a)
fromInterval

-- | Returns 'True' if the given 'Interval' is non-empty, 'False' otherwise. An
-- 'Interval' is non-empty if its 'lesser' is not equal to its 'greater'.
--
-- @
-- isNonEmpty ('toInterval' (1, 2)) '==' 'True'
-- isNonEmpty ('toInterval' (1, 1)) '==' 'False'
-- @
--
-- See 'isEmpty' for the opposite check.
isNonEmpty :: Eq a => Interval a -> Bool
isNonEmpty :: Interval a -> Bool
isNonEmpty = Bool -> Bool
not (Bool -> Bool) -> (Interval a -> Bool) -> Interval a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interval a -> Bool
forall a. Eq a => Interval a -> Bool
isEmpty

-- | This type describes how two 'Interval's relate to each other. Each
-- constructor represents one of the 13 possible relations. Taken together
-- these relations are mutually exclusive and exhaustive.
--
-- Use 'relate' to determine the relation between two 'Interval's.
--
-- The following image shows all 13 possible 'Interval' relations. If for
-- whatever reason you can't see the image, each constructor for this type has
-- ASCII art showing the 'Interval' relation.
--
-- ![All 13 interval relation.](docs/interval-relations.svg)
data Relation
  = Before
  -- ^ 'Interval' @x@ is before 'Interval' @y@.
  --
  -- @
  -- 'greater' x '<' 'lesser' y
  -- @
  --
  -- > +---+
  -- > | x |
  -- > +---+
  -- >       +---+
  -- >       | y |
  -- >       +---+
  | Meets
  -- ^ 'Interval' @x@ meets 'Interval' @y@.
  --
  -- @
  -- 'isNonEmpty' x '&&'
  -- 'greater' x '==' 'lesser' y
  -- @
  --
  -- > +---+
  -- > | x |
  -- > +---+
  -- >     +---+
  -- >     | y |
  -- >     +---+
  | Overlaps
  -- ^ 'Interval' @x@ overlaps 'Interval' @y@.
  --
  -- @
  -- 'lesser' x '<' 'lesser' y '&&'
  -- 'greater' x '>' 'lesser' y '&&'
  -- 'greater' x '<' 'greater' y
  -- @
  --
  -- > +---+
  -- > | x |
  -- > +---+
  -- >   +---+
  -- >   | y |
  -- >   +---+
  | FinishedBy
  -- ^ 'Interval' @x@ is finished by 'Interval' @y@.
  --
  -- @
  -- 'isNonEmpty' y '&&'
  -- 'lesser' x '<' 'lesser' y '&&'
  -- 'greater' x '==' 'greater' y
  -- @
  --
  -- > +-----+
  -- > |  x  |
  -- > +-----+
  -- >   +---+
  -- >   | y |
  -- >   +---+
  | Contains
  -- ^ 'Interval' @x@ contains 'Interval' @y@.
  --
  -- @
  -- 'lesser' x '<' 'lesser' y '&&'
  -- 'greater' x '>' 'greater' y
  -- @
  --
  -- > +-------+
  -- > |   x   |
  -- > +-------+
  -- >   +---+
  -- >   | y |
  -- >   +---+
  | Starts
  -- ^ 'Interval' @x@ starts 'Interval' @y@.
  --
  -- @
  -- 'isNonEmpty' x '&&'
  -- 'lesser' x '==' 'lesser' y '&&'
  -- 'greater' x '<' 'greater' y
  -- @
  --
  -- > +---+
  -- > | x |
  -- > +---+
  -- > +-----+
  -- > |  y  |
  -- > +-----+
  | Equal
  -- ^ 'Interval' @x@ is equal to 'Interval' @y@.
  --
  -- @
  -- 'lesser' x '==' 'lesser' y '&&'
  -- 'greater' x '==' 'greater' y
  -- @
  --
  -- > +---+
  -- > | x |
  -- > +---+
  -- > +---+
  -- > | y |
  -- > +---+
  | StartedBy
  -- ^ 'Interval' @x@ is started by 'Interval' @y@.
  --
  -- @
  -- 'isNonEmpty' y '&&'
  -- 'lesser' x '==' 'lesser' y '&&'
  -- 'greater' x '>' 'greater' y
  -- @
  --
  -- > +-----+
  -- > |  x  |
  -- > +-----+
  -- > +---+
  -- > | y |
  -- > +---+
  | During
  -- ^ 'Interval' @x@ is during 'Interval' @y@.
  --
  -- @
  -- 'lesser' x '>' 'lesser' y '&&'
  -- 'greater' x '<' 'greater' y
  -- @
  --
  -- >   +---+
  -- >   | x |
  -- >   +---+
  -- > +-------+
  -- > |   y   |
  -- > +-------+
  | Finishes
  -- ^ 'Interval' @x@ finishes 'Interval' @y@.
  --
  -- @
  -- 'isNonEmpty' x '&&'
  -- 'lesser' x '>' 'lesser' y '&&'
  -- 'greater' x '==' 'greater' y
  -- @
  --
  -- >   +---+
  -- >   | x |
  -- >   +---+
  -- > +-----+
  -- > |  y  |
  -- > +-----+
  | OverlappedBy
  -- ^ 'Interval' @x@ is overlapped by 'Interval' @y@.
  --
  -- @
  -- 'lesser' x '>' 'lesser' y '&&'
  -- 'lesser' x '<' 'greater' y '&&'
  -- 'greater' x '>' 'greater' y
  -- @
  --
  -- >   +---+
  -- >   | x |
  -- >   +---+
  -- > +---+
  -- > | y |
  -- > +---+
  | MetBy
  -- ^ 'Interval' @x@ is met by 'Interval' @y@.
  --
  -- @
  -- 'isNonEmpty' y '&&'
  -- 'lesser' x '==' 'greater' y
  -- @
  --
  -- >     +---+
  -- >     | x |
  -- >     +---+
  -- > +---+
  -- > | y |
  -- > +---+
  | After
  -- ^ 'Interval' @x@ is after 'Interval' @y@.
  --
  -- @
  -- 'lesser' x '>' 'greater' y
  -- @
  --
  -- >       +---+
  -- >       | x |
  -- >       +---+
  -- > +---+
  -- > | y |
  -- > +---+
  deriving (Relation -> Relation -> Bool
(Relation -> Relation -> Bool)
-> (Relation -> Relation -> Bool) -> Eq Relation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Relation -> Relation -> Bool
$c/= :: Relation -> Relation -> Bool
== :: Relation -> Relation -> Bool
$c== :: Relation -> Relation -> Bool
Eq, Int -> Relation -> ShowS
[Relation] -> ShowS
Relation -> String
(Int -> Relation -> ShowS)
-> (Relation -> String) -> ([Relation] -> ShowS) -> Show Relation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Relation] -> ShowS
$cshowList :: [Relation] -> ShowS
show :: Relation -> String
$cshow :: Relation -> String
showsPrec :: Int -> Relation -> ShowS
$cshowsPrec :: Int -> Relation -> ShowS
Show)

-- | Relates two 'Interval's. Calling @relate x y@ tells you how 'Interval' @x@
-- relates to 'Interval' @y@. Consult the 'Relation' documentation for an
-- explanation of all the possible results.
--
-- @
-- relate ('toInterval' (1, 2)) ('toInterval' (3, 7)) '==' 'Before'
-- relate ('toInterval' (2, 3)) ('toInterval' (3, 7)) '==' 'Meets'
-- relate ('toInterval' (2, 4)) ('toInterval' (3, 7)) '==' 'Overlaps'
-- relate ('toInterval' (2, 7)) ('toInterval' (3, 7)) '==' 'FinishedBy'
-- relate ('toInterval' (2, 8)) ('toInterval' (3, 7)) '==' 'Contains'
-- relate ('toInterval' (3, 4)) ('toInterval' (3, 7)) '==' 'Starts'
-- relate ('toInterval' (3, 7)) ('toInterval' (3, 7)) '==' 'Equal'
-- relate ('toInterval' (3, 8)) ('toInterval' (3, 7)) '==' 'StartedBy'
-- relate ('toInterval' (4, 6)) ('toInterval' (3, 7)) '==' 'During'
-- relate ('toInterval' (6, 7)) ('toInterval' (3, 7)) '==' 'Finishes'
-- relate ('toInterval' (6, 8)) ('toInterval' (3, 7)) '==' 'OverlappedBy'
-- relate ('toInterval' (7, 8)) ('toInterval' (3, 7)) '==' 'MetBy'
-- relate ('toInterval' (8, 9)) ('toInterval' (3, 7)) '==' 'After'
-- @
--
-- Note that relating an empty interval with a non-empty interval may be
-- surprising when the intervals share an endpoint.
--
-- @
-- >>> relate ('toInterval' (3, 3)) ('toInterval' (3, 7)) '==' 'Overlaps'
-- >>> relate ('toInterval' (7, 7)) ('toInterval' (3, 7)) '==' 'OverlappedBy'
-- >>> relate ('toInterval' (3, 7)) ('toInterval' (3, 3)) '==' 'OverlappedBy'
-- >>> relate ('toInterval' (3, 7)) ('toInterval' (7, 7)) '==' 'Overlaps'
-- @
relate :: Ord a => Interval a -> Interval a -> Relation
relate :: Interval a -> Interval a -> Relation
relate Interval a
x Interval a
y =
  let
    lxly :: Ordering
lxly = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Interval a -> a
forall a. Interval a -> a
lesser Interval a
x) (Interval a -> a
forall a. Interval a -> a
lesser Interval a
y)
    lxgy :: Ordering
lxgy = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Interval a -> a
forall a. Interval a -> a
lesser Interval a
x) (Interval a -> a
forall a. Interval a -> a
greater Interval a
y)
    gxly :: Ordering
gxly = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Interval a -> a
forall a. Interval a -> a
greater Interval a
x) (Interval a -> a
forall a. Interval a -> a
lesser Interval a
y)
    gxgy :: Ordering
gxgy = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Interval a -> a
forall a. Interval a -> a
greater Interval a
x) (Interval a -> a
forall a. Interval a -> a
greater Interval a
y)
  in case (Ordering
lxly, Ordering
lxgy, Ordering
gxly, Ordering
gxgy) of
    (Ordering
EQ, Ordering
_, Ordering
_, Ordering
EQ) -> Relation
Equal
    (Ordering
_, Ordering
_, Ordering
LT, Ordering
_) -> Relation
Before
    (Ordering
LT, Ordering
_, Ordering
EQ, Ordering
LT) -> Relation
Meets
    (Ordering
_, Ordering
_, Ordering
EQ, Ordering
_) -> Relation
Overlaps
    (Ordering
GT, Ordering
EQ, Ordering
_, Ordering
GT) -> Relation
MetBy
    (Ordering
_, Ordering
EQ, Ordering
_, Ordering
_) -> Relation
OverlappedBy
    (Ordering
_, Ordering
GT, Ordering
_, Ordering
_) -> Relation
After
    (Ordering
LT, Ordering
_, Ordering
_, Ordering
LT) -> Relation
Overlaps
    (Ordering
LT, Ordering
_, Ordering
_, Ordering
EQ) -> Relation
FinishedBy
    (Ordering
LT, Ordering
_, Ordering
_, Ordering
GT) -> Relation
Contains
    (Ordering
EQ, Ordering
_, Ordering
_, Ordering
LT) -> Relation
Starts
    (Ordering
EQ, Ordering
_, Ordering
_, Ordering
GT) -> Relation
StartedBy
    (Ordering
GT, Ordering
_, Ordering
_, Ordering
LT) -> Relation
During
    (Ordering
GT, Ordering
_, Ordering
_, Ordering
EQ) -> Relation
Finishes
    (Ordering
GT, Ordering
_, Ordering
_, Ordering
GT) -> Relation
OverlappedBy

-- | Inverts a 'Relation'. Every 'Relation' has an inverse.
--
-- @
-- invert 'Before'       '==' 'After'
-- invert 'After'        '==' 'Before'
-- invert 'Meets'        '==' 'MetBy'
-- invert 'MetBy'        '==' 'Meets'
-- invert 'Overlaps'     '==' 'OverlappedBy'
-- invert 'OverlappedBy' '==' 'Overlaps'
-- invert 'Starts'       '==' 'StartedBy'
-- invert 'StartedBy'    '==' 'Starts'
-- invert 'Finishes'     '==' 'FinishedBy'
-- invert 'FinishedBy'   '==' 'Finishes'
-- invert 'Contains'     '==' 'During'
-- invert 'During'       '==' 'Contains'
-- invert 'Equal'        '==' 'Equal'
-- @
--
-- Inverting a 'Relation' twice will return the original 'Relation'.
--
-- prop> invert (invert r) == r
--
-- Inverting a 'Relation' is like swapping the arguments to 'relate'.
--
-- prop> invert (relate x y) == relate y x
invert :: Relation -> Relation
invert :: Relation -> Relation
invert Relation
x = case Relation
x of
  Relation
After -> Relation
Before
  Relation
Before -> Relation
After
  Relation
Contains -> Relation
During
  Relation
During -> Relation
Contains
  Relation
Equal -> Relation
Equal
  Relation
FinishedBy -> Relation
Finishes
  Relation
Finishes -> Relation
FinishedBy
  Relation
Meets -> Relation
MetBy
  Relation
MetBy -> Relation
Meets
  Relation
OverlappedBy -> Relation
Overlaps
  Relation
Overlaps -> Relation
OverlappedBy
  Relation
StartedBy -> Relation
Starts
  Relation
Starts -> Relation
StartedBy