{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-}
{-# LANGUAGE Safe #-}
module Data.IntegerInterval
(
IntegerInterval
, module Data.ExtendedReal
, interval
, (<=..<=)
, (<..<=)
, (<=..<)
, (<..<)
, whole
, empty
, singleton
, null
, member
, notMember
, isSubsetOf
, isProperSubsetOf
, lowerBound
, upperBound
, lowerBound'
, upperBound'
, width
, (<!), (<=!), (==!), (>=!), (>!), (/=!)
, (<?), (<=?), (==?), (>=?), (>?), (/=?)
, (<??), (<=??), (==??), (>=??), (>??), (/=??)
, intersection
, intersections
, hull
, hulls
, mapMonotonic
, pickup
, simplestIntegerWithin
, toInterval
, fromInterval
, fromIntervalOver
, fromIntervalUnder
) where
import Algebra.Lattice
import Control.Exception (assert)
import Control.Monad hiding (join)
import Data.ExtendedReal
import Data.List hiding (null)
import Data.Maybe
import Prelude hiding (null)
import Data.IntegerInterval.Internal
import qualified Data.Interval as Interval
infix 5 <..<=
infix 5 <=..<
infix 5 <..<
infix 4 <!
infix 4 <=!
infix 4 ==!
infix 4 >=!
infix 4 >!
infix 4 /=!
infix 4 <?
infix 4 <=?
infix 4 ==?
infix 4 >=?
infix 4 >?
infix 4 /=?
infix 4 <??
infix 4 <=??
infix 4 ==??
infix 4 >=??
infix 4 >??
infix 4 /=??
lowerBound' :: IntegerInterval -> (Extended Integer, Bool)
lowerBound' x =
case lowerBound x of
lb@(Finite _) -> (lb, True)
lb@_ -> (lb, False)
upperBound' :: IntegerInterval -> (Extended Integer, Bool)
upperBound' x =
case upperBound x of
ub@(Finite _) -> (ub, True)
ub@_ -> (ub, False)
#if MIN_VERSION_lattices(2,0,0)
instance Lattice IntegerInterval where
(\/) = hull
(/\) = intersection
instance BoundedJoinSemiLattice IntegerInterval where
bottom = empty
instance BoundedMeetSemiLattice IntegerInterval where
top = whole
#else
instance JoinSemiLattice IntegerInterval where
join = hull
instance MeetSemiLattice IntegerInterval where
meet = intersection
instance Lattice IntegerInterval
instance BoundedJoinSemiLattice IntegerInterval where
bottom = empty
instance BoundedMeetSemiLattice IntegerInterval where
top = whole
instance BoundedLattice IntegerInterval
#endif
instance Show IntegerInterval where
showsPrec _ x | null x = showString "empty"
showsPrec p x =
showParen (p > rangeOpPrec) $
showsPrec (rangeOpPrec+1) (lowerBound x) .
showString " <=..<= " .
showsPrec (rangeOpPrec+1) (upperBound x)
instance Read IntegerInterval where
readsPrec p r =
(readParen (p > appPrec) $ \s0 -> do
("interval",s1) <- lex s0
(lb,s2) <- readsPrec (appPrec+1) s1
(ub,s3) <- readsPrec (appPrec+1) s2
return (interval lb ub, s3)) r
++
(readParen (p > rangeOpPrec) $ \s0 -> do
(do (lb,s1) <- readsPrec (rangeOpPrec+1) s0
("<=..<=",s2) <- lex s1
(ub,s3) <- readsPrec (rangeOpPrec+1) s2
return (lb <=..<= ub, s3))) r
++
(do ("empty", s) <- lex r
return (empty, s))
interval
:: (Extended Integer, Bool)
-> (Extended Integer, Bool)
-> IntegerInterval
interval (x1,in1) (x2,in2) =
(if in1 then x1 else x1 + 1) <=..<= (if in2 then x2 else x2 - 1)
(<..<=)
:: Extended Integer
-> Extended Integer
-> IntegerInterval
(<..<=) lb ub = (lb+1) <=..<= ub
(<=..<)
:: Extended Integer
-> Extended Integer
-> IntegerInterval
(<=..<) lb ub = lb <=..<= ub-1
(<..<)
:: Extended Integer
-> Extended Integer
-> IntegerInterval
(<..<) lb ub = lb+1 <=..<= ub-1
whole :: IntegerInterval
whole = NegInf <=..<= PosInf
singleton :: Integer -> IntegerInterval
singleton x = Finite x <=..<= Finite x
intersection :: IntegerInterval -> IntegerInterval -> IntegerInterval
intersection x1 x2 =
max (lowerBound x1) (lowerBound x2) <=..<= min (upperBound x1) (upperBound x2)
intersections :: [IntegerInterval] -> IntegerInterval
intersections = foldl' intersection whole
hull :: IntegerInterval -> IntegerInterval -> IntegerInterval
hull x1 x2
| null x1 = x2
| null x2 = x1
hull x1 x2 =
min (lowerBound x1) (lowerBound x2) <=..<= max (upperBound x1) (upperBound x2)
hulls :: [IntegerInterval] -> IntegerInterval
hulls = foldl' hull empty
mapMonotonic :: (Integer -> Integer) -> IntegerInterval -> IntegerInterval
mapMonotonic f x = fmap f (lowerBound x) <=..<= fmap f (upperBound x)
null :: IntegerInterval -> Bool
null x = upperBound x < lowerBound x
isSingleton :: IntegerInterval -> Bool
isSingleton x = lowerBound x == upperBound x
member :: Integer -> IntegerInterval -> Bool
member x i = lowerBound i <= Finite x && Finite x <= upperBound i
notMember :: Integer -> IntegerInterval -> Bool
notMember a i = not $ member a i
isSubsetOf :: IntegerInterval -> IntegerInterval -> Bool
isSubsetOf i1 i2 = lowerBound i2 <= lowerBound i1 && upperBound i1 <= upperBound i2
isProperSubsetOf :: IntegerInterval -> IntegerInterval -> Bool
isProperSubsetOf i1 i2 = i1 /= i2 && i1 `isSubsetOf` i2
width :: IntegerInterval -> Integer
width x
| null x = 0
| otherwise =
case (upperBound x, lowerBound x) of
(Finite lb, Finite ub) -> ub - lb
_ -> error "Data.IntegerInterval.width: unbounded interval"
pickup :: IntegerInterval -> Maybe Integer
pickup x =
case (lowerBound x, upperBound x) of
(NegInf, PosInf) -> Just 0
(Finite l, _) -> Just l
(_, Finite u) -> Just u
_ -> Nothing
simplestIntegerWithin :: IntegerInterval -> Maybe Integer
simplestIntegerWithin i
| null i = Nothing
| 0 <! i = Just $ let Finite x = lowerBound i in x
| i <! 0 = Just $ let Finite x = upperBound i in x
| otherwise = assert (0 `member` i) $ Just 0
(<!) :: IntegerInterval -> IntegerInterval -> Bool
a <! b = a+1 <=! b
(<=!) :: IntegerInterval -> IntegerInterval -> Bool
a <=! b = upperBound a <= lowerBound b
(==!) :: IntegerInterval -> IntegerInterval -> Bool
a ==! b = a <=! b && a >=! b
(/=!) :: IntegerInterval -> IntegerInterval -> Bool
a /=! b = null $ a `intersection` b
(>=!) :: IntegerInterval -> IntegerInterval -> Bool
(>=!) = flip (<=!)
(>!) :: IntegerInterval -> IntegerInterval -> Bool
(>!) = flip (<!)
(<?) :: IntegerInterval -> IntegerInterval -> Bool
a <? b = lowerBound a < upperBound b
(<??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer, Integer)
a <?? b = do
(x,y) <- a+1 <=?? b
return (x-1,y)
(<=?) :: IntegerInterval -> IntegerInterval -> Bool
a <=? b =
case lb_a `compare` ub_b of
LT -> True
GT -> False
EQ ->
case lb_a of
NegInf -> False
PosInf -> False
Finite _ -> True
where
lb_a = lowerBound a
ub_b = upperBound b
(<=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer,Integer)
a <=?? b =
case pickup (intersection a b) of
Just x -> return (x,x)
Nothing -> do
guard $ upperBound a <= lowerBound b
x <- pickup a
y <- pickup b
return (x,y)
(==?) :: IntegerInterval -> IntegerInterval -> Bool
a ==? b = not $ null $ intersection a b
(==??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer,Integer)
a ==?? b = do
x <- pickup (intersection a b)
return (x,x)
(/=?) :: IntegerInterval -> IntegerInterval -> Bool
a /=? b = not (null a) && not (null b) && not (a == b && isSingleton a)
(/=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer,Integer)
a /=?? b = do
guard $ not $ null a
guard $ not $ null b
guard $ not $ a == b && isSingleton a
if not (isSingleton b)
then f a b
else liftM (\(y,x) -> (x,y)) $ f b a
where
f a b = do
x <- pickup a
y <- msum [pickup (b `intersection` c) | c <- [-inf <..< Finite x, Finite x <..< inf]]
return (x,y)
(>=?) :: IntegerInterval -> IntegerInterval -> Bool
(>=?) = flip (<=?)
(>?) :: IntegerInterval -> IntegerInterval -> Bool
(>?) = flip (<?)
(>=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer, Integer)
(>=??) = flip (<=??)
(>??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer, Integer)
(>??) = flip (<??)
appPrec :: Int
appPrec = 10
rangeOpPrec :: Int
rangeOpPrec = 5
scaleInterval :: Integer -> IntegerInterval -> IntegerInterval
scaleInterval _ x | null x = empty
scaleInterval c x =
case compare c 0 of
EQ -> singleton 0
LT -> Finite c * upperBound x <=..<= Finite c * lowerBound x
GT -> Finite c * lowerBound x <=..<= Finite c * upperBound x
instance Num IntegerInterval where
a + b
| null a || null b = empty
| otherwise = lowerBound a + lowerBound b <=..<= upperBound a + upperBound b
negate = scaleInterval (-1)
fromInteger i = singleton (fromInteger i)
abs x = (x `intersection` nonneg) `hull` (negate x `intersection` nonneg)
where
nonneg = 0 <=..< inf
signum x = zero `hull` pos `hull` neg
where
zero = if member 0 x then singleton 0 else empty
pos = if null $ (0 <..< inf) `intersection` x
then empty
else singleton 1
neg = if null $ (-inf <..< 0) `intersection` x
then empty
else singleton (-1)
a * b
| null a || null b = empty
| otherwise = minimum xs <=..<= maximum xs
where
xs = [ mul x1 x2 | x1 <- [lowerBound a, upperBound a], x2 <- [lowerBound b, upperBound b] ]
mul :: Extended Integer -> Extended Integer -> Extended Integer
mul 0 _ = 0
mul _ 0 = 0
mul x1 x2 = x1*x2
toInterval :: Real r => IntegerInterval -> Interval.Interval r
toInterval x = fmap fromInteger (lowerBound x) Interval.<=..<= fmap fromInteger (upperBound x)
fromInterval :: Interval.Interval Integer -> IntegerInterval
fromInterval i = (if in1 then x1 else x1 + 1) <=..<= (if in2 then x2 else x2 - 1)
where
(x1,in1) = Interval.lowerBound' i
(x2,in2) = Interval.upperBound' i
fromIntervalOver :: RealFrac r => Interval.Interval r -> IntegerInterval
fromIntervalOver i = fmap floor lb <=..<= fmap ceiling ub
where
lb = Interval.lowerBound i
ub = Interval.upperBound i
fromIntervalUnder :: RealFrac r => Interval.Interval r -> IntegerInterval
fromIntervalUnder i = fmap f lb <=..<= fmap g ub
where
lb = Interval.lowerBound i
ub = Interval.upperBound i
f x = if fromIntegral y `Interval.member` i then y else y+1
where
y = ceiling x
g x = if fromIntegral y `Interval.member` i then y else y-1
where
y = floor x