-----------------------------------------------------------------------------
--
-- Module      :  Data.Ranged.Ranges
-- Copyright   :  (c) Paul Johnson 2006
-- License     :  BSD-style
-- Maintainer  :  paul@cogito.org.uk
-- Stability   :  experimental
-- Portability :  portable
--
-----------------------------------------------------------------------------

-- | A range has an upper and lower boundary.
module Data.Ranged.Ranges (
   -- ** Construction
   Range (..),
   emptyRange,
   fullRange,
   -- ** Predicates
   rangeIsEmpty,
   rangeIsFull,
   rangeOverlap,
   rangeEncloses,
   rangeSingletonValue,
   -- ** Membership
   rangeHas,
   rangeListHas,
   -- ** Set Operations
   singletonRange,
   rangeIntersection,
   rangeUnion,
   rangeDifference,
   -- ** QuickCheck properties
   prop_unionRange,
   prop_unionRangeLength,
   prop_intersectionRange,
   prop_differenceRange,
   prop_intersectionOverlap,
   prop_enclosureUnion,
   prop_singletonRangeHas,
   prop_singletonRangeHasOnly,
   prop_singletonRangeConverse,
   prop_emptyNonSingleton,
   prop_fullNonSingleton,
   prop_nonSingleton,
   prop_intSingleton
) where

import Control.Monad
import Data.Ranged.Boundaries
import Data.Maybe
import Test.QuickCheck

-- | A Range has upper and lower boundaries.
data Ord v => Range v = Range {rangeLower, rangeUpper :: Boundary v}

instance (DiscreteOrdered a) => Eq (Range a) where
   r1 == r2   = (rangeIsEmpty r1 && rangeIsEmpty r2) ||
                (rangeLower r1 == rangeLower r2 &&
                 rangeUpper r1 == rangeUpper r2)


instance (DiscreteOrdered a) => Ord (Range a) where
   compare r1 r2
      | r1 == r2       = EQ
      | rangeIsEmpty r1  = LT
      | rangeIsEmpty r2  = GT
      | otherwise      = compare (rangeLower r1, rangeUpper r1)
                                 (rangeLower r2, rangeUpper r2)

instance (Show a, DiscreteOrdered a) => Show (Range a) where
   show r
      | rangeIsEmpty r     = "Empty"
      | rangeIsFull r      = "All x"
      | otherwise          =
         case rangeSingletonValue r of
            Just v  -> "x == " ++ show v
            Nothing -> lowerBound ++ "x" ++ upperBound
      where
         lowerBound = case rangeLower r of
            BoundaryBelowAll -> ""
            BoundaryBelow v  -> show v ++ " <= "
            BoundaryAbove v  -> show v ++ " < "
            BoundaryAboveAll -> error "show Range: lower bound is BoundaryAboveAll"
         upperBound = case rangeUpper r of
            BoundaryBelowAll -> error "show Range: upper bound is BoundaryBelowAll"
            BoundaryBelow v  -> " < " ++ show v
            BoundaryAbove v  -> " <= " ++ show v
            BoundaryAboveAll -> ""


-- | True if the value is within the range.
rangeHas :: Ord v => Range v -> v -> Bool

rangeHas (Range b1 b2) v =
   (v />/ b1) && not (v />/ b2)


-- | True if the value is within one of the ranges.
rangeListHas :: Ord v =>
   [Range v] -> v -> Bool
rangeListHas ls v = or $ map (\r -> rangeHas r v) ls


-- | The empty range
emptyRange :: DiscreteOrdered v => Range v
emptyRange = Range BoundaryAboveAll BoundaryBelowAll


-- | The full range.  All values are within it.
fullRange :: DiscreteOrdered v => Range v
fullRange = Range BoundaryBelowAll BoundaryAboveAll


-- | A range containing a single value
singletonRange :: DiscreteOrdered v => v -> Range v
singletonRange v = Range (BoundaryBelow v) (BoundaryAbove v)


-- | If the range is a singleton, returns @Just@ the value.  Otherwise returns
-- @Nothing@.
--
-- Known bug: This always returns @Nothing@ for ranges including
-- @BoundaryBelowAll@ or @BoundaryAboveAll@.  For bounded types this can be
-- incorrect.  For instance, the following range only contains one value:
--
-- >    Range (BoundaryBelow maxBound) BoundaryAboveAll
rangeSingletonValue :: DiscreteOrdered v => Range v -> Maybe v
rangeSingletonValue (Range (BoundaryBelow v1) (BoundaryBelow v2))
   | adjacent v1 v2  = Just v1
   | otherwise       = Nothing
rangeSingletonValue (Range (BoundaryBelow v1) (BoundaryAbove v2))
   | v1 == v2        = Just v1
   | otherwise       = Nothing
rangeSingletonValue (Range (BoundaryAbove v1) (BoundaryBelow v2)) =
   do
      v2' <- adjacentBelow v2
      v2'' <- adjacentBelow v2'
      if v1 == v2'' then return v2' else Nothing
rangeSingletonValue (Range (BoundaryAbove v1) (BoundaryAbove v2))
   | adjacent v1 v2  = Just v2
   | otherwise       = Nothing
rangeSingletonValue (Range _ _) = Nothing

-- | A range is empty unless its upper boundary is greater than its lower
-- boundary.
rangeIsEmpty :: DiscreteOrdered v => Range v -> Bool
rangeIsEmpty (Range lower upper) = upper <= lower


-- | A range is full if it contains every possible value.
rangeIsFull :: DiscreteOrdered v => Range v -> Bool
rangeIsFull = (== fullRange)

-- | Two ranges overlap if their intersection is non-empty.
rangeOverlap :: DiscreteOrdered v => Range v -> Range v -> Bool
rangeOverlap r1 r2 =
   not (rangeIsEmpty r1)
   && not (rangeIsEmpty r2)
   && not (rangeUpper r1 <= rangeLower r2 || rangeUpper r2 <= rangeLower r1)


-- | The first range encloses the second if every value in the second range is
-- also within the first range.  If the second range is empty then this is
-- always true.
rangeEncloses :: DiscreteOrdered v => Range v -> Range v -> Bool
rangeEncloses r1 r2 =
   (rangeLower r1 <= rangeLower r2 && rangeUpper r2 <= rangeUpper r1)
   || rangeIsEmpty r2


-- | Intersection of two ranges, if any.
rangeIntersection :: DiscreteOrdered v => Range v -> Range v -> Range v
rangeIntersection r1@(Range lower1 upper1) r2@(Range lower2 upper2)
    | rangeIsEmpty r1 || rangeIsEmpty r2  = emptyRange
    | otherwise  = Range (max lower1 lower2) (min upper1 upper2)


-- | Union of two ranges.  Returns one or two results.
--
-- If there are two results then they are guaranteed to have a non-empty
-- gap in between, but may not be in ascending order.
rangeUnion :: DiscreteOrdered v => Range v -> Range v -> [Range v]
rangeUnion r1@(Range lower1 upper1) r2@(Range lower2 upper2)
   | rangeIsEmpty r1  = [r2]
   | rangeIsEmpty r2  = [r1]
   | otherwise =
       if touching then [Range lower upper] else [r1, r2]
   where
     touching = (max lower1 lower2) <= (min upper1 upper2)
     lower = min lower1 lower2
     upper = max upper1 upper2


-- | @range1@ minus @range2@.  Returns zero, one or two results.  Multiple
-- results are guaranteed to have non-empty gaps in between, but may not be in
-- ascending order.
rangeDifference :: DiscreteOrdered v => Range v -> Range v -> [Range v]

rangeDifference r1@(Range lower1 upper1) (Range lower2 upper2) =
   -- There are six possibilities
   --    1: r2 completely less than r1
   --    2: r2 overlaps bottom of r1
   --    3: r2 encloses r1
   --    4: r1 encloses r2
   --    5: r2 overlaps top of r1
   --    6: r2 completely greater than r1
   if intersects
      then -- Cases 2,3,4,5
         filter (not . rangeIsEmpty) [Range lower1 lower2, Range upper2 upper1]
      else -- Cases 1, 6
         [r1]
   where
      intersects = (max lower1 lower2) < (min upper1 upper2)


-- QuickCheck generators

instance (Arbitrary v,  DiscreteOrdered v, Show v) =>
   Arbitrary (Range v) where

   arbitrary = frequency [
      (17, do  -- Ordinary range
         b1 <- arbitrary
         b2 <- arbitrary
         if b1 < b2
            then return $ Range b1 b2
            else return $ Range b2 b1
      ),
      (1, do  -- Singleton range
         v <- arbitrary
         return $ singletonRange v
      ),
      (1, return emptyRange),
      (1, return fullRange)
      ]

instance (CoArbitrary v, DiscreteOrdered v, Show v) =>
   CoArbitrary (Range v) where

   coarbitrary (Range lower upper) =
      variant (0 :: Int) . coarbitrary lower . coarbitrary upper



-- QuickCheck Properties

-- | The union of two ranges has a value iff either range has it.
--
-- > prop_unionRange r1 r2 n =
-- >    (r1 `rangeHas` n || r2 `rangeHas` n)
-- >    == (r1 `rangeUnion` r2) `rangeListHas` n
prop_unionRange :: (DiscreteOrdered a) => Range a -> Range a -> a -> Bool
prop_unionRange r1 r2 n =
   (r1 `rangeHas` n || r2 `rangeHas` n)
   == (r1 `rangeUnion` r2) `rangeListHas` n

-- | The union of two ranges always contains one or two ranges.
--
-- > prop_unionRangeLength r1 r2 = (n == 1) || (n == 2)
-- >    where n = length $ rangeUnion r1 r2
prop_unionRangeLength :: (DiscreteOrdered a) => Range a -> Range a -> Bool
prop_unionRangeLength r1 r2 = (n == 1) || (n == 2)
   where n = length $ rangeUnion r1 r2

-- | The intersection of two ranges has a value iff both ranges have it.
--
-- > prop_intersectionRange r1 r2 n =
-- >    (r1 `rangeHas` n && r2 `rangeHas` n)
-- >    == (r1 `rangeIntersection` r2) `rangeHas` n
prop_intersectionRange :: (DiscreteOrdered a) => Range a -> Range a -> a -> Bool
prop_intersectionRange r1 r2 n =
   (r1 `rangeHas` n && r2 `rangeHas` n)
   == (r1 `rangeIntersection` r2) `rangeHas` n

-- | The difference of two ranges has a value iff the first range has it and
-- the second does not.
--
-- > prop_differenceRange r1 r2 n =
-- >    (r1 `rangeHas` n && not (r2 `rangeHas` n))
-- >    == (r1 `rangeDifference` r2) `rangeListHas` n
prop_differenceRange :: (DiscreteOrdered a) => Range a -> Range a -> a -> Bool
prop_differenceRange r1 r2 n =
   (r1 `rangeHas` n && not (r2 `rangeHas` n))
   == (r1 `rangeDifference` r2) `rangeListHas` n

-- | Iff two ranges overlap then their intersection is non-empty.
--
-- > prop_intersectionOverlap r1 r2 =
-- >     (rangeIsEmpty $ rangeIntersection r1 r2) == (rangeOverlap r1 r2)
prop_intersectionOverlap :: (DiscreteOrdered a) => Range a -> Range a -> Bool
prop_intersectionOverlap r1 r2 =
    (rangeIsEmpty $ rangeIntersection r1 r2) == not (rangeOverlap r1 r2)

-- | Range enclosure makes union an identity function.
--
-- > prop_enclosureUnion r1 r2 =
-- >    rangeEncloses r1 r2 == (rangeUnion r1 r2 == [r1])
prop_enclosureUnion :: (DiscreteOrdered a) => Range a -> Range a -> Bool
prop_enclosureUnion r1 r2 = rangeEncloses r1 r2 == (rangeUnion r1 r2 == [r1])

-- | Range Singleton has its member.
--
-- > prop_singletonRangeHas v = singletonRange v `rangeHas` v
prop_singletonRangeHas :: (DiscreteOrdered a) => a -> Bool
prop_singletonRangeHas v = singletonRange v `rangeHas` v

-- | Range Singleton has only its member.
--
-- > prop_singletonHasOnly v1 v2 =
-- >    (v1 == v2) == (singletonRange v1 `rangeHas` v2)
prop_singletonRangeHasOnly :: (DiscreteOrdered a) => a -> a -> Bool
prop_singletonRangeHasOnly v1 v2 =
   (v1 == v2) == (singletonRange v1 `rangeHas` v2)

-- | A singleton range can have its value extracted.
--
-- > prop_singletonRangeConverse v =
-- >    rangeSingletonValue (singletonRange v) == Just v
prop_singletonRangeConverse:: (DiscreteOrdered a) => a -> Bool
prop_singletonRangeConverse v =
   rangeSingletonValue (singletonRange v) == Just v

-- | The empty range is not a singleton.
--
-- > prop_emptyNonSingleton = rangeSingletonValue emptyRange == Nothing
prop_emptyNonSingleton :: Bool
prop_emptyNonSingleton =
    rangeSingletonValue (emptyRange :: Range Int) == Nothing

-- | The full range is not a singleton.
--
-- > prop_fullNonSingleton = rangeSingletonValue fullRange == Nothing
prop_fullNonSingleton :: Bool
prop_fullNonSingleton =
    rangeSingletonValue (fullRange :: Range Int) == Nothing

-- | For real x and y, @x < y@ implies that any range between them is a
-- non-singleton.
prop_nonSingleton :: Double -> Double -> Property
prop_nonSingleton x y = (x < y) ==> null $ mapMaybe rangeSingletonValue rs
   where rs = [
          Range (BoundaryBelow x) (BoundaryBelow y),
          Range (BoundaryAbove x) (BoundaryBelow y),
          Range (BoundaryBelow x) (BoundaryAbove y),
          Range (BoundaryAbove x) (BoundaryAbove y)]


-- | For all integers x and y, any range formed from boundaries on either side
-- of x and y is a singleton iff it contains exactly one integer.
prop_intSingleton :: Integer -> Integer -> Property
prop_intSingleton x y = forAll (rangeAround x y) $ \r ->
                        case filter (rangeHas r) [x-1 .. y+1] of
                          [v]  -> rangeSingletonValue r == Just v
                          _    -> rangeSingletonValue r == Nothing
    where
      rangeAround v1 v2 = return Range `ap` genBound v1 `ap` genBound v2
      genBound v = elements [BoundaryAbove v, BoundaryBelow v]