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

-- | 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 | a `overlaps` b = let v = combineOverlapping a b in v `seq` Just v
            | otherwise      = Nothing

combineOverlapping :: (Ord a) => Interval a -> Interval a -> Interval a
combineOverlapping a b = case (compareL a b, compareU a b) of
                           (LT, LT) -> construct a b
                           (LT, _ ) -> a
                           (EQ, LT) -> b
                           (EQ, _ ) -> a
                           (GT, GT) -> construct b a
                           (GT, _ ) -> b
    where
      construct lowerBoundInterval upperBoundInterval =
         let newLowerBound = lowerBound lowerBoundInterval
             newUpperBound = upperBound upperBoundInterval
         in
             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