{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE DeriveAnyClass  #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Range
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Data type for representing Generic Ranges (Intervals) and functions that
-- work with them.
--
--------------------------------------------------------------------------------
module Data.Range( EndPoint(..)
                 , isOpen, isClosed
                 , unEndPoint
                 , Range(.., OpenRange, ClosedRange, Range')
                 , prettyShow
                 , lower, upper
                 , inRange, width, clipLower, clipUpper, midPoint, clampTo
                 , isValidRange, covers

                 , shiftLeft, shiftRight
                 ) where

import Control.Monad((<=<))
import Control.DeepSeq
import Control.Lens
import Control.Applicative
import Data.Intersection
import Data.Vinyl.CoRec
import GHC.Generics (Generic)
import Test.QuickCheck
import Data.Functor.Classes
import Text.Read

--------------------------------------------------------------------------------
-- * Representing Endpoints of a Range

-- | Endpoints of a range may either be open or closed.
data EndPoint a = Open   !a
                | Closed !a
                deriving (Eq,Functor,Foldable,Traversable,Generic,NFData)

instance (Show a) => Show (EndPoint a) where
  showsPrec = liftShowsPrec showsPrec showList

instance Show1 EndPoint where
  liftShowsPrec sp _sl d (Open a)   = showsUnaryWith sp "Open" d a
  liftShowsPrec sp _sl d (Closed a) = showsUnaryWith sp "Closed" d a

instance (Read a) => Read (EndPoint a) where
  readPrec     = liftReadPrec readPrec readListPrec
  readListPrec = readListPrecDefault

instance Read1 EndPoint where
  liftReadPrec rp _rl = readData $
      readUnaryWith rp "Open" Open <|>
      readUnaryWith rp "Closed" Closed
  liftReadListPrec = liftReadListPrecDefault


instance Ord a => Ord (EndPoint a) where
  -- | order on the actual value, and Open before Closed
  a `compare` b = f a `compare` f b
    where
      f (Open x)   = (x,False)
      f (Closed x) = (x,True)

instance Arbitrary r => Arbitrary (EndPoint r) where
  arbitrary = frequency [ (1, Open   <$> arbitrary)
                        , (9, Closed <$> arbitrary)
                        ]

_unEndPoint            :: EndPoint a -> a
_unEndPoint (Open a)   = a
_unEndPoint (Closed a) = a

-- | Access lens for EndPoint value regardless of whether it is open or closed.
--
-- >>> Open 5 ^. unEndPoint
-- 5
-- >>> Closed 10 ^. unEndPoint
-- 10
-- >>> Open 4 & unEndPoint .~ 0
-- Open 0
unEndPoint :: Lens (EndPoint a) (EndPoint b) a b
unEndPoint = lens _unEndPoint f
  where
    f (Open _) a   = Open a
    f (Closed _) a = Closed a
{-# INLINE unEndPoint #-}

-- | True iff EndPoint is open.
isOpen          :: EndPoint a -> Bool
isOpen Open{} = True
isOpen _      = False

-- | True iff EndPoint is closed.
isClosed :: EndPoint a -> Bool
isClosed = not . isOpen


--------------------------------------------------------------------------------
-- * The Range Data type

-- | Data type for representing ranges.
data Range a = Range { _lower :: !(EndPoint a)
                     , _upper :: !(EndPoint a)
                     }
               deriving (Eq,Functor,Foldable,Traversable,Generic,NFData)

-- | Lens access for the lower part of a range.
lower :: Lens' (Range a) (EndPoint a)
lower = lens _lower (\r l -> r{_lower=l})

-- | Lens access for the upper part of a range.
upper :: Lens' (Range a) (EndPoint a)
upper = lens _upper (\r u -> r{_upper=u})

-- instance Show a => Show (Range a) where
--   show (Range l u) = printf "Range (%s) (%s)" (show l) (show u)

instance (Show a) => Show (Range a) where
  showsPrec = liftShowsPrec showsPrec showList

instance Show1 Range where
  liftShowsPrec sp sl d (Range l u) =
      showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Range" d l u

instance (Read a) => Read (Range a) where
  readPrec     = liftReadPrec readPrec readListPrec
  readListPrec = readListPrecDefault

instance Read1 Range where
  liftReadPrec rp rl = readData $
      readBinaryWith (liftReadPrec rp rl) (liftReadPrec rp rl) "Range" Range
  liftReadListPrec = liftReadListPrecDefault


pattern OpenRange       :: a -> a -> Range a
pattern OpenRange   l u = Range (Open l)   (Open u)

pattern ClosedRange     :: a -> a -> Range a
pattern ClosedRange l u = Range (Closed l) (Closed u)

-- | A range from l to u, ignoring/forgetting the type of the endpoints
pattern Range'     :: a -> a -> Range a
pattern Range' l u <- ((\r -> (r^.lower.unEndPoint,r^.upper.unEndPoint) -> (l,u)))
{-# COMPLETE Range' #-}

instance (Arbitrary r, Ord r) => Arbitrary (Range r) where
  arbitrary = do
                l <- arbitrary
                r <- suchThat arbitrary (p l)
                return $ Range l r
   where
     p (Open l)   r = l <  r^.unEndPoint
     p (Closed l) r = l <= r^.unEndPoint


-- | Helper function to show a range in mathematical notation.
--
-- >>> prettyShow $ OpenRange 0 2
-- "(0,2)"
-- >>> prettyShow $ ClosedRange 0 2
-- "[0,2]"
-- >>> prettyShow $ Range (Open 0) (Closed 5)
-- "(0,5]"
prettyShow             :: Show a => Range a -> String
prettyShow (Range l u) = concat [ lowerB, show (l^.unEndPoint), ","
                                , show (u^.unEndPoint), upperB
                                ]
  where
    lowerB = if isOpen l then "(" else "["
    upperB = if isOpen u then ")" else "]"



-- | Test if a value lies in a range.
--
-- >>> 1 `inRange` (OpenRange 0 2)
-- True
-- >>> 1 `inRange` (OpenRange 0 1)
-- False
-- >>> 1 `inRange` (ClosedRange 0 1)
-- True
-- >>> 1 `inRange` (ClosedRange 1 1)
-- True
-- >>> 10 `inRange` (OpenRange 1 10)
-- False
-- >>> 10 `inRange` (ClosedRange 0 1)
-- False
--
-- This one is kind of weird
--
-- >>> 0 `inRange` Range (Closed 0) (Open 0)
-- False
inRange                 :: Ord a => a -> Range a -> Bool
x `inRange` (Range l u) = case ((l^.unEndPoint) `compare` x, x `compare` (u^.unEndPoint)) of
    (_, GT) -> False
    (GT, _) -> False
    (LT,LT) -> True
    (LT,EQ) -> include u -- depends on only u
    (EQ,LT) -> include l -- depends on only l
    (EQ,EQ) -> include l && include u -- depends on l and u
  where
    include = isClosed

type instance IntersectionOf (Range a) (Range a) = [ NoIntersection, Range a]

instance Ord a => Range a `HasIntersectionWith` Range a
instance Ord a => Range a `IsIntersectableWith` Range a where

  nonEmptyIntersection = defaultNonEmptyIntersection

  -- The intersection is empty, if after clipping, the order of the end points is inverted
  -- or if the endpoints are the same, but both are open.
  (Range l u) `intersect` s = case (clipLower l <=< clipUpper u $ s) of
                                Nothing -> coRec NoIntersection
                                Just i  -> coRec i

-- | Get the width of the interval
--
-- >>> width $ ClosedRange 1 10
-- 9
-- >>> width $ OpenRange 5 10
-- 5
width   :: Num r => Range r -> r
width i = i^.upper.unEndPoint - i^.lower.unEndPoint

-- | Compute the halfway point between the start and end of a range.
midPoint   :: Fractional r => Range r -> r
midPoint r = let w = width r in r^.lower.unEndPoint + (w / 2)

-- | Clamps a value to a range. I.e. if the value lies outside the range we
-- report the closest value "in the range". Note that if an endpoint of the
-- range is open we report that value anyway, so we return a value that is
-- truely inside the range only if that side of the range is closed.
--
-- >>> clampTo (ClosedRange 0 10) 20
-- 10
-- >>> clampTo (ClosedRange 0 10) (-20)
-- 0
-- >>> clampTo (ClosedRange 0 10) 5
-- 5
-- >>> clampTo (OpenRange 0 10) 20
-- 10
-- >>> clampTo (OpenRange 0 10) (-20)
-- 0
-- >>> clampTo (OpenRange 0 10) 5
-- 5
clampTo                :: Ord r => Range r -> r -> r
clampTo (Range' l u) x = (x `max` l) `min` u


--------------------------------------------------------------------------------
-- * Helper functions

-- | Clip the interval from below. I.e. intersect with the interval {l,infty),
-- where { is either open, (, orr closed, [.
clipLower     :: Ord a => EndPoint a -> Range a -> Maybe (Range a)
clipLower p rr@(Range l r) = case (p^.unEndPoint) `compare` (r^.unEndPoint) of
                               GT                        -> Nothing
                               EQ | isOpen r || isOpen p -> Nothing
                               _                         -> Just $
                                 case (p^.unEndPoint) `compare` (l^.unEndPoint) of
                                   LT -> rr
                                   EQ -> if isOpen p then Range p r else rr
                                   GT -> Range p r

-- | Clip the interval from above. I.e. intersect with (-\infty, u}, where } is
-- either open, ), or closed, ],
clipUpper     :: Ord a => EndPoint a -> Range a -> Maybe (Range a)
clipUpper p (Range l r) = case (p^.unEndPoint) `compare` (l^.unEndPoint) of
                            LT                        -> Nothing
                            EQ | isOpen l || isOpen p -> Nothing
                            _                         -> Just $ Range l (p `min` r)


-- | Wether or not the first range completely covers the second one
covers       :: forall a. Ord a => Range a -> Range a -> Bool
x `covers` y = (== Just y) . asA @(Range a) $ x `intersect` y

-- | Check if the range is valid and nonEmpty, i.e. if the lower endpoint is
-- indeed smaller than the right endpoint. Note that we treat empty open-ranges
-- as invalid as well.
--
-- >>> isValidRange $ Range (Open 4) (Closed 4)
-- False
-- >>> isValidRange $ Range (Open 5) (Closed 4)
-- False
-- >>> isValidRange $ Range (Open 4) (Closed 5)
-- True
-- >>> isValidRange $ Range (Closed 5) (Closed 40)
-- True
isValidRange             :: Ord a => Range a -> Bool
isValidRange (Range l u) = case _unEndPoint l `compare` _unEndPoint u of
                             LT                            -> True
                             EQ | isClosed l && isClosed u -> True
                             _                             -> False

--------------------------------------------------------------------------------

-- | Shift a range x units to the left
--
-- >>> prettyShow $ shiftLeft 10 (ClosedRange 10 20)
-- "[0,10]"
-- >>> prettyShow $ shiftLeft 10 (OpenRange 15 25)
-- "(5,15)"
shiftLeft   :: Num r => r -> Range r -> Range r
shiftLeft x = shiftRight (-x)

-- | Shifts the range to the right
--
-- >>> prettyShow $ shiftRight 10 (ClosedRange 10 20)
-- "[20,30]"
-- >>> prettyShow $ shiftRight 10 (OpenRange 15 25)
-- "(25,35)"
shiftRight   :: Num r => r -> Range r -> Range r
shiftRight x = fmap (+x)