-- | -- Module : Data.IntervalMap.Interval -- Copyright : (c) Christoph Breitkopf 2011 -- License : BSD-style -- Maintainer : chbreitkopf@gmail.com -- Stability : experimental -- Portability : portable -- -- A conservative implementation of Intervals, mostly for use as keys in -- a 'Data.IntervalMap'. -- -- This should really be a typeclass, so you could have a tuple be an instance -- of Interval, but that is currently not possible in standard Haskell. -- -- The contructor names of the half-open intervals seem somewhat clumsy, -- and I'm open to suggestions for better names. -- module Data.IntervalMap.Interval ( -- * Interval type Interval(..), -- * Query lowerBound, upperBound, leftClosed, rightClosed, isEmpty, -- * Interval operations overlaps, subsumes, before, after, compareByUpper, combine, -- * Point operations below, inside, above ) where import Control.DeepSeq (NFData(rnf)) import Data.List (maximumBy) -- | Intervals with endpoints of type @a@. -- -- 'Read' and 'Show' use mathematical notation with square brackets for closed -- and parens for open intervals. -- This is better for human readability, but is not a valid Haskell expression. -- Closed intervals look like a list, open intervals look like a tuple, -- and half-open intervals look like mismatched parens. data Interval a = IntervalCO !a !a -- ^ Including lower bound, excluding upper | ClosedInterval !a !a -- ^ Closed at both ends | OpenInterval !a !a -- ^ Open at both ends | IntervalOC !a !a -- ^ Excluding lower bound, including upper 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] ) -- compare only the lower bound 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 -- compare only the upper bound 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 -- | Like 'compare', but considering the upper bound first. compareByUpper :: Ord a => Interval a -> Interval a -> Ordering compareByUpper a b = case compareU a b of EQ -> compareL a b r -> r -- | Get the lower bound. lowerBound :: Interval a -> a lowerBound (ClosedInterval lo _) = lo lowerBound (OpenInterval lo _) = lo lowerBound (IntervalCO lo _) = lo lowerBound (IntervalOC lo _) = lo -- | Get the upper bound. upperBound :: Interval a -> a upperBound (ClosedInterval _ hi) = hi upperBound (OpenInterval _ hi) = hi upperBound (IntervalCO _ hi) = hi upperBound (IntervalOC _ hi) = hi -- | Is the interval empty? isEmpty :: (Ord a) => Interval a -> Bool isEmpty (ClosedInterval a b) = a > b isEmpty iv = lowerBound iv >= upperBound iv -- | Does the interval include its lower bound? leftClosed :: Interval a -> Bool leftClosed (ClosedInterval _ _) = True leftClosed (IntervalCO _ _) = True leftClosed _ = False -- | Does the interval include its upper bound? rightClosed :: Interval a -> Bool rightClosed (ClosedInterval _ _) = True rightClosed (IntervalOC _ _) = True rightClosed _ = False -- | Do the two intervals overlap? 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 -- | Does the first interval completely contain the second? 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 -- | Interval strictly before another? -- True if the upper bound of the first interval is below the lower bound of the second. 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 -- | Interval strictly after another? -- Same as 'flip before'. after :: Ord a => Interval a -> Interval a -> Bool r `after` l = l `before` r -- | Does the interval contain a given point? 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 -- | Is a point strictly less than lower bound? 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 -- | Is a point strictly greater than upper bound? 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 -- | If the intervals overlap combine them into one. 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