ideas-0.6: 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.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 b c) = f GT b && f LT c
where
f value x =
let g c = (c==EQ && isIncluding x) || c==value
in maybe True (g . compare a) (getPoint x)
---------------------------------------------------------------------
-- 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 . coarbitrary a
coarbitrary (Including a) = variant 1 . coarbitrary a
coarbitrary Unbounded = variant 2
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
coarbitrary (I a b) = variant 1 . 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 :: IO ()
testMe = do
putStrLn "** Intervals"
-- Constructor functions
quickCheck $ op0 empty (const False)
quickCheck $ op0 unbounded (const True)
quickCheck $ op1 greaterThan (>)
quickCheck $ op1 greaterThanOrEqualTo (>=)
quickCheck $ op1 lessThan (<)
quickCheck $ op1 lessThanOrEqualTo (<=)
quickCheck $ op1 singleton (==)
quickCheck $ op2 open (<) (<)
quickCheck $ op2 closed (<=) (<=)
quickCheck $ op2 leftOpen (<) (<=)
quickCheck $ op2 rightOpen (<=) (<)
-- From/to lists
quickCheck fromTo1
quickCheck fromTo2
-- Combinators
quickCheck defExcept
quickCheck defUnion
quickCheck defIntersect
quickCheck defComplement
-- Combinator properties
quickCheck $ selfInverse complement
quickCheck $ transitive union
quickCheck $ commutative union
quickCheck $ absorption union
quickCheck $ transitive intersect
quickCheck $ commutative intersect
quickCheck $ 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