-----------------------------------------------------------------------------
-- |
-- 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 :: Bool -> Bool -> Bool
adjacent = Bool -> Bool -> Bool
forall a. (Ord a, Enum a) => a -> a -> Bool
boundedAdjacent
   adjacentBelow :: Bool -> Maybe Bool
adjacentBelow = Bool -> Maybe Bool
forall a. (Eq a, Enum a, Bounded a) => a -> Maybe a
boundedBelow

instance DiscreteOrdered Ordering where
   adjacent :: Ordering -> Ordering -> Bool
adjacent = Ordering -> Ordering -> Bool
forall a. (Ord a, Enum a) => a -> a -> Bool
boundedAdjacent
   adjacentBelow :: Ordering -> Maybe Ordering
adjacentBelow = Ordering -> Maybe Ordering
forall a. (Eq a, Enum a, Bounded a) => a -> Maybe a
boundedBelow

instance DiscreteOrdered Char where
   adjacent :: Char -> Char -> Bool
adjacent = Char -> Char -> Bool
forall a. (Ord a, Enum a) => a -> a -> Bool
boundedAdjacent
   adjacentBelow :: Char -> Maybe Char
adjacentBelow = Char -> Maybe Char
forall a. (Eq a, Enum a, Bounded a) => a -> Maybe a
boundedBelow

instance DiscreteOrdered Int where
   adjacent :: Int -> Int -> Bool
adjacent = Int -> Int -> Bool
forall a. (Ord a, Enum a) => a -> a -> Bool
boundedAdjacent
   adjacentBelow :: Int -> Maybe Int
adjacentBelow = Int -> Maybe Int
forall a. (Eq a, Enum a, Bounded a) => a -> Maybe a
boundedBelow

instance DiscreteOrdered Integer where
   adjacent :: Integer -> Integer -> Bool
adjacent = Integer -> Integer -> Bool
forall a. (Ord a, Enum a) => a -> a -> Bool
enumAdjacent
   adjacentBelow :: Integer -> Maybe Integer
adjacentBelow = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> (Integer -> Integer) -> Integer -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer
forall a. Enum a => a -> a
pred

instance DiscreteOrdered Double where
   adjacent :: Double -> Double -> Bool
adjacent Double
_ Double
_ = Bool
False
   adjacentBelow :: Double -> Maybe Double
adjacentBelow = Maybe Double -> Double -> Maybe Double
forall a b. a -> b -> a
const Maybe Double
forall a. Maybe a
Nothing

instance DiscreteOrdered Float where
   adjacent :: Float -> Float -> Bool
adjacent Float
_ Float
_ = Bool
False
   adjacentBelow :: Float -> Maybe Float
adjacentBelow = Maybe Float -> Float -> Maybe Float
forall a b. a -> b -> a
const Maybe Float
forall a. Maybe a
Nothing

instance (Integral a) => DiscreteOrdered (Ratio a) where
   adjacent :: Ratio a -> Ratio a -> Bool
adjacent Ratio a
_ Ratio a
_ = Bool
False
   adjacentBelow :: Ratio a -> Maybe (Ratio a)
adjacentBelow = Maybe (Ratio a) -> Ratio a -> Maybe (Ratio a)
forall a b. a -> b -> a
const Maybe (Ratio a)
forall a. Maybe a
Nothing

instance Ord a => DiscreteOrdered [a] where
   adjacent :: [a] -> [a] -> Bool
adjacent [a]
_ [a]
_ = Bool
False
   adjacentBelow :: [a] -> Maybe [a]
adjacentBelow = Maybe [a] -> [a] -> Maybe [a]
forall a b. a -> b -> a
const Maybe [a]
forall a. Maybe a
Nothing

instance (Ord a, DiscreteOrdered b) => DiscreteOrdered (a, b)
   where
      adjacent :: (a, b) -> (a, b) -> Bool
adjacent (a
x1, b
x2) (a
y1, b
y2) = (a
x1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y1) Bool -> Bool -> Bool
&& b -> b -> Bool
forall a. DiscreteOrdered a => a -> a -> Bool
adjacent b
x2 b
y2
      adjacentBelow :: (a, b) -> Maybe (a, b)
adjacentBelow (a
x1, b
x2) = do -- Maybe monad
         b
x2' <- b -> Maybe b
forall a. DiscreteOrdered a => a -> Maybe a
adjacentBelow b
x2
         (a, b) -> Maybe (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x1, b
x2')

instance (Ord a, Ord b, DiscreteOrdered c) => DiscreteOrdered (a, b, c)
   where
      adjacent :: (a, b, c) -> (a, b, c) -> Bool
adjacent (a
x1, b
x2, c
x3) (a
y1, b
y2, c
y3) =
         (a
x1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y1) Bool -> Bool -> Bool
&& (b
x2 b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
y2) Bool -> Bool -> Bool
&& c -> c -> Bool
forall a. DiscreteOrdered a => a -> a -> Bool
adjacent c
x3 c
y3
      adjacentBelow :: (a, b, c) -> Maybe (a, b, c)
adjacentBelow (a
x1, b
x2, c
x3) = do -- Maybe monad
         c
x3' <- c -> Maybe c
forall a. DiscreteOrdered a => a -> Maybe a
adjacentBelow c
x3
         (a, b, c) -> Maybe (a, b, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x1, b
x2, c
x3')

instance (Ord a, Ord b, Ord c, DiscreteOrdered d) =>
         DiscreteOrdered (a, b, c, d)
   where
      adjacent :: (a, b, c, d) -> (a, b, c, d) -> Bool
adjacent (a
x1, b
x2, c
x3, d
x4) (a
y1, b
y2, c
y3, d
y4) =
         (a
x1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y1) Bool -> Bool -> Bool
&& (b
x2 b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
y2) Bool -> Bool -> Bool
&& (c
x3 c -> c -> Bool
forall a. Eq a => a -> a -> Bool
== c
y3) Bool -> Bool -> Bool
&& d -> d -> Bool
forall a. DiscreteOrdered a => a -> a -> Bool
adjacent d
x4 d
y4
      adjacentBelow :: (a, b, c, d) -> Maybe (a, b, c, d)
adjacentBelow (a
x1, b
x2, c
x3, d
x4) = do -- Maybe monad
         d
x4' <- d -> Maybe d
forall a. DiscreteOrdered a => a -> Maybe a
adjacentBelow d
x4
         (a, b, c, d) -> Maybe (a, b, c, d)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x1, b
x2, c
x3, d
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 :: a -> a -> Bool
enumAdjacent a
x a
y = (a -> a
forall a. Enum a => a -> a
succ a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
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 :: a -> a -> Bool
boundedAdjacent a
x a
y = if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y then a -> a
forall a. Enum a => a -> a
succ a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y else Bool
False


-- | The usual implementation of 'adjacentBelow' for bounded enumerated types.
boundedBelow :: (Eq a, Enum a, Bounded a) => a -> Maybe a
boundedBelow :: a -> Maybe a
boundedBelow a
x = if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Bounded a => a
minBound then Maybe a
forall a. Maybe a
Nothing else a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Enum a => a -> a
pred a
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 (Int -> Boundary a -> ShowS
[Boundary a] -> ShowS
Boundary a -> String
(Int -> Boundary a -> ShowS)
-> (Boundary a -> String)
-> ([Boundary a] -> ShowS)
-> Show (Boundary a)
forall a. Show a => Int -> Boundary a -> ShowS
forall a. Show a => [Boundary a] -> ShowS
forall a. Show a => Boundary a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Boundary a] -> ShowS
$cshowList :: forall a. Show a => [Boundary a] -> ShowS
show :: Boundary a -> String
$cshow :: forall a. Show a => Boundary a -> String
showsPrec :: Int -> Boundary a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Boundary a -> ShowS
Show)

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

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

instance (DiscreteOrdered a) => Eq (Boundary a) where
   Boundary a
b1 == :: Boundary a -> Boundary a -> Bool
== Boundary a
b2  = Boundary a -> Boundary a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Boundary a
b1 Boundary a
b2 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

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

   compare :: Boundary a -> Boundary a -> Ordering
compare Boundary a
boundary1 Boundary a
boundary2 =
      case Boundary a
boundary1 of
         BoundaryAbove a
b1 ->
            case Boundary a
boundary2 of
               BoundaryAbove a
b2 -> a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
b1 a
b2
               BoundaryBelow a
b2 ->
                  if a
b1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
b2
                     then
                        if a -> a -> Bool
forall a. DiscreteOrdered a => a -> a -> Bool
adjacent a
b1 a
b2 then Ordering
EQ else Ordering
LT
                     else Ordering
GT
               Boundary a
BoundaryAboveAll -> Ordering
LT
               Boundary a
BoundaryBelowAll -> Ordering
GT
         BoundaryBelow a
b1 ->
            case Boundary a
boundary2 of
               BoundaryAbove a
b2 ->
                  if a
b1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
b2
                     then
                        if a -> a -> Bool
forall a. DiscreteOrdered a => a -> a -> Bool
adjacent a
b2 a
b1 then Ordering
EQ else Ordering
GT
                     else Ordering
LT
               BoundaryBelow a
b2 -> a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
b1 a
b2
               Boundary a
BoundaryAboveAll -> Ordering
LT
               Boundary a
BoundaryBelowAll -> Ordering
GT
         Boundary a
BoundaryAboveAll ->
            case Boundary a
boundary2 of
               Boundary a
BoundaryAboveAll -> Ordering
EQ
               Boundary a
_        -> Ordering
GT
         Boundary a
BoundaryBelowAll ->
            case Boundary a
boundary2 of
               Boundary a
BoundaryBelowAll -> Ordering
EQ
               Boundary a
_        -> Ordering
LT

-- QuickCheck Generator

instance Arbitrary a => Arbitrary (Boundary a) where
   arbitrary :: Gen (Boundary a)
arbitrary = [(Int, Gen (Boundary a))] -> Gen (Boundary a)
forall a. [(Int, Gen a)] -> Gen a
frequency [
      (Int
1, Boundary a -> Gen (Boundary a)
forall (m :: * -> *) a. Monad m => a -> m a
return Boundary a
forall a. Boundary a
BoundaryAboveAll),
      (Int
1, Boundary a -> Gen (Boundary a)
forall (m :: * -> *) a. Monad m => a -> m a
return Boundary a
forall a. Boundary a
BoundaryBelowAll),
      (Int
18, do
         a
v <- Gen a
forall a. Arbitrary a => Gen a
arbitrary
         [Gen (Boundary a)] -> Gen (Boundary a)
forall a. [Gen a] -> Gen a
oneof [Boundary a -> Gen (Boundary a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Boundary a -> Gen (Boundary a)) -> Boundary a -> Gen (Boundary a)
forall a b. (a -> b) -> a -> b
$ a -> Boundary a
forall a. a -> Boundary a
BoundaryAbove a
v, Boundary a -> Gen (Boundary a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Boundary a -> Gen (Boundary a)) -> Boundary a -> Gen (Boundary a)
forall a b. (a -> b) -> a -> b
$ a -> Boundary a
forall a. a -> Boundary a
BoundaryBelow a
v]
      )]

instance CoArbitrary a => CoArbitrary (Boundary a) where
   coarbitrary :: Boundary a -> Gen b -> Gen b
coarbitrary Boundary a
BoundaryBelowAll   = Int -> Gen b -> Gen b
forall n a. Integral n => n -> Gen a -> Gen a
variant (Int
0 :: Int)
   coarbitrary Boundary a
BoundaryAboveAll   = Int -> Gen b -> Gen b
forall n a. Integral n => n -> Gen a -> Gen a
variant (Int
1 :: Int)
   coarbitrary (BoundaryBelow a
v)  = Int -> Gen b -> Gen b
forall n a. Integral n => n -> Gen a -> Gen a
variant (Int
2 :: Int) (Gen b -> Gen b) -> (Gen b -> Gen b) -> Gen b -> Gen b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
coarbitrary a
v
   coarbitrary (BoundaryAbove a
v)  = Int -> Gen b -> Gen b
forall n a. Integral n => n -> Gen a -> Gen a
variant (Int
3 :: Int) (Gen b -> Gen b) -> (Gen b -> Gen b) -> Gen b -> Gen b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
coarbitrary a
v