{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-}
{-# LANGUAGE Safe #-}
module Data.IntegerInterval
(
IntegerInterval
, module Data.ExtendedReal
, Boundary(..)
, interval
, (<=..<=)
, (<..<=)
, (<=..<)
, (<..<)
, whole
, empty
, singleton
, null
, isSingleton
, 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 Data.Interval (Boundary(..))
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, Boundary)
lowerBound' x =
case lowerBound x of
lb@(Finite _) -> (lb, Closed)
lb@_ -> (lb, Open)
upperBound' :: IntegerInterval -> (Extended Integer, Boundary)
upperBound' x =
case upperBound x of
ub@(Finite _) -> (ub, Closed)
ub@_ -> (ub, Open)
#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, Boundary)
-> (Extended Integer, Boundary)
-> IntegerInterval
interval (x1,in1) (x2,in2) =
(if in1 == Closed then x1 else x1 + 1) <=..<= (if in2 == Closed 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 i j = do
x <- pickup i
y <- msum [pickup (j `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 = x1' <=..<= x2'
where
(x1,in1) = Interval.lowerBound' i
(x2,in2) = Interval.upperBound' i
x1' = case in1 of
Interval.Open -> x1 + 1
Interval.Closed -> x1
x2' = case in2 of
Interval.Open -> x2 - 1
Interval.Closed -> x2
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