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

    module Data.Ranged.Boundaries (
       DiscreteOrdered (..),
       enumAdjacent,
       boundedAdjacent,
       boundedBelow,
       Boundary (..),
       above,
       (/>/)
    ) where

    import Data.Ratio
    import Test.QuickCheck

    infix 4 />/

    {- |
    Distinguish between dense and sparse ordered types.  A dense type is
    one in which any two values @v1 < v2@ have a third value @v3@ such that
    @v1 < v3 < v2@.

    In theory the floating types are dense, although in practice they can only have
    finitely many values.  This class treats them as dense.

    Tuples up to 4 members are declared as instances.  Larger tuples may be added
    if necessary.

    Most values of sparse types have an @adjacentBelow@, such that, for all x:

    > case adjacentBelow x of
    >    Just x1 -> adjacent x1 x
    >    Nothing -> True

    The exception is for bounded types when @x == lowerBound@.  For dense types
    @adjacentBelow@ always returns 'Nothing'.

    This approach was suggested by Ben Rudiak-Gould on comp.lang.functional.
    -}

    class Ord a => DiscreteOrdered a where
       -- | Two values @x@ and @y@ are adjacent if @x < y@ and there does not
       -- exist a third value between them.  Always @False@ for dense types.
       adjacent :: a -> a -> Bool
       -- | The value immediately below the argument, if it can be determined.
       adjacentBelow :: a -> Maybe a

    -- Implementation note: the precise rules about unbounded enumerated vs
    -- bounded enumerated types are difficult to express using Haskell 98, so
    -- the prelude types are listed individually here.

    instance DiscreteOrdered Bool where
       adjacent = boundedAdjacent
       adjacentBelow = boundedBelow

    instance DiscreteOrdered Ordering where
       adjacent = boundedAdjacent
       adjacentBelow = boundedBelow

    instance DiscreteOrdered Char where
       adjacent = boundedAdjacent
       adjacentBelow = boundedBelow

    instance DiscreteOrdered Int where
       adjacent = boundedAdjacent
       adjacentBelow = boundedBelow

    instance DiscreteOrdered Integer where
       adjacent = enumAdjacent
       adjacentBelow = Just . pred

    instance DiscreteOrdered Double where
       adjacent _ _ = False
       adjacentBelow = const Nothing

    instance DiscreteOrdered Float where
       adjacent _ _ = False
       adjacentBelow = const Nothing

    instance (Integral a) => DiscreteOrdered (Ratio a) where
       adjacent _ _ = False
       adjacentBelow = const Nothing

    instance Ord a => DiscreteOrdered [a] where
       adjacent _ _ = False
       adjacentBelow = const Nothing

    instance (Ord a, DiscreteOrdered b) => DiscreteOrdered (a, b)
       where
          adjacent (x1, x2) (y1, y2) = (x1 == y1) && adjacent x2 y2
          adjacentBelow (x1, x2) = do -- Maybe monad
             x2' <- adjacentBelow x2
             return (x1, x2')

    instance (Ord a, Ord b, DiscreteOrdered c) => DiscreteOrdered (a, b, c)
       where
          adjacent (x1, x2, x3) (y1, y2, y3) =
             (x1 == y1) && (x2 == y2) && adjacent x3 y3
          adjacentBelow (x1, x2, x3) = do -- Maybe monad
             x3' <- adjacentBelow x3
             return (x1, x2, x3')

    instance (Ord a, Ord b, Ord c, DiscreteOrdered d) =>
             DiscreteOrdered (a, b, c, d)
       where
          adjacent (x1, x2, x3, x4) (y1, y2, y3, y4) =
             (x1 == y1) && (x2 == y2) && (x3 == y3) && adjacent x4 y4
          adjacentBelow (x1, x2, x3, x4) = do -- Maybe monad
             x4' <- adjacentBelow x4
             return (x1, x2, x3, x4')

    -- | Check adjacency for sparse enumerated types (i.e. where there
    -- is no value between @x@ and @succ x@).
    enumAdjacent :: (Ord a, Enum a) => a -> a -> Bool
    enumAdjacent x y = (succ x == y)

    -- | Check adjacency, allowing for case where x = maxBound.  Use as the
    -- definition of "adjacent" for bounded enumerated types such as Int and Char.
    boundedAdjacent :: (Ord a, Enum a) => a -> a -> Bool
    boundedAdjacent x y = if x < y then succ x == y else False

    -- | The usual implementation of 'adjacentBelow' for bounded enumerated types.
    boundedBelow :: (Eq a, Enum a, Bounded a) => a -> Maybe a
    boundedBelow x = if x == minBound then Nothing else Just $ pred x

    {- |
    A Boundary is a division of an ordered type into values above
    and below the boundary.  No value can sit on a boundary.

    Known bug: for Bounded types

    * @BoundaryAbove maxBound < BoundaryAboveAll@

    * @BoundaryBelow minBound > BoundaryBelowAll@

    This is incorrect because there are no possible values in
    between the left and right sides of these inequalities.
    -}

    data Boundary a =
          -- | The argument is the highest value below the boundary.
          BoundaryAbove a |
          -- | The argument is the lowest value above the boundary.
          BoundaryBelow a |
          -- | The boundary above all values.
          BoundaryAboveAll |
          -- | The boundary below all values.
          BoundaryBelowAll
       deriving (Show)

    -- | True if the value is above the boundary, false otherwise.
    above :: Ord v => Boundary v -> v -> Bool
    above (BoundaryAbove b) v    = v > b
    above (BoundaryBelow b) v    = v >= b
    above BoundaryAboveAll _     = False
    above BoundaryBelowAll _     = True

    -- | Same as 'above', but with the arguments reversed for more intuitive infix
    -- usage.
    (/>/) :: Ord v => v -> Boundary v -> Bool
    (/>/) = flip above

    instance (DiscreteOrdered a) => Eq (Boundary a) where
       b1 == b2  = compare b1 b2 == EQ

    instance (DiscreteOrdered a) => Ord (Boundary a) where
       -- Comparison alogrithm based on brute force and ignorance:
       -- enumerate all combinations.

       compare boundary1 boundary2 =
          case boundary1 of
             BoundaryAbove b1 ->
                case boundary2 of
                   BoundaryAbove b2 -> compare b1 b2
                   BoundaryBelow b2 ->
                      if b1 < b2
                         then
                            if adjacent b1 b2 then EQ else LT
                         else GT
                   BoundaryAboveAll -> LT
                   BoundaryBelowAll -> GT
             BoundaryBelow b1 ->
                case boundary2 of
                   BoundaryAbove b2 ->
                      if b1 > b2
                         then
                            if adjacent b2 b1 then EQ else GT
                         else LT
                   BoundaryBelow b2 -> compare b1 b2
                   BoundaryAboveAll -> LT
                   BoundaryBelowAll -> GT
             BoundaryAboveAll ->
                case boundary2 of
                   BoundaryAboveAll -> EQ
                   _        -> GT
             BoundaryBelowAll ->
                case boundary2 of
                   BoundaryBelowAll -> EQ
                   _        -> LT

    -- QuickCheck Generator

    instance Arbitrary a => Arbitrary (Boundary a) where
       arbitrary = frequency [
          (1, return BoundaryAboveAll),
          (1, return BoundaryBelowAll),
          (18, do
             v <- arbitrary
             oneof [return $ BoundaryAbove v, return $ BoundaryBelow v]
          )]

    instance CoArbitrary a => CoArbitrary (Boundary a) where
       coarbitrary BoundaryBelowAll   = variant (0 :: Int)
       coarbitrary BoundaryAboveAll   = variant (1 :: Int)
       coarbitrary (BoundaryBelow v)  = variant (2 :: Int) . coarbitrary v
       coarbitrary (BoundaryAbove v)  = variant (3 :: Int) . coarbitrary v