-- |
-- Module       : Data.Interval
-- Copyright    : (c) Melanie Brown 2022
-- License:     : BSD3 (see the file LICENSE)
--
-- Intervals over types and their operations.
module Data.Interval (
  Extremum (..),
  opposite,
  Bound (..),
  unBound,
  Bounding (..),
  compareBounds,
  SomeBound (..),
  unSomeBound,
  oppose,
  Interval (..),
  imap,
  imapLev,
  itraverse,
  itraverseLev,
  pattern (:<->:),
  pattern (:<-|:),
  pattern (:|->:),
  pattern (:|-|:),
  pattern (:---:),
  pattern (:<>:),
  pattern (:<|:),
  pattern (:|>:),
  pattern (:||:),
  pattern (:--:),
  pattern Whole,
  (+/-),
  (...),
  bounds,
  lower,
  lowerBound,
  upper,
  upperBound,
  interval,
  imin,
  iinf,
  isup,
  imax,
  hull,
  hulls,
  within,
  point,
  open,
  close,
  openclosed,
  closedopen,
  openLower,
  closedLower,
  openUpper,
  closedUpper,
  setLower,
  setUpper,
  Adjacency (..),
  converseAdjacency,
  adjacency,
  intersect,
  union,
  unions,
  unionsAsc,
  complement,
  difference,
  (\\),
  symmetricDifference,
  measure,
  measuring,
  hausdorff,
  isSubsetOf,
  OneOrTwo (..),
) where

import Algebra.Lattice.Levitated (Levitated (..), foldLevitated)
import Control.Applicative (liftA2)
import Control.Monad (join)
import Data.Data
import Data.Function (on)
import Data.Functor.Const (Const (Const))
import Data.Kind (Constraint, Type)
import Data.List (sort)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.OneOrTwo (OneOrTwo (..))
import Data.Ord (comparing)
import GHC.Generics (Generic (..), type (:*:) (..))

-- | The kinds of extremum an interval can have.
data Extremum
  = Minimum
  | Infimum
  | Supremum
  | Maximum
  deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Data, Typeable)

-- |
-- The 'opposite' of an 'Extremum' is its complementary analogue:
-- how the same point would be viewed from the complement of the
-- interval to which it belongs.
--
-- c.f. 'opposeBound'.
opposite :: Extremum -> Extremum
opposite = \case
  Minimum -> Supremum
  Infimum -> Maximum
  Supremum -> Minimum
  Maximum -> Infimum

-- | A 'Bound' is an endpoint of an 'Interval'.
type Bound :: Extremum -> Type -> Type
data Bound ext x where
  Min :: !x -> Bound Minimum x
  Inf :: !x -> Bound Infimum x
  Sup :: !x -> Bound Supremum x
  Max :: !x -> Bound Maximum x

-- | Extract the term from a 'Bound'.
unBound :: Bound ext x -> x
unBound = \case
  Min x -> x
  Inf x -> x
  Sup x -> x
  Max x -> x

instance Functor (Bound ext) where
  fmap f = \case
    Min x -> Min (f x)
    Inf x -> Inf (f x)
    Sup x -> Sup (f x)
    Max x -> Max (f x)

instance Foldable (Bound ext) where
  foldMap f = \case
    Min x -> f x
    Inf x -> f x
    Sup x -> f x
    Max x -> f x

instance Traversable (Bound ext) where
  traverse f = \case
    Min x -> Min <$> f x
    Inf x -> Inf <$> f x
    Sup x -> Sup <$> f x
    Max x -> Max <$> f x

instance (Eq x) => Eq (Bound ext x) where
  Min x == Min y = x == y
  Inf x == Inf y = x == y
  Sup x == Sup y = x == y
  Max x == Max y = x == y

instance (Ord x) => Ord (Bound ext (Levitated x)) where
  compare = compareBounds

-- | A type class for inverting 'Bound's.
type Bounding :: Extremum -> Constraint
class (Opposite (Opposite ext) ~ ext) => Bounding ext where
  type Opposite ext :: Extremum
  bound :: x -> Bound ext x

  -- | c.f. 'opposite'.
  opposeBound :: Bound ext x -> Bound (Opposite ext) x

instance Bounding Minimum where
  type Opposite Minimum = Supremum
  bound = Min
  opposeBound (Min x) = Sup x

instance Bounding Infimum where
  type Opposite Infimum = Maximum
  bound = Inf
  opposeBound (Inf x) = Max x

instance Bounding Supremum where
  type Opposite Supremum = Minimum
  bound = Sup
  opposeBound (Sup x) = Min x

instance Bounding Maximum where
  type Opposite Maximum = Infimum
  bound = Max
  opposeBound (Max x) = Inf x

-- | 'Bound's have special comparison rules for identical points.
--
-- >>> compareBounds (Min (Levitate 5)) (Max (Levitate 5))
-- EQ
-- >>> compareBounds (Inf (Levitate 5)) (Sup (Levitate 5))
-- GT
-- >>> compareBounds (Max (Levitate 5)) (Sup (Levitate 5))
-- GT
-- >>> compareBounds (Inf (Levitate 5)) (Min (Levitate 5))
-- GT
-- >>> compareBounds (Max (Levitate 5)) (Inf (Levitate 5))
-- LT
compareBounds ::
  (Ord x) =>
  Bound ext1 x ->
  Bound ext2 x ->
  Ordering
compareBounds (Min l) = \case
  Min ll -> compare l ll
  Inf ll -> compare l ll <> LT
  Sup u -> compare l u <> GT
  Max u -> compare l u
compareBounds (Inf l) = \case
  Min ll -> compare l ll <> GT
  Inf ll -> compare l ll
  Sup u -> compare l u <> GT
  Max u -> compare l u <> GT
compareBounds (Sup l) = \case
  Min u -> compare l u <> LT
  Inf u -> compare l u <> LT
  Sup uu -> compare l uu
  Max uu -> compare l uu <> LT
compareBounds (Max l) = \case
  Min u -> compare l u
  Inf u -> compare l u <> LT
  Sup uu -> compare l uu <> GT
  Max uu -> compare l uu

data SomeBound x
  = forall ext.
    (Bounding ext, Bounding (Opposite ext)) =>
    SomeBound !(Bound ext x)

instance (Eq x) => Eq (SomeBound (Levitated x)) where
  SomeBound (Min a) == SomeBound (Min b) = a == b
  SomeBound (Max a) == SomeBound (Max b) = a == b
  SomeBound (Inf a) == SomeBound (Inf b) = a == b
  SomeBound (Sup a) == SomeBound (Sup b) = a == b
  _ == _ = False

instance (Ord x) => Ord (SomeBound (Levitated x)) where
  SomeBound b0 `compare` SomeBound b1 = compareBounds b0 b1

oppose :: SomeBound x -> SomeBound x
oppose (SomeBound b) = SomeBound (opposeBound b)

unSomeBound :: (Ord x) => SomeBound x -> x
unSomeBound (SomeBound b) = unBound b

infix 5 :<-->:

infix 5 :<--|:

infix 5 :|-->:

infix 5 :|--|:

type Interval :: Type -> Type
data Interval x where
  -- Open-open interval. You probably want '(:<->:)' or '(:<>:)'.
  (:<-->:) ::
    (Ord x) =>
    !(Bound Infimum (Levitated x)) ->
    !(Bound Supremum (Levitated x)) ->
    Interval x
  -- Open-closed interval. You probably want '(:<-|:)' or '(:<|:)'.
  (:<--|:) ::
    (Ord x) =>
    !(Bound Infimum (Levitated x)) ->
    !(Bound Maximum (Levitated x)) ->
    Interval x
  -- Closed-open interval. You probably want '(:|->:)' or '(:|>:)'.
  (:|-->:) ::
    (Ord x) =>
    !(Bound Minimum (Levitated x)) ->
    !(Bound Supremum (Levitated x)) ->
    Interval x
  -- Closed-closed interval. You probably want '(:|-|:)' or '(:||:)'.
  (:|--|:) ::
    (Ord x) =>
    !(Bound Minimum (Levitated x)) ->
    !(Bound Maximum (Levitated x)) ->
    Interval x

infix 5 :<->:

infix 5 :<-|:

infix 5 :|->:

infix 5 :|-|:

-- | A bidirectional pattern synonym matching open intervals.
pattern (:<->:) :: (Ord x) => Levitated x -> Levitated x -> Interval x
pattern l :<->: u <-
  Inf l :<-->: Sup u
  where
    b1 :<->: b2 =
      let inf = min b1 b2
          sup = max b1 b2
       in case compare b1 b2 of
            EQ -> Min inf :|--|: Max sup
            _ -> Inf inf :<-->: Sup sup

-- | A bidirectional pattern synonym matching open-closed intervals.
pattern (:<-|:) :: (Ord x) => Levitated x -> Levitated x -> Interval x
pattern l :<-|: u <-
  Inf l :<--|: Max u
  where
    b1 :<-|: b2 =
      let inf = min b1 b2
          sup = max b1 b2
       in case compare b1 b2 of
            LT -> Inf inf :<--|: Max sup
            EQ -> Min inf :|--|: Max sup
            GT -> Min inf :|-->: Sup sup

-- | A bidirectional pattern synonym matching closed-open intervals.
pattern (:|->:) :: (Ord x) => Levitated x -> Levitated x -> Interval x
pattern l :|->: u <-
  Min l :|-->: Sup u
  where
    b1 :|->: b2 =
      let inf = min b1 b2
          sup = max b1 b2
       in case compare b1 b2 of
            LT -> Min inf :|-->: Sup sup
            EQ -> Min inf :|--|: Max sup
            GT -> Inf inf :<--|: Max sup

-- | A bidirectional pattern synonym matching closed intervals.
pattern (:|-|:) :: (Ord x) => Levitated x -> Levitated x -> Interval x
pattern l :|-|: u <-
  Min l :|--|: Max u
  where
    b1 :|-|: b2 = Min (min b1 b2) :|--|: Max (max b1 b2)

{-# COMPLETE (:<->:), (:<-|:), (:|->:), (:|-|:) #-}

-- | A unidirectional pattern synonym ignoring the particular 'Bound's.
pattern (:---:) :: forall x. (Ord x) => Levitated x -> Levitated x -> Interval x
pattern l :---: u <-
  (bounds -> (SomeBound (unBound -> l), SomeBound (unBound -> u)))

{-# COMPLETE (:---:) #-}

infix 5 :<>:

infix 5 :<|:

infix 5 :|>:

infix 5 :||:

-- | A bidirectional pattern synonym matching finite open intervals.
pattern (:<>:) :: forall x. (Ord x) => x -> x -> Interval x
pattern l :<>: u <-
  Levitate l :<->: Levitate u
  where
    b1 :<>: b2 =
      let inf = Levitate (min b1 b2)
          sup = Levitate (max b1 b2)
       in case compare b1 b2 of
            EQ -> Min inf :|--|: Max sup
            _ -> Inf inf :<-->: Sup sup

-- | A bidirectional pattern synonym matching finite open-closed intervals.
pattern (:<|:) :: forall x. (Ord x) => x -> x -> Interval x
pattern l :<|: u <-
  Levitate l :<-|: Levitate u
  where
    b1 :<|: b2 =
      let inf = Levitate (min b1 b2)
          sup = Levitate (max b1 b2)
       in case compare b1 b2 of
            LT -> Inf inf :<--|: Max sup
            EQ -> Min inf :|--|: Max sup
            GT -> Min inf :|-->: Sup sup

-- | A bidirectional pattern synonym matching finite closed-open intervals.
pattern (:|>:) :: forall x. (Ord x) => x -> x -> Interval x
pattern l :|>: u <-
  Levitate l :|->: Levitate u
  where
    b1 :|>: b2 =
      let inf = Levitate (min b1 b2)
          sup = Levitate (max b1 b2)
       in case compare b1 b2 of
            LT -> Min inf :|-->: Sup sup
            EQ -> Min inf :|--|: Max sup
            GT -> Inf inf :<--|: Max sup

-- | A bidirectional pattern synonym matching finite closed intervals.
pattern (:||:) :: forall x. (Ord x) => x -> x -> Interval x
pattern l :||: u <-
  Levitate l :|-|: Levitate u
  where
    b1 :||: b2 = Min (Levitate $ min b1 b2) :|--|: Max (Levitate $ max b1 b2)

-- |
-- A unidirectional pattern synonym matching finite intervals,
-- that ignores the particular 'Bound's.
pattern (:--:) :: forall x. (Ord x) => x -> x -> Interval x
pattern l :--: u <-
  ( bounds ->
      (SomeBound (unBound -> Levitate l), SomeBound (unBound -> Levitate u))
    )

-- | The whole interval.
pattern Whole :: (Ord x) => Interval x
pattern Whole = Bottom :|-|: Top

deriving instance (Ord x) => Eq (Interval x)

instance (Ord x, Show x) => Show (Interval x) where
  show = \case
    l :<>: u -> "(" <> show l <> " :<>: " <> show u <> ")"
    l :|>: u -> "(" <> show l <> " :|>: " <> show u <> ")"
    l :<|: u -> "(" <> show l <> " :<|: " <> show u <> ")"
    l :||: u -> "(" <> show l <> " :||: " <> show u <> ")"
    l :<->: u -> "(" <> show l <> " :<->: " <> show u <> ")"
    l :|->: u -> "(" <> show l <> " :|->: " <> show u <> ")"
    l :<-|: u -> "(" <> show l <> " :<-|: " <> show u <> ")"
    l :|-|: u -> "(" <> show l <> " :|-|: " <> show u <> ")"

instance (Ord x) => Ord (Interval x) where
  compare i1 i2 = on compare lower i1 i2 <> on compare upper i1 i2

instance (Ord x, Data x) => Data (Interval x) where
  gfoldl (<^>) gpure = \case
    l :<->: u -> gpure (:<->:) <^> l <^> u
    l :|->: u -> gpure (:|->:) <^> l <^> u
    l :<-|: u -> gpure (:<-|:) <^> l <^> u
    l :|-|: u -> gpure (:|-|:) <^> l <^> u
  toConstr = \case
    _ :<->: _ -> intervalOpenOpenConstr
    _ :|->: _ -> intervalClosedOpenConstr
    _ :<-|: _ -> intervalOpenClosedConstr
    _ :|-|: _ -> intervalClosedClosedConstr
  dataTypeOf _ = intervalDataType
  gunfold k gpure constr = case constrIndex constr of
    0 -> k (k (gpure (:<->:)))
    1 -> k (k (gpure (:|->:)))
    2 -> k (k (gpure (:<-|:)))
    3 -> k (k (gpure (:|-|:)))
    _ -> error "gunfold"

intervalOpenOpenConstr :: Constr
intervalOpenOpenConstr =
  mkConstr
    intervalDataType
    ":<--->:"
    []
    Infix

intervalClosedOpenConstr :: Constr
intervalClosedOpenConstr =
  mkConstr
    intervalDataType
    ":|--->:"
    []
    Infix

intervalOpenClosedConstr :: Constr
intervalOpenClosedConstr =
  mkConstr
    intervalDataType
    ":<---|:"
    []
    Infix

intervalClosedClosedConstr :: Constr
intervalClosedClosedConstr =
  mkConstr
    intervalDataType
    ":|---|:"
    []
    Infix

intervalDataType :: DataType
intervalDataType =
  mkDataType
    "Data.Interval.Interval"
    [ intervalOpenOpenConstr
    , intervalClosedOpenConstr
    , intervalOpenClosedConstr
    , intervalClosedClosedConstr
    ]

deriving instance Typeable x => Typeable (Interval x)

instance (Ord x, Generic x) => Generic (Interval x) where
  type Rep (Interval x) = (Const (Levitated x, Extremum) :*: Const (Levitated x, Extremum))
  from = \case
    l :<->: u -> (Const (l, Infimum) :*: Const (u, Supremum))
    l :|->: u -> (Const (l, Minimum) :*: Const (u, Supremum))
    l :<-|: u -> (Const (l, Infimum) :*: Const (u, Maximum))
    l :|-|: u -> (Const (l, Minimum) :*: Const (u, Maximum))
  to (Const l :*: Const u) = l ... u

-- | Since the 'Ord' constraints on the constructors for 'Interval'
-- prevent it from being a 'Functor', this will have to suffice.
imap :: (Ord x, Ord y) => (x -> y) -> Interval x -> Interval y
imap f = \case
  l :<->: u -> fmap f l :<->: fmap f u
  l :|->: u -> fmap f l :|->: fmap f u
  l :<-|: u -> fmap f l :<-|: fmap f u
  l :|-|: u -> fmap f l :|-|: fmap f u

-- | Same as 'imap' but on the 'Levitated' of the underlying type.
imapLev ::
  (Ord x, Ord y) =>
  (Levitated x -> Levitated y) ->
  Interval x ->
  Interval y
imapLev f = \case
  l :<->: u -> f l :<->: f u
  l :|->: u -> f l :|->: f u
  l :<-|: u -> f l :<-|: f u
  l :|-|: u -> f l :|-|: f u

-- | Since the 'Ord' constraints on the constructors for 'Interval'
-- prevent it from being 'Traversable', this will have to suffice.
itraverse ::
  (Ord x, Ord y, Applicative f) =>
  (x -> f y) ->
  Interval x ->
  f (Interval y)
itraverse f = \case
  l :<->: u -> liftA2 (:<->:) (traverse f l) (traverse f u)
  l :|->: u -> liftA2 (:|->:) (traverse f l) (traverse f u)
  l :<-|: u -> liftA2 (:<-|:) (traverse f l) (traverse f u)
  l :|-|: u -> liftA2 (:|-|:) (traverse f l) (traverse f u)

-- | Same as 'itraverse' but on the 'Levitated' of the underlying type.
itraverseLev ::
  (Ord x, Ord y, Applicative f) =>
  (Levitated x -> f (Levitated y)) ->
  Interval x ->
  f (Interval y)
itraverseLev f = \case
  l :<->: u -> liftA2 (:<->:) (f l) (f u)
  l :|->: u -> liftA2 (:|->:) (f l) (f u)
  l :<-|: u -> liftA2 (:<-|:) (f l) (f u)
  l :|-|: u -> liftA2 (:|-|:) (f l) (f u)

-- | Get the @(lower, upper)@ 'bounds' of an 'Interval'.
--
-- c.f. 'lower', 'upper'.
bounds :: Interval x -> (SomeBound (Levitated x), SomeBound (Levitated x))
bounds = \case
  l :<-->: u -> (SomeBound l, SomeBound u)
  l :<--|: u -> (SomeBound l, SomeBound u)
  l :|-->: u -> (SomeBound l, SomeBound u)
  l :|--|: u -> (SomeBound l, SomeBound u)

-- | Get the lower bound of an interval.
--
-- > lower = fst . bounds
lower :: (Ord x) => Interval x -> SomeBound (Levitated x)
lower = fst . bounds

-- | Get the upper bound of an interval.
--
-- > upper = snd . bounds
upper :: (Ord x) => Interval x -> SomeBound (Levitated x)
upper = snd . bounds

-- | Get the lower bound of an interval
-- (with the bound expressed at the term level).
lowerBound :: (Ord x) => Interval x -> (Levitated x, Extremum)
lowerBound = \case
  l :<->: _ -> (l, Infimum)
  l :<-|: _ -> (l, Infimum)
  l :|->: _ -> (l, Minimum)
  l :|-|: _ -> (l, Minimum)

-- | Get the upper bound of an interval
-- (with the bound expressed at the term level).
upperBound :: (Ord x) => Interval x -> (Levitated x, Extremum)
upperBound = \case
  _ :<->: u -> (u, Supremum)
  _ :<-|: u -> (u, Maximum)
  _ :|->: u -> (u, Supremum)
  _ :|-|: u -> (u, Maximum)

-- | Given 'SomeBound's, try to make an interval.
interval ::
  (Ord x) =>
  SomeBound (Levitated x) ->
  SomeBound (Levitated x) ->
  Interval x
interval (SomeBound b1) (SomeBound b2) = case (b1, b2) of
  (Min l, Sup u) -> l :|->: u
  (Min l, Max u) -> l :|-|: u
  (Inf l, Sup u) -> l :<->: u
  (Inf l, Max u) -> l :<-|: u
  (Sup u, Min l) -> l :|->: u
  (Sup u, Inf l) -> l :<->: u
  (Max u, Min l) -> l :|-|: u
  (Max u, Inf l) -> l :<-|: u
  _ -> error "cannot make an interval with the given bounds"

-- | Given limits and 'Extremum's, try to make an interval.
(...) ::
  (Ord x) =>
  (Levitated x, Extremum) ->
  (Levitated x, Extremum) ->
  Interval x
(x, b1) ... (y, b2) = case (b1, b2) of
  (Minimum, Supremum) -> l :|->: u
  (Minimum, Maximum) -> l :|-|: u
  (Infimum, Supremum) -> l :<->: u
  (Infimum, Maximum) -> l :<-|: u
  (Supremum, Minimum) -> l :|->: u
  (Supremum, Infimum) -> l :<->: u
  (Maximum, Minimum) -> l :|-|: u
  (Maximum, Infimum) -> l :<-|: u
  _ -> error "cannot make an interval with the given bounds"
 where
  l = min x y
  u = max x y

-- | According to
-- [Allen](https://en.wikipedia.org/wiki/Allen%27s_interval_algebra),
-- two intervals can be "adjacent" in 13 different ways,
-- into at most 3 distinct intervals. In this package,
-- this quality is called the 'Adjacency' of the intervals.
data Adjacency x
  = Before !(Interval x) !(Interval x)
  | Meets !(Interval x) !(Interval x) !(Interval x)
  | Overlaps !(Interval x) !(Interval x) !(Interval x)
  | Starts !(Interval x) !(Interval x)
  | During !(Interval x) !(Interval x) !(Interval x)
  | Finishes !(Interval x) !(Interval x)
  | Identical !(Interval x)
  | FinishedBy !(Interval x) !(Interval x)
  | Contains !(Interval x) !(Interval x) !(Interval x)
  | StartedBy !(Interval x) !(Interval x)
  | OverlappedBy !(Interval x) !(Interval x) !(Interval x)
  | MetBy !(Interval x) !(Interval x) !(Interval x)
  | After !(Interval x) !(Interval x)
  deriving (Eq, Ord, Show, Generic, Typeable, Data)

-- | The result of having compared the same two intervals in reverse order.
converseAdjacency :: Adjacency x -> Adjacency x
converseAdjacency = \case
  Before i j -> After i j
  Meets i j k -> MetBy i j k
  Overlaps i j k -> OverlappedBy i j k
  Starts i j -> StartedBy i j
  During i j k -> Contains i j k
  Finishes i j -> FinishedBy i j
  Identical i -> Identical i
  FinishedBy i j -> Finishes i j
  Contains i j k -> During i j k
  StartedBy i j -> Starts i j
  OverlappedBy i j k -> Overlaps i j k
  MetBy i j k -> Meets i j k
  After i j -> Before i j

-- | Get the convex hull of two intervals.
--
-- >>> hull (7 :|>: 8) (3 :|>: 4)
-- (3 :|>: 8)
--
-- >>> hull (Bottom :<-|: Levitate 3) (4 :<>: 5)
-- (Bottom :<->: Levitate 5)
hull :: (Ord x) => Interval x -> Interval x -> Interval x
hull i1 i2 = case adjacency i1 i2 of
  Before i j -> lowerBound i ... upperBound j
  Meets i _ k -> lowerBound i ... upperBound k
  Overlaps i _ k -> lowerBound i ... upperBound k
  Starts i j -> lowerBound i ... upperBound j
  During i _ k -> lowerBound i ... upperBound k
  Finishes i j -> lowerBound i ... upperBound j
  Identical i -> i
  FinishedBy i j -> lowerBound i ... upperBound j
  Contains i _ k -> lowerBound i ... upperBound k
  StartedBy i j -> lowerBound i ... upperBound j
  OverlappedBy i _ k -> lowerBound i ... upperBound k
  MetBy i _ k -> lowerBound i ... upperBound k
  After i j -> lowerBound i ... upperBound j

-- | Get the convex hull of a non-empty list of intervals.
hulls :: (Ord x) => NonEmpty (Interval x) -> Interval x
hulls (i :| []) = i
hulls (i :| j : is) = hulls $ hull i j :| is

-- | Test whether a point is contained in the interval.
within :: (Ord x) => x -> Interval x -> Bool
within (Levitate -> x) = \case
  l :<->: u -> l < x && x < u
  l :<-|: u -> l < x && x <= u
  l :|->: u -> l <= x && x < u
  l :|-|: u -> l <= x && x <= u

-- | Create the closed-closed interval at a given point.
point :: (Ord x) => x -> Interval x
point = join (:||:)

-- | Get the infimum of an interval, weakening if necessary.
iinf :: (Ord x) => Interval x -> Levitated x
iinf (x :---: _) = x

-- | Get the minimum of an interval, if it exists.
imin :: (Ord x) => Interval x -> Maybe (Levitated x)
imin = \case
  (x :|->: _) -> Just x
  (x :|-|: _) -> Just x
  _ -> Nothing

-- | Get the maximum of an interval if it exists.
imax :: (Ord x) => Interval x -> Maybe (Levitated x)
imax = \case
  (_ :<-|: x) -> Just x
  (_ :|-|: x) -> Just x
  _ -> Nothing

-- | Get the supremum of an interval, weakening if necessary.
isup :: (Ord x) => Interval x -> Levitated x
isup (_ :---: x) = x

-- | Open both bounds of the given interval.
open :: (Ord x) => Interval x -> Interval x
open (l :---: u) = l :<->: u

-- | Close both bounds of the given interval.
close :: (Ord x) => Interval x -> Interval x
close (l :---: u) = l :|-|: u

-- | Make the interval open-closed, leaving the endpoints unchanged.
openclosed :: (Ord x) => Interval x -> Interval x
openclosed (l :---: u) = l :<-|: u

-- | Make the interval closed-open, leaving the endpoints unchanged.
closedopen :: (Ord x) => Interval x -> Interval x
closedopen (l :---: u) = l :|->: u

-- | Make the lower bound open, leaving the endpoints unchanged.
openLower :: (Ord x) => Interval x -> Interval x
openLower = \case
  l :<->: u -> l :<->: u
  l :<-|: u -> l :<-|: u
  l :|->: u -> l :<->: u
  l :|-|: u -> l :<-|: u

-- | Make the lower bound closed, leaving the endpoints unchanged.
closedLower :: (Ord x) => Interval x -> Interval x
closedLower = \case
  l :<->: u -> l :|->: u
  l :<-|: u -> l :|-|: u
  l :|->: u -> l :|->: u
  l :|-|: u -> l :|-|: u

-- | Make the upper bound open, leaving the endpoints unchanged.
openUpper :: (Ord x) => Interval x -> Interval x
openUpper = \case
  l :<->: u -> l :<->: u
  l :<-|: u -> l :<->: u
  l :|->: u -> l :|->: u
  l :|-|: u -> l :|->: u

-- | Make the upper bound closed, leaving the endpoints unchanged.
closedUpper :: (Ord x) => Interval x -> Interval x
closedUpper = \case
  l :<->: u -> l :<-|: u
  l :<-|: u -> l :<-|: u
  l :|->: u -> l :|-|: u
  l :|-|: u -> l :|-|: u

setLower :: (Ord x) => Levitated x -> Interval x -> Interval x
setLower x = \case
  _ :<->: u -> x :<->: u
  _ :<-|: u -> x :<-|: u
  _ :|->: u -> x :|->: u
  _ :|-|: u -> x :|-|: u

setUpper :: (Ord x) => Levitated x -> Interval x -> Interval x
setUpper x = \case
  l :<->: _ -> l :<->: x
  l :<-|: _ -> l :<-|: x
  l :|->: _ -> l :|->: x
  l :|-|: _ -> l :|-|: x

-- | Calculate the 'Adjacency' between two intervals, according to
-- [Allen](https://en.wikipedia.org/wiki/Allen%27s_interval_algebra).
adjacency :: (Ord x) => Interval x -> Interval x -> Adjacency x
adjacency i1 i2 = case (comparing lower i1 i2, comparing upper i1 i2) of
  (LT, LT) -> case unSomeBound ub1 `compare` unSomeBound lb2 of
    LT -> Before i1 i2
    EQ -> case (ub1, lb2) of
      (SomeBound (Max _), SomeBound (Min _)) ->
        Meets
          (openUpper i1)
          (interval lb2 ub1)
          (openLower i2)
      _ -> Before i1 i2
    GT ->
      Overlaps
        (interval lb1 (oppose lb2))
        (interval lb2 ub1)
        (interval (oppose ub1) ub2)
  (LT, EQ) ->
    Finishes
      (interval lb1 (oppose lb2))
      i2
  (LT, GT) ->
    Contains
      (interval lb1 (oppose lb2))
      (interval lb2 ub2)
      (interval (oppose ub2) ub1)
  (EQ, LT) ->
    Starts
      i1
      (interval (oppose ub1) ub2)
  (EQ, EQ) -> Identical i1
  (EQ, GT) ->
    StartedBy
      i2
      (interval (oppose ub2) ub1)
  (GT, LT) ->
    During
      (interval lb2 (oppose lb1))
      (interval lb1 ub1)
      (interval (oppose ub1) ub2)
  (GT, EQ) ->
    FinishedBy
      (interval lb2 (oppose lb1))
      i1
  (GT, GT) -> case unSomeBound ub2 `compare` unSomeBound lb1 of
    GT ->
      OverlappedBy
        (interval lb2 (oppose lb1))
        (interval lb1 ub2)
        (interval (oppose ub2) ub1)
    EQ -> case (ub2, lb1) of
      (SomeBound (Max _), SomeBound (Min _)) ->
        MetBy
          (openUpper i2)
          (interval lb1 ub2)
          (openLower i1)
      _ -> After i2 i1
    LT -> After i2 i1
 where
  (lb1, ub1) = bounds i1
  (lb2, ub2) = bounds i2

-- | Calculate the intersection of two intervals, if it exists.
--
-- @
--
-- >>> intersect (2 :<>: 4) (3 :||: 5)
-- Just (3 :|>: 4)
--
-- >>> intersect (2 :<>: 4) (4 :||: 5)
-- Nothing
--
-- >>> intersect (1 :<>: 4) (2 :||: 3)
-- Just (2 :||: 3)
--
-- @
intersect ::
  forall x.
  (Ord x) =>
  Interval x ->
  Interval x ->
  Maybe (Interval x)
intersect i1 i2 = case adjacency i1 i2 of
  Before _ _ -> Nothing
  Meets _ j _ -> Just j
  Overlaps _ j _ -> Just j
  Starts i _ -> Just i
  During _ j _ -> Just j
  Finishes _ j -> Just j
  Identical i -> Just i
  FinishedBy _ j -> Just j
  Contains _ j _ -> Just j
  StartedBy i _ -> Just i
  OverlappedBy _ j _ -> Just j
  MetBy _ j _ -> Just j
  After _ _ -> Nothing

-- | Get the union of two intervals, as either 'OneOrTwo'.
--
-- @
--
-- >>> union (2 :||: 5) (5 :<>: 7)
-- One (Levitate 2 :|->: Levitate 7)
--
-- >>> union (2 :||: 4) (5 :<>: 7)
-- Two (Levitate 2 :|-|: Levitate 4) (Levitate 5 :<->: Levitate 7)
--
-- @
union ::
  forall x.
  (Ord x) =>
  Interval x ->
  Interval x ->
  OneOrTwo (Interval x)
union i1 i2 = case adjacency i1 i2 of
  Before i j
    | fst (upperBound i) == fst (lowerBound j) -> One $ hull i j
    | otherwise -> Two i j
  Meets i _ k -> One $ hull i k
  Overlaps i _ k -> One $ hull i k
  Starts i j -> One $ hull i j
  During i _ k -> One $ hull i k
  Finishes i j -> One $ hull i j
  Identical i -> One i
  FinishedBy i j -> One $ hull i j
  Contains i _ k -> One $ hull i k
  StartedBy i j -> One $ hull i j
  OverlappedBy i _ k -> One $ hull i k
  MetBy i _ k -> One $ hull i k
  After i j
    | fst (upperBound i) == fst (lowerBound j) -> One $ hull i j
    | otherwise -> Two i j

-- | /O(n log n)/. Get the union of a list of intervals.
--
-- This function uses 'sort'. See also 'unionsAsc'.
unions :: forall x. (Ord x) => [Interval x] -> [Interval x]
unions = unionsAsc . sort

-- | /O(n)/. Get the union of a sorted list of intervals.
--
-- NOTE: The input condition is not checked. Use with care.
unionsAsc :: forall x. (Ord x) => [Interval x] -> [Interval x]
unionsAsc = \case
  i : j : is -> case i `union` j of
    One k -> unionsAsc (k : is)
    _ -> i : unionsAsc (j : is)
  x -> x

-- | Take the complement of the interval, as possibly 'OneOrTwo'.
--
-- @
--
-- >>> complement (3 :<>: 4)
-- Just (Two (Bottom :|-|: Levitate 3) (Levitate 4 :|-|: Top))
--
-- @
--
-- Note that infinitely-open intervals will return the points at infinity
-- toward which they are infinite in their result:
--
-- @
--
-- >>> complement (Levitate 3 :<->: Top)
-- Just (Two (Bottom :|-|: Levitate 3) (Top :|-|: Top))
--
-- @
complement ::
  forall x.
  (Ord x) =>
  Interval x ->
  Maybe (OneOrTwo (Interval x))
complement = \case
  Whole -> Nothing
  Bottom :|-|: u -> Just (One (u :<-|: Top))
  Bottom :|->: u -> Just (One (u :|-|: Top))
  Bottom :<-|: u -> Just (Two (Bottom :|-|: Bottom) (u :<-|: Top))
  Bottom :<->: u -> Just (Two (Bottom :|-|: Bottom) (u :|-|: Top))
  --
  l :|-|: Top -> Just (One (Bottom :|->: l))
  l :<-|: Top -> Just (One (Bottom :|-|: l))
  l :|->: Top -> Just (Two (Bottom :|->: l) (Top :|-|: Top))
  l :<->: Top -> Just (Two (Bottom :|-|: l) (Top :|-|: Top))
  --
  l :|-|: u -> Just (Two (Bottom :|->: l) (u :<-|: Top))
  l :|->: u -> Just (Two (Bottom :|->: l) (u :|-|: Top))
  l :<-|: u -> Just (Two (Bottom :|-|: l) (u :<-|: Top))
  l :<->: u -> Just (Two (Bottom :|-|: l) (u :|-|: Top))

-- | Remove all points of the second interval from the first.
--
-- @
--
-- >>> difference Whole (3 :<>: 4)
-- Just (Two (Bottom :|-|: Levitate 3) (Levitate 4 :|-|: Top))
--
-- >>> difference (1 :<>: 4) (2 :||: 3)
-- Just (Two (1 :<>: 2) (3 :<>: 4))
--
-- >>> difference (1 :|>: 4) (0 :||: 1)
-- Just (One (1 :<>: 4))
--
-- >>> difference (1 :<>: 4) (0 :||: 1)
-- Just (One (1 :<>: 4))
--
-- @
difference ::
  forall x.
  (Ord x) =>
  Interval x ->
  Interval x ->
  Maybe (OneOrTwo (Interval x))
difference i1 i2 = case adjacency i1 i2 of
  -- not commutative!!
  Before i _ -> Just $ One i
  Meets i _ _ -> Just $ One i
  Overlaps i _ _ -> Just $ One i
  Starts{} -> Nothing
  During{} -> Nothing
  Finishes{} -> Nothing
  Identical{} -> Nothing
  FinishedBy i _ -> Just $ One i
  Contains i _ k -> Just $ Two i k
  StartedBy _ j -> Just $ One j
  OverlappedBy _ _ k -> Just $ One k
  MetBy _ _ k -> Just $ One k
  After _ j -> Just $ One j

-- | Infix synonym for 'difference'
(\\) ::
  forall x.
  (Ord x) =>
  Interval x ->
  Interval x ->
  Maybe (OneOrTwo (Interval x))
(\\) = difference

-- | The difference of the union and intersection of two intervals.
--
-- @
--
-- >>> symmetricDifference Whole (3 :<>: 4)
-- Just (Two (Bottom :|-|: Levitate 3) (Levitate 4 :|-|: Top))
--
-- >>> symmetricDifference (1 :<>: 4) (2 :||: 3)
-- Just (Two (1 :<>: 2) (3 :<>: 4))
--
-- @
symmetricDifference ::
  forall x.
  (Ord x) =>
  Interval x ->
  Interval x ->
  Maybe (OneOrTwo (Interval x))
symmetricDifference i1 i2 = case i1 `union` i2 of
  Two j1 j2 -> Just (Two j1 j2)
  One u -> case i1 `intersect` i2 of
    Nothing -> Just (One u)
    Just i -> difference u i

-- | Get the measure of an interval.
--
-- @
--
-- >>> measure (-1 :<>: 1)
-- Just 2
--
-- >>> measure (Bottom :<->: Levitate 1)
-- Nothing
--
-- @
measure :: forall x. (Ord x, Num x) => Interval x -> Maybe x
measure = measuring subtract

-- | Apply a function to the lower, then upper, endpoint of an interval.
--
-- @
--
-- >>> measuring max (-1 :<>: 1)
-- Just 1
--
-- >>> measuring min (-1 :<>: 1)
-- Just (-1)
--
-- >>> measuring (*) (4 :<>: 6)
-- Just 24
--
-- @
measuring ::
  forall y x.
  (Ord x, Num y) =>
  (x -> x -> y) ->
  Interval x ->
  Maybe y
measuring f = \case
  Levitate l :---: Levitate u -> Just (f l u)
  l :---: u
    | l == u -> Just 0
    | otherwise -> Nothing

-- | Get the distance between two intervals, or 0 if they adjacency.
--
-- @
--
-- >>> hausdorff (3 :<>: 5) (6 :<>: 7)
-- Just 1
--
-- >>> hausdorff (3 :<>: 5) Whole
-- Just 0
--
-- @
hausdorff :: (Ord x, Num x) => Interval x -> Interval x -> Maybe x
hausdorff i1 i2 = case adjacency i1 i2 of
  Before (_ :---: a) (b :---: _) -> levMaybe $ liftA2 (-) b a
  After (_ :---: a) (b :---: _) -> levMaybe $ liftA2 (-) b a
  _ -> Just 0
 where
  levMaybe = foldLevitated Nothing Just Nothing

-- | @m '+/-' r@ creates the closed interval centred at @m@ with radius @r@.
--
-- For the open interval, simply write @'open' (x '+/-' y)@.
(+/-) :: (Ord x, Num x) => x -> x -> Interval x
m +/- r = m - r :||: m + r

-- | Full containment.
isSubsetOf :: (Ord x) => Interval x -> Interval x -> Bool
isSubsetOf i j = case adjacency i j of
  Before{} -> False
  Meets{} -> False
  Overlaps{} -> False
  Starts{} -> True
  During{} -> True
  Finishes{} -> True
  Identical{} -> True
  FinishedBy{} -> False
  Contains{} -> False
  StartedBy{} -> False
  OverlappedBy{} -> False
  MetBy{} -> False
  After{} -> False