#if __GLASGOW_HASKELL__ >= 704
#endif
module Numeric.Interval.NonEmpty.Internal
( Interval(..)
, (...)
, interval
, whole
, singleton
, elem
, notElem
, inf
, sup
, singular
, width
, midpoint
, distance
, intersection
, hull
, bisect
, bisectIntegral
, magnitude
, mignitude
, contains
, isSubsetOf
, certainly, (<!), (<=!), (==!), (>=!), (>!)
, possibly, (<?), (<=?), (==?), (>=?), (>?)
, clamp
, inflate, deflate
, scale, symmetric
, idouble
, ifloat
) where
import Control.Exception as Exception
import Data.Data
import Data.Foldable hiding (minimum, maximum, elem, notElem)
import Data.Function (on)
import Data.Monoid
#if __GLASGOW_HASKELL__ >= 704
import GHC.Generics
#endif
import Numeric.Interval.Exception
import Prelude hiding (null, elem, notElem)
data Interval a = I !a !a deriving
( Data
, Typeable
#if __GLASGOW_HASKELL__ >= 704
, Generic
#if __GLASGOW_HASKELL__ >= 706
, Generic1
#endif
#endif
)
instance Foldable Interval where
foldMap f (I a b) = f a `mappend` f b
infix 3 ...
negInfinity :: Fractional a => a
negInfinity = (1)/0
posInfinity :: Fractional a => a
posInfinity = 1/0
fmod :: RealFrac a => a -> a -> a
fmod a b = a q*b where
q = realToFrac (truncate $ a / b :: Integer)
(...) :: Ord a => a -> a -> Interval a
a ... b
| a <= b = I a b
| otherwise = I b a
interval :: Ord a => a -> a -> Maybe (Interval a)
interval a b
| a <= b = Just $ I a b
| otherwise = Nothing
whole :: Fractional a => Interval a
whole = I negInfinity posInfinity
singleton :: a -> Interval a
singleton a = I a a
inf :: Interval a -> a
inf (I a _) = a
sup :: Interval a -> a
sup (I _ b) = b
singular :: Ord a => Interval a -> Bool
singular (I a b) = a == b
instance Eq a => Eq (Interval a) where
(==) = (==!)
instance Show a => Show (Interval a) where
showsPrec n (I a b) =
showParen (n > 3) $
showsPrec 3 a .
showString " ... " .
showsPrec 3 b
width :: Num a => Interval a -> a
width (I a b) = b a
magnitude :: (Num a, Ord a) => Interval a -> a
magnitude = sup . abs
mignitude :: (Num a, Ord a) => Interval a -> a
mignitude = inf . abs
instance (Num a, Ord a) => Num (Interval a) where
I a b + I a' b' = (a + a') ... (b + b')
I a b I a' b' = (a b') ... (b a')
I a b * I a' b' =
minimum [a * a', a * b', b * a', b * b']
...
maximum [a * a', a * b', b * a', b * b']
abs x@(I a b)
| a >= 0 = x
| b <= 0 = negate x
| otherwise = 0 ... max ( a) b
signum = increasing signum
fromInteger i = singleton (fromInteger i)
bisect :: Fractional a => Interval a -> (Interval a, Interval a)
bisect (I a b) = (I a m, I m b) where m = a + (b a) / 2
bisectIntegral :: Integral a => Interval a -> (Interval a, Interval a)
bisectIntegral (I a b)
| a == m || b == m = (I a a, I b b)
| otherwise = (I a m, I m b)
where m = a + (b a) `div` 2
midpoint :: Fractional a => Interval a -> a
midpoint (I a b) = a + (b a) / 2
distance :: (Num a, Ord a) => Interval a -> Interval a -> a
distance i1 i2 = mignitude (i1 i2)
elem :: Ord a => a -> Interval a -> Bool
elem x (I a b) = x >= a && x <= b
notElem :: Ord a => a -> Interval a -> Bool
notElem x xs = not (elem x xs)
instance Real a => Real (Interval a) where
toRational (I ra rb) = a + (b a) / 2 where
a = toRational ra
b = toRational rb
instance Ord a => Ord (Interval a) where
compare (I ax bx) (I ay by)
| bx < ay = LT
| ax > by = GT
| bx == ay && ax == by = EQ
| otherwise = Exception.throw AmbiguousComparison
max (I a b) (I a' b') = max a a' ... max b b'
min (I a b) (I a' b') = min a a' ... min b b'
divNonZero :: (Fractional a, Ord a) => Interval a -> Interval a -> Interval a
divNonZero (I a b) (I a' b') =
minimum [a / a', a / b', b / a', b / b']
...
maximum [a / a', a / b', b / a', b / b']
divPositive :: (Fractional a, Ord a) => Interval a -> a -> Interval a
divPositive x@(I a b) y
| a == 0 && b == 0 = x
| b < 0 = negInfinity ... (b / y)
| a < 0 = whole
| otherwise = (a / y) ... posInfinity
divNegative :: (Fractional a, Ord a) => Interval a -> a -> Interval a
divNegative x@(I a b) y
| a == 0 && b == 0 = x
| b < 0 = (b / y) ... posInfinity
| a < 0 = whole
| otherwise = negInfinity ... (a / y)
divZero :: (Fractional a, Ord a) => Interval a -> Interval a
divZero x@(I a b)
| a == 0 && b == 0 = x
| otherwise = whole
instance (Fractional a, Ord a) => Fractional (Interval a) where
x / y@(I a b)
| 0 `notElem` y = divNonZero x y
| iz && sz = Exception.throw DivideByZero
| iz = divPositive x a
| sz = divNegative x b
| otherwise = divZero x
where
iz = a == 0
sz = b == 0
recip (I a b) = on min recip a b ... on max recip a b
fromRational r = let r' = fromRational r in I r' r'
instance RealFrac a => RealFrac (Interval a) where
properFraction x = (b, x fromIntegral b)
where
b = truncate (midpoint x)
ceiling x = ceiling (sup x)
floor x = floor (inf x)
round x = round (midpoint x)
truncate x = truncate (midpoint x)
instance (RealFloat a, Ord a) => Floating (Interval a) where
pi = singleton pi
exp = increasing exp
log (I a b) = (if a > 0 then log a else negInfinity) ... log b
cos x
| width t >= pi = (1) ... 1
| inf t >= pi = cos (t pi)
| sup t <= pi = decreasing cos t
| sup t <= 2 * pi = (1) ... cos ((pi * 2 sup t) `min` inf t)
| otherwise = (1) ... 1
where
t = fmod x (pi * 2)
sin x = cos (x pi / 2)
tan x
| inf t' <= pi / 2 || sup t' >= pi / 2 = whole
| otherwise = increasing tan x
where
t = x `fmod` pi
t' | t >= pi / 2 = t pi
| otherwise = t
asin (I a b) = I (if a <= 1 then halfPi else asin a) (if b >= 1 then halfPi else asin b)
where halfPi = pi / 2
acos (I a b) = I (if b >= 1 then 0 else acos b) (if a < 1 then pi else acos a)
atan = increasing atan
sinh = increasing sinh
cosh x@(I a b)
| b < 0 = decreasing cosh x
| a >= 0 = increasing cosh x
| otherwise = I 0 $ cosh $ if a > b
then a
else b
tanh = increasing tanh
asinh = increasing asinh
acosh (I a b) = I lo $ acosh b
where lo | a <= 1 = 0
| otherwise = acosh a
atanh (I a b) = I (if a <= 1 then negInfinity else atanh a) (if b >= 1 then posInfinity else atanh b)
increasing :: (a -> b) -> Interval a -> Interval b
increasing f (I a b) = I (f a) (f b)
decreasing :: (a -> b) -> Interval a -> Interval b
decreasing f (I a b) = I (f b) (f a)
instance RealFloat a => RealFloat (Interval a) where
floatRadix = floatRadix . midpoint
floatDigits = floatDigits . midpoint
floatRange = floatRange . midpoint
decodeFloat = decodeFloat . midpoint
encodeFloat m e = singleton (encodeFloat m e)
exponent = exponent . midpoint
significand x = min a b ... max a b
where
(_ ,em) = decodeFloat (midpoint x)
(mi,ei) = decodeFloat (inf x)
(ms,es) = decodeFloat (sup x)
a = encodeFloat mi (ei em floatDigits x)
b = encodeFloat ms (es em floatDigits x)
scaleFloat n (I a b) = I (scaleFloat n a) (scaleFloat n b)
isNaN (I a b) = isNaN a || isNaN b
isInfinite (I a b) = isInfinite a || isInfinite b
isDenormalized (I a b) = isDenormalized a || isDenormalized b
isNegativeZero (I a b) = not (a > 0)
&& not (b < 0)
&& ( (b == 0 && (a < 0 || isNegativeZero a))
|| (a == 0 && isNegativeZero a)
|| (a < 0 && b >= 0))
isIEEE _ = False
atan2 = error "unimplemented"
intersection :: Ord a => Interval a -> Interval a -> Maybe (Interval a)
intersection x@(I a b) y@(I a' b')
| x /=! y = Nothing
| otherwise = Just $ I (max a a') (min b b')
hull :: Ord a => Interval a -> Interval a -> Interval a
hull (I a b) (I a' b') = I (min a a') (max b b')
(<!) :: Ord a => Interval a -> Interval a -> Bool
I _ bx <! I ay _ = bx < ay
(<=!) :: Ord a => Interval a -> Interval a -> Bool
I _ bx <=! I ay _ = bx <= ay
(==!) :: Eq a => Interval a -> Interval a -> Bool
I ax bx ==! I ay by = bx == ay && ax == by
(/=!) :: Ord a => Interval a -> Interval a -> Bool
I ax bx /=! I ay by = bx < ay || ax > by
(>!) :: Ord a => Interval a -> Interval a -> Bool
I ax _ >! I _ by = ax > by
(>=!) :: Ord a => Interval a -> Interval a -> Bool
I ax _ >=! I _ by = ax >= by
certainly :: Ord a => (forall b. Ord b => b -> b -> Bool) -> Interval a -> Interval a -> Bool
certainly cmp l r
| lt && eq && gt = True
| lt && eq = l <=! r
| lt && gt = l /=! r
| lt = l <! r
| eq && gt = l >=! r
| eq = l ==! r
| gt = l >! r
| otherwise = False
where
lt = cmp False True
eq = cmp True True
gt = cmp True False
contains :: Ord a => Interval a -> Interval a -> Bool
contains (I ax bx) (I ay by) = ax <= ay && by <= bx
isSubsetOf :: Ord a => Interval a -> Interval a -> Bool
isSubsetOf = flip contains
(<?) :: Ord a => Interval a -> Interval a -> Bool
I ax _ <? I _ by = ax < by
(<=?) :: Ord a => Interval a -> Interval a -> Bool
I ax _ <=? I _ by = ax <= by
(==?) :: Ord a => Interval a -> Interval a -> Bool
I ax bx ==? I ay by = ax <= by && bx >= ay
(/=?) :: Eq a => Interval a -> Interval a -> Bool
I ax bx /=? I ay by = ax /= by || bx /= ay
(>?) :: Ord a => Interval a -> Interval a -> Bool
I _ bx >? I ay _ = bx > ay
(>=?) :: Ord a => Interval a -> Interval a -> Bool
I _ bx >=? I ay _ = bx >= ay
possibly :: Ord a => (forall b. Ord b => b -> b -> Bool) -> Interval a -> Interval a -> Bool
possibly cmp l r
| lt && eq && gt = True
| lt && eq = l <=? r
| lt && gt = l /=? r
| lt = l <? r
| eq && gt = l >=? r
| eq = l ==? r
| gt = l >? r
| otherwise = False
where
lt = cmp LT EQ
eq = cmp EQ EQ
gt = cmp GT EQ
clamp :: Ord a => Interval a -> a -> a
clamp (I a b) x
| x < a = a
| x > b = b
| otherwise = x
inflate :: (Num a, Ord a) => a -> Interval a -> Interval a
inflate x y = symmetric x + y
deflate :: (Fractional a, Ord a) => a -> Interval a -> Interval a
deflate x i@(I a b) | a' <= b' = I a' b'
| otherwise = singleton m
where
a' = a + x
b' = b x
m = midpoint i
scale :: (Fractional a, Ord a) => a -> Interval a -> Interval a
scale x i = a ... b where
h = x * width i / 2
mid = midpoint i
a = mid h
b = mid + h
symmetric :: (Num a, Ord a) => a -> Interval a
symmetric x = negate x ... x
idouble :: Interval Double -> Interval Double
idouble = id
ifloat :: Interval Float -> Interval Float
ifloat = id
default (Integer,Double)