module Data.IntervalMap.Interval (
Interval(..),
lowerBound, upperBound, leftClosed, rightClosed, isEmpty,
overlaps, subsumes, before, after,
compareByUpper, combine,
below, inside, above
) where
import Control.DeepSeq (NFData(rnf))
import Data.List (maximumBy)
data Interval a = IntervalCO !a !a
| ClosedInterval !a !a
| OpenInterval !a !a
| IntervalOC !a !a
deriving (Eq)
instance Show a => Show (Interval a) where
showsPrec _ (IntervalCO a b) = showChar '[' . shows a . showChar ',' . shows b . showChar ')'
showsPrec _ (ClosedInterval a b) = showChar '[' . shows a . showChar ',' . shows b . showChar ']'
showsPrec _ (OpenInterval a b) = showChar '(' . shows a . showChar ',' . shows b . showChar ')'
showsPrec _ (IntervalOC a b) = showChar '(' . shows a . showChar ',' . shows b . showChar ']'
instance Read a => Read (Interval a) where
readsPrec _ = readParen False
(\r -> [(ClosedInterval a b, w) | ("[", s) <- lex r,
(a, t) <- reads s,
(",", u) <- lex t,
(b, v) <- reads u,
("]", w) <- lex v]
++
[(OpenInterval a b, w) | ("(", s) <- lex r,
(a, t) <- reads s,
(",", u) <- lex t,
(b, v) <- reads u,
(")", w) <- lex v]
++
[(IntervalCO a b, w) | ("[", s) <- lex r,
(a, t) <- reads s,
(",", u) <- lex t,
(b, v) <- reads u,
(")", w) <- lex v]
++
[(IntervalOC a b, w) | ("(", s) <- lex r,
(a, t) <- reads s,
(",", u) <- lex t,
(b, v) <- reads u,
("]", w) <- lex v]
)
compareL :: Ord a => Interval a -> Interval a -> Ordering
compareL (IntervalCO a _) (IntervalCO b _) = compare a b
compareL (IntervalCO a _) (ClosedInterval b _) = compare a b
compareL (IntervalCO a _) (OpenInterval b _) = if a <= b then LT else GT
compareL (IntervalCO a _) (IntervalOC b _) = if a <= b then LT else GT
compareL (ClosedInterval a _) (IntervalCO b _) = compare a b
compareL (ClosedInterval a _) (ClosedInterval b _) = compare a b
compareL (ClosedInterval a _) (OpenInterval b _) = if a <= b then LT else GT
compareL (ClosedInterval a _) (IntervalOC b _) = if a <= b then LT else GT
compareL (OpenInterval a _) (IntervalCO b _) = if a < b then LT else GT
compareL (OpenInterval a _) (ClosedInterval b _) = if a < b then LT else GT
compareL (OpenInterval a _) (OpenInterval b _) = compare a b
compareL (OpenInterval a _) (IntervalOC b _) = compare a b
compareL (IntervalOC a _) (IntervalCO b _) = if a < b then LT else GT
compareL (IntervalOC a _) (ClosedInterval b _) = if a < b then LT else GT
compareL (IntervalOC a _) (OpenInterval b _) = compare a b
compareL (IntervalOC a _) (IntervalOC b _) = compare a b
compareU :: Ord a => Interval a -> Interval a -> Ordering
compareU (IntervalCO _ a) (IntervalCO _ b) = compare a b
compareU (IntervalCO _ a) (ClosedInterval _ b) = if a <= b then LT else GT
compareU (IntervalCO _ a) (OpenInterval _ b) = compare a b
compareU (IntervalCO _ a) (IntervalOC _ b) = if a <= b then LT else GT
compareU (ClosedInterval _ a) (IntervalCO _ b) = if a < b then LT else GT
compareU (ClosedInterval _ a) (ClosedInterval _ b) = compare a b
compareU (ClosedInterval _ a) (OpenInterval _ b) = if a < b then LT else GT
compareU (ClosedInterval _ a) (IntervalOC _ b) = compare a b
compareU (OpenInterval _ a) (IntervalCO _ b) = compare a b
compareU (OpenInterval _ a) (ClosedInterval _ b) = if a <= b then LT else GT
compareU (OpenInterval _ a) (OpenInterval _ b) = compare a b
compareU (OpenInterval _ a) (IntervalOC _ b) = if a <= b then LT else GT
compareU (IntervalOC _ a) (IntervalCO _ b) = if a < b then LT else GT
compareU (IntervalOC _ a) (ClosedInterval _ b) = compare a b
compareU (IntervalOC _ a) (OpenInterval _ b) = if a < b then LT else GT
compareU (IntervalOC _ a) (IntervalOC _ b) = compare a b
instance Ord a => Ord (Interval a) where
compare a b = case compareL a b of
EQ -> compareU a b
r -> r
instance Functor Interval where
fmap f (IntervalCO a b) = IntervalCO (f a) (f b)
fmap f (ClosedInterval a b) = ClosedInterval (f a) (f b)
fmap f (OpenInterval a b) = OpenInterval (f a) (f b)
fmap f (IntervalOC a b) = IntervalOC (f a) (f b)
instance NFData a => NFData (Interval a) where
rnf (IntervalCO a b) = rnf a `seq` rnf b
rnf (ClosedInterval a b) = rnf a `seq` rnf b
rnf (OpenInterval a b) = rnf a `seq` rnf b
rnf (IntervalOC a b) = rnf a `seq` rnf b
compareByUpper :: Ord a => Interval a -> Interval a -> Ordering
compareByUpper a b = case compareU a b of
EQ -> compareL a b
r -> r
lowerBound :: Interval a -> a
lowerBound (ClosedInterval lo _) = lo
lowerBound (OpenInterval lo _) = lo
lowerBound (IntervalCO lo _) = lo
lowerBound (IntervalOC lo _) = lo
upperBound :: Interval a -> a
upperBound (ClosedInterval _ hi) = hi
upperBound (OpenInterval _ hi) = hi
upperBound (IntervalCO _ hi) = hi
upperBound (IntervalOC _ hi) = hi
isEmpty :: (Ord a) => Interval a -> Bool
isEmpty (ClosedInterval a b) = a > b
isEmpty iv = lowerBound iv >= upperBound iv
leftClosed :: Interval a -> Bool
leftClosed (ClosedInterval _ _) = True
leftClosed (IntervalCO _ _) = True
leftClosed _ = False
rightClosed :: Interval a -> Bool
rightClosed (ClosedInterval _ _) = True
rightClosed (IntervalOC _ _) = True
rightClosed _ = False
overlaps :: (Ord a) => Interval a -> Interval a -> Bool
overlaps (ClosedInterval lo1 hi1) (ClosedInterval lo2 hi2) = lo1 <= hi2 && hi1 >= lo2
overlaps (ClosedInterval lo1 hi1) (OpenInterval lo2 hi2) = lo1 < hi2 && hi1 > lo2
overlaps (ClosedInterval lo1 hi1) (IntervalCO lo2 hi2) = lo1 < hi2 && hi1 >= lo2
overlaps (ClosedInterval lo1 hi1) (IntervalOC lo2 hi2) = lo1 <= hi2 && hi1 > lo2
overlaps (OpenInterval lo1 hi1) (ClosedInterval lo2 hi2) = lo1 < hi2 && hi1 > lo2
overlaps (OpenInterval lo1 hi1) (OpenInterval lo2 hi2) = lo1 < hi2 && hi1 > lo2
overlaps (OpenInterval lo1 hi1) (IntervalCO lo2 hi2) = lo1 < hi2 && hi1 > lo2
overlaps (OpenInterval lo1 hi1) (IntervalOC lo2 hi2) = lo1 < hi2 && hi1 > lo2
overlaps (IntervalCO lo1 hi1) (ClosedInterval lo2 hi2) = lo1 <= hi2 && hi1 > lo2
overlaps (IntervalCO lo1 hi1) (OpenInterval lo2 hi2) = lo1 < hi2 && hi1 > lo2
overlaps (IntervalCO lo1 hi1) (IntervalCO lo2 hi2) = lo1 < hi2 && hi1 > lo2
overlaps (IntervalCO lo1 hi1) (IntervalOC lo2 hi2) = lo1 <= hi2 && hi1 > lo2
overlaps (IntervalOC lo1 hi1) (ClosedInterval lo2 hi2) = lo1 < hi2 && hi1 >= lo2
overlaps (IntervalOC lo1 hi1) (OpenInterval lo2 hi2) = lo1 < hi2 && hi1 > lo2
overlaps (IntervalOC lo1 hi1) (IntervalCO lo2 hi2) = lo1 < hi2 && hi1 >= lo2
overlaps (IntervalOC lo1 hi1) (IntervalOC lo2 hi2) = lo1 < hi2 && hi1 > lo2
subsumes :: (Ord a) => Interval a -> Interval a -> Bool
subsumes (ClosedInterval lo1 hi1) (ClosedInterval lo2 hi2) = lo1 <= lo2 && hi1 >= hi2
subsumes (ClosedInterval lo1 hi1) (OpenInterval lo2 hi2) = lo1 <= lo2 && hi1 >= hi2
subsumes (ClosedInterval lo1 hi1) (IntervalCO lo2 hi2) = lo1 <= lo2 && hi1 >= hi2
subsumes (ClosedInterval lo1 hi1) (IntervalOC lo2 hi2) = lo1 <= lo2 && hi1 >= hi2
subsumes (OpenInterval lo1 hi1) (ClosedInterval lo2 hi2) = lo1 < lo2 && hi1 > hi2
subsumes (OpenInterval lo1 hi1) (OpenInterval lo2 hi2) = lo1 <= lo2 && hi1 >= hi2
subsumes (OpenInterval lo1 hi1) (IntervalCO lo2 hi2) = lo1 < lo2 && hi1 >= hi2
subsumes (OpenInterval lo1 hi1) (IntervalOC lo2 hi2) = lo1 <= lo2 && hi1 > hi2
subsumes (IntervalCO lo1 hi1) (ClosedInterval lo2 hi2) = lo1 <= lo2 && hi1 > hi2
subsumes (IntervalCO lo1 hi1) (OpenInterval lo2 hi2) = lo1 <= lo2 && hi1 >= hi2
subsumes (IntervalCO lo1 hi1) (IntervalCO lo2 hi2) = lo1 <= lo2 && hi1 >= hi2
subsumes (IntervalCO lo1 hi1) (IntervalOC lo2 hi2) = lo1 <= lo2 && hi1 > hi2
subsumes (IntervalOC lo1 hi1) (ClosedInterval lo2 hi2) = lo1 < lo2 && hi1 >= hi2
subsumes (IntervalOC lo1 hi1) (OpenInterval lo2 hi2) = lo1 <= lo2 && hi1 >= hi2
subsumes (IntervalOC lo1 hi1) (IntervalCO lo2 hi2) = lo1 < lo2 && hi1 >= hi2
subsumes (IntervalOC lo1 hi1) (IntervalOC lo2 hi2) = lo1 <= lo2 && hi1 >= hi2
before :: Ord a => Interval a -> Interval a -> Bool
IntervalCO _ l `before` r = l <= lowerBound r
ClosedInterval _ l `before` IntervalCO r _ = l < r
ClosedInterval _ l `before` ClosedInterval r _ = l < r
ClosedInterval _ l `before` OpenInterval r _ = l <= r
ClosedInterval _ l `before` IntervalOC r _ = l <= r
OpenInterval _ l `before` r = l <= lowerBound r
IntervalOC _ l `before` IntervalCO r _ = l < r
IntervalOC _ l `before` ClosedInterval r _ = l < r
IntervalOC _ l `before` OpenInterval r _ = l <= r
IntervalOC _ l `before` IntervalOC r _ = l <= r
after :: Ord a => Interval a -> Interval a -> Bool
r `after` l = l `before` r
inside :: (Ord a) => a -> Interval a -> Bool
p `inside` (IntervalCO lo hi) = lo <= p && p < hi
p `inside` (ClosedInterval lo hi) = lo <= p && p <= hi
p `inside` (OpenInterval lo hi) = lo < p && p < hi
p `inside` (IntervalOC lo hi) = lo < p && p <= hi
below :: (Ord a) => a -> Interval a -> Bool
p `below` (IntervalCO l _) = p < l
p `below` (ClosedInterval l _) = p < l
p `below` (OpenInterval l _) = p <= l
p `below` (IntervalOC l _) = p <= l
above :: (Ord a) => a -> Interval a -> Bool
p `above` (IntervalCO _ u) = p >= u
p `above` (ClosedInterval _ u) = p > u
p `above` (OpenInterval _ u) = p >= u
p `above` (IntervalOC _ u) = p > u
combine :: (Ord a) => Interval a -> Interval a -> Maybe (Interval a)
combine a b =
if a `overlaps` b
then let lowerBoundInterval = min a b
upperBoundInterval = maximumBy compareByUpper [a, b]
newLowerBound = lowerBound lowerBoundInterval
newUpperBound = upperBound upperBoundInterval
interval =
if leftClosed lowerBoundInterval
then if rightClosed upperBoundInterval
then ClosedInterval newLowerBound newUpperBound
else IntervalCO newLowerBound newUpperBound
else if rightClosed upperBoundInterval
then IntervalOC newLowerBound newUpperBound
else OpenInterval newLowerBound newUpperBound
in Just interval
else Nothing