-- |
-- 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