module Data.Ranged.Boundaries (
DiscreteOrdered,
adjacent,
enumAdjacent,
boundedAdjacent,
Boundary (..),
above,
(/>/)
) where
import Data.Ratio
import Test.QuickCheck
infix 4 />/
class Ord a => DiscreteOrdered a where
adjacent :: a -> a -> Bool
instance DiscreteOrdered Bool where adjacent = boundedAdjacent
instance DiscreteOrdered Ordering where adjacent = boundedAdjacent
instance DiscreteOrdered Char where adjacent = boundedAdjacent
instance DiscreteOrdered Int where adjacent = boundedAdjacent
instance DiscreteOrdered Integer where adjacent = enumAdjacent
instance Integral a => DiscreteOrdered (Ratio a)
where adjacent _ _ = False
instance DiscreteOrdered Float where adjacent _ _ = False
instance DiscreteOrdered Double where adjacent _ _ = False
instance Ord a => DiscreteOrdered [a] where adjacent _ _ = False
instance (Ord a, DiscreteOrdered b) => DiscreteOrdered (a, b)
where adjacent (x1, x2) (y1, y2) = (x1 == y1) && adjacent x2 y2
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
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
enumAdjacent :: (Ord a, Enum a) => a -> a -> Bool
enumAdjacent x y = (succ x == y)
boundedAdjacent :: (Ord a, Enum a) => a -> a -> Bool
boundedAdjacent x y = if x < y then succ x == y else False
data Boundary a =
BoundaryAbove a |
BoundaryBelow a |
BoundaryAboveAll |
BoundaryBelowAll
deriving (Show)
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
(/>/) :: 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
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
otherwise -> GT
BoundaryBelowAll ->
case boundary2 of
BoundaryBelowAll -> EQ
otherwise -> LT
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]
)]
coarbitrary BoundaryBelowAll = variant 0
coarbitrary BoundaryAboveAll = variant 1
coarbitrary (BoundaryBelow v) = variant 2 . coarbitrary v
coarbitrary (BoundaryAbove v) = variant 3 . coarbitrary v