module Domain.Math.Data.Interval
(
Interval, Endpoint(..)
, empty, point, unbounded, open, closed
, leftOpen, rightOpen, greaterThan, greaterThanOrEqualTo
, lessThan, lessThanOrEqualTo, true, false
, except, union, intersect, complement
, segments, isIn
, testMe
) where
import Control.Monad
import Data.List (intercalate)
import Data.Maybe
import Domain.Algebra.Boolean
import Domain.Algebra.BooleanLaws
import Domain.Algebra.Law
import Ideas.Utils.TestSuite
import Test.QuickCheck
newtype Interval a = I [Segment a]
deriving Eq
data Segment a = S (Endpoint a) (Endpoint a)
deriving Eq
data Endpoint a = Excluding a | Including a | Unbounded
deriving (Eq,Show)
instance Ord a => BoolValue (Interval a) where
fromBool b = if b then unbounded else empty
isTrue = (==true)
isFalse = (==false)
instance Ord a => Boolean (Interval a) where
(<&&>) = intersect
(<||>) = union
complement = complementIntervals
instance Show a => Show (Interval a) where
show (I xs) = "{ " ++ intercalate ", " (map show xs) ++ " }"
instance Show a => Show (Segment a) where
show (S a b) = showLeft a ++ "," ++ showRight b
instance Functor Endpoint where
fmap f (Excluding a) = Excluding (f a)
fmap f (Including a) = Including (f a)
fmap _ Unbounded = Unbounded
showLeft, showRight :: Show a => Endpoint a -> String
showLeft (Excluding a) = '(' : show a
showLeft (Including a) = '[' : show a
showLeft Unbounded = "(-inf"
showRight (Excluding a) = show a ++ ")"
showRight (Including a) = show a ++ "]"
showRight Unbounded = "inf)"
empty :: Interval a
empty = I []
point :: a -> Interval a
point a = I [S (Including a) (Including a)]
unbounded :: Ord a => Interval a
unbounded = makeInterval Unbounded Unbounded
open :: Ord a => a -> a -> Interval a
open a b = makeInterval (Excluding a) (Excluding b)
closed :: Ord a => a -> a -> Interval a
closed a b = makeInterval (Including a) (Including b)
leftOpen :: Ord a => a -> a -> Interval a
leftOpen a b = makeInterval (Excluding a) (Including b)
rightOpen :: Ord a => a -> a -> Interval a
rightOpen a b = makeInterval (Including a) (Excluding b)
greaterThan :: Ord a => a -> Interval a
greaterThan a = makeInterval (Excluding a) Unbounded
greaterThanOrEqualTo :: Ord a => a -> Interval a
greaterThanOrEqualTo a = makeInterval (Including a) Unbounded
lessThan :: Ord a => a -> Interval a
lessThan a = makeInterval Unbounded (Excluding a)
lessThanOrEqualTo :: Ord a => a -> Interval a
lessThanOrEqualTo a = makeInterval Unbounded (Including a)
makeInterval :: Ord a => Endpoint a -> Endpoint a -> Interval a
makeInterval pl pr = maybe empty (I . return) (makeSegment pl pr)
makeSegment :: Ord a => Endpoint a -> Endpoint a -> Maybe (Segment a)
makeSegment pl pr =
case compare <$> getPoint pl <*> getPoint pr of
Just EQ
| isExcluding pl -> Nothing
| isExcluding pr -> Nothing
Just GT -> Nothing
_ -> Just (S pl pr)
isIncluding :: Endpoint a -> Bool
isIncluding (Including _) = True
isIncluding _ = False
isExcluding :: Endpoint a -> Bool
isExcluding (Excluding _) = True
isExcluding _ = False
segments :: Interval a -> [(Endpoint a, Endpoint a)]
segments (I xs) = [ (a, b) | S a b <- xs ]
except :: Ord a => a -> Interval a
except a = lessThan a <||> greaterThan a
insert :: Ord a => Segment a -> Interval a -> Interval a
insert ia (I xs) = I (rec ia xs)
where
rec iv [] = [iv]
rec iv@(S a _) (hd@(S b _):rest) =
case merge iv hd of
Just new -> rec new rest
Nothing
| minPointLeft b a == b -> hd:rec iv rest
| otherwise -> iv:hd:rest
union :: Ord a => Interval a -> Interval a -> Interval a
union xs (I ys) = foldr insert xs ys
intersect :: Ord a => Interval a -> Interval a -> Interval a
intersect (I xs) (I ys) = I (f xs ys)
where
f (a@(S _ ar):as) (b@(S _ br):bs) =
let cond = maxPointRight ar br == ar
rest | cond = f (a:as) bs
| otherwise = f as (b:bs)
in maybe id (:) (inBoth a b) rest
f _ _ = []
complementIntervals :: Ord a => Interval a -> Interval a
complementIntervals (I xs)
| null xs = unbounded
| otherwise = I $ catMaybes $
left (head xs) : zipWith f xs (drop 1 xs) ++ [right (last xs)]
where
f (S _ a) (S b _) = S <$> g a <*> g b
g (Including a) = Just (Excluding a)
g (Excluding a) = Just (Including a)
g Unbounded = Nothing
left (S al _) = fmap (S Unbounded) (g al)
right (S _ ar) = fmap (flip S Unbounded) (g ar)
isIn :: Ord a => a -> Interval a -> Bool
isIn a (I xs) = any p xs
where
p (S x y) = f GT x && f LT y
f value b =
let g c = (c==EQ && isIncluding b) || c==value
in maybe True (g . compare a) (getPoint b)
getPoint :: Endpoint a -> Maybe a
getPoint (Including a) = Just a
getPoint (Excluding a) = Just a
getPoint Unbounded = Nothing
merge :: Ord a => Segment a -> Segment a -> Maybe (Segment a)
merge ia@(S al ar) ib@(S bl br)
| minPointLeft al bl /= al = merge ib ia
| otherwise =
case compare <$> getPoint ar <*> getPoint bl of
Just LT -> Nothing
Just EQ | isExcluding ar && isExcluding bl -> Nothing
_ -> Just (S al (maxPointRight ar br))
inBoth :: Ord a => Segment a -> Segment a -> Maybe (Segment a)
inBoth (S al ar) (S bl br) =
makeSegment (maxPointLeft al bl) (minPointRight ar br)
minPointLeft, minPointRight, maxPointLeft, maxPointRight
:: Ord a => Endpoint a -> Endpoint a -> Endpoint a
minPointLeft = compareEndpoint True True
minPointRight = compareEndpoint True False
maxPointLeft = compareEndpoint False False
maxPointRight = compareEndpoint False True
compareEndpoint :: Ord a => Bool -> Bool -> Endpoint a -> Endpoint a -> Endpoint a
compareEndpoint b1 b2 a b =
case compare <$> getPoint a <*> getPoint b of
Just LT -> x
Just EQ | p a -> x
| otherwise -> y
Just GT -> y
Nothing | b2 -> Unbounded
| x==Unbounded -> y
| otherwise -> x
where
p = if b1==b2 then isIncluding else isExcluding
(x, y) = if b1 then (a, b) else (b, a)
instance (Arbitrary a, Ord a) => Arbitrary (Endpoint a) where
arbitrary = frequency
[ (2, Excluding <$> arbitrary)
, (2, Including <$> arbitrary)
, (1, return Unbounded)
]
instance (CoArbitrary a, Ord a) => CoArbitrary (Endpoint a) where
coarbitrary (Excluding a) = variant (0 :: Int) . coarbitrary a
coarbitrary (Including a) = variant (1 :: Int) . coarbitrary a
coarbitrary Unbounded = variant (2 :: Int)
instance (Arbitrary a, Ord a) => Arbitrary (Interval a) where
arbitrary = do
n <- choose (0, 100)
xs <- replicateM n (makeInterval <$> arbitrary <*> arbitrary)
return (ors xs)
instance (CoArbitrary a, Ord a) => CoArbitrary (Segment a) where
coarbitrary (S a b) = coarbitrary a . coarbitrary b
instance (CoArbitrary a, Ord a) => CoArbitrary (Interval a) where
coarbitrary (I xs) = coarbitrary xs
testMe :: TestSuite
testMe = suite "Intervals"
[ suite "Constructor functions"
[ useProperty "empty" $ op0 empty (const False)
, useProperty "unbounded" $ op0 unbounded (const True)
, useProperty "greater than" $ op1 greaterThan (>)
, useProperty "greater than or equal to" $ op1 greaterThanOrEqualTo (>=)
, useProperty "less than" $ op1 lessThan (<)
, useProperty "less than or equal to" $ op1 lessThanOrEqualTo (<=)
, useProperty "point " $ op1 point (==)
, useProperty "open" $ op2 open (<) (<)
, useProperty "closed" $ op2 closed (<=) (<=)
, useProperty "left open" $ op2 leftOpen (<) (<=)
, useProperty "right open" $ op2 rightOpen (<=) (<)
]
, suite "Combinators"
[ useProperty "except" defExcept
, useProperty "union" defUnion
, useProperty "intersect" defIntersect
, useProperty "complement" defComplement
]
, suite "Boolean algebra"
[ useProperty (show p) p
| p <- booleanLaws :: [Law (Interval Int)]
]
]
defExcept :: Int -> Int -> Bool
defExcept a b = isIn a (except b) == (a/=b)
defUnion, defIntersect :: Int -> Interval Int -> Interval Int -> Bool
defUnion a b c = isIn a (b `union` c) == (isIn a b || isIn a c)
defIntersect a b c = isIn a (b `intersect` c) == (isIn a b && isIn a c)
defComplement :: Int -> Interval Int -> Bool
defComplement a b = isIn a (complement b) == not (isIn a b)
op0 :: Interval Int -> (Int -> Bool) -> Int -> Bool
op0 g p a = isIn a g == p a
op1 :: (Int -> Interval Int) -> (Int -> Int -> Bool) -> Int -> Int -> Bool
op1 g op a b = isIn a (g b) == (a `op` b)
op2 :: (Int -> Int -> Interval Int) -> (Int -> Int -> Bool) -> (Int -> Int -> Bool) -> Int -> Int -> Int -> Bool
op2 g opl opr a b c = isIn a (g b c) == (b `opl` a && a `opr` c)