intervals-0.7.1/0000755000000000000000000000000012465050470011717 5ustar0000000000000000intervals-0.7.1/.travis.yml0000644000000000000000000000002212465050470014022 0ustar0000000000000000language: haskell intervals-0.7.1/CHANGELOG.markdown0000644000000000000000000000201312465050470014746 0ustar00000000000000000.7.1 ----- * Now compatible with GHC 7.10.1-rc1 * Fixed a number of broken `#if` pragmas, fixing previously missing instances. 0.7.0.1 ------- * Removed a couple of unnecessary `Fractional` constraints. 0.7 --- * Corrected the definition of `mignitude`. * Added a notion of `distance` between intervals 0.6 --- * Added `Numeric.Interval.Exception`. For consistency, we tend to throw exceptions now instead of rely on `NaN` when working with empty intervals. 0.5.1.1 ------- * Misc `doctest` fixes. 0.5.1 ----- * Added `interval` to facilitate the construction of known non-empty intervals. 0.5 --- * The default `Numeric.Interval` now deals more conventionally with empty intervals. * The old "Kaucher directed interval" behavior is available as `Numeric.Interval.Kaucher`. * Strictly Non-Empty intervals are now contained in `Numeric.Interval.NonEmpty` * Renamed `bisection` to `bisect`. * Added `bisectIntegral`. 0.4.2 ----- * Added `clamp` 0.4 --- * Distributive Interval 0.3 --- * Removed dependency on `numeric-extras` intervals-0.7.1/HLint.hs0000644000000000000000000000032712465050470013273 0ustar0000000000000000import "hint" HLint.HLint -- not viable ignore "Reduce duplication" -- don't want to! ignore "Use infix" -- these don't consider the corner cases when using doubles ignore "Use >" ignore "Use <=" ignore "Use >=" intervals-0.7.1/intervals.cabal0000644000000000000000000000400612465050470014712 0ustar0000000000000000name: intervals version: 0.7.1 synopsis: Interval Arithmetic description: A 'Numeric.Interval.Interval' is a closed, convex set of floating point values. . We do not control the rounding mode of the end points of the interval when using floating point arithmetic, so be aware that in order to get precise containment of the result, you will need to use an underlying type with both lower and upper bounds like 'CReal' homepage: http://github.com/ekmett/intervals bug-reports: http://github.com/ekmett/intervals/issues license: BSD3 license-file: LICENSE author: Edward Kmett maintainer: ekmett@gmail.com category: Math build-type: Custom cabal-version: >=1.8 tested-with: GHC == 7.4.2, GHC == 7.6.1, GHC == 7.6.3 extra-source-files: .travis.yml CHANGELOG.markdown README.markdown HLint.hs source-repository head type: git location: git://github.com/ekmett/intervals.git -- You can disable the doctests test suite with -f-test-doctests flag test-doctests description: Enable (or disable via f-test-doctests) the doctest suite when using the enable-tests option for cabal. default: True manual: True library hs-source-dirs: src exposed-modules: Numeric.Interval Numeric.Interval.Exception Numeric.Interval.Internal Numeric.Interval.Kaucher Numeric.Interval.NonEmpty Numeric.Interval.NonEmpty.Internal build-depends: array >= 0.3 && < 0.6, base >= 4 && < 5, distributive >= 0.2 && < 1 if impl(ghc >=7.4) build-depends: ghc-prim ghc-options: -Wall -O2 test-suite doctests type: exitcode-stdio-1.0 main-is: doctests.hs ghc-options: -Wall -threaded hs-source-dirs: tests if !flag(test-doctests) buildable: False else build-depends: base, directory >= 1.0, doctest >= 0.9.1, filepath if impl(ghc<7.6.1) ghc-options: -Werror intervals-0.7.1/LICENSE0000644000000000000000000000245612465050470012733 0ustar0000000000000000Copyright (c) 2010-2013, Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. intervals-0.7.1/README.markdown0000644000000000000000000000056212465050470014423 0ustar0000000000000000intervals ========== [![Build Status](https://secure.travis-ci.org/ekmett/intervals.png?branch=master)](http://travis-ci.org/ekmett/intervals) Basic interval arithmetic Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett intervals-0.7.1/Setup.lhs0000644000000000000000000000464412465050470013537 0ustar0000000000000000#!/usr/bin/runhaskell \begin{code} {-# OPTIONS_GHC -Wall #-} module Main (main) where import Data.List ( nub ) import Data.Version ( showVersion ) import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName ) import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles ) import Distribution.Simple.BuildPaths ( autogenModulesDir ) import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref)) import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity, normal ) import System.FilePath ( () ) main :: IO () main = defaultMainWithHooks simpleUserHooks { buildHook = \pkg lbi hooks flags -> do generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi buildHook simpleUserHooks pkg lbi hooks flags , postHaddock = \args flags pkg lbi -> do copyFiles normal (haddockOutputDir flags pkg) [] postHaddock simpleUserHooks args flags pkg lbi } haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath haddockOutputDir flags pkg = destDir where baseDir = case haddockDistPref flags of NoFlag -> "." Flag x -> x destDir = baseDir "doc" "html" display (packageName pkg) generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () generateBuildModule verbosity pkg lbi = do let dir = autogenModulesDir lbi createDirectoryIfMissingVerbose verbosity True dir withLibLBI pkg lbi $ \_ libcfg -> do withTestLBI pkg lbi $ \suite suitecfg -> do rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines [ "module Build_" ++ testName suite ++ " where" , "deps :: [String]" , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) ] where formatdeps = map (formatone . snd) formatone p = case packageName p of PackageName n -> n ++ "-" ++ showVersion (packageVersion p) testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys \end{code} intervals-0.7.1/src/0000755000000000000000000000000012465050470012506 5ustar0000000000000000intervals-0.7.1/src/Numeric/0000755000000000000000000000000012465050470014110 5ustar0000000000000000intervals-0.7.1/src/Numeric/Interval.hs0000644000000000000000000000163412465050470016234 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Numeric.Interval -- Copyright : (c) Edward Kmett 2010-2014 -- License : BSD3 -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : DeriveDataTypeable -- -- Interval arithmetic ----------------------------------------------------------------------------- module Numeric.Interval ( Interval , (...) , (+/-) , interval , whole , empty , null , singleton , elem , notElem , inf , sup , singular , width , midpoint , intersection , hull , bisect , bisectIntegral , magnitude , mignitude , distance , inflate, deflate , scale, symmetric , contains , isSubsetOf , certainly, (=!), (>!) , possibly, (=?), (>?) , idouble , ifloat ) where import Numeric.Interval.Internal import Prelude () intervals-0.7.1/src/Numeric/Interval/0000755000000000000000000000000012465050470015674 5ustar0000000000000000intervals-0.7.1/src/Numeric/Interval/Exception.hs0000644000000000000000000000106712465050470020172 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Numeric.Interval.Exception ( EmptyInterval(..) , AmbiguousComparison(..) ) where import Control.Exception import Data.Data data EmptyInterval = EmptyInterval deriving (Eq,Ord,Typeable,Data) instance Show EmptyInterval where show EmptyInterval = "empty interval" instance Exception EmptyInterval data AmbiguousComparison = AmbiguousComparison deriving (Eq,Ord,Typeable,Data) instance Show AmbiguousComparison where show AmbiguousComparison = "ambiguous comparison" instance Exception AmbiguousComparison intervals-0.7.1/src/Numeric/Interval/Internal.hs0000644000000000000000000005354012465050470020013 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE DeriveGeneric #-} #endif {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Interval.Internal -- Copyright : (c) Edward Kmett 2010-2013 -- License : BSD3 -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : DeriveDataTypeable -- -- Interval arithmetic -- ----------------------------------------------------------------------------- module Numeric.Interval.Internal ( Interval(..) , (...) , (+/-) , interval , whole , empty , null , singleton , elem , notElem , inf , sup , singular , width , midpoint , intersection , hull , bisect , bisectIntegral , magnitude , mignitude , distance , inflate, deflate , scale, symmetric , contains , isSubsetOf , certainly, (=!), (>!) , possibly, (=?), (>?) , idouble , ifloat ) where import Control.Exception as Exception import Data.Data import Data.Foldable hiding (minimum, maximum, elem, notElem #if __GLASGOW_HASKELL__ >= 710 , null #endif ) 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) -- $setup data Interval a = I !a !a | Empty 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 foldMap _ Empty = mempty {-# INLINE foldMap #-} infix 3 ... infixl 6 +/- (+/-) :: (Num a, Ord a) => a -> a -> Interval a a +/- b = a - b ... a + b negInfinity :: Fractional a => a negInfinity = (-1)/0 {-# INLINE negInfinity #-} posInfinity :: Fractional a => a posInfinity = 1/0 {-# INLINE posInfinity #-} interval :: Ord a => a -> a -> Maybe (Interval a) interval a b | a <= b = Just $ I a b | otherwise = Nothing {-# INLINE interval #-} fmod :: RealFrac a => a -> a -> a fmod a b = a - q*b where q = realToFrac (truncate $ a / b :: Integer) {-# INLINE fmod #-} (...) :: Ord a => a -> a -> Interval a a ... b | a <= b = I a b | otherwise = Empty {-# INLINE (...) #-} -- | The whole real number line -- -- >>> whole -- -Infinity ... Infinity whole :: Fractional a => Interval a whole = I negInfinity posInfinity {-# INLINE whole #-} -- | An empty interval -- -- >>> empty -- Empty empty :: Ord a => Interval a empty = Empty {-# INLINE empty #-} -- | Check if an interval is empty -- -- >>> null (1 ... 5) -- False -- -- >>> null (1 ... 1) -- False -- -- >>> null empty -- True null :: Interval a -> Bool null Empty = True null _ = False {-# INLINE null #-} -- | A singleton point -- -- >>> singleton 1 -- 1 ... 1 singleton :: a -> Interval a singleton a = I a a {-# INLINE singleton #-} -- | The infimum (lower bound) of an interval -- -- >>> inf (1.0 ... 20.0) -- 1.0 -- -- >>> inf empty -- *** Exception: empty interval inf :: Interval a -> a inf (I a _) = a inf Empty = Exception.throw EmptyInterval {-# INLINE inf #-} -- | The supremum (upper bound) of an interval -- -- >>> sup (1.0 ... 20.0) -- 20.0 -- -- >>> sup empty -- *** Exception: empty interval sup :: Interval a -> a sup (I _ b) = b sup Empty = Exception.throw EmptyInterval {-# INLINE sup #-} -- | Is the interval a singleton point? -- N.B. This is fairly fragile and likely will not hold after -- even a few operations that only involve singletons -- -- >>> singular (singleton 1) -- True -- -- >>> singular (1.0 ... 20.0) -- False singular :: Ord a => Interval a -> Bool singular Empty = False singular (I a b) = a == b {-# INLINE singular #-} instance Eq a => Eq (Interval a) where (==) = (==!) {-# INLINE (==) #-} instance Show a => Show (Interval a) where showsPrec _ Empty = showString "Empty" showsPrec n (I a b) = showParen (n > 3) $ showsPrec 3 a . showString " ... " . showsPrec 3 b -- | Calculate the width of an interval. -- -- >>> width (1 ... 20) -- 19 -- -- >>> width (singleton 1) -- 0 -- -- >>> width empty -- 0 width :: Num a => Interval a -> a width (I a b) = b - a width Empty = 0 {-# INLINE width #-} -- | Magnitude -- -- >>> magnitude (1 ... 20) -- 20 -- -- >>> magnitude (-20 ... 10) -- 20 -- -- >>> magnitude (singleton 5) -- 5 -- -- throws 'EmptyInterval' if the interval is empty. -- -- >>> magnitude empty -- *** Exception: empty interval magnitude :: (Num a, Ord a) => Interval a -> a magnitude = sup . abs {-# INLINE magnitude #-} -- | \"mignitude\" -- -- >>> mignitude (1 ... 20) -- 1 -- -- >>> mignitude (-20 ... 10) -- 0 -- -- >>> mignitude (singleton 5) -- 5 -- -- throws 'EmptyInterval' if the interval is empty. -- -- >>> mignitude empty -- *** Exception: empty interval mignitude :: (Num a, Ord a) => Interval a -> a mignitude = inf . abs {-# INLINE mignitude #-} -- | Hausdorff distance between intervals. -- -- >>> distance (1 ... 7) (6 ... 10) -- 0 -- -- >>> distance (1 ... 7) (15 ... 24) -- 8 -- -- >>> distance (1 ... 7) (-10 ... -2) -- 3 -- -- >>> distance Empty (1 ... 1) -- *** Exception: empty interval distance :: (Num a, Ord a) => Interval a -> Interval a -> a distance i1 i2 = mignitude (i1 - i2) -- | Inflate an interval by enlarging it at both ends. -- -- >>> inflate 3 (-1 ... 7) -- -4 ... 10 -- -- >>> inflate (-2) (0 ... 4) -- -2 ... 6 -- -- >>> inflate 1 empty -- Empty inflate :: (Num a, Ord a) => a -> Interval a -> Interval a inflate x y = symmetric x + y -- | Deflate an interval by shrinking it from both ends. -- -- >>> deflate 3.0 (-4.0 ... 10.0) -- -1.0 ... 7.0 -- -- >>> deflate 2.0 (-1.0 ... 1.0) -- Empty -- -- >>> deflate 1.0 empty -- Empty deflate :: (Fractional a, Ord a) => a -> Interval a -> Interval a deflate _ Empty = Empty deflate x (I a b) | a' <= b' = I a' b' | otherwise = Empty where a' = a + x b' = b - x -- | Scale an interval about its midpoint. -- -- >>> scale 1.1 (-6.0 ... 4.0) -- -6.5 ... 4.5 -- -- >>> scale (-2.0) (-1.0 ... 1.0) -- Empty -- -- >>> scale 3.0 empty -- Empty scale :: (Fractional a, Ord a) => a -> Interval a -> Interval a scale _ Empty = Empty scale x i = a ... b where h = x * width i / 2 mid = midpoint i a = mid - h b = mid + h -- | Construct a symmetric interval. -- -- >>> symmetric 3 -- -3 ... 3 -- -- >>> symmetric (-2) -- -2 ... 2 symmetric :: (Num a, Ord a) => a -> Interval a symmetric x | a <= b = I a b | otherwise = I b a where a = negate x b = x instance (Num a, Ord a) => Num (Interval a) where I a b + I a' b' = (a + a') ... (b + b') _ + _ = Empty {-# INLINE (+) #-} I a b - I a' b' = (a - b') ... (b - a') _ - _ = Empty {-# INLINE (-) #-} I a b * I a' b' = minimum [a * a', a * b', b * a', b * b'] ... maximum [a * a', a * b', b * a', b * b'] _ * _ = Empty {-# INLINE (*) #-} abs x@(I a b) | a >= 0 = x | b <= 0 = negate x | otherwise = 0 ... max (- a) b abs Empty = Empty {-# INLINE abs #-} signum = increasing signum {-# INLINE signum #-} fromInteger i = singleton (fromInteger i) {-# INLINE fromInteger #-} -- | Bisect an interval at its midpoint. -- -- >>> bisect (10.0 ... 20.0) -- (10.0 ... 15.0,15.0 ... 20.0) -- -- >>> bisect (singleton 5.0) -- (5.0 ... 5.0,5.0 ... 5.0) -- -- >>> bisect Empty -- (Empty,Empty) bisect :: Fractional a => Interval a -> (Interval a, Interval a) bisect Empty = (Empty,Empty) bisect (I a b) = (I a m, I m b) where m = a + (b - a) / 2 {-# INLINE bisect #-} bisectIntegral :: Integral a => Interval a -> (Interval a, Interval a) bisectIntegral Empty = (Empty, Empty) 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 -- | Nearest point to the midpoint of the interval. -- -- >>> midpoint (10.0 ... 20.0) -- 15.0 -- -- >>> midpoint (singleton 5.0) -- 5.0 -- -- >>> midpoint empty -- *** Exception: empty interval midpoint :: Fractional a => Interval a -> a midpoint (I a b) = a + (b - a) / 2 midpoint Empty = Exception.throw EmptyInterval {-# INLINE midpoint #-} -- | Determine if a point is in the interval. -- -- >>> elem 3.2 (1.0 ... 5.0) -- True -- -- >>> elem 5 (1.0 ... 5.0) -- True -- -- >>> elem 1 (1.0 ... 5.0) -- True -- -- >>> elem 8 (1.0 ... 5.0) -- False -- -- >>> elem 5 empty -- False -- elem :: Ord a => a -> Interval a -> Bool elem x (I a b) = x >= a && x <= b elem _ Empty = False {-# INLINE elem #-} -- | Determine if a point is not included in the interval -- -- >>> notElem 8 (1.0 ... 5.0) -- True -- -- >>> notElem 1.4 (1.0 ... 5.0) -- False -- -- And of course, nothing is a member of the empty interval. -- -- >>> notElem 5 empty -- True notElem :: Ord a => a -> Interval a -> Bool notElem x xs = not (elem x xs) {-# INLINE notElem #-} -- | 'realToFrac' will use the midpoint instance Real a => Real (Interval a) where toRational Empty = Exception.throw EmptyInterval toRational (I ra rb) = a + (b - a) / 2 where a = toRational ra b = toRational rb {-# INLINE toRational #-} instance Ord a => Ord (Interval a) where compare Empty Empty = EQ compare Empty _ = LT compare _ Empty = GT compare (I ax bx) (I ay by) | bx < ay = LT | ax > by = GT | bx == ay && ax == by = EQ | otherwise = Exception.throw AmbiguousComparison {-# INLINE compare #-} max (I a b) (I a' b') = max a a' ... max b b' max Empty i = i max i Empty = i {-# INLINE max #-} min (I a b) (I a' b') = min a a' ... min b b' min Empty _ = Empty min _ Empty = Empty {-# INLINE min #-} -- @'divNonZero' X Y@ assumes @0 `'notElem'` Y@ 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'] divNonZero _ _ = Empty -- @'divPositive' X y@ assumes y > 0, and divides @X@ by [0 ... y] divPositive :: (Fractional a, Ord a) => Interval a -> a -> Interval a divPositive Empty _ = Empty divPositive x@(I a b) y | a == 0 && b == 0 = x -- b < 0 || isNegativeZero b = negInfinity ... ( b / y) | b < 0 = negInfinity ... (b / y) | a < 0 = whole | otherwise = (a / y) ... posInfinity {-# INLINE divPositive #-} -- divNegative assumes y < 0 and divides the interval @X@ by [y ... 0] divNegative :: (Fractional a, Ord a) => Interval a -> a -> Interval a divNegative Empty _ = Empty divNegative x@(I a b) y | a == 0 && b == 0 = - x -- flip negative zeros -- b < 0 || isNegativeZero b = (b / y) ... posInfinity | b < 0 = (b / y) ... posInfinity | a < 0 = whole | otherwise = negInfinity ... (a / y) {-# INLINE divNegative #-} divZero :: (Fractional a, Ord a) => Interval a -> Interval a divZero x@(I a b) | a == 0 && b == 0 = x | otherwise = whole divZero Empty = Empty {-# INLINE divZero #-} instance (Fractional a, Ord a) => Fractional (Interval a) where -- TODO: check isNegativeZero properly _ / Empty = Empty 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 Empty = Empty recip (I a b) = on min recip a b ... on max recip a b {-# INLINE recip #-} fromRational r = let r' = fromRational r in I r' r' {-# INLINE fromRational #-} instance RealFrac a => RealFrac (Interval a) where properFraction x = (b, x - fromIntegral b) where b = truncate (midpoint x) {-# INLINE properFraction #-} ceiling x = ceiling (sup x) {-# INLINE ceiling #-} floor x = floor (inf x) {-# INLINE floor #-} round x = round (midpoint x) {-# INLINE round #-} truncate x = truncate (midpoint x) {-# INLINE truncate #-} instance (RealFloat a, Ord a) => Floating (Interval a) where pi = singleton pi {-# INLINE pi #-} exp = increasing exp {-# INLINE exp #-} log (I a b) = (if a > 0 then log a else negInfinity) ... log b log Empty = Empty {-# INLINE log #-} cos Empty = Empty 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) {-# INLINE cos #-} sin Empty = Empty sin x = cos (x - pi / 2) {-# INLINE sin #-} tan Empty = Empty 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 {-# INLINE tan #-} asin Empty = Empty asin (I a b) | b < -1 || a > 1 = Empty | otherwise = (if a <= -1 then -halfPi else asin a) ... (if b >= 1 then halfPi else asin b) where halfPi = pi / 2 {-# INLINE asin #-} acos Empty = Empty acos (I a b) | b < -1 || a > 1 = Empty | otherwise = (if b >= 1 then 0 else acos b) ... (if a < -1 then pi else acos a) {-# INLINE acos #-} atan = increasing atan {-# INLINE atan #-} sinh = increasing sinh {-# INLINE sinh #-} cosh Empty = Empty 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 {-# INLINE cosh #-} tanh = increasing tanh {-# INLINE tanh #-} asinh = increasing asinh {-# INLINE asinh #-} acosh Empty = Empty acosh (I a b) | b < 1 = Empty | otherwise = I lo $ acosh b where lo | a <= 1 = 0 | otherwise = acosh a {-# INLINE acosh #-} atanh Empty = Empty atanh (I a b) | b < -1 || a > 1 = Empty | otherwise = (if a <= - 1 then negInfinity else atanh a) ... (if b >= 1 then posInfinity else atanh b) {-# INLINE atanh #-} -- | lift a monotone increasing function over a given interval increasing :: (a -> b) -> Interval a -> Interval b increasing f (I a b) = I (f a) (f b) increasing _ Empty = Empty -- | lift a monotone decreasing function over a given interval decreasing :: (a -> b) -> Interval a -> Interval b decreasing f (I a b) = I (f b) (f a) decreasing _ Empty = Empty -- | We have to play some semantic games to make these methods make sense. -- Most compute with the midpoint of the interval. 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 _ Empty = Empty scaleFloat n (I a b) = I (scaleFloat n a) (scaleFloat n b) isNaN (I a b) = isNaN a || isNaN b isNaN Empty = True isInfinite (I a b) = isInfinite a || isInfinite b isInfinite Empty = False isDenormalized (I a b) = isDenormalized a || isDenormalized b isDenormalized Empty = False -- contains negative zero isNegativeZero (I a b) = not (a > 0) && not (b < 0) && ( (b == 0 && (a < 0 || isNegativeZero a)) || (a == 0 && isNegativeZero a) || (a < 0 && b >= 0)) isNegativeZero Empty = False isIEEE _ = False atan2 = error "unimplemented" -- TODO: (^), (^^) to give tighter bounds -- | Calculate the intersection of two intervals. -- -- >>> intersection (1 ... 10 :: Interval Double) (5 ... 15 :: Interval Double) -- 5.0 ... 10.0 intersection :: Ord a => Interval a -> Interval a -> Interval a intersection x@(I a b) y@(I a' b') | x /=! y = Empty | otherwise = I (max a a') (min b b') intersection _ _ = Empty {-# INLINE intersection #-} -- | Calculate the convex hull of two intervals -- -- >>> hull (0 ... 10 :: Interval Double) (5 ... 15 :: Interval Double) -- 0.0 ... 15.0 -- -- >>> hull (15 ... 85 :: Interval Double) (0 ... 10 :: Interval Double) -- 0.0 ... 85.0 hull :: Ord a => Interval a -> Interval a -> Interval a hull (I a b) (I a' b') = I (min a a') (max b b') hull Empty x = x hull x Empty = x {-# INLINE hull #-} -- | For all @x@ in @X@, @y@ in @Y@. @x '<' y@ -- -- >>> (5 ... 10 :: Interval Double) >> (5 ... 10 :: Interval Double) >> (20 ... 30 :: Interval Double) Interval a -> Interval a -> Bool Empty >> (5 ... 10 :: Interval Double) <=! (20 ... 30 :: Interval Double) -- True -- -- >>> (5 ... 10 :: Interval Double) <=! (10 ... 30 :: Interval Double) -- True -- -- >>> (20 ... 30 :: Interval Double) <=! (5 ... 10 :: Interval Double) -- False (<=!) :: Ord a => Interval a -> Interval a -> Bool Empty <=! _ = True _ <=! Empty = True I _ bx <=! I ay _ = bx <= ay {-# INLINE (<=!) #-} -- | For all @x@ in @X@, @y@ in @Y@. @x '==' y@ -- -- Only singleton intervals or empty intervals can return true -- -- >>> (singleton 5 :: Interval Double) ==! (singleton 5 :: Interval Double) -- True -- -- >>> (5 ... 10 :: Interval Double) ==! (5 ... 10 :: Interval Double) -- False (==!) :: Eq a => Interval a -> Interval a -> Bool Empty ==! _ = True _ ==! Empty = True I ax bx ==! I ay by = bx == ay && ax == by {-# INLINE (==!) #-} -- | For all @x@ in @X@, @y@ in @Y@. @x '/=' y@ -- -- >>> (5 ... 15 :: Interval Double) /=! (20 ... 40 :: Interval Double) -- True -- -- >>> (5 ... 15 :: Interval Double) /=! (15 ... 40 :: Interval Double) -- False (/=!) :: Ord a => Interval a -> Interval a -> Bool Empty /=! _ = True _ /=! Empty = True I ax bx /=! I ay by = bx < ay || ax > by {-# INLINE (/=!) #-} -- | For all @x@ in @X@, @y@ in @Y@. @x '>' y@ -- -- >>> (20 ... 40 :: Interval Double) >! (10 ... 19 :: Interval Double) -- True -- -- >>> (5 ... 20 :: Interval Double) >! (15 ... 40 :: Interval Double) -- False (>!) :: Ord a => Interval a -> Interval a -> Bool Empty >! _ = True _ >! Empty = True I ax _ >! I _ by = ax > by {-# INLINE (>!) #-} -- | For all @x@ in @X@, @y@ in @Y@. @x '>=' y@ -- -- >>> (20 ... 40 :: Interval Double) >=! (10 ... 20 :: Interval Double) -- True -- -- >>> (5 ... 20 :: Interval Double) >=! (15 ... 40 :: Interval Double) -- False (>=!) :: Ord a => Interval a -> Interval a -> Bool Empty >=! _ = True _ >=! Empty = True I ax _ >=! I _ by = ax >= by {-# INLINE (>=!) #-} -- | For all @x@ in @X@, @y@ in @Y@. @x `op` y@ 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 = l ==! r | gt = l >! r | otherwise = False where lt = cmp False True eq = cmp True True gt = cmp True False {-# INLINE certainly #-} -- | Check if interval @X@ totally contains interval @Y@ -- -- >>> (20 ... 40 :: Interval Double) `contains` (25 ... 35 :: Interval Double) -- True -- -- >>> (20 ... 40 :: Interval Double) `contains` (15 ... 35 :: Interval Double) -- False contains :: Ord a => Interval a -> Interval a -> Bool contains _ Empty = True contains (I ax bx) (I ay by) = ax <= ay && by <= bx contains Empty I{} = False {-# INLINE contains #-} -- | Flipped version of `contains`. Check if interval @X@ a subset of interval @Y@ -- -- >>> (25 ... 35 :: Interval Double) `isSubsetOf` (20 ... 40 :: Interval Double) -- True -- -- >>> (20 ... 40 :: Interval Double) `isSubsetOf` (15 ... 35 :: Interval Double) -- False isSubsetOf :: Ord a => Interval a -> Interval a -> Bool isSubsetOf = flip contains {-# INLINE isSubsetOf #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@? ( Interval a -> Interval a -> Bool Empty Interval a -> Interval a -> Bool Empty <=? _ = False _ <=? Empty = False I ax _ <=? I _ by = ax <= by {-# INLINE (<=?) #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@? (==?) :: Ord a => Interval a -> Interval a -> Bool I ax bx ==? I ay by = ax <= by && bx >= ay _ ==? _ = False {-# INLINE (==?) #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@? (/=?) :: Eq a => Interval a -> Interval a -> Bool I ax bx /=? I ay by = ax /= by || bx /= ay _ /=? _ = False {-# INLINE (/=?) #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@? (>?) :: Ord a => Interval a -> Interval a -> Bool I _ bx >? I ay _ = bx > ay _ >? _ = False {-# INLINE (>?) #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@? (>=?) :: Ord a => Interval a -> Interval a -> Bool I _ bx >=? I ay _ = bx >= ay _ >=? _ = False {-# INLINE (>=?) #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x `op` y@? 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 = l ==? r | gt = l >? r | otherwise = False where lt = cmp LT EQ eq = cmp EQ EQ gt = cmp GT EQ {-# INLINE possibly #-} -- | id function. Useful for type specification -- -- >>> :t idouble (1 ... 3) -- idouble (1 ... 3) :: Interval Double idouble :: Interval Double -> Interval Double idouble = id -- | id function. Useful for type specification -- -- >>> :t ifloat (1 ... 3) -- ifloat (1 ... 3) :: Interval Float ifloat :: Interval Float -> Interval Float ifloat = id -- Bugs: -- sin 1 :: Interval Double default (Integer,Double) intervals-0.7.1/src/Numeric/Interval/Kaucher.hs0000644000000000000000000005132712465050470017622 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE DeriveGeneric #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Numeric.Interval -- Copyright : (c) Edward Kmett 2010-2014 -- License : BSD3 -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : DeriveDataTypeable -- -- "Directed" Interval arithmetic -- ----------------------------------------------------------------------------- module Numeric.Interval.Kaucher ( Interval(..) , (...) , interval , whole , empty , null , singleton , elem , notElem , inf , sup , singular , width , midpoint , intersection , hull , bisect , magnitude , mignitude , distance , inflate, deflate , scale, symmetric , contains , isSubsetOf , certainly, (=!), (>!) , possibly, (=?), (>?) , clamp , idouble , ifloat ) where import Control.Applicative hiding (empty) import Control.Exception as Exception import Data.Data import Data.Distributive import Data.Foldable hiding (minimum, maximum, elem, notElem #if __GLASGOW_HASKELL__ >= 710 , null #endif ) import Data.Function (on) import Data.Monoid import Data.Traversable #if __GLASGOW_HASKELL__ >= 704 import GHC.Generics #endif import Numeric.Interval.Exception import Prelude hiding (null, elem, notElem) -- $setup data Interval a = I !a !a deriving ( Data , Typeable #if __GLASGOW_HASKELL__ >= 704 , Generic #if __GLASGOW_HASKELL__ >= 706 , Generic1 #endif #endif ) instance Functor Interval where fmap f (I a b) = I (f a) (f b) {-# INLINE fmap #-} instance Foldable Interval where foldMap f (I a b) = f a `mappend` f b {-# INLINE foldMap #-} instance Traversable Interval where traverse f (I a b) = I <$> f a <*> f b {-# INLINE traverse #-} instance Applicative Interval where pure a = I a a {-# INLINE pure #-} I f g <*> I a b = I (f a) (g b) {-# INLINE (<*>) #-} instance Monad Interval where return a = I a a {-# INLINE return #-} I a b >>= f = I a' b' where I a' _ = f a I _ b' = f b {-# INLINE (>>=) #-} instance Distributive Interval where distribute f = fmap inf f ... fmap sup f {-# INLINE distribute #-} infix 3 ... negInfinity :: Fractional a => a negInfinity = (-1)/0 {-# INLINE negInfinity #-} posInfinity :: Fractional a => a posInfinity = 1/0 {-# INLINE posInfinity #-} nan :: Fractional a => a nan = 0/0 fmod :: RealFrac a => a -> a -> a fmod a b = a - q*b where q = realToFrac (truncate $ a / b :: Integer) {-# INLINE fmod #-} -- | Create a directed interval. (...) :: a -> a -> Interval a (...) = I {-# INLINE (...) #-} -- | Try to create a non-empty interval. interval :: Ord a => a -> a -> Maybe (Interval a) interval a b | a <= b = Just $ I a b | otherwise = Nothing -- | The whole real number line -- -- >>> whole -- -Infinity ... Infinity whole :: Fractional a => Interval a whole = negInfinity ... posInfinity {-# INLINE whole #-} -- | An empty interval -- -- >>> empty -- NaN ... NaN empty :: Fractional a => Interval a empty = nan ... nan {-# INLINE empty #-} -- | negation handles NaN properly -- -- >>> null (1 ... 5) -- False -- -- >>> null (1 ... 1) -- False -- -- >>> null empty -- True null :: Ord a => Interval a -> Bool null x = not (inf x <= sup x) {-# INLINE null #-} -- | A singleton point -- -- >>> singleton 1 -- 1 ... 1 singleton :: a -> Interval a singleton a = a ... a {-# INLINE singleton #-} -- | The infinumum (lower bound) of an interval -- -- >>> inf (1 ... 20) -- 1 inf :: Interval a -> a inf (I a _) = a {-# INLINE inf #-} -- | The supremum (upper bound) of an interval -- -- >>> sup (1 ... 20) -- 20 sup :: Interval a -> a sup (I _ b) = b {-# INLINE sup #-} -- | Is the interval a singleton point? -- N.B. This is fairly fragile and likely will not hold after -- even a few operations that only involve singletons -- -- >>> singular (singleton 1) -- True -- -- >>> singular (1.0 ... 20.0) -- False singular :: Ord a => Interval a -> Bool singular x = not (null x) && inf x == sup x {-# INLINE singular #-} instance Eq a => Eq (Interval a) where (==) = (==!) {-# INLINE (==) #-} instance Show a => Show (Interval a) where showsPrec n (I a b) = showParen (n > 3) $ showsPrec 3 a . showString " ... " . showsPrec 3 b -- | Calculate the width of an interval. -- -- >>> width (1 ... 20) -- 19 -- -- >>> width (singleton 1) -- 0 -- -- >>> width empty -- NaN width :: Num a => Interval a -> a width (I a b) = b - a {-# INLINE width #-} -- | Magnitude -- -- >>> magnitude (1 ... 20) -- 20 -- -- >>> magnitude (-20 ... 10) -- 20 -- -- >>> magnitude (singleton 5) -- 5 magnitude :: (Num a, Ord a) => Interval a -> a magnitude = sup . abs {-# INLINE magnitude #-} -- | \"mignitude\" -- -- >>> mignitude (1 ... 20) -- 1 -- -- >>> mignitude (-20 ... 10) -- 0 -- -- >>> mignitude (singleton 5) -- 5 -- -- >>> mignitude empty -- NaN mignitude :: (Num a, Ord a) => Interval a -> a mignitude = inf . abs {-# INLINE mignitude #-} -- | Hausdorff distance between non-empty intervals. -- -- >>> distance (1 ... 7) (6 ... 10) -- 0 -- -- >>> distance (1 ... 7) (15 ... 24) -- 8 -- -- >>> distance (1 ... 7) (-10 ... -2) -- 3 -- -- >>> distance empty (1 ... 1) -- NaN distance :: (Num a, Ord a) => Interval a -> Interval a -> a distance i1 i2 = mignitude (i1 - i2) -- | Inflate an interval by enlarging it at both ends. -- -- >>> inflate 3 (-1 ... 7) -- -4 ... 10 -- -- >>> inflate (-2) (0 ... 4) -- 2 ... 2 inflate :: (Num a, Ord a) => a -> Interval a -> Interval a inflate x y = symmetric x + y -- | Deflate an interval by shrinking it from both ends. -- -- >>> deflate 3.0 (-4.0 ... 10.0) -- -1.0 ... 7.0 -- -- >>> deflate 2.0 (-1.0 ... 1.0) -- 1.0 ... -1.0 deflate :: (Fractional a, Ord a) => a -> Interval a -> Interval a deflate x (I a b) = I a' b' where a' = a + x b' = b - x -- | Scale an interval about its midpoint. -- -- >>> scale 1.1 (-6.0 ... 4.0) -- -6.5 ... 4.5 -- -- >>> scale (-2.0) (-1.0 ... 1.0) -- 2.0 ... -2.0 scale :: (Fractional a, Ord a) => a -> Interval a -> Interval a scale x i = I a b where h = x * width i / 2 mid = midpoint i a = mid - h b = mid + h -- | Construct a symmetric interval. -- -- >>> symmetric 3 -- -3 ... 3 -- -- >>> symmetric (-2) -- 2 ... -2 symmetric :: (Num a, Ord a) => a -> Interval a symmetric x = negate x ... x instance (Num a, Ord a) => Num (Interval a) where I a b + I a' b' = (a + a') ... (b + b') {-# INLINE (+) #-} I a b - I a' b' = (a - b') ... (b - a') {-# INLINE (-) #-} I a b * I a' b' = minimum [a * a', a * b', b * a', b * b'] ... maximum [a * a', a * b', b * a', b * b'] {-# INLINE (*) #-} abs x@(I a b) | a >= 0 = x | b <= 0 = negate x | b > 0 && a < 0 = 0 ... max (- a) b | otherwise = x -- preserve the empty interval {-# INLINE abs #-} signum = increasing signum {-# INLINE signum #-} fromInteger i = singleton (fromInteger i) {-# INLINE fromInteger #-} -- | Bisect an interval at its midpoint. -- -- >>> bisect (10.0 ... 20.0) -- (10.0 ... 15.0,15.0 ... 20.0) -- -- >>> bisect (singleton 5.0) -- (5.0 ... 5.0,5.0 ... 5.0) -- -- >>> bisect empty -- (NaN ... NaN,NaN ... NaN) bisect :: Fractional a => Interval a -> (Interval a, Interval a) bisect x = (inf x ... m, m ... sup x) where m = midpoint x {-# INLINE bisect #-} -- | Nearest point to the midpoint of the interval. -- -- >>> midpoint (10.0 ... 20.0) -- 15.0 -- -- >>> midpoint (singleton 5.0) -- 5.0 -- -- >>> midpoint empty -- NaN midpoint :: Fractional a => Interval a -> a midpoint x = inf x + (sup x - inf x) / 2 {-# INLINE midpoint #-} -- | Determine if a point is in the interval. -- -- >>> elem 3.2 (1.0 ... 5.0) -- True -- -- >>> elem 5 (1.0 ... 5.0) -- True -- -- >>> elem 1 (1.0 ... 5.0) -- True -- -- >>> elem 8 (1.0 ... 5.0) -- False -- -- >>> elem 5 empty -- False -- elem :: Ord a => a -> Interval a -> Bool elem x xs = x >= inf xs && x <= sup xs {-# INLINE elem #-} -- | Determine if a point is not included in the interval -- -- >>> notElem 8 (1.0 ... 5.0) -- True -- -- >>> notElem 1.4 (1.0 ... 5.0) -- False -- -- And of course, nothing is a member of the empty interval. -- -- >>> notElem 5 empty -- True notElem :: Ord a => a -> Interval a -> Bool notElem x xs = not (elem x xs) {-# INLINE notElem #-} -- | 'realToFrac' will use the midpoint instance Real a => Real (Interval a) where toRational x | null x = Exception.throw EmptyInterval | otherwise = a + (b - a) / 2 where a = toRational (inf x) b = toRational (sup x) {-# INLINE toRational #-} instance Ord a => Ord (Interval a) where compare x y | sup x < inf y = LT | inf x > sup y = GT | sup x == inf y && inf x == sup y = EQ | otherwise = Exception.throw AmbiguousComparison {-# INLINE compare #-} max (I a b) (I a' b') = max a a' ... max b b' {-# INLINE max #-} min (I a b) (I a' b') = min a a' ... min b b' {-# INLINE min #-} -- @'divNonZero' X Y@ assumes @0 `'notElem'` Y@ 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' X y@ assumes y > 0, and divides @X@ by [0 ... y] divPositive :: (Fractional a, Ord a) => Interval a -> a -> Interval a divPositive x@(I a b) y | a == 0 && b == 0 = x -- b < 0 || isNegativeZero b = negInfinity ... ( b / y) | b < 0 = negInfinity ... ( b / y) | a < 0 = whole | otherwise = (a / y) ... posInfinity {-# INLINE divPositive #-} -- divNegative assumes y < 0 and divides the interval @X@ by [y ... 0] divNegative :: (Fractional a, Ord a) => Interval a -> a -> Interval a divNegative x@(I a b) y | a == 0 && b == 0 = - x -- flip negative zeros -- b < 0 || isNegativeZero b = (b / y) ... posInfinity | b < 0 = (b / y) ... posInfinity | a < 0 = whole | otherwise = negInfinity ... (a / y) {-# INLINE divNegative #-} divZero :: (Fractional a, Ord a) => Interval a -> Interval a divZero x | inf x == 0 && sup x == 0 = x | otherwise = whole {-# INLINE divZero #-} instance (Fractional a, Ord a) => Fractional (Interval a) where -- TODO: check isNegativeZero properly x / y | 0 `notElem` y = divNonZero x y | iz && sz = empty -- division by 0 | iz = divPositive x (inf y) | sz = divNegative x (sup y) | otherwise = divZero x where iz = inf y == 0 sz = sup y == 0 recip (I a b) = on min recip a b ... on max recip a b {-# INLINE recip #-} fromRational r = let r' = fromRational r in r' ... r' {-# INLINE fromRational #-} instance RealFrac a => RealFrac (Interval a) where properFraction x = (b, x - fromIntegral b) where b = truncate (midpoint x) {-# INLINE properFraction #-} ceiling x = ceiling (sup x) {-# INLINE ceiling #-} floor x = floor (inf x) {-# INLINE floor #-} round x = round (midpoint x) {-# INLINE round #-} truncate x = truncate (midpoint x) {-# INLINE truncate #-} instance (RealFloat a, Ord a) => Floating (Interval a) where pi = singleton pi {-# INLINE pi #-} exp = increasing exp {-# INLINE exp #-} log (I a b) = (if a > 0 then log a else negInfinity) ... log b {-# INLINE log #-} cos x | null x = empty | 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) {-# INLINE cos #-} sin x | null x = empty | otherwise = cos (x - pi / 2) {-# INLINE sin #-} tan x | null x = empty | 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 {-# INLINE tan #-} asin x@(I a b) | null x || b < -1 || a > 1 = empty | otherwise = (if a <= -1 then -halfPi else asin a) ... (if b >= 1 then halfPi else asin b) where halfPi = pi / 2 {-# INLINE asin #-} acos x@(I a b) | null x || b < -1 || a > 1 = empty | otherwise = (if b >= 1 then 0 else acos b) ... (if a < -1 then pi else acos a) {-# INLINE acos #-} atan = increasing atan {-# INLINE atan #-} sinh = increasing sinh {-# INLINE sinh #-} cosh x@(I a b) | null x = empty | b < 0 = decreasing cosh x | a >= 0 = increasing cosh x | otherwise = I 0 $ cosh $ if - a > b then a else b {-# INLINE cosh #-} tanh = increasing tanh {-# INLINE tanh #-} asinh = increasing asinh {-# INLINE asinh #-} acosh x@(I a b) | null x || b < 1 = empty | otherwise = I lo $ acosh b where lo | a <= 1 = 0 | otherwise = acosh a {-# INLINE acosh #-} atanh x@(I a b) | null x || b < -1 || a > 1 = empty | otherwise = (if a <= - 1 then negInfinity else atanh a) ... (if b >= 1 then posInfinity else atanh b) {-# INLINE atanh #-} -- | lift a monotone increasing function over a given interval increasing :: (a -> b) -> Interval a -> Interval b increasing f (I a b) = f a ... f b -- | lift a monotone decreasing function over a given interval decreasing :: (a -> b) -> Interval a -> Interval b decreasing f (I a b) = f b ... f a -- | We have to play some semantic games to make these methods make sense. -- Most compute with the midpoint of the interval. 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 x = scaleFloat n (inf x) ... scaleFloat n (sup x) isNaN x = isNaN (inf x) || isNaN (sup x) isInfinite x = isInfinite (inf x) || isInfinite (sup x) isDenormalized x = isDenormalized (inf x) || isDenormalized (sup x) -- contains negative zero isNegativeZero x = not (inf x > 0) && not (sup x < 0) && ( (sup x == 0 && (inf x < 0 || isNegativeZero (inf x))) || (inf x == 0 && isNegativeZero (inf x)) || (inf x < 0 && sup x >= 0)) isIEEE x = isIEEE (inf x) && isIEEE (sup x) atan2 = error "unimplemented" -- TODO: (^), (^^) to give tighter bounds -- | Calculate the intersection of two intervals. -- -- >>> intersection (1 ... 10 :: Interval Double) (5 ... 15 :: Interval Double) -- 5.0 ... 10.0 intersection :: (Fractional a, Ord a) => Interval a -> Interval a -> Interval a intersection x@(I a b) y@(I a' b') | x /=! y = empty | otherwise = max a a' ... min b b' {-# INLINE intersection #-} -- | Calculate the convex hull of two intervals -- -- >>> hull (0 ... 10 :: Interval Double) (5 ... 15 :: Interval Double) -- 0.0 ... 15.0 -- -- >>> hull (15 ... 85 :: Interval Double) (0 ... 10 :: Interval Double) -- 0.0 ... 85.0 hull :: Ord a => Interval a -> Interval a -> Interval a hull x@(I a b) y@(I a' b') | null x = y | null y = x | otherwise = min a a' ... max b b' {-# INLINE hull #-} -- | For all @x@ in @X@, @y@ in @Y@. @x '<' y@ -- -- >>> (5 ... 10 :: Interval Double) >> (5 ... 10 :: Interval Double) >> (20 ... 30 :: Interval Double) Interval a -> Interval a -> Bool x >> (5 ... 10 :: Interval Double) <=! (20 ... 30 :: Interval Double) -- True -- -- >>> (5 ... 10 :: Interval Double) <=! (10 ... 30 :: Interval Double) -- True -- -- >>> (20 ... 30 :: Interval Double) <=! (5 ... 10 :: Interval Double) -- False (<=!) :: Ord a => Interval a -> Interval a -> Bool x <=! y = sup x <= inf y {-# INLINE (<=!) #-} -- | For all @x@ in @X@, @y@ in @Y@. @x '==' y@ -- -- Only singleton intervals return true -- -- >>> (singleton 5 :: Interval Double) ==! (singleton 5 :: Interval Double) -- True -- -- >>> (5 ... 10 :: Interval Double) ==! (5 ... 10 :: Interval Double) -- False (==!) :: Eq a => Interval a -> Interval a -> Bool x ==! y = sup x == inf y && inf x == sup y {-# INLINE (==!) #-} -- | For all @x@ in @X@, @y@ in @Y@. @x '/=' y@ -- -- >>> (5 ... 15 :: Interval Double) /=! (20 ... 40 :: Interval Double) -- True -- -- >>> (5 ... 15 :: Interval Double) /=! (15 ... 40 :: Interval Double) -- False (/=!) :: Ord a => Interval a -> Interval a -> Bool x /=! y = sup x < inf y || inf x > sup y {-# INLINE (/=!) #-} -- | For all @x@ in @X@, @y@ in @Y@. @x '>' y@ -- -- >>> (20 ... 40 :: Interval Double) >! (10 ... 19 :: Interval Double) -- True -- -- >>> (5 ... 20 :: Interval Double) >! (15 ... 40 :: Interval Double) -- False (>!) :: Ord a => Interval a -> Interval a -> Bool x >! y = inf x > sup y {-# INLINE (>!) #-} -- | For all @x@ in @X@, @y@ in @Y@. @x '>=' y@ -- -- >>> (20 ... 40 :: Interval Double) >=! (10 ... 20 :: Interval Double) -- True -- -- >>> (5 ... 20 :: Interval Double) >=! (15 ... 40 :: Interval Double) -- False (>=!) :: Ord a => Interval a -> Interval a -> Bool x >=! y = inf x >= sup y {-# INLINE (>=!) #-} -- | For all @x@ in @X@, @y@ in @Y@. @x `op` y@ -- -- 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 = l ==! r | gt = l >! r | otherwise = False where lt = cmp LT EQ eq = cmp EQ EQ gt = cmp GT EQ {-# INLINE certainly #-} -- | Check if interval @X@ totally contains interval @Y@ -- -- >>> (20 ... 40 :: Interval Double) `contains` (25 ... 35 :: Interval Double) -- True -- -- >>> (20 ... 40 :: Interval Double) `contains` (15 ... 35 :: Interval Double) -- False contains :: Ord a => Interval a -> Interval a -> Bool contains x y = null y || (not (null x) && inf x <= inf y && sup y <= sup x) {-# INLINE contains #-} -- | Flipped version of `contains`. Check if interval @X@ a subset of interval @Y@ -- -- >>> (25 ... 35 :: Interval Double) `isSubsetOf` (20 ... 40 :: Interval Double) -- True -- -- >>> (20 ... 40 :: Interval Double) `isSubsetOf` (15 ... 35 :: Interval Double) -- False isSubsetOf :: Ord a => Interval a -> Interval a -> Bool isSubsetOf = flip contains {-# INLINE isSubsetOf #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@? ( Interval a -> Interval a -> Bool x Interval a -> Interval a -> Bool x <=? y = inf x <= sup y {-# INLINE (<=?) #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@? (==?) :: Ord a => Interval a -> Interval a -> Bool x ==? y = inf x <= sup y && sup x >= inf y {-# INLINE (==?) #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@? (/=?) :: Eq a => Interval a -> Interval a -> Bool x /=? y = inf x /= sup y || sup x /= inf y {-# INLINE (/=?) #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@? (>?) :: Ord a => Interval a -> Interval a -> Bool x >? y = sup x > inf y {-# INLINE (>?) #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@? (>=?) :: Ord a => Interval a -> Interval a -> Bool x >=? y = sup x >= inf y {-# INLINE (>=?) #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x `op` y@? 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 = l ==? r | gt = l >? r | otherwise = False where lt = cmp LT EQ eq = cmp EQ EQ gt = cmp GT EQ {-# INLINE possibly #-} -- | The nearest value to that supplied which is contained in the interval. clamp :: Ord a => Interval a -> a -> a clamp (I a b) x | x < a = a | x > b = b | otherwise = x -- | id function. Useful for type specification -- -- >>> :t idouble (1 ... 3) -- idouble (1 ... 3) :: Interval Double idouble :: Interval Double -> Interval Double idouble = id -- | id function. Useful for type specification -- -- >>> :t ifloat (1 ... 3) -- ifloat (1 ... 3) :: Interval Float ifloat :: Interval Float -> Interval Float ifloat = id -- Bugs: -- sin 1 :: Interval Double default (Integer,Double) intervals-0.7.1/src/Numeric/Interval/NonEmpty.hs0000644000000000000000000000210212465050470017774 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE DeriveGeneric #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Numeric.Interval.NonEmpty -- Copyright : (c) Edward Kmett 2010-2013 -- License : BSD3 -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : DeriveDataTypeable -- -- Interval arithmetic -- ----------------------------------------------------------------------------- module Numeric.Interval.NonEmpty ( 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 Numeric.Interval.NonEmpty.Internal import Prelude () intervals-0.7.1/src/Numeric/Interval/NonEmpty/0000755000000000000000000000000012465050470017445 5ustar0000000000000000intervals-0.7.1/src/Numeric/Interval/NonEmpty/Internal.hs0000644000000000000000000004625412465050470021570 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE DeriveGeneric #-} #endif {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Interval.NonEmpty.Internal -- Copyright : (c) Edward Kmett 2010-2014 -- License : BSD3 -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : DeriveDataTypeable -- -- Interval arithmetic ----------------------------------------------------------------------------- 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) -- $setup 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 {-# INLINE foldMap #-} infix 3 ... negInfinity :: Fractional a => a negInfinity = (-1)/0 {-# INLINE negInfinity #-} posInfinity :: Fractional a => a posInfinity = 1/0 {-# INLINE posInfinity #-} fmod :: RealFrac a => a -> a -> a fmod a b = a - q*b where q = realToFrac (truncate $ a / b :: Integer) {-# INLINE fmod #-} -- | Create a non-empty interval, turning it around if necessary (...) :: Ord a => a -> a -> Interval a a ... b | a <= b = I a b | otherwise = I b a {-# INLINE (...) #-} -- | Try to create a non-empty interval. interval :: Ord a => a -> a -> Maybe (Interval a) interval a b | a <= b = Just $ I a b | otherwise = Nothing -- | The whole real number line -- -- >>> whole -- -Infinity ... Infinity whole :: Fractional a => Interval a whole = I negInfinity posInfinity {-# INLINE whole #-} -- | A singleton point -- -- >>> singleton 1 -- 1 ... 1 singleton :: a -> Interval a singleton a = I a a {-# INLINE singleton #-} -- | The infinumum (lower bound) of an interval -- -- >>> inf (1 ... 20) -- 1 inf :: Interval a -> a inf (I a _) = a {-# INLINE inf #-} -- | The supremum (upper bound) of an interval -- -- >>> sup (1 ... 20) -- 20 sup :: Interval a -> a sup (I _ b) = b {-# INLINE sup #-} -- | Is the interval a singleton point? -- N.B. This is fairly fragile and likely will not hold after -- even a few operations that only involve singletons -- -- >>> singular (singleton 1) -- True -- -- >>> singular (1.0 ... 20.0) -- False singular :: Ord a => Interval a -> Bool singular (I a b) = a == b {-# INLINE singular #-} instance Eq a => Eq (Interval a) where (==) = (==!) {-# INLINE (==) #-} instance Show a => Show (Interval a) where showsPrec n (I a b) = showParen (n > 3) $ showsPrec 3 a . showString " ... " . showsPrec 3 b -- | Calculate the width of an interval. -- -- >>> width (1 ... 20) -- 19 -- -- >>> width (singleton 1) -- 0 width :: Num a => Interval a -> a width (I a b) = b - a {-# INLINE width #-} -- | Magnitude -- -- >>> magnitude (1 ... 20) -- 20 -- -- >>> magnitude (-20 ... 10) -- 20 -- -- >>> magnitude (singleton 5) -- 5 magnitude :: (Num a, Ord a) => Interval a -> a magnitude = sup . abs {-# INLINE magnitude #-} -- | \"mignitude\" -- -- >>> mignitude (1 ... 20) -- 1 -- -- >>> mignitude (-20 ... 10) -- 0 -- -- >>> mignitude (singleton 5) -- 5 mignitude :: (Num a, Ord a) => Interval a -> a mignitude = inf . abs {-# INLINE mignitude #-} instance (Num a, Ord a) => Num (Interval a) where I a b + I a' b' = (a + a') ... (b + b') {-# INLINE (+) #-} I a b - I a' b' = (a - b') ... (b - a') {-# INLINE (-) #-} I a b * I a' b' = minimum [a * a', a * b', b * a', b * b'] ... maximum [a * a', a * b', b * a', b * b'] {-# INLINE (*) #-} abs x@(I a b) | a >= 0 = x | b <= 0 = negate x | otherwise = 0 ... max (- a) b {-# INLINE abs #-} signum = increasing signum {-# INLINE signum #-} fromInteger i = singleton (fromInteger i) {-# INLINE fromInteger #-} -- | Bisect an interval at its midpoint. -- -- >>> bisect (10.0 ... 20.0) -- (10.0 ... 15.0,15.0 ... 20.0) -- -- >>> bisect (singleton 5.0) -- (5.0 ... 5.0,5.0 ... 5.0) 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 {-# INLINE bisect #-} 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 {-# INLINE bisectIntegral #-} -- | Nearest point to the midpoint of the interval. -- -- >>> midpoint (10.0 ... 20.0) -- 15.0 -- -- >>> midpoint (singleton 5.0) -- 5.0 midpoint :: Fractional a => Interval a -> a midpoint (I a b) = a + (b - a) / 2 {-# INLINE midpoint #-} -- | Hausdorff distance between intervals. -- -- >>> distance (1 ... 7) (6 ... 10) -- 0 -- -- >>> distance (1 ... 7) (15 ... 24) -- 8 -- -- >>> distance (1 ... 7) (-10 ... -2) -- 3 distance :: (Num a, Ord a) => Interval a -> Interval a -> a distance i1 i2 = mignitude (i1 - i2) -- | Determine if a point is in the interval. -- -- >>> elem 3.2 (1.0 ... 5.0) -- True -- -- >>> elem 5 (1.0 ... 5.0) -- True -- -- >>> elem 1 (1.0 ... 5.0) -- True -- -- >>> elem 8 (1.0 ... 5.0) -- False elem :: Ord a => a -> Interval a -> Bool elem x (I a b) = x >= a && x <= b {-# INLINE elem #-} -- | Determine if a point is not included in the interval -- -- >>> notElem 8 (1.0 ... 5.0) -- True -- -- >>> notElem 1.4 (1.0 ... 5.0) -- False notElem :: Ord a => a -> Interval a -> Bool notElem x xs = not (elem x xs) {-# INLINE notElem #-} -- | 'realToFrac' will use the midpoint instance Real a => Real (Interval a) where toRational (I ra rb) = a + (b - a) / 2 where a = toRational ra b = toRational rb {-# INLINE toRational #-} 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 {-# INLINE compare #-} max (I a b) (I a' b') = max a a' ... max b b' {-# INLINE max #-} min (I a b) (I a' b') = min a a' ... min b b' {-# INLINE min #-} -- @'divNonZero' X Y@ assumes @0 `'notElem'` Y@ 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' X y@ assumes y > 0, and divides @X@ by [0 ... y] divPositive :: (Fractional a, Ord a) => Interval a -> a -> Interval a divPositive x@(I a b) y | a == 0 && b == 0 = x -- b < 0 || isNegativeZero b = negInfinity ... ( b / y) | b < 0 = negInfinity ... (b / y) | a < 0 = whole | otherwise = (a / y) ... posInfinity {-# INLINE divPositive #-} -- divNegative assumes y < 0 and divides the interval @X@ by [y ... 0] divNegative :: (Fractional a, Ord a) => Interval a -> a -> Interval a divNegative x@(I a b) y | a == 0 && b == 0 = - x -- flip negative zeros -- b < 0 || isNegativeZero b = (b / y) ... posInfinity | b < 0 = (b / y) ... posInfinity | a < 0 = whole | otherwise = negInfinity ... (a / y) {-# INLINE divNegative #-} divZero :: (Fractional a, Ord a) => Interval a -> Interval a divZero x@(I a b) | a == 0 && b == 0 = x | otherwise = whole {-# INLINE divZero #-} instance (Fractional a, Ord a) => Fractional (Interval a) where -- TODO: check isNegativeZero properly 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 {-# INLINE recip #-} fromRational r = let r' = fromRational r in I r' r' {-# INLINE fromRational #-} instance RealFrac a => RealFrac (Interval a) where properFraction x = (b, x - fromIntegral b) where b = truncate (midpoint x) {-# INLINE properFraction #-} ceiling x = ceiling (sup x) {-# INLINE ceiling #-} floor x = floor (inf x) {-# INLINE floor #-} round x = round (midpoint x) {-# INLINE round #-} truncate x = truncate (midpoint x) {-# INLINE truncate #-} instance (RealFloat a, Ord a) => Floating (Interval a) where pi = singleton pi {-# INLINE pi #-} exp = increasing exp {-# INLINE exp #-} log (I a b) = (if a > 0 then log a else negInfinity) ... log b {-# INLINE log #-} 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) {-# INLINE cos #-} sin x = cos (x - pi / 2) {-# INLINE sin #-} 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 {-# INLINE tan #-} 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 {-# INLINE asin #-} acos (I a b) = I (if b >= 1 then 0 else acos b) (if a < -1 then pi else acos a) {-# INLINE acos #-} atan = increasing atan {-# INLINE atan #-} sinh = increasing sinh {-# INLINE 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 {-# INLINE cosh #-} tanh = increasing tanh {-# INLINE tanh #-} asinh = increasing asinh {-# INLINE asinh #-} acosh (I a b) = I lo $ acosh b where lo | a <= 1 = 0 | otherwise = acosh a {-# INLINE acosh #-} atanh (I a b) = I (if a <= - 1 then negInfinity else atanh a) (if b >= 1 then posInfinity else atanh b) {-# INLINE atanh #-} -- | lift a monotone increasing function over a given interval increasing :: (a -> b) -> Interval a -> Interval b increasing f (I a b) = I (f a) (f b) -- | lift a monotone decreasing function over a given interval decreasing :: (a -> b) -> Interval a -> Interval b decreasing f (I a b) = I (f b) (f a) -- | We have to play some semantic games to make these methods make sense. -- Most compute with the midpoint of the interval. 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 -- contains negative zero 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" -- TODO: (^), (^^) to give tighter bounds -- | Calculate the intersection of two intervals. -- -- >>> intersection (1 ... 10 :: Interval Double) (5 ... 15 :: Interval Double) -- Just (5.0 ... 10.0) 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') {-# INLINE intersection #-} -- | Calculate the convex hull of two intervals -- -- >>> hull (0 ... 10 :: Interval Double) (5 ... 15 :: Interval Double) -- 0.0 ... 15.0 -- -- >>> hull (15 ... 85 :: Interval Double) (0 ... 10 :: Interval Double) -- 0.0 ... 85.0 hull :: Ord a => Interval a -> Interval a -> Interval a hull (I a b) (I a' b') = I (min a a') (max b b') {-# INLINE hull #-} -- | For all @x@ in @X@, @y@ in @Y@. @x '<' y@ -- -- >>> (5 ... 10 :: Interval Double) >> (5 ... 10 :: Interval Double) >> (20 ... 30 :: Interval Double) Interval a -> Interval a -> Bool I _ bx >> (5 ... 10 :: Interval Double) <=! (20 ... 30 :: Interval Double) -- True -- -- >>> (5 ... 10 :: Interval Double) <=! (10 ... 30 :: Interval Double) -- True -- -- >>> (20 ... 30 :: Interval Double) <=! (5 ... 10 :: Interval Double) -- False (<=!) :: Ord a => Interval a -> Interval a -> Bool I _ bx <=! I ay _ = bx <= ay {-# INLINE (<=!) #-} -- | For all @x@ in @X@, @y@ in @Y@. @x '==' y@ -- -- Only singleton intervals or empty intervals can return true -- -- >>> (singleton 5 :: Interval Double) ==! (singleton 5 :: Interval Double) -- True -- -- >>> (5 ... 10 :: Interval Double) ==! (5 ... 10 :: Interval Double) -- False (==!) :: Eq a => Interval a -> Interval a -> Bool I ax bx ==! I ay by = bx == ay && ax == by {-# INLINE (==!) #-} -- | For all @x@ in @X@, @y@ in @Y@. @x '/=' y@ -- -- >>> (5 ... 15 :: Interval Double) /=! (20 ... 40 :: Interval Double) -- True -- -- >>> (5 ... 15 :: Interval Double) /=! (15 ... 40 :: Interval Double) -- False (/=!) :: Ord a => Interval a -> Interval a -> Bool I ax bx /=! I ay by = bx < ay || ax > by {-# INLINE (/=!) #-} -- | For all @x@ in @X@, @y@ in @Y@. @x '>' y@ -- -- >>> (20 ... 40 :: Interval Double) >! (10 ... 19 :: Interval Double) -- True -- -- >>> (5 ... 20 :: Interval Double) >! (15 ... 40 :: Interval Double) -- False (>!) :: Ord a => Interval a -> Interval a -> Bool I ax _ >! I _ by = ax > by {-# INLINE (>!) #-} -- | For all @x@ in @X@, @y@ in @Y@. @x '>=' y@ -- -- >>> (20 ... 40 :: Interval Double) >=! (10 ... 20 :: Interval Double) -- True -- -- >>> (5 ... 20 :: Interval Double) >=! (15 ... 40 :: Interval Double) -- False (>=!) :: Ord a => Interval a -> Interval a -> Bool I ax _ >=! I _ by = ax >= by {-# INLINE (>=!) #-} -- | For all @x@ in @X@, @y@ in @Y@. @x `op` y@ 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 = l ==! r | gt = l >! r | otherwise = False where lt = cmp False True eq = cmp True True gt = cmp True False {-# INLINE certainly #-} -- | Check if interval @X@ totally contains interval @Y@ -- -- >>> (20 ... 40 :: Interval Double) `contains` (25 ... 35 :: Interval Double) -- True -- -- >>> (20 ... 40 :: Interval Double) `contains` (15 ... 35 :: Interval Double) -- False contains :: Ord a => Interval a -> Interval a -> Bool contains (I ax bx) (I ay by) = ax <= ay && by <= bx {-# INLINE contains #-} -- | Flipped version of `contains`. Check if interval @X@ a subset of interval @Y@ -- -- >>> (25 ... 35 :: Interval Double) `isSubsetOf` (20 ... 40 :: Interval Double) -- True -- -- >>> (20 ... 40 :: Interval Double) `isSubsetOf` (15 ... 35 :: Interval Double) -- False isSubsetOf :: Ord a => Interval a -> Interval a -> Bool isSubsetOf = flip contains {-# INLINE isSubsetOf #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@? ( Interval a -> Interval a -> Bool I ax _ Interval a -> Interval a -> Bool I ax _ <=? I _ by = ax <= by {-# INLINE (<=?) #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@? (==?) :: Ord a => Interval a -> Interval a -> Bool I ax bx ==? I ay by = ax <= by && bx >= ay {-# INLINE (==?) #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@? (/=?) :: Eq a => Interval a -> Interval a -> Bool I ax bx /=? I ay by = ax /= by || bx /= ay {-# INLINE (/=?) #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@? (>?) :: Ord a => Interval a -> Interval a -> Bool I _ bx >? I ay _ = bx > ay {-# INLINE (>?) #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@? (>=?) :: Ord a => Interval a -> Interval a -> Bool I _ bx >=? I ay _ = bx >= ay {-# INLINE (>=?) #-} -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x `op` y@? 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 = l ==? r | gt = l >? r | otherwise = False where lt = cmp LT EQ eq = cmp EQ EQ gt = cmp GT EQ {-# INLINE possibly #-} -- | The nearest value to that supplied which is contained in the interval. clamp :: Ord a => Interval a -> a -> a clamp (I a b) x | x < a = a | x > b = b | otherwise = x -- | Inflate an interval by enlarging it at both ends. -- -- >>> inflate 3 (-1 ... 7) -- -4 ... 10 -- -- >>> inflate (-2) (0 ... 4) -- -2 ... 6 inflate :: (Num a, Ord a) => a -> Interval a -> Interval a inflate x y = symmetric x + y -- | Deflate an interval by shrinking it from both ends. -- Note that in cases that would result in an empty interval, the result is a singleton interval at the midpoint. -- -- >>> deflate 3.0 (-4.0 ... 10.0) -- -1.0 ... 7.0 -- -- >>> deflate 2.0 (-1.0 ... 1.0) -- 0.0 ... 0.0 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 an interval about its midpoint. -- -- >>> scale 1.1 (-6.0 ... 4.0) -- -6.5 ... 4.5 -- -- >>> scale (-2.0) (-1.0 ... 1.0) -- -2.0 ... 2.0 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 -- | Construct a symmetric interval. -- -- >>> symmetric 3 -- -3 ... 3 -- -- >>> symmetric (-2) -- -2 ... 2 symmetric :: (Num a, Ord a) => a -> Interval a symmetric x = negate x ... x -- | id function. Useful for type specification -- -- >>> :t idouble (1 ... 3) -- idouble (1 ... 3) :: Interval Double idouble :: Interval Double -> Interval Double idouble = id -- | id function. Useful for type specification -- -- >>> :t ifloat (1 ... 3) -- ifloat (1 ... 3) :: Interval Float ifloat :: Interval Float -> Interval Float ifloat = id -- Bugs: -- sin 1 :: Interval Double default (Integer,Double) intervals-0.7.1/tests/0000755000000000000000000000000012465050470013061 5ustar0000000000000000intervals-0.7.1/tests/doctests.hsc0000644000000000000000000000450112465050470015410 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | -- Module : Main (doctests) -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- This module provides doctests for a project based on the actual versions -- of the packages it was built with. It requires a corresponding Setup.lhs -- to be added to the project ----------------------------------------------------------------------------- module Main where import Build_doctests (deps) import Control.Applicative import Control.Monad import Data.List import System.Directory import System.FilePath import Test.DocTest ##if defined(mingw32_HOST_OS) ##if defined(i386_HOST_ARCH) ##define USE_CP import Control.Applicative import Control.Exception import Foreign.C.Types foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt ##elif defined(x86_64_HOST_ARCH) ##define USE_CP import Control.Applicative import Control.Exception import Foreign.C.Types foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt ##endif ##endif -- | Run in a modified codepage where we can print UTF-8 values on Windows. withUnicode :: IO a -> IO a ##ifdef USE_CP withUnicode m = do cp <- c_GetConsoleCP (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp ##else withUnicode m = m ##endif main :: IO () main = withUnicode $ getSources >>= \sources -> doctest $ "-isrc" : "-idist/build/autogen" : "-optP-include" : "-optPdist/build/autogen/cabal_macros.h" : "-hide-all-packages" : map ("-package="++) deps ++ sources getSources :: IO [FilePath] getSources = filter (isSuffixOf ".hs") <$> go "src" where go dir = do (dirs, files) <- getFilesAndDirectories dir (files ++) . concat <$> mapM go dirs getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) getFilesAndDirectories dir = do c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c