ideas-0.7: src/Domain/Math/Data/Interval.hs
-----------------------------------------------------------------------------
-- Copyright 2010, Open Universiteit Nederland. This file is distributed
-- under the terms of the GNU General Public License. For more information,
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
-- Support for mathematical intervals (open, closed, unbounded). @Intervals@
-- is a normalized (and sorted) list of intervals that supports testing for
-- equality.
--
-----------------------------------------------------------------------------
module Domain.Math.Data.Interval
( -- Data types
Intervals, Interval
-- Interval constructors
, empty, singleton, unbounded, open, closed
, leftOpen, rightOpen, greaterThan, greaterThanOrEqualTo
, lessThan, lessThanOrEqualTo
-- Inspecing an interval
, isEmpty, leftPoint, rightPoint, Endpoint(..)
-- Making intervals
, except, toList, fromList
, union, intersect, complement
, isIn, isInInterval
-- QuickChecks
, testMe
) where
import Common.TestSuite
import Common.Utils (commaList)
import Control.Monad
import Data.Maybe
import Test.QuickCheck
--------------------------------------------------------------------
-- Data declarations
newtype Intervals a = IS [Interval a]
deriving Eq
data Interval a = Empty | I (Endpoint a) (Endpoint a)
deriving Eq
data Endpoint a = Excluding a | Including a | Unbounded
deriving Eq
instance Show a => Show (Intervals a) where
show xs = "{ " ++ commaList (map show (toList xs)) ++ " }"
instance Show a => Show (Interval a) where
show interval =
case interval of
Empty -> "{}"
I 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
instance Functor Interval where
fmap _ Empty = Empty
fmap f (I a b) = I (fmap f a) (fmap f b) -- function should not change order
instance Functor Intervals where
fmap f (IS xs) = IS (map (fmap f) xs)
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)"
--------------------------------------------------------------------
-- Interval constructors
empty :: Interval a
empty = Empty
singleton :: Ord a => a -> Interval a
singleton a = closed a 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)
-- local constructor
makeInterval :: Ord a => Endpoint a -> Endpoint a -> Interval a
makeInterval pl pr =
case liftM2 compare (getPoint pl) (getPoint pr) of
Just LT -> I pl pr
Just EQ
| isIncluding pl && isIncluding pr -> I pl pr
| otherwise -> Empty
Just GT -> Empty
Nothing -> I pl pr
isIncluding :: Endpoint a -> Bool
isIncluding (Including _) = True
isIncluding _ = False
isExcluding :: Endpoint a -> Bool
isExcluding (Excluding _) = True
isExcluding _ = False
--------------------------------------------------------------------
-- Inspecting an interval
isEmpty :: Interval a -> Bool
isEmpty Empty = True
isEmpty _ = False
leftPoint, rightPoint :: Interval a -> Endpoint a
leftPoint (I a _) = a
leftPoint Empty = error "leftPoint Empty"
rightPoint (I _ a) = a
rightPoint Empty = error "rightPoint Empty"
--------------------------------------------------------------------
-- Combining multiple intervals
except :: Ord a => a -> Intervals a
except a = fromList [lessThan a, greaterThan a]
toList :: Intervals a -> [Interval a]
toList (IS xs) = xs
fromList :: Ord a => [Interval a] -> Intervals a
fromList = foldr insert (IS [])
insert :: Ord a => Interval a -> Intervals a -> Intervals a
insert Empty xs = xs
insert iv@(I l _) (IS xs) = rec xs
where
rec [] = IS [iv]
rec (hd:rest) =
case (hd, merge iv hd) of
(Empty, _) -> rec rest
(_, Just new) -> insert new (IS rest)
(I a _, Nothing)
| minPointLeft a l == a -> let IS tl = rec rest in IS (hd:tl)
| otherwise -> IS (iv:hd:rest)
union :: Ord a => Intervals a -> Intervals a -> Intervals a
union xs = foldr insert xs . toList
intersect :: Ord a => Intervals a -> Intervals a -> Intervals a
intersect (IS xs) (IS ys) = fromList (f xs ys)
where
f (a@(I _ ar):as) (b@(I _ br):bs) = inBoth a b : rest
where
rest | maxPointRight ar br == ar = f (a:as) bs
| otherwise = f as (b:bs)
f _ _ = []
complement :: Ord a => Intervals a -> Intervals a
complement (IS xs) = fromList (left ++ zipWith f xs (drop 1 xs) ++ right)
where
f (I _ a) (I b _) = fromMaybe Empty (liftM2 I (g a) (g b))
f _ _ = Empty
g (Including a) = Just (Excluding a)
g (Excluding a) = Just (Including a)
g Unbounded = Nothing
left = case xs of
I al _:_ -> maybe [] (return . I Unbounded) (g al)
_ -> [unbounded]
right = case reverse xs of
I _ ar:_ -> maybe [] (return . flip I Unbounded) (g ar)
_ -> [unbounded]
isIn :: Ord a => a -> Intervals a -> Bool
isIn a (IS xs) = any (isInInterval a) xs
isInInterval :: Ord a => a -> Interval a -> Bool
isInInterval _ Empty = False
isInInterval a (I x y) = f GT x && f LT y
where
f value b =
let g c = (c==EQ && isIncluding b) || c==value
in maybe True (g . compare a) (getPoint b)
---------------------------------------------------------------------
-- Local helper functions
getPoint :: Endpoint a -> Maybe a
getPoint (Including a) = Just a
getPoint (Excluding a) = Just a
getPoint Unbounded = Nothing
merge :: Ord a => Interval a -> Interval a -> Maybe (Interval a)
merge a Empty = Just a
merge Empty b = Just b
merge ia@(I al ar) ib@(I bl br)
| minPointLeft al bl /= al = merge ib ia
| otherwise =
case liftM2 compare (getPoint ar) (getPoint bl) of
Just LT -> Nothing
Just EQ
| isIncluding ar || isIncluding bl -> ok
| otherwise -> Nothing
Just GT -> ok
Nothing -> ok
where
ok = Just (I al (maxPointRight ar br))
inBoth :: Ord a => Interval a -> Interval a -> Interval a
inBoth _ Empty = Empty
inBoth Empty _ = Empty
inBoth (I al ar) (I bl br) = makeInterval (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 liftM2 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)
---------------------------------------------------------------------
-- QuickCheck
instance (Arbitrary a, Ord a) => Arbitrary (Endpoint a) where
arbitrary = frequency
[ (2, liftM Excluding arbitrary)
, (2, liftM 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 = frequency
[ (1, return Empty)
, (5, liftM2 makeInterval arbitrary arbitrary)
]
instance (CoArbitrary a, Ord a) => CoArbitrary (Interval a) where
coarbitrary Empty = variant (0 :: Int)
coarbitrary (I a b) = variant (1 :: Int) . coarbitrary a . coarbitrary b
instance (Arbitrary a, Ord a) => Arbitrary (Intervals a) where
arbitrary = do
n <- choose (0, 100)
xs <- replicateM n arbitrary
return (fromList xs)
instance (CoArbitrary a, Ord a) => CoArbitrary (Intervals a) where
coarbitrary (IS xs) = coarbitrary xs
testMe :: TestSuite
testMe = suite "Intervals" $ do
suite "Constructor functions" $ do
addProperty "empty" $ op0 empty (const False)
addProperty "unbounded" $ op0 unbounded (const True)
addProperty "greater than" $ op1 greaterThan (>)
addProperty "greater than or equal to" $ op1 greaterThanOrEqualTo (>=)
addProperty "less than" $ op1 lessThan (<)
addProperty "less than or equal to" $ op1 lessThanOrEqualTo (<=)
addProperty "singleton" $ op1 singleton (==)
addProperty "open" $ op2 open (<) (<)
addProperty "closed" $ op2 closed (<=) (<=)
addProperty "left open" $ op2 leftOpen (<) (<=)
addProperty "right open" $ op2 rightOpen (<=) (<)
suite "From/to lists" $ do
addProperty "" fromTo1
addProperty "" fromTo2
suite "Combinators" $ do
addProperty "except" defExcept
addProperty "union" defUnion
addProperty "intersect" defIntersect
addProperty "complement" defComplement
suite "Combinator properties" $ do
addProperty "inverse complement" $ selfInverse complement
addProperty "transitive union" $ transitive union
addProperty "commutative union" $ commutative union
addProperty "absorption union" $ absorption union
addProperty "transitive intersect" $ transitive intersect
addProperty "commutative intersect" $ commutative intersect
addProperty "absorption intersect" $ absorption intersect
fromTo1, fromTo2 :: Intervals Int -> Bool
fromTo1 a = fromList (toList a) == a
fromTo2 a = fromList (reverse (toList a)) == a
defExcept :: Int -> Int -> Bool
defExcept a b = isIn a (except b) == (a/=b)
defUnion, defIntersect :: Int -> Intervals Int -> Intervals 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 -> Intervals Int -> Bool
defComplement a b = isIn a (complement b) == not (isIn a b)
op0 :: Interval Int -> (Int -> Bool) -> Int -> Bool
op0 g p a = isInInterval a g == p a
op1 :: (Int -> Interval Int) -> (Int -> Int -> Bool) -> Int -> Int -> Bool
op1 g op a b = isInInterval 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 = isInInterval a (g b c) == (b `opl` a && a `opr` c)
transitive :: (Intervals Int -> Intervals Int -> Intervals Int) -> Intervals Int -> Intervals Int -> Intervals Int -> Bool
transitive op a b c = op a (op b c) == op (op a b) c
commutative :: (Intervals Int -> Intervals Int -> Intervals Int) -> Intervals Int -> Intervals Int -> Bool
commutative op a b = op a b == op b a
absorption :: (Intervals Int -> Intervals Int -> Intervals Int) -> Intervals Int -> Bool
absorption op a = op a a == a
selfInverse :: (Intervals Int -> Intervals Int) -> Intervals Int -> Bool
selfInverse op a = op (op a) == a