ieee 0.6.1 → 0.7
raw patch · 12 files changed
+1906/−597 lines, 12 filessetup-changed
Files
- Data/AEq.hs +518/−213
- LICENSE.Tango +83/−0
- NEWS +39/−0
- Numeric/IEEE.hs +251/−121
- Setup.lhs +1/−3
- cbits/double.c +98/−0
- cbits/feqrel_source.c +114/−0
- cbits/float.c +97/−0
- ieee.cabal +26/−12
- tests/Makefile +19/−0
- tests/Properties.hs +0/−248
- tests/Tests.hs +660/−0
Data/AEq.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.AEq@@ -7,277 +7,582 @@ -- Maintainer : Patrick Perry <patperry@gmail.com> -- Stability : experimental ----- A type class for approximate and exact equalilty comparisons and instances --- for common data types. +-- A type class for approximate and exact equalilty comparisons and instances+-- for common data types. module Data.AEq ( AEq(..), ) where +import Foreign import Foreign.C.Types-import Data.Int-import Data.Word import Data.Complex import Numeric.IEEE -infix 4 ===, ~==+infix 4 ===, ~== +-- | Types with approximate and exact equality comparisons. class Eq a => AEq a where- -- | A reliable way to test if two values are exactly equal. For floating- -- point values, this will consider @NaN@ to be (===) to @NaN@.+ -- | An exact equality comparison.+ --+ -- For real 'IEEE' types, two values are equivalent in the+ -- following cases:+ --+ -- * both values are @+0@;+ --+ -- * both values are @-0@;+ --+ -- * both values are nonzero and equal to each other+ -- (according to '==');+ --+ -- * both values are @NaN@ with the same payload and sign.+ --+ -- For complex 'IEEE' types, two values are equivalent if their+ -- real and imaginary parts are equivalent.+ -- (===) :: a -> a -> Bool (===) = (==)- - -- | An approximate equality comparison operator. For @RealFloat@ values, - -- @(~==) x y = (x == y)- -- || (abs (x - y) < epsilon) - -- || (eqRel delta x y) - -- || (isNaN x && isNaN y)@.- -- For Complex numbers, the if the real and imaginary parts are not- -- approximately equal, the polar forms are compared, instead.+ {-# INLINE (===) #-}++ -- | An approximate equality comparison operator.+ --+ -- For real 'IEEE' types, two values are approximately equal in the+ -- following cases:+ --+ -- * at least half of their significand bits agree;+ --+ -- * both values are less than 'epsilon';+ --+ -- * both values are @NaN@.+ --+ -- For complex 'IEEE' types, two values are approximately equal in the+ -- followiing cases:+ --+ -- * their magnitudes are approximately equal and the angle between+ -- them is less than @32*'epsilon'@;+ --+ -- * both magnitudes are less than 'epsilon';+ --+ -- * both have a @NaN@ real or imaginary part.+ --+ -- Admitedly, the @32@ is a bit of a hack. Future versions of the+ -- library may switch to a more principled test of the angle.+ -- (~==) :: a -> a -> Bool- (~==) = (==) - -identicalRealFloat :: (RealFloat a) => a -> a -> Bool-identicalRealFloat x y = - (x == y) || (isNaN x && isNaN y)+ (~==) = (==)+ {-# INLINE (~==) #-} -approxEqRealFloat :: (RealFloat a) => a -> a -> Bool-approxEqRealFloat x y =- (x == y) || (abs (x - y) < epsilon) || (eqRel delta x y) || (isNaN x && isNaN y)+approxEqIEEE :: (IEEE a) => a -> a -> Bool+approxEqIEEE x y =+ ( sameSignificandBits x y >= d+ || (x < epsilon && y < epsilon)+ || (isNaN x && isNaN y)+ )+ where+ d = (floatDigits x + 1) `div` 2+{-# INLINE approxEqIEEE #-} -identicalComplexFloat :: (RealFloat a) => Complex a -> Complex a -> Bool-identicalComplexFloat (x1 :+ y1) (x2 :+ y2) =- (identicalRealFloat x1 x2) && (identicalRealFloat y1 y2)+identicalComplexIEEE :: (IEEE a) => Complex a -> Complex a -> Bool+identicalComplexIEEE (x1 :+ y1) (x2 :+ y2) =+ (identicalIEEE x1 x2) && (identicalIEEE y1 y2)+{-# INLINE identicalComplexIEEE #-} -approxEqComplexFloat :: (RealFloat a) => Complex a -> Complex a -> Bool-approxEqComplexFloat z1@(x1 :+ y1) z2@(x2 :+ y2) = let+approxEqComplexIEEE :: (IEEE a) => Complex a -> Complex a -> Bool+approxEqComplexIEEE z1 z2 = let (r1,c1) = polar z1 (r2,c2) = polar z2- c = min c1 c2- c' = max c1 c2 in- ((approxEqRealFloat x1 x2 && approxEqRealFloat y1 y2) - || ((approxEqRealFloat r1 r2) - && ((approxEqRealFloat c1 c2) || (approxEqRealFloat (c + 2 * pi) c'))))+ angle = abs (c1 - c2)+ in ( ( approxEqIEEE r1 r2+ && (angle < 32*epsilon || angle > 2*(pi - 16*epsilon) || isNaN angle)+ )+ || (r1 < epsilon && r2 < epsilon)+ )+{-# INLINE approxEqComplexIEEE #-} instance AEq Float where- (===) = identicalRealFloat- (~==) = approxEqRealFloat- -instance AEq Double where- (===) = identicalRealFloat- (~==) = approxEqRealFloat--instance (RealFloat a) => AEq (Complex a) where- (===) = identicalComplexFloat- (~==) = approxEqComplexFloat+ (===) = identicalIEEE+ {-# INLINE (===) #-}+ (~==) = approxEqIEEE+ {-# INLINE (~==) #-} -instance AEq Bool where- (===) = (==)- (~==) = (==)+instance AEq Double where+ (===) = identicalIEEE+ {-# INLINE (===) #-}+ (~==) = approxEqIEEE+ {-# INLINE (~==) #-} -instance AEq Char where- (===) = (==)- (~==) = (==)- -instance AEq Int where- (===) = (==)- (~==) = (==)+instance AEq (Complex Float) where+ (===) = identicalComplexIEEE+ {-# INLINE (===) #-}+ (~==) = approxEqComplexIEEE+ {-# INLINE (~==) #-} -instance AEq Int8 where- (===) = (==)- (~==) = (==)- -instance AEq Int16 where- (===) = (==)- (~==) = (==)- -instance AEq Int32 where- (===) = (==)- (~==) = (==)+instance AEq (Complex Double) where+ (===) = identicalComplexIEEE+ {-# INLINE (===) #-}+ (~==) = approxEqComplexIEEE+ {-# INLINE (~==) #-} -instance AEq Int64 where- (===) = (==)- (~==) = (==)+instance AEq CFloat where+ (===) = identicalIEEE+ {-# INLINE (===) #-}+ (~==) = approxEqIEEE+ {-# INLINE (~==) #-} -instance AEq Integer where- (===) = (==)- (~==) = (==)+instance AEq CDouble where+ (===) = identicalIEEE+ {-# INLINE (===) #-}+ (~==) = approxEqIEEE+ {-# INLINE (~==) #-} -instance AEq Ordering where- (===) = (==)- (~==) = (==)+instance AEq (Complex CFloat) where+ (===) = identicalComplexIEEE+ {-# INLINE (===) #-}+ (~==) = approxEqComplexIEEE+ {-# INLINE (~==) #-} -instance AEq Word where- (===) = (==)- (~==) = (==)+instance AEq (Complex CDouble) where+ (===) = identicalComplexIEEE+ {-# INLINE (===) #-}+ (~==) = approxEqComplexIEEE+ {-# INLINE (~==) #-} -instance AEq Word8 where- (===) = (==)- (~==) = (==)- -instance AEq Word16 where- (===) = (==)- (~==) = (==)- -instance AEq Word32 where- (===) = (==)- (~==) = (==)- -instance AEq Word64 where- (===) = (==)- (~==) = (==)+instance AEq Bool+instance AEq Char+instance AEq Int+instance AEq Int8+instance AEq Int16+instance AEq Int32+instance AEq Int64+instance AEq Integer+instance AEq Ordering+instance AEq Word+instance AEq Word8+instance AEq Word16+instance AEq Word32+instance AEq Word64+instance AEq ()+instance AEq WordPtr+instance AEq IntPtr+instance AEq (StablePtr a)+instance AEq (Ptr a)+instance AEq (FunPtr a)+instance AEq (ForeignPtr a)+instance AEq CChar+instance AEq CSChar+instance AEq CUChar+instance AEq CShort+instance AEq CUShort+instance AEq CInt+instance AEq CUInt+instance AEq CLong+instance AEq CULong+instance AEq CPtrdiff+instance AEq CSize+instance AEq CWchar+instance AEq CSigAtomic+instance AEq CLLong+instance AEq CULLong+instance AEq CIntPtr+instance AEq CUIntPtr+instance AEq CIntMax+instance AEq CUIntMax+instance AEq CClock+instance AEq CTime -instance AEq () where- (===) = (==)- (~==) = (==)- -instance AEq CChar where- (===) = (==)- (~==) = (==)+eqListsWith :: (a -> a -> Bool) -> [a] -> [a] -> Bool+eqListsWith f (x:xs) (y:ys) = f x y && eqListsWith f xs ys+eqListsWith _ [] [] = True+eqListsWith _ _ _ = False+{-# INLINE eqListsWith #-} -instance AEq CSChar where- (===) = (==)- (~==) = (==)+instance (AEq a) => AEq [a] where+ (===) = eqListsWith (===)+ {-# INLINE (===) #-}+ (~==) = eqListsWith (~==)+ {-# INLINE (~==) #-} -instance AEq CUChar where- (===) = (==)- (~==) = (==)+instance (AEq a) => AEq (Maybe a) where+ (===) Nothing Nothing = True+ (===) (Just x) (Just y) = (===) x y+ (===) _ _ = False+ {-# INLINE (===) #-} -instance AEq CShort where- (===) = (==)- (~==) = (==)+ (~==) Nothing Nothing = True+ (~==) (Just x) (Just y) = (~==) x y+ (~==) _ _ = False+ {-# INLINE (~==) #-} -instance AEq CUShort where- (===) = (==)- (~==) = (==)+instance (AEq a, AEq b) => AEq (Either a b) where+ (===) (Left a1) (Left a2) = (===) a1 a2+ (===) (Right b1) (Right b2) = (===) b1 b2+ (===) _ _ = False+ {-# INLINE (===) #-} -instance AEq CInt where- (===) = (==)- (~==) = (==)+ (~==) (Left a1) (Left a2) = (~==) a1 a2+ (~==) (Right b1) (Right b2) = (~==) b1 b2+ (~==) _ _ = False+ {-# INLINE (~==) #-} -instance AEq CUInt where- (===) = (==)- (~==) = (==)+instance (AEq a, AEq b) => AEq (a,b) where+ (===) (a1,b1) (a2,b2) =+ ( ((===) a1 a2)+ && ((===) b1 b2)+ )+ {-# INLINE (===) #-} -instance AEq CLong where- (===) = (==)- (~==) = (==)+ (~==) (a1,b1) (a2,b2) =+ ( ((~==) a1 a2)+ && ((~==) b1 b2)+ )+ {-# INLINE (~==) #-} -instance AEq CULong where- (===) = (==)- (~==) = (==)+instance (AEq a, AEq b, AEq c) => AEq (a,b,c) where+ (===) (a1,b1,c1) (a2,b2,c2) =+ ( ((===) a1 a2)+ && ((===) b1 b2)+ && ((===) c1 c2)+ )+ {-# INLINE (===) #-} -instance AEq CPtrdiff where- (===) = (==)- (~==) = (==)+ (~==) (a1,b1,c1) (a2,b2,c2) =+ ( ((~==) a1 a2)+ && ((~==) b1 b2)+ && ((~==) c1 c2)+ )+ {-# INLINE (~==) #-} -instance AEq CSize where- (===) = (==)- (~==) = (==)+instance (AEq a, AEq b, AEq c, AEq d) => AEq (a,b,c,d) where+ (===) (a1,b1,c1,d1) (a2,b2,c2,d2) =+ ( ((===) a1 a2)+ && ((===) b1 b2)+ && ((===) c1 c2)+ && ((===) d1 d2)+ )+ {-# INLINE (===) #-} -instance AEq CWchar where- (===) = (==)- (~==) = (==)+ (~==) (a1,b1,c1,d1) (a2,b2,c2,d2) =+ ( ((~==) a1 a2)+ && ((~==) b1 b2)+ && ((~==) c1 c2)+ && ((~==) d1 d2)+ )+ {-# INLINE (~==) #-} -instance AEq CSigAtomic where- (===) = (==)- (~==) = (==)+instance (AEq a, AEq b, AEq c, AEq d, AEq e) => AEq (a,b,c,d,e) where+ (===) (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) =+ ( ((===) a1 a2)+ && ((===) b1 b2)+ && ((===) c1 c2)+ && ((===) d1 d2)+ && ((===) e1 e2)+ )+ {-# INLINE (===) #-} -instance AEq CLLong where- (===) = (==)- (~==) = (==)+ (~==) (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) =+ ( ((~==) a1 a2)+ && ((~==) b1 b2)+ && ((~==) c1 c2)+ && ((~==) d1 d2)+ && ((~==) e1 e2)+ )+ {-# INLINE (~==) #-} -instance AEq CULLong where- (===) = (==)- (~==) = (==)+instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f) => AEq (a,b,c,d,e,f) where+ (===) (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) =+ ( ((===) a1 a2)+ && ((===) b1 b2)+ && ((===) c1 c2)+ && ((===) d1 d2)+ && ((===) e1 e2)+ && ((===) f1 f2)+ )+ {-# INLINE (===) #-} -instance AEq CIntPtr where- (===) = (==)- (~==) = (==)+ (~==) (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) =+ ( ((~==) a1 a2)+ && ((~==) b1 b2)+ && ((~==) c1 c2)+ && ((~==) d1 d2)+ && ((~==) e1 e2)+ && ((~==) f1 f2)+ )+ {-# INLINE (~==) #-} -instance AEq CUIntPtr where- (===) = (==)- (~==) = (==)+instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g) => AEq (a,b,c,d,e,f,g) where+ (===) (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) =+ ( ((===) a1 a2)+ && ((===) b1 b2)+ && ((===) c1 c2)+ && ((===) d1 d2)+ && ((===) e1 e2)+ && ((===) f1 f2)+ && ((===) g1 g2)+ )+ {-# INLINE (===) #-} -instance AEq CIntMax where- (===) = (==)- (~==) = (==)+ (~==) (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) =+ ( ((~==) a1 a2)+ && ((~==) b1 b2)+ && ((~==) c1 c2)+ && ((~==) d1 d2)+ && ((~==) e1 e2)+ && ((~==) f1 f2)+ && ((~==) g1 g2)+ )+ {-# INLINE (~==) #-} -instance AEq CUIntMax where- (===) = (==)- (~==) = (==)+instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h) => AEq (a,b,c,d,e,f,g,h) where+ (===) (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) =+ ( ((===) a1 a2)+ && ((===) b1 b2)+ && ((===) c1 c2)+ && ((===) d1 d2)+ && ((===) e1 e2)+ && ((===) f1 f2)+ && ((===) g1 g2)+ && ((===) h1 h2)+ )+ {-# INLINE (===) #-} -instance AEq CClock where- (===) = (==)- (~==) = (==)+ (~==) (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) =+ ( ((~==) a1 a2)+ && ((~==) b1 b2)+ && ((~==) c1 c2)+ && ((~==) d1 d2)+ && ((~==) e1 e2)+ && ((~==) f1 f2)+ && ((~==) g1 g2)+ && ((~==) h1 h2)+ )+ {-# INLINE (~==) #-} -instance AEq CTime where- (===) = (==)- (~==) = (==)+instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h, AEq i) => AEq (a,b,c,d,e,f,g,h,i) where+ (===) (a1,b1,c1,d1,e1,f1,g1,h1,i1) (a2,b2,c2,d2,e2,f2,g2,h2,i2) =+ ( ((===) a1 a2)+ && ((===) b1 b2)+ && ((===) c1 c2)+ && ((===) d1 d2)+ && ((===) e1 e2)+ && ((===) f1 f2)+ && ((===) g1 g2)+ && ((===) h1 h2)+ && ((===) i1 i2)+ )+ {-# INLINE (===) #-} -instance AEq CFloat where- (===) = identicalRealFloat- (~==) = approxEqRealFloat- -instance AEq CDouble where- (===) = identicalRealFloat- (~==) = approxEqRealFloat+ (~==) (a1,b1,c1,d1,e1,f1,g1,h1,i1) (a2,b2,c2,d2,e2,f2,g2,h2,i2) =+ ( ((~==) a1 a2)+ && ((~==) b1 b2)+ && ((~==) c1 c2)+ && ((~==) d1 d2)+ && ((~==) e1 e2)+ && ((~==) f1 f2)+ && ((~==) g1 g2)+ && ((~==) h1 h2)+ && ((~==) i1 i2)+ )+ {-# INLINE (~==) #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 610+instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h, AEq i, AEq j) => AEq (a,b,c,d,e,f,g,h,i,j) where+ (===) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) =+ ( ((===) a1 a2)+ && ((===) b1 b2)+ && ((===) c1 c2)+ && ((===) d1 d2)+ && ((===) e1 e2)+ && ((===) f1 f2)+ && ((===) g1 g2)+ && ((===) h1 h2)+ && ((===) i1 i2)+ && ((===) j1 j2)+ )+ {-# INLINE (===) #-} -{-- - CLDouble was removed[1] from GHC 6.12 but is due to return later[2].- -- - [1] http://hackage.haskell.org/trac/ghc/ticket/2793- - [2] http://hackage.haskell.org/trac/ghc/ticket/3353- -}- -instance AEq CLDouble where- (===) = identicalRealFloat- (~==) = approxEqRealFloat+ (~==) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) =+ ( ((~==) a1 a2)+ && ((~==) b1 b2)+ && ((~==) c1 c2)+ && ((~==) d1 d2)+ && ((~==) e1 e2)+ && ((~==) f1 f2)+ && ((~==) g1 g2)+ && ((~==) h1 h2)+ && ((~==) i1 i2)+ && ((~==) j1 j2)+ )+ {-# INLINE (~==) #-} -#endif+instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h, AEq i, AEq j, AEq k) => AEq (a,b,c,d,e,f,g,h,i,j,k) where+ (===) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) =+ ( ((===) a1 a2)+ && ((===) b1 b2)+ && ((===) c1 c2)+ && ((===) d1 d2)+ && ((===) e1 e2)+ && ((===) f1 f2)+ && ((===) g1 g2)+ && ((===) h1 h2)+ && ((===) i1 i2)+ && ((===) j1 j2)+ && ((===) k1 k2)+ )+ {-# INLINE (===) #-} -instance (AEq a, AEq b) => AEq (a,b) where- (===) (a1,b1) (a2,b2) = ((===) a1 a2) && ((===) b1 b2)- (~==) (a1,b1) (a2,b2) = ((~==) a1 a2) && ((~==) b1 b2)+ (~==) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) =+ ( ((~==) a1 a2)+ && ((~==) b1 b2)+ && ((~==) c1 c2)+ && ((~==) d1 d2)+ && ((~==) e1 e2)+ && ((~==) f1 f2)+ && ((~==) g1 g2)+ && ((~==) h1 h2)+ && ((~==) i1 i2)+ && ((~==) j1 j2)+ && ((~==) k1 k2)+ )+ {-# INLINE (~==) #-} -instance (AEq a, AEq b, AEq c) => AEq (a,b,c) where- (===) (a1,b1,c1) (a2,b2,c2) = ((===) a1 a2) && ((===) b1 b2) && ((===) c1 c2)- (~==) (a1,b1,c1) (a2,b2,c2) = ((~==) a1 a2) && ((~==) b1 b2) && ((~==) c1 c2)+instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h, AEq i, AEq j, AEq k, AEq l) => AEq (a,b,c,d,e,f,g,h,i,j,k,l) where+ (===) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) =+ ( ((===) a1 a2)+ && ((===) b1 b2)+ && ((===) c1 c2)+ && ((===) d1 d2)+ && ((===) e1 e2)+ && ((===) f1 f2)+ && ((===) g1 g2)+ && ((===) h1 h2)+ && ((===) i1 i2)+ && ((===) j1 j2)+ && ((===) k1 k2)+ && ((===) l1 l2)+ )+ {-# INLINE (===) #-} -instance (AEq a, AEq b, AEq c, AEq d) => AEq (a,b,c,d) where- (===) (a1,b1,c1,d1) (a2,b2,c2,d2) = ((===) a1 a2) && ((===) b1 b2) && ((===) c1 c2) && ((===) d1 d2)- (~==) (a1,b1,c1,d1) (a2,b2,c2,d2) = ((~==) a1 a2) && ((~==) b1 b2) && ((~==) c1 c2) && ((~==) d1 d2)+ (~==) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) =+ ( ((~==) a1 a2)+ && ((~==) b1 b2)+ && ((~==) c1 c2)+ && ((~==) d1 d2)+ && ((~==) e1 e2)+ && ((~==) f1 f2)+ && ((~==) g1 g2)+ && ((~==) h1 h2)+ && ((~==) i1 i2)+ && ((~==) j1 j2)+ && ((~==) k1 k2)+ && ((~==) l1 l2)+ )+ {-# INLINE (~==) #-} -instance (AEq a, AEq b, AEq c, AEq d, AEq e) => AEq (a,b,c,d,e) where- (===) (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = ((===) a1 a2) && ((===) b1 b2) && ((===) c1 c2) && ((===) d1 d2) && ((===) e1 e2)- (~==) (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = ((~==) a1 a2) && ((~==) b1 b2) && ((~==) c1 c2) && ((~==) d1 d2) && ((~==) e1 e2)+instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h, AEq i, AEq j, AEq k, AEq l, AEq m) => AEq (a,b,c,d,e,f,g,h,i,j,k,l,m) where+ (===) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) =+ ( ((===) a1 a2)+ && ((===) b1 b2)+ && ((===) c1 c2)+ && ((===) d1 d2)+ && ((===) e1 e2)+ && ((===) f1 f2)+ && ((===) g1 g2)+ && ((===) h1 h2)+ && ((===) i1 i2)+ && ((===) j1 j2)+ && ((===) k1 k2)+ && ((===) l1 l2)+ && ((===) m1 m2)+ )+ {-# INLINE (===) #-} + (~==) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) =+ ( ((~==) a1 a2)+ && ((~==) b1 b2)+ && ((~==) c1 c2)+ && ((~==) d1 d2)+ && ((~==) e1 e2)+ && ((~==) f1 f2)+ && ((~==) g1 g2)+ && ((~==) h1 h2)+ && ((~==) i1 i2)+ && ((~==) j1 j2)+ && ((~==) k1 k2)+ && ((~==) l1 l2)+ && ((~==) m1 m2)+ )+ {-# INLINE (~==) #-} -compareListsWith :: (a -> a -> Bool) -> [a] -> [a] -> Bool-compareListsWith _ [] [] = True-compareListsWith f (x:xs) (y:ys) = (f x y) && (compareListsWith f xs ys)-compareListsWith _ _ _ = False+instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h, AEq i, AEq j, AEq k, AEq l, AEq m, AEq n) => AEq (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where+ (===) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) =+ ( ((===) a1 a2)+ && ((===) b1 b2)+ && ((===) c1 c2)+ && ((===) d1 d2)+ && ((===) e1 e2)+ && ((===) f1 f2)+ && ((===) g1 g2)+ && ((===) h1 h2)+ && ((===) i1 i2)+ && ((===) j1 j2)+ && ((===) k1 k2)+ && ((===) l1 l2)+ && ((===) m1 m2)+ && ((===) n1 n2)+ )+ {-# INLINE (===) #-} -instance (AEq a) => AEq [a] where- (===) = compareListsWith (===)- (~==) = compareListsWith (~==)+ (~==) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) =+ ( ((~==) a1 a2)+ && ((~==) b1 b2)+ && ((~==) c1 c2)+ && ((~==) d1 d2)+ && ((~==) e1 e2)+ && ((~==) f1 f2)+ && ((~==) g1 g2)+ && ((~==) h1 h2)+ && ((~==) i1 i2)+ && ((~==) j1 j2)+ && ((~==) k1 k2)+ && ((~==) l1 l2)+ && ((~==) m1 m2)+ && ((~==) n1 n2)+ )+ {-# INLINE (~==) #-} -instance (AEq a) => AEq (Maybe a) where- (===) Nothing Nothing = True- (===) (Just x) (Just y) = (===) x y- (===) _ _ = False- - (~==) Nothing Nothing = True- (~==) (Just x) (Just y) = (~==) x y- (~==) _ _ = False- -instance (AEq a, AEq b) => AEq (Either a b) where- (===) (Left a1) (Left a2) = (===) a1 a2- (===) (Right b1) (Right b2) = (===) b1 b2- (===) _ _ = False+instance (AEq a, AEq b, AEq c, AEq d, AEq e, AEq f, AEq g, AEq h, AEq i, AEq j, AEq k, AEq l, AEq m, AEq n, AEq o) => AEq (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where+ (===) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) =+ ( ((===) a1 a2)+ && ((===) b1 b2)+ && ((===) c1 c2)+ && ((===) d1 d2)+ && ((===) e1 e2)+ && ((===) f1 f2)+ && ((===) g1 g2)+ && ((===) h1 h2)+ && ((===) i1 i2)+ && ((===) j1 j2)+ && ((===) k1 k2)+ && ((===) l1 l2)+ && ((===) m1 m2)+ && ((===) n1 n2)+ && ((===) o1 o2)+ )+ {-# INLINE (===) #-} - (~==) (Left a1) (Left a2) = (~==) a1 a2- (~==) (Right b1) (Right b2) = (~==) b1 b2- (~==) _ _ = False+ (~==) (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) =+ ( ((~==) a1 a2)+ && ((~==) b1 b2)+ && ((~==) c1 c2)+ && ((~==) d1 d2)+ && ((~==) e1 e2)+ && ((~==) f1 f2)+ && ((~==) g1 g2)+ && ((~==) h1 h2)+ && ((~==) i1 i2)+ && ((~==) j1 j2)+ && ((~==) k1 k2)+ && ((~==) l1 l2)+ && ((~==) m1 m2)+ && ((~==) n1 n2)+ && ((~==) o1 o2)+ )+ {-# INLINE (~==) #-}
+ LICENSE.Tango view
@@ -0,0 +1,83 @@+Tango is Open Source software, distributed by a group of developers which has been set up for the purpose of providing a vendor-neutral owner of Tango intellectual property. The goals of all Tango licensing decisions are to:++ * Encourage adoption+ * Discourage political contention+ * Encourage collaboration and integration with other projects+ * Be transparent++Tango is dual-licensed:+ * Academic Free License v3.0 (http://www.dsource.org/projects/tango/wiki/AcademicFreeLicense30) [2]+ * BSD License (http://www.dsource.org/projects/tango/wiki/BSDLicense) [1][3]++The preferred license is the Academic Free License v3.0. All Tango projects release their code under the terms of this license. Both licenses:++ * Allow commercial use without encumbrance+ * Provide broad rights to make new products and derivative works+ * Place no requirement on users to contribute back (although we appreciate it if you do)++Users who wish to include Tango with software licensed under the (L)GPL will want to use Tango under the terms of the BSD License. [1] Tango projects may request a variance from the developers to release their projects under additional licenses in conjunction with the AFL.++If you have further questions regarding Tango licensing, please do not hesitate to contact us (http://dsource.org/projects/tango/wiki/Contact).+++[1] The advertising clause has not been a part of the BSD License since July 22, 1999. (ftp://ftp.cs.berkeley.edu/pub/4bsd/README.Impt.License.Change)++[2] Academic Free License v3.0+Original Work: Tango+Licensor: Tango contributors++This Academic Free License (the "License") applies to any original work of authorship (the "Original Work") whose owner (the "Licensor") has placed the following licensing notice adjacent to the copyright notice for the Original Work: ++Licensed under the Academic Free License version 3.0 +1. Grant of Copyright License. Licensor grants You a worldwide, royalty-free, non-exclusive, sublicensable license, for the duration of the copyright, to do the following: ++ a) to reproduce the Original Work in copies, either alone or as part of a collective work; ++ b) to translate, adapt, alter, transform, modify, or arrange the Original Work, thereby creating derivative works ("Derivative Works") based upon the Original Work; ++ c) to distribute or communicate copies of the Original Work and Derivative Works to the public, under any license of your choice that does not contradict the terms and conditions, including Licensor’s reserved rights and remedies, in this Academic Free License; ++ d) to perform the Original Work publicly; and ++ e) to display the Original Work publicly. ++2. Grant of Patent License. Licensor grants You a worldwide, royalty-free, non-exclusive, sublicensable license, under patent claims owned or controlled by the Licensor that are embodied in the Original Work as furnished by the Licensor, for the duration of the patents, to make, use, sell, offer for sale, have made, and import the Original Work and Derivative Works. ++3. Grant of Source Code License. The term "Source Code" means the preferred form of the Original Work for making modifications to it and all available documentation describing how to modify the Original Work. Licensor agrees to provide a machine-readable copy of the Source Code of the Original Work along with each copy of the Original Work that Licensor distributes. Licensor reserves the right to satisfy this obligation by placing a machine-readable copy of the Source Code in an information repository reasonably calculated to permit inexpensive and convenient access by You for as long as Licensor continues to distribute the Original Work. ++4. Exclusions From License Grant. Neither the names of Licensor, nor the names of any contributors to the Original Work, nor any of their trademarks or service marks, may be used to endorse or promote products derived from this Original Work without express prior permission of the Licensor. Except as expressly stated herein, nothing in this License grants any license to Licensor’s trademarks, copyrights, patents, trade secrets or any other intellectual property. No patent license is granted to make, use, sell, offer for sale, have made, or import embodiments of any patent claims other than the licensed claims defined in Section 2. No license is granted to the trademarks of Licensor even if such marks are included in the Original Work. Nothing in this License shall be interpreted to prohibit Licensor from licensing under terms different from this License any Original Work that Licensor otherwise would have a right to license. ++5. External Deployment. The term "External Deployment" means the use, distribution, or communication of the Original Work or Derivative Works in any way such that the Original Work or Derivative Works may be used by anyone other than You, whether those works are distributed or communicated to those persons or made available as an application intended for use over a network. As an express condition for the grants of license hereunder, You must treat any External Deployment by You of the Original Work or a Derivative Work as a distribution under section 1(c). ++6. Attribution Rights. You must retain, in the Source Code of any Derivative Works that You create, all copyright, patent, or trademark notices from the Source Code of the Original Work, as well as any notices of licensing and any descriptive text identified therein as an "Attribution Notice." You must cause the Source Code for any Derivative Works that You create to carry a prominent Attribution Notice reasonably calculated to inform recipients that You have modified the Original Work. ++7. Warranty of Provenance and Disclaimer of Warranty. Licensor warrants that the copyright in and to the Original Work and the patent rights granted herein by Licensor are owned by the Licensor or are sublicensed to You under the terms of this License with the permission of the contributor(s) of those copyrights and patent rights. Except as expressly stated in the immediately preceding sentence, the Original Work is provided under this License on an "AS IS" BASIS and WITHOUT WARRANTY, either express or implied, including, without limitation, the warranties of non-infringement, merchantability or fitness for a particular purpose. THE ENTIRE RISK AS TO THE QUALITY OF THE ORIGINAL WORK IS WITH YOU. This DISCLAIMER OF WARRANTY constitutes an essential part of this License. No license to the Original Work is granted by this License except under this disclaimer. ++8. Limitation of Liability. Under no circumstances and under no legal theory, whether in tort (including negligence), contract, or otherwise, shall the Licensor be liable to anyone for any indirect, special, incidental, or consequential damages of any character arising as a result of this License or the use of the Original Work including, without limitation, damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses. This limitation of liability shall not apply to the extent applicable law prohibits such limitation. ++9. Acceptance and Termination. If, at any time, You expressly assented to this License, that assent indicates your clear and irrevocable acceptance of this License and all of its terms and conditions. If You distribute or communicate copies of the Original Work or a Derivative Work, You must make a reasonable effort under the circumstances to obtain the express assent of recipients to the terms of this License. This License conditions your rights to undertake the activities listed in Section 1, including your right to create Derivative Works based upon the Original Work, and doing so without honoring these terms and conditions is prohibited by copyright law and international treaty. Nothing in this License is intended to affect copyright exceptions and limitations (including “fair use” or “fair dealing”). This License shall terminate immediately and You may no longer exercise any of the rights granted to You by this License upon your failure to honor the conditions in Section 1(c). ++10. Termination for Patent Action. This License shall terminate automatically and You may no longer exercise any of the rights granted to You by this License as of the date You commence an action, including a cross-claim or counterclaim, against Licensor or any licensee alleging that the Original Work infringes a patent. This termination provision shall not apply for an action alleging patent infringement by combinations of the Original Work with other software or hardware. ++11. Jurisdiction, Venue and Governing Law. Any action or suit relating to this License may be brought only in the courts of a jurisdiction wherein the Licensor resides or in which Licensor conducts its primary business, and under the laws of that jurisdiction excluding its conflict-of-law provisions. The application of the United Nations Convention on Contracts for the International Sale of Goods is expressly excluded. Any use of the Original Work outside the scope of this License or after its termination shall be subject to the requirements and penalties of copyright or patent law in the appropriate jurisdiction. This section shall survive the termination of this License. ++12. Attorneys’ Fees. In any action to enforce the terms of this License or seeking damages relating thereto, the prevailing party shall be entitled to recover its costs and expenses, including, without limitation, reasonable attorneys' fees and costs incurred in connection with such action, including any appeal of such action. This section shall survive the termination of this License. ++13. Miscellaneous. If any provision of this License is held to be unenforceable, such provision shall be reformed only to the extent necessary to make it enforceable. ++14. Definition of "You" in This License. "You" throughout this License, whether in upper or lower case, means an individual or a legal entity exercising rights under, and complying with all of the terms of, this License. For legal entities, "You" includes any entity that controls, is controlled by, or is under common control with you. For purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. ++15. Right to Use. You may use the Original Work in all ways not otherwise restricted or conditioned by this License or by law, and Licensor promises not to interfere with or be responsible for such uses by You. ++16. Modification of This License. This License is Copyright © 2005 Lawrence Rosen. Permission is granted to copy, distribute, or communicate this License without modification. Nothing in this License permits You to modify this License as applied to the Original Work or to Derivative Works. However, You may modify the text of this License and copy, distribute or communicate your modified version (the "Modified License") and apply it to other original works of authorship subject to the following conditions: (i) You may not indicate in any way that your Modified License is the "Academic Free License" or "AFL" and you may not use those names in the name of your Modified License; (ii) You must replace the notice specified in the first paragraph above with the notice "Licensed under <insert your license name here>" or with a notice of your own that is not confusingly similar to the notice in this License; and (iii) You may not claim that your original works are open source software unless your Modified License has been approved by Open Source Initiative (OSI) and You comply with its license review and certification process.++[3]. BSD license+Copyright (c) 2004-2008, Tango contributors+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.+ * Neither the name of the <ORGANIZATION> nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++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.
NEWS view
@@ -1,3 +1,42 @@+Changes in 0.7:++* Add IEEE type class with instances for Double, Float, CDouble, and CFloat++* Add functions for getting/setting NaN payloads++* Add succIEEE/predIEEE for advancing up and down the IEEE number line+ (ported from Tango's nextUp and nextDown)++* Add bisectIEEE for midpoints of two numbers on the IEEE number line+ (ported from Tango's ieeeMean)++* Add identicalIEEE for exact (bitwise) equality of IEEE numbers++* Add copySign for setting the sign bit of an IEEE number++* Add sameSignificandBits for seeing how many significand bits of two+ IEEE numbers agree, ported from Tango's feqrel++* Add nan, infinity, maxFinite, minNormal constants for IEEE numbers++* Add maxNum and minNum++* Rename maxF and minF to maxNaN and minNaN++* Switch to a simpler "~==" comparison for complex numbers++* Make "~==" comparison use sameSignificandBits for IEEE types++* Make "===" comparison use bitwise equality for IEEE types++* Remove old "eqRel" comparisons.++* Remove old epsilon' and delta constants++* Remove (RealFloat a) => AEq (Complex a) instance in favor of explicit+ instances for Complex {Double,Float,CDouble,CFloat}++ Changes in 0.6.1: * Remove AEq instance for CLDouble (thanks to Bjorn Buckwalter)
Numeric/IEEE.hs view
@@ -1,147 +1,277 @@+{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.IEEE--- Copyright : Copyright (c) 2008, Patrick Perry <patperry@stanford.edu>+-- Copyright : Copyright (c) 2010, Patrick Perry <patperry@gmail.com> -- License : BSD3--- Maintainer : Patrick Perry <patperry@stanford.edu>+-- Maintainer : Patrick Perry <patperry@gmail.com> -- Stability : experimental ----- Approximate comparison of floating point numbers based on the--- algorithm in Section 4.2.2 of Knuth's _Seminumerical Algorithms_--- and NaN-aware minimum and maximum.--- --- Relative accuracy within @eps@ is measured using an interval of size @2*r@,--- where @r = 2^k eps@, and @k@ is the maximum exponent of @x@ and @y@. If --- @x@ and @y@ lie within this interval, they are considered approximately --- equal.--- --- Note that @x@ and @y@ are compared to relative accuracy, so these functions--- are not suitable for testing whether a value is approximately zero.+-- Operations on IEEE floating point numbers. ----- The implementation is based on the GNU Scientific Library implementation, --- which is based on the package @fcmp@ by T.C. Belding. module Numeric.IEEE (- + -- * IEEE type class+ IEEE(..), -- * NaN-aware minimum and maximum- maxF,- minF,- - -- * Relative comparisons- delta,- epsilon,- epsilon',-- eqRel,- neqRel,- ltRel,- lteRel,- gtRel,- gteRel,- compareRel,+ minNum,+ maxNum,+ minNaN,+ maxNaN, ) where --- | A version of 'max' that returns @NaN@ if either argument is @NaN@.-maxF :: RealFloat a => a -> a -> a-maxF a b- | isNaN a = a- | b < a = a- | otherwise = b-{-# INLINE maxF #-}+import Data.Word+import Foreign.C.Types( CFloat, CDouble ) --- | A version of 'min' that returns @NaN@ if either argument is @NaN@.-minF :: RealFloat a => a -> a -> a-minF a b- | isNaN a = a- | b > a = a- | otherwise = b-{-# INLINE minF #-}+-- | IEEE floating point types.+class (RealFloat a) => IEEE a where+ -- | Infinity value.+ infinity :: a + -- | The smallest representable positive normalized value.+ minNormal :: a -epsHelp :: RealFloat a => (Int -> Int) -> a-epsHelp = epsHelp' undefined- where- epsHelp' :: RealFloat a => a -> (Int -> Int) -> a- epsHelp' a f =- let digits = floatDigits a- in encodeFloat 1 $ f digits+ -- | The largest representable finite value.+ maxFinite :: a --- | A value suitable for relative comparisons when half of of the --- digits of precision are important. For @Double@s this value is --- @7.450580596923828e-9@.-delta :: RealFloat a => a-delta = epsHelp (\digits -> negate $ digits `div` 2 + 1)+ -- | The smallest representalbe positive value @x@ such that @1 + x /= 1@.+ epsilon :: a --- | The smallest positive floating-point number x such that @1 + x != 1@.--- Suitable for relative comparisons when all but the least significant digit--- of precision are important. For @Double@s this value is --- @2.220446049250313e-16@.-epsilon :: RealFloat a => a-epsilon = epsHelp (\digits -> negate $ digits - 1)+ -- | @copySign x y@ returns @x@ with its sign changed to @y@'s.+ copySign :: a -> a -> a --- | The smallest positive floating-point number x such that @1 - x != 1@.--- Suitable for relative comparisons when one number is exact and all but the --- least significant digit of precision in the other number are important. --- For @Double@s this value is @1.1102230246251565e-16@.-epsilon' :: RealFloat a => a-epsilon' = epsHelp (\digits -> negate $ digits)+ -- | Return 'True' if two values are /exactly/ (bitwise) equal.+ identicalIEEE :: a -> a -> Bool + -- | Return the next largest IEEE value (@Infinity@ and @NaN@ are+ -- unchanged).+ succIEEE :: a -> a -compareRelHelp :: (RealFloat a) => (a -> a -> Bool) -> a -> a -> a -> Bool-compareRelHelp cmp tol x y =- let e = max (exponent x) (exponent y)- (epsM,epsE) = decodeFloat tol- r = encodeFloat epsM (epsE + e)- diff = x - y- in- diff `cmp` r-{-# INLINE compareRelHelp #-}+ -- | Return the next smallest IEEE value (@-Infinity@ and @NaN@ are+ -- unchanged).+ predIEEE :: a -> a --- | @eqRel eps x y@. Relative equality comparator.--- Returns @False@ if either argument is @NaN@.-eqRel :: (RealFloat a) => a -> a -> a -> Bool-eqRel = compareRelHelp (\diff r -> abs diff <= r)-{-# INLINE eqRel #-}+ -- | Given two values with the same sign, return the value halfway+ -- between them on the IEEE number line. If the signs of the values+ -- differ or either is @NaN@, the value is undefined.+ bisectIEEE :: a -> a -> a --- | @neqRel eps x y@. Relative inequality comparator.--- Returns @False@ if either argument is @NaN@.-neqRel :: (RealFloat a) => a -> a -> a -> Bool-neqRel = compareRelHelp (\diff r -> abs diff > r)-{-# INLINE neqRel #-}+ -- | The number of significand bits which are equal in the two arguments+ -- (equivalent to @feqrel@ from the Tango Math library). The result is+ -- between @0@ and @'floatDigits'@.+ sameSignificandBits :: a -> a -> Int --- | @ltRel eps x y@. Relative less-than comparator. --- Returns @False@ if either argument is @NaN@.-ltRel :: (RealFloat a) => a -> a -> a -> Bool-ltRel = compareRelHelp (\diff r -> diff < -r)-{-# INLINE ltRel #-}+ -- | Default @NaN@ value.+ nan :: a --- | @lteRel eps x y@. Relative less-than-or-equal-to comparator. --- Returns @False@ if either argument is @NaN@.-lteRel :: (RealFloat a) => a -> a -> a -> Bool-lteRel = compareRelHelp (\diff r -> diff <= r)-{-# INLINE lteRel #-}+ -- | @NaN@ value with a positive integer payload. Payload must be+ -- ess than 'maxNaNPayload'. Beware that while some platforms allow+ -- using @0@ as a payload, this behavior is not portable.+ nanWithPayload :: Word64 -> a --- | @gtRel eps x y@. Relative greater-than comparator.--- Returns @False@ if either argument is @NaN@.-gtRel :: (RealFloat a) => a -> a -> a -> Bool-gtRel = compareRelHelp (\diff r -> diff > r)-{-# INLINE gtRel #-}+ -- | Maximum @NaN@ payload for type @a@.+ maxNaNPayload :: a -> Word64 --- | @gteRel eps x y@. Relative greater-than-or-equal-to comparator.--- Returns @False@ if either argument is @NaN@.-gteRel :: (RealFloat a) => a -> a -> a -> Bool-gteRel = compareRelHelp (\diff r -> diff >= -r)-{-# INLINE gteRel #-}+ -- | The payload stored in a @NaN@ value. Undefined if the argument+ -- is not @NaN@.+ nanPayload :: a -> Word64 --- | @compareRel eps x y@ gives an ordering of @x@ and @y@ based on a --- relative comparison of accuracy @eps@. This will call @error@ if either--- argument is @NaN@.-compareRel :: RealFloat a => a -> a -> a -> Ordering-compareRel eps x y =- if ltRel eps x y- then LT- else if gtRel eps x y- then GT- else if eqRel eps x y- then EQ- else error $ "NaN comparison"-{-# INLINE compareRel #-}++-- | Return the maximum of two values; if one value is @NaN@, return the+-- other. Prefer the first if both values are @NaN@.+maxNum :: (RealFloat a) => a -> a -> a+maxNum x y | x >= y || isNaN y = x+ | otherwise = y+{-# INLINE maxNum #-}++-- | Return the minimum of two values; if one value is @NaN@, return the+-- other. Prefer the first if both values are @NaN@.+minNum :: (RealFloat a) => a -> a -> a+minNum x y | x <= y || isNaN y = x+ | otherwise = y+{-# INLINE minNum #-}++-- | Return the maximum of two values; if one value is @NaN@, return it.+-- Prefer the first if both values are @NaN@.+maxNaN :: (RealFloat a) => a -> a -> a+maxNaN x y | x >= y || isNaN x = x+ | otherwise = y+{-# INLINE maxNaN #-}++-- | Return the minimum of two values; if one value is @NaN@, return it.+-- Prefer the first if both values are @NaN@.+minNaN :: (RealFloat a) => a -> a -> a+minNaN x y | x <= y || isNaN x = x+ | otherwise = y+{-# INLINE minNaN #-}+++instance IEEE Float where+ identicalIEEE x y = c_identicalf x y /= 0+ {-# INLINE identicalIEEE #-}+ infinity = 1/0+ {-# INLINE infinity #-}+ nan = (0/0)+ {-# INLINE nan #-}+ nanWithPayload n = c_mknanf (fromIntegral n)+ {-# INLINE nanWithPayload #-}+ maxNaNPayload _ = 0x003FFFFF+ {-# INLINE maxNaNPayload #-}+ nanPayload x = fromIntegral $ c_getnanf x+ {-# INLINE nanPayload #-}+ minNormal = 1.17549435e-38+ {-# INLINE minNormal #-}+ maxFinite = 3.40282347e+38+ {-# INLINE maxFinite #-}+ epsilon = 1.19209290e-07+ {-# INLINE epsilon #-}+ copySign = c_copysignf+ {-# INLINE copySign #-}+ succIEEE = c_nextupf+ {-# INLINE succIEEE #-}+ predIEEE = c_nextdownf+ {-# INLINE predIEEE #-}+ bisectIEEE = c_ieeemeanf+ {-# INLINE bisectIEEE #-}+ sameSignificandBits = c_feqrelf+ {-# INLINE sameSignificandBits #-}+++instance IEEE CFloat where+ identicalIEEE x y = c_identicalf (realToFrac x) (realToFrac y) /= 0+ {-# INLINE identicalIEEE #-}+ infinity = 1/0+ {-# INLINE infinity #-}+ nan = (0/0)+ {-# INLINE nan #-}+ nanWithPayload n = realToFrac $ c_mknanf (fromIntegral n)+ {-# INLINE nanWithPayload #-}+ maxNaNPayload _ = 0x003FFFFF+ {-# INLINE maxNaNPayload #-}+ nanPayload x = fromIntegral $ c_getnanf (realToFrac x)+ {-# INLINE nanPayload #-}+ minNormal = 1.17549435e-38+ {-# INLINE minNormal #-}+ maxFinite = 3.40282347e+38+ {-# INLINE maxFinite #-}+ epsilon = 1.19209290e-07+ {-# INLINE epsilon #-}+ copySign x y = realToFrac $ c_copysignf (realToFrac x) (realToFrac y)+ {-# INLINE copySign #-}+ succIEEE x = realToFrac $ c_nextupf (realToFrac x)+ {-# INLINE succIEEE #-}+ predIEEE x = realToFrac $ c_nextdownf (realToFrac x)+ {-# INLINE predIEEE #-}+ bisectIEEE x y = realToFrac $ c_ieeemeanf (realToFrac x) (realToFrac y)+ {-# INLINE bisectIEEE #-}+ sameSignificandBits x y = c_feqrelf (realToFrac x) (realToFrac y)+ {-# INLINE sameSignificandBits #-}+++instance IEEE Double where+ identicalIEEE x y = c_identical x y /= 0+ {-# INLINE identicalIEEE #-}+ infinity = 1/0+ {-# INLINE infinity #-}+ nan = (0/0)+ {-# INLINE nan #-}+ nanWithPayload n = c_mknan n+ {-# INLINE nanWithPayload #-}+ maxNaNPayload _ = 0x0007FFFFFFFFFFFF+ {-# INLINE maxNaNPayload #-}+ nanPayload x = c_getnan x+ {-# INLINE nanPayload #-}+ minNormal = 2.2250738585072014e-308+ {-# INLINE minNormal #-}+ maxFinite = 1.7976931348623157e+308+ {-# INLINE maxFinite #-}+ epsilon = 2.2204460492503131e-16+ {-# INLINE epsilon #-}+ copySign = c_copysign+ {-# INLINE copySign #-}+ succIEEE = c_nextup+ {-# INLINE succIEEE #-}+ predIEEE = c_nextdown+ {-# INLINE predIEEE #-}+ bisectIEEE = c_ieeemean+ {-# INLINE bisectIEEE #-}+ sameSignificandBits = c_feqrel+ {-# INLINE sameSignificandBits #-}+++instance IEEE CDouble where+ identicalIEEE x y = c_identical (realToFrac x) (realToFrac y) /= 0+ {-# INLINE identicalIEEE #-}+ infinity = 1/0+ {-# INLINE infinity #-}+ nan = (0/0)+ {-# INLINE nan #-}+ nanWithPayload n = realToFrac $ c_mknan n+ {-# INLINE nanWithPayload #-}+ maxNaNPayload _ = 0x0007FFFFFFFFFFFF+ {-# INLINE maxNaNPayload #-}+ nanPayload x = c_getnan (realToFrac x)+ {-# INLINE nanPayload #-}+ minNormal = 2.2250738585072014e-308+ {-# INLINE minNormal #-}+ maxFinite = 1.7976931348623157e+308+ {-# INLINE maxFinite #-}+ epsilon = 2.2204460492503131e-16+ {-# INLINE epsilon #-}+ succIEEE x = realToFrac $ c_nextup (realToFrac x)+ {-# INLINE succIEEE #-}+ copySign x y = realToFrac $ c_copysign (realToFrac x) (realToFrac y)+ {-# INLINE copySign #-}+ predIEEE x = realToFrac $ c_nextdown (realToFrac x)+ {-# INLINE predIEEE #-}+ bisectIEEE x y = realToFrac $ c_ieeemean (realToFrac x) (realToFrac y)+ {-# INLINE bisectIEEE #-}+ sameSignificandBits x y = c_feqrel (realToFrac x) (realToFrac y)+ {-# INLINE sameSignificandBits #-}+++foreign import ccall unsafe "identical"+ c_identical :: Double -> Double -> Int++foreign import ccall unsafe "identicalf"+ c_identicalf :: Float -> Float -> Int++foreign import ccall unsafe "feqrel"+ c_feqrel :: Double -> Double -> Int+foreign import ccall unsafe "feqrelf"+ c_feqrelf :: Float -> Float -> Int++foreign import ccall unsafe "nextup"+ c_nextup :: Double -> Double++foreign import ccall unsafe "nextupf"+ c_nextupf :: Float -> Float++foreign import ccall unsafe "nextdown"+ c_nextdown :: Double -> Double++foreign import ccall unsafe "nextdownf"+ c_nextdownf :: Float -> Float++foreign import ccall unsafe "ieeemean"+ c_ieeemean :: Double -> Double -> Double++foreign import ccall unsafe "ieeemeanf"+ c_ieeemeanf :: Float -> Float -> Float++foreign import ccall unsafe "copysign"+ c_copysign :: Double -> Double -> Double++foreign import ccall unsafe "copysignf"+ c_copysignf :: Float -> Float -> Float++foreign import ccall unsafe "mknan"+ c_mknan :: Word64 -> Double++foreign import ccall unsafe "getnan"+ c_getnan :: Double -> Word64++foreign import ccall unsafe "mknanf"+ c_mknanf :: Word32 -> Float++foreign import ccall unsafe "getnanf"+ c_getnanf :: Float -> Word32
Setup.lhs view
@@ -2,7 +2,5 @@ > import Distribution.Simple > import System.Cmd >-> testing _ _ _ _ = system "runhaskell tests/Properties.hs" >> return ()+> main = defaultMain >-> main = defaultMainWithHooks simpleUserHooks-> {runTests=testing}
+ cbits/double.c view
@@ -0,0 +1,98 @@++#include <float.h>+#include <math.h>+#include <stdint.h>++#define REAL double+#define REAL_ABS fabs++#define REAL_MIN_NORMAL DBL_MIN+#define REAL_EPSILON DBL_EPSILON+#define REAL_MAX DBL_MAX+#define REAL_MANT_DIG DBL_MANT_DIG++#define FEQREL feqrel+#include "feqrel_source.c"++int+identical (double x, double y)+{+ uint64_t *ux = (uint64_t *)(&x);+ uint64_t *uy = (uint64_t *)(&y);+ return *ux == *uy;+}++/* ported from tango/math/IEEE.d */+double+nextup (double x)+{+ uint64_t *ps = (uint64_t *)&x;++ if ((*ps & 0x7FF0000000000000ULL) == 0x7FF0000000000000ULL) {+ /* First, deal with NANs and infinity */+ if (x == -INFINITY) return -REAL_MAX;+ return x; // +INF and NAN are unchanged.+ }+ if (*ps & 0x8000000000000000ULL) { /* Negative number */+ if (*ps == 0x8000000000000000ULL) { /* it was negative zero */+ *ps = 0x0000000000000001ULL; /* change to smallest subnormal */+ return x;+ }+ --*ps;+ } else { /* Positive number */+ ++*ps;+ }+ return x;+}++/* ported from tango/math/IEEE.d */+double+nextdown (double x)+{+ return -nextup(-x);+}++/* ported from tango/math/IEEE.d */+double+ieeemean (double x, double y)+{+ if (!((x>=0 && y>=0) || (x<=0 && y<=0))) return NAN;+ + double u;+ + uint64_t *ul = (uint64_t *)&u;+ uint64_t *xl = (uint64_t *)&x;+ uint64_t *yl = (uint64_t *)&y;+ uint64_t m = ( ((*xl) & 0x7FFFFFFFFFFFFFFFULL)+ + ((*yl) & 0x7FFFFFFFFFFFFFFFULL) ) >> 1;+ m |= ((*xl) & 0x8000000000000000ULL);+ *ul = m;+ + return u;+}++double+mknan (uint64_t payload)+{+ double x = NAN;+ uint64_t *ux = (uint64_t *)(&x);+ + /* get sign, exponent, and quiet bit from NAN */ + *ux &= 0xFFF8000000000000ULL; + + /* ignore sign, exponent, and quiet bit in payload */+ payload &= 0x0007FFFFFFFFFFFFULL;+ *ux |= payload;++ return x;+}++uint64_t+getnan (double x)+{+ uint64_t payload = *(uint64_t *)(&x);+ + /* clear ignore sign, exponent, and quiet bit */+ payload &= 0x0007FFFFFFFFFFFFULL; + return payload;+}
+ cbits/feqrel_source.c view
@@ -0,0 +1,114 @@+/* adapted from Tango version 0.99.9, BSD Licensed+ */++/* REAL_EXPMASK is a ushort mask to select the exponent portion (without sign)+ * REAL_SIGNMASK is a ushort mask to select the sign bit.+ * REAL_EXPPOS_SHORT is the index of the exponent when represented as a uint16_t array.+ * REAL_SIGNPOS_BYTE is the index of the sign when represented as a uint8_t array.+ * REAL_RECIP_EPSILON is the value such that + * (smallest_denormal) * REAL_RECIP_EPSILON == REAL_MIN_NORMAL+ */+#define REAL_RECIP_EPSILON (1 / REAL_EPSILON)++#if REAL_MANT_DIG == 24+# define REAL_EXPMASK ((uint16_t) 0x7F80)+# define REAL_SIGNMASK ((uint16_t) 0x8000)+# define REAL_EXPBIAS ((uint16_t) 0x3F00)+# define REAL_EXPBIAS_INT32 ((uint32_t) 0x7F800000)+# define REAL_MANTISSAMASK_INT32 ((uint32_t) 0x007FFFFF)+# if BIG_ENDIAN == 1+# define REAL_EXPPOS_INT16 0+# else+# define REAL_EXPPOS_INT16 1+# endif+#+#elif REAL_MANT_DIG == 53 /* double */+# define REAL_EXPMASK ((uint16_t) 0x7FF0)+# define REAL_SIGNMASK ((uint16_t) 0x8000)+# define REAL_EXPBIAS ((uint16_t) 0x3FE0)+# define REAL_EXPBIAS_INT32 ((uint32_t) 0x7FF00000)+# define REAL_MANTISSAMASK_INT32 ((uint32_t) 0x000FFFFF); /* for the MSB only */+# if BIG_ENDIAN == 1+# define REAL_EXPPOS_INT16 0+# define REAL_SIGNPOS_BYTE 0+# else+# define REAL_EXPPOS_INT16 3+# define REAL_SIGNPOS_BYTE 7+# endif+#endif++int+FEQREL (REAL x, REAL y)+{+ /* Public Domain. Original Author: Don Clugston, 18 Aug 2005.+ * Ported to C by Patrick Perry, 26 Feb 2010.+ */+ if (x == y) return REAL_MANT_DIG; /* ensure diff!= 0, cope with INF. */++ REAL diff = REAL_ABS(x - y);++ uint16_t *pa = (uint16_t *)(&x);+ uint16_t *pb = (uint16_t *)(&y);+ uint16_t *pd = (uint16_t *)(&diff);++ /* The difference in abs(exponent) between x or y and abs(x-y)+ * is equal to the number of significand bits of x which are+ * equal to y. If negative, x and y have different exponents.+ * If positive, x and y are equal to 'bitsdiff' bits.+ * AND with 0x7FFF to form the absolute value.+ * To avoid out-by-1 errors, we subtract 1 so it rounds down+ * if the exponents were different. This means 'bitsdiff' is+ * always 1 lower than we want, except that if bitsdiff==0,+ * they could have 0 or 1 bits in common.+ */+#if REAL_MANT_DIG == 53 /* double */+ int bitsdiff = (( ((pa[REAL_EXPPOS_INT16] & REAL_EXPMASK)+ + (pb[REAL_EXPPOS_INT16] & REAL_EXPMASK)+ - ((uint16_t) 0x8000 - REAL_EXPMASK)) >> 1)+ - (pd[REAL_EXPPOS_INT16] & REAL_EXPMASK)) >> 4;+#elif REAL_MANT_DIG == 24 /* float */+ int bitsdiff = (( ((pa[REAL_EXPPOS_INT16] & REAL_EXPMASK)+ + (pb[REAL_EXPPOS_INT16] & REAL_EXPMASK)+ - ((uint16_t) 0x8000 - REAL_EXPMASK)) >> 1)+ - (pd[REAL_EXPPOS_INT16] & REAL_EXPMASK)) >> 7;+#else+# error unsuported floating-point mantissa size+#endif++ if ((pd[REAL_EXPPOS_INT16] & REAL_EXPMASK) == 0) {+ /* Difference is denormal+ * For denormals, we need to add the number of zeros that+ * lie at the start of diff's significand.+ * We do this by multiplying by 2^REAL_MANT_DIG+ */+ diff *= REAL_RECIP_EPSILON;++#if REAL_MANT_DIG == 53 /* double */+ return (bitsdiff + REAL_MANT_DIG+ - (pd[REAL_EXPPOS_INT16] >> 4));+#elif REAL_MANT_DIG == 24 /* float */+ return (bitsdiff + REAL_MANT_DIG+ - (pd[REAL_EXPPOS_INT16] >> 7));+#else+# error unsuported floating-point mantissa size+#endif++ }++ if (bitsdiff > 0)+ return bitsdiff + 1; /* add the 1 we subtracted before */++ /* Avoid out-by-1 errors when factor is almost 2. */+ return (bitsdiff == 0+ && !((pa[REAL_EXPPOS_INT16]+ ^ pb[REAL_EXPPOS_INT16]) & REAL_EXPMASK)) ? 1 : 0;+}++#undef REAL_RECIP_EPSILON+#undef REAL_EXPMASK+#undef REAL_SIGNMASK+#undef REAL_EXPBIAS+#undef REAL_EXPBIAS_INT32+#undef REAL_MANTISSAMASK_INT32+#undef REAL_EXPPOS_INT16+#undef REAL_SIGNPOS_BYTE
+ cbits/float.c view
@@ -0,0 +1,97 @@++#include <float.h>+#include <math.h>+#include <stdint.h>++#define REAL float+#define REAL_ABS fabsf++#define REAL_MIN_NORMAL FLT_MIN+#define REAL_EPSILON FLT_EPSILON+#define REAL_MAX FLT_MAX+#define REAL_MANT_DIG FLT_MANT_DIG++#define FEQREL feqrelf+#include "feqrel_source.c"++int+identicalf (float x, float y)+{+ uint32_t *ux = (uint32_t *)(&x);+ uint32_t *uy = (uint32_t *)(&y);+ return *ux == *uy;+}++/* ported from tango/math/IEEE.d */+float+nextupf (float x)+{+ uint32_t *ps = (uint32_t *)&x;++ if ((*ps & 0x7F800000) == 0x7F800000) {+ /* First, deal with NANs and infinity */+ if (x == -INFINITY) return -REAL_MAX;+ return x; /* +INF and NAN are unchanged. */+ }+ if (*ps & 0x80000000) { /* Negative number */+ if (*ps == 0x80000000) { /* it was negative zero */+ *ps = 0x00000001; /* change to smallest subnormal */+ return x;+ }+ --*ps;+ } else { /* Positive number */+ ++*ps;+ }+ return x;+}++/* ported from tango/math/IEEE.d */+float+nextdownf (float x)+{+ return -nextupf(-x);+}++/* ported from tango/math/IEEE.d */+float+ieeemeanf (float x, float y)+{+ if (!((x>=0 && y>=0) || (x<=0 && y<=0))) return NAN;+ + float u;+ + uint32_t *ul = (uint32_t *)&u;+ uint32_t *xl = (uint32_t *)&x;+ uint32_t *yl = (uint32_t *)&y;+ uint32_t m = (((*xl) & 0x7FFFFFFF) + ((*yl) & 0x7FFFFFFF)) >> 1;+ m |= ((*xl) & 0x80000000);+ *ul = m;+ + return u;+}++float+mknanf (uint32_t payload)+{+ float x = NAN;+ uint32_t *ux = (uint32_t *)(&x);+ + /* get sign, exponent, and quiet bit from NAN */ + *ux &= 0xFFC00000; + + /* ignore sign, exponent, and quiet bit in payload */+ payload &= 0x003FFFFF;+ *ux |= payload;++ return x;+}++uint32_t+getnanf (float x)+{+ uint32_t payload = *(uint32_t *)(&x);+ + /* clear sign, exponent, and quiet bit */+ payload &= 0x003FFFFF;+ return payload;+}
ieee.cabal view
@@ -1,13 +1,11 @@ name: ieee-version: 0.6.1+version: 0.7 homepage: http://github.com/patperry/hs-ieee-synopsis: Approximate comparisons for IEEE floating point numbers+synopsis: Utilities for dealing with IEEE floating point numbers description:- Approximate comparison of floating point numbers based on the- algorithm in Section 4.2.2 of Knuth's _Seminumerical Algorithms_,- NaN-aware minimum and maximum, and a type class for approximate - comparisons.- .+ Utilities for dealing with IEEE floating point numbers, ported+ from the Tango math library; approximate and exact equality+ comparisons for general types. category: Math license: BSD3 license-file: LICENSE@@ -15,17 +13,33 @@ author: Patrick Perry maintainer: Patrick Perry <patperry@gmail.com> cabal-version: >= 1.2.0-build-type: Custom-tested-with: GHC ==6.12.2+build-type: Simple+tested-with: GHC ==6.12.3 -extra-source-files: NEWS tests/Properties.hs+extra-source-files: LICENSE.Tango NEWS cbits/feqrel_source.c+ tests/Makefile tests/Tests.hs +flag big_endian+ description: Build for a big endian machine. Beware that only+ little endian machines have been tested.+ default: False+ library exposed-modules: Data.AEq Numeric.IEEE - build-depends: base >= 3 && < 5+ extensions: FlexibleInstances+ ForeignFunctionInterface + build-depends: base >= 3 && < 5 ghc-options: -Wall - extensions: CPP++ c-sources: cbits/float.c+ cbits/double.c++ cc-options: -Wall --std=c99+ if flag(big_endian)+ cc-options: -DBIG_ENDIAN++ extra-libraries: m
+ tests/Makefile view
@@ -0,0 +1,19 @@+all:+ ghc -O ../cbits/double.c ../cbits/float.c -lm \+ -i. -i.. Tests.hs --make -o test-ieee+ ./test-ieee++hpc:+ ghc -fforce-recomp ../cbits/double.c ../cbits/float.c -lm \+ -i. -i.. -fhpc --make Tests.hs -o test-ieee+ rm -f test-ieee.tix+ ./test-ieee+ hpc markup test-ieee++clean:+ find ../lib . -name '*.hi' | xargs rm -f+ find ../lib . -name '*.o' | xargs rm -f+ find . -name '*.html' | xargs rm -f+ rm -f test-ieee test-ieee.tix+ rm -rf .hpc+
− tests/Properties.hs
@@ -1,248 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--import Test.QuickCheck-import Data.Int--import Numeric.IEEE--type D = Double--b = floatRadix (undefined :: D)--nan :: RealFloat a => a-nan = 0 / 0--incSignif :: RealFloat a => Integer -> a -> a-incSignif i x =- let (m,n) = decodeFloat x- in encodeFloat (m+i) n---------------------------- NaN-aware min and max -------------------------------prop_minF (x :: D) (y :: D) =- not (isNaN x || isNaN y) ==> minF x y == min x y--prop_minF_nan1 (x :: D) =- isNaN (minF x nan)- -prop_minF_nan2 (x :: D) =- isNaN (minF nan x)---prop_maxF (x :: D) (y :: D) =- not (isNaN x || isNaN y) ==> maxF x y == max x y--prop_maxF_nan1 (x :: D) =- isNaN (maxF x nan)- -prop_maxF_nan2 (x :: D) =- isNaN (maxF nan x)- ------------------------------ NaN comparisons ---------------------------------prop_nan1 (x :: D) (eps :: D) =- eps >= 0 ==> (not . or) [ eqRel eps x nan- , neqRel eps x nan- , ltRel eps x nan- , lteRel eps x nan- , gtRel eps x nan- , gteRel eps x nan- ]--prop_nan2 (x :: D) (eps :: D) =- eps >= 0 ==> (not . or) [ eqRel eps nan x- , neqRel eps nan x- , ltRel eps nan x- , lteRel eps nan x- , gtRel eps nan x- , gteRel eps nan x- ]------------------------ Comparisons relative to 0 -------------------------------prop_0_exact (x :: D) =- not (isNaN x || x == 0) ==> and [ eqRel 0 x x'- , lteRel 0 x x'- , gteRel 0 x x'- ]- && (not . or) [ neqRel 0 x x'- , ltRel 0 x x'- , gtRel 0 x x'- ]- && (compareRel epsilon' x x' == EQ)- where - x' = x--prop_plus_1_exact (x :: D) =- not (isNaN x || x == 0) ==> and [ neqRel 0 x x'- , ltRel 0 x x'- , lteRel 0 x x'- ]- && (not . or) [ eqRel 0 x x'- , gtRel 0 x x'- , gteRel 0 x x'- ]- && (compareRel 0 x x' == LT)- where - x' = incSignif 1 x--prop_minus_1_exact (x :: D) =- not (isNaN x || x == 0) ==> and [ neqRel 0 x x'- , gtRel 0 x x'- , gteRel 0 x x'- ]- && (not . or) [ eqRel 0 x x'- , ltRel 0 x x'- , lteRel 0 x x'- ]- && (compareRel 0 x x' == GT)- where - x' = incSignif (-1) x----------------------- Comparisons relative to epsilon' ------------------------prop_plus_1' (x :: D) =- not (isNaN x || x == 0) ==> and [ eqRel epsilon' x x'- , lteRel epsilon' x x'- , gteRel epsilon' x x'- ]- && (not . or) [ neqRel epsilon' x x'- , ltRel epsilon' x x'- , gtRel epsilon' x x'- ]- && (compareRel epsilon' x x' == EQ)- where - x' = incSignif 1 x--prop_minus_1' (x :: D) =- not (isNaN x || x == 0) ==> and [ eqRel epsilon' x x'- , lteRel epsilon' x x'- , gteRel epsilon' x x'- ]- && (not . or) [ neqRel epsilon' x x'- , ltRel epsilon' x x'- , gtRel epsilon' x x'- ]- && (compareRel epsilon' x x' == EQ)- where - x' = incSignif (-1) x---prop_plus_b' (x :: D) =- not (isNaN x || x == 0) ==> and [ neqRel epsilon' x x'- , ltRel epsilon' x x'- , lteRel epsilon' x x'- ]- && (not . or) [ eqRel epsilon' x x'- , gtRel epsilon' x x'- , gteRel epsilon' x x'- ]- && (compareRel epsilon' x x' == LT)- where - x' = incSignif b x--prop_minus_b' (x :: D) =- not (isNaN x || x == 0) ==> and [ neqRel epsilon' x x'- , gtRel epsilon' x x'- , gteRel epsilon' x x'- ]- && (not . or) [ eqRel epsilon' x x'- , ltRel epsilon' x x'- , lteRel epsilon' x x'- ]- && (compareRel epsilon' x x' == GT)- where - x' = incSignif (-b) x------------------------ Comparisons relative to epsilon -------------------------prop_plus_b (x :: D) =- not (isNaN x || x == 0) ==> and [ eqRel epsilon x x'- , lteRel epsilon x x'- , gteRel epsilon x x'- ]- && (not . or) [ neqRel epsilon x x'- , ltRel epsilon x x'- , gtRel epsilon x x'- ]- && (compareRel epsilon x x' == EQ)- where - x' = incSignif b x--prop_minus_b (x :: D) =- not (isNaN x || x == 0) ==> and [ eqRel epsilon x x'- , lteRel epsilon x x'- , gteRel epsilon x x'- ]- && (not . or) [ neqRel epsilon x x'- , ltRel epsilon x x'- , gtRel epsilon x x'- ]- && (compareRel epsilon x x' == EQ)- where - x' = incSignif (-b) x---prop_plus_b1 (x :: D) =- not (isNaN x || x == 0) ==> and [ neqRel epsilon x x'- , ltRel epsilon x x'- , lteRel epsilon x x'- ]- && (not . or) [ eqRel epsilon x x'- , gtRel epsilon x x'- , gteRel epsilon x x'- ]- && (compareRel epsilon x x' == LT)- where - x' = incSignif (b+1) x--prop_minus_b1 (x :: D) =- not (isNaN x || x == 0) ==> and [ neqRel epsilon x x'- , gtRel epsilon x x'- , gteRel epsilon x x'- ]- && (not . or) [ eqRel epsilon x x'- , ltRel epsilon x x'- , lteRel epsilon x x'- ]- && (compareRel epsilon x x' == GT)- where - x' = incSignif (-b-1) x--main = do- let runT s a = do print s; a-- runT "minF" $ do- quickCheck prop_minF - quickCheck prop_minF_nan1- quickCheck prop_minF_nan2- - runT "maxF" $ do- quickCheck prop_maxF- quickCheck prop_maxF_nan1 - quickCheck prop_maxF_nan2-- runT "NaN comparisons" $ do- quickCheck prop_nan1- quickCheck prop_nan2- - runT "comparisons relative to 0" $ do- quickCheck prop_0_exact- quickCheck prop_plus_1_exact- quickCheck prop_minus_1_exact- - runT "comparisons relative to epsilon'" $ do- quickCheck prop_plus_1'- quickCheck prop_minus_1'- quickCheck prop_plus_b'- quickCheck prop_minus_b'-- runT "comparisons relative to epsilon" $ do- quickCheck prop_plus_b- quickCheck prop_minus_b- quickCheck prop_plus_b1- quickCheck prop_minus_b1-
+ tests/Tests.hs view
@@ -0,0 +1,660 @@+module Main+ where++import Control.Monad( forM_, unless )+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import Data.AEq+import Numeric.IEEE++type D = Double+type F = Float++infix 1 @?~=, @?==+ +(@?~=) actual expected = + unless (actual ~== expected) (assertFailure msg)+ where+ msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual++(@?==) actual expected = + unless (actual === expected) (assertFailure msg)+ where+ msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual++++test_maxNum = testGroup "maxNum"+ [ testCase "D1" test_maxNum_D1+ , testCase "D2" test_maxNum_D2+ , testCase "D3" test_maxNum_D3+ , testCase "D4" test_maxNum_D4+ , testCase "D5" test_maxNum_D5 + , testCase "F1" test_maxNum_F1+ , testCase "F2" test_maxNum_F2+ , testCase "F3" test_maxNum_F3+ , testCase "F4" test_maxNum_F4+ , testCase "F5" test_maxNum_F5 + ]++test_maxNum_D1 = maxNum nan 1 @?= (1 :: D)+test_maxNum_D2 = maxNum 1 nan @?= (1 :: D)+test_maxNum_D3 = maxNum 1 0 @?= (1 :: D)+test_maxNum_D4 = maxNum 0 1 @?= (1 :: D)+test_maxNum_D5 =+ maxNum (nanWithPayload 1) (nanWithPayload 2)+ @?== (nanWithPayload 1 :: D)+test_maxNum_F1 = maxNum nan 1 @?= (1 :: F)+test_maxNum_F2 = maxNum 1 nan @?= (1 :: F)+test_maxNum_F3 = maxNum 1 0 @?= (1 :: F)+test_maxNum_F4 = maxNum 0 1 @?= (1 :: F)+test_maxNum_F5 =+ maxNum (nanWithPayload 1) (nanWithPayload 2)+ @?== (nanWithPayload 1 :: F)+++test_minNum = testGroup "minNum"+ [ testCase "D1" test_minNum_D1+ , testCase "D2" test_minNum_D2+ , testCase "D3" test_minNum_D3+ , testCase "D4" test_minNum_D4+ , testCase "D5" test_minNum_D5 + , testCase "F1" test_minNum_F1+ , testCase "F2" test_minNum_F2+ , testCase "F3" test_minNum_F3+ , testCase "F4" test_minNum_F4+ , testCase "F5" test_minNum_F5 + ]++test_minNum_D1 = minNum nan 1 @?= (1 :: D)+test_minNum_D2 = minNum 1 nan @?= (1 :: D)+test_minNum_D3 = minNum 1 2 @?= (1 :: D)+test_minNum_D4 = minNum 2 1 @?= (1 :: D)+test_minNum_D5 =+ minNum (nanWithPayload 1) (nanWithPayload 2)+ @?== (nanWithPayload 1 :: D)+test_minNum_F1 = minNum nan 1 @?= (1 :: F)+test_minNum_F2 = minNum 1 nan @?= (1 :: F)+test_minNum_F3 = minNum 1 2 @?= (1 :: F)+test_minNum_F4 = minNum 2 1 @?= (1 :: F)+test_minNum_F5 =+ minNum (nanWithPayload 1) (nanWithPayload 2)+ @?== (nanWithPayload 1 :: F)++++test_maxNaN = testGroup "maxNaN"+ [ testCase "D1" test_maxNaN_D1+ , testCase "D2" test_maxNaN_D2+ , testCase "D3" test_maxNaN_D3+ , testCase "D4" test_maxNaN_D4+ , testCase "D5" test_maxNaN_D5 + , testCase "F1" test_maxNaN_F1+ , testCase "F2" test_maxNaN_F2+ , testCase "F3" test_maxNaN_F3+ , testCase "F4" test_maxNaN_F4+ , testCase "F5" test_maxNaN_F5 + ]++test_maxNaN_D1 = maxNaN nan 1 @?== (nan :: D)+test_maxNaN_D2 = maxNaN 1 nan @?== (nan :: D)+test_maxNaN_D3 = maxNaN 1 0 @?== (1 :: D)+test_maxNaN_D4 = maxNaN 0 1 @?== (1 :: D)+test_maxNaN_D5 =+ maxNaN (nanWithPayload 1) (nanWithPayload 2)+ @?== (nanWithPayload 1 :: D)+test_maxNaN_F1 = maxNaN nan 1 @?== (nan :: F)+test_maxNaN_F2 = maxNaN 1 nan @?== (nan :: F)+test_maxNaN_F3 = maxNaN 1 0 @?== (1 :: F)+test_maxNaN_F4 = maxNaN 0 1 @?== (1 :: F)+test_maxNaN_F5 =+ maxNaN (nanWithPayload 1) (nanWithPayload 2)+ @?== (nanWithPayload 1 :: F)++++test_minNaN = testGroup "minNaN"+ [ testCase "D1" test_minNaN_D1+ , testCase "D2" test_minNaN_D2+ , testCase "D3" test_minNaN_D3+ , testCase "D4" test_minNaN_D4+ , testCase "D5" test_minNaN_D5 + , testCase "F1" test_minNaN_F1+ , testCase "F2" test_minNaN_F2+ , testCase "F3" test_minNaN_F3+ , testCase "F4" test_minNaN_F4+ , testCase "F5" test_minNaN_F5 + ]++test_minNaN_D1 = minNaN nan 1 @?== (nan :: D)+test_minNaN_D2 = minNaN 1 nan @?== (nan :: D)+test_minNaN_D3 = minNaN 1 2 @?== (1 :: D)+test_minNaN_D4 = minNaN 2 1 @?== (1 :: D)+test_minNaN_D5 =+ minNaN (nanWithPayload 1) (nanWithPayload 2)+ @?== (nanWithPayload 1 :: D)+test_minNaN_F1 = minNaN nan 1 @?== (nan :: F)+test_minNaN_F2 = minNaN 1 nan @?== (nan :: F)+test_minNaN_F3 = minNaN 1 2 @?== (1 :: F)+test_minNaN_F4 = minNaN 2 1 @?== (1 :: F)+test_minNaN_F5 =+ minNaN (nanWithPayload 1) (nanWithPayload 2)+ @?== (nanWithPayload 1 :: F)+++++test_nan = testGroup "nan" $+ [ testCase "D" test_nan_D+ , testCase "F" test_nan_F+ ]++test_nan_D = isNaN (nan :: D) @?= True+test_nan_F = isNaN (nan :: F) @?= True+++test_infinity = testGroup "infinity"+ [ testCase "D1" test_infinity_D1+ , testCase "D2" test_infinity_D2+ , testCase "F1" test_infinity_F1+ , testCase "F2" test_infinity_F2+ ]++test_infinity_D1 = isInfinite (infinity :: D) @?= True+test_infinity_D2 = infinity > (0 :: D) @?= True++test_infinity_F1 = isInfinite (infinity :: F) @?= True+test_infinity_F2 = infinity > (0 :: F) @?= True++-- succIEEE and predIEEE tests ported from tango/math/IEEE.d+test_succIEEE = testGroup "succIEEE"+ [ testCase "nan D" test_succIEEE_nan_D+ , testCase "neg D1" test_succIEEE_neg_D1+ , testCase "neg D2" test_succIEEE_neg_D2+ , testCase "neg D3" test_succIEEE_neg_D3+ , testCase "neg denorm D1" test_succIEEE_neg_denorm_D1+ , testCase "neg denorm D2" test_succIEEE_neg_denorm_D2+ , testCase "neg denrom D3" test_succIEEE_neg_denorm_D3+ , testCase "zero D1" test_succIEEE_zero_D1+ , testCase "zero D2" test_succIEEE_zero_D2+ , testCase "pos denorm D1" test_succIEEE_pos_denorm_D1+ , testCase "pos denorm D2" test_succIEEE_pos_denorm_D2+ , testCase "pos D1" test_succIEEE_pos_D1+ , testCase "pos D2" test_succIEEE_pos_D2+ , testCase "pos D3" test_succIEEE_pos_D3+ , testCase "nan F" test_succIEEE_nan_F+ , testCase "neg F1" test_succIEEE_neg_F1+ , testCase "neg F2" test_succIEEE_neg_F2+ , testCase "neg F3" test_succIEEE_neg_F3+ , testCase "neg denorm F1" test_succIEEE_neg_denorm_F1+ , testCase "neg denorm F2" test_succIEEE_neg_denorm_F2+ , testCase "neg denrom F3" test_succIEEE_neg_denorm_F3+ , testCase "zero F1" test_succIEEE_zero_F1+ , testCase "zero F2" test_succIEEE_zero_F2+ , testCase "pos denorm F1" test_succIEEE_pos_denorm_F1+ , testCase "pos denorm F2" test_succIEEE_pos_denorm_F2+ , testCase "pos F1" test_succIEEE_pos_F1+ , testCase "pos F2" test_succIEEE_pos_F2+ , testCase "pos F3" test_succIEEE_pos_F3+ ]++test_succIEEE_nan_D = isNaN (succIEEE (nan :: D)) @?= True+test_succIEEE_neg_D1 = succIEEE (-infinity) @?= (-maxFinite :: D)+test_succIEEE_neg_D2 = succIEEE (-1 - epsilon) @?= (-1 :: D)+test_succIEEE_neg_D3 = succIEEE (-2) @?= (-2 + epsilon :: D)+test_succIEEE_neg_denorm_D1 = succIEEE (-minNormal) @?= (-minNormal*(1 - epsilon) :: D)+test_succIEEE_neg_denorm_D2 = succIEEE (-minNormal*(1-epsilon)) @?= (-minNormal*(1-2*epsilon) :: D)+test_succIEEE_neg_denorm_D3 = isNegativeZero (succIEEE (-minNormal*epsilon :: D)) @?= True+test_succIEEE_zero_D1 = succIEEE (-0) @?= (minNormal * epsilon :: D)+test_succIEEE_zero_D2 = succIEEE 0 @?= (minNormal * epsilon :: D)+test_succIEEE_pos_denorm_D1 = succIEEE (minNormal*(1-epsilon)) @?= (minNormal :: D)+test_succIEEE_pos_denorm_D2 = succIEEE (minNormal) @?= (minNormal*(1+epsilon) :: D)+test_succIEEE_pos_D1 = succIEEE 1 @?= (1 + epsilon :: D)+test_succIEEE_pos_D2 = succIEEE (2 - epsilon) @?= (2 :: D)+test_succIEEE_pos_D3 = succIEEE maxFinite @?= (infinity :: D)++test_succIEEE_nan_F = isNaN (succIEEE (nan :: F)) @?= True+test_succIEEE_neg_F1 = succIEEE (-infinity) @?= (-maxFinite :: F)+test_succIEEE_neg_F2 = succIEEE (-1 - epsilon) @?= (-1 :: F)+test_succIEEE_neg_F3 = succIEEE (-2) @?= (-2 + epsilon :: F)+test_succIEEE_neg_denorm_F1 = succIEEE (-minNormal) @?= (-minNormal*(1 - epsilon) :: F)+test_succIEEE_neg_denorm_F2 = succIEEE (-minNormal*(1-epsilon)) @?= (-minNormal*(1-2*epsilon) :: F)+test_succIEEE_neg_denorm_F3 = isNegativeZero (succIEEE (-minNormal*epsilon :: F)) @?= True+test_succIEEE_zero_F1 = succIEEE (-0) @?= (minNormal * epsilon :: F)+test_succIEEE_zero_F2 = succIEEE 0 @?= (minNormal * epsilon :: F)+test_succIEEE_pos_denorm_F1 = succIEEE (minNormal*(1-epsilon)) @?= (minNormal :: F)+test_succIEEE_pos_denorm_F2 = succIEEE (minNormal) @?= (minNormal*(1+epsilon) :: F)+test_succIEEE_pos_F1 = succIEEE 1 @?= (1 + epsilon :: F)+test_succIEEE_pos_F2 = succIEEE (2 - epsilon) @?= (2 :: F)+test_succIEEE_pos_F3 = succIEEE maxFinite @?= (infinity :: F)+++test_predIEEE = testGroup "predIEEE"+ [ testCase "D" test_predIEEE_D+ , testCase "F" test_predIEEE_F+ ]++test_predIEEE_D = predIEEE (1 + epsilon) @?= (1 :: D)+test_predIEEE_F = predIEEE (1 + epsilon) @?= (1 :: F)++test_bisectIEEE = testGroup "bisectIEEE"+ [ testCase "D1" test_bisectIEEE_D1+ , testCase "D2" test_bisectIEEE_D2+ , testCase "D3" test_bisectIEEE_D3+ , testCase "D4" test_bisectIEEE_D4+ , testCase "D5" test_bisectIEEE_D5 + , testCase "D6" test_bisectIEEE_D6 + , testCase "D7" test_bisectIEEE_D7 + , testCase "D8" test_bisectIEEE_D8 + , testCase "D9" test_bisectIEEE_D9+ , testCase "F1" test_bisectIEEE_F1+ , testCase "F2" test_bisectIEEE_F2+ , testCase "F3" test_bisectIEEE_F3+ , testCase "F4" test_bisectIEEE_F4+ , testCase "F5" test_bisectIEEE_F5 + , testCase "F6" test_bisectIEEE_F6 + , testCase "F7" test_bisectIEEE_F7 + , testCase "F8" test_bisectIEEE_F8 + , testCase "F9" test_bisectIEEE_F9+ ]++test_bisectIEEE_D1 = bisectIEEE (-0) (-1e-20) < (0 :: D) @?= True+test_bisectIEEE_D2 = bisectIEEE (0) (1e-20) > (0 :: D) @?= True+test_bisectIEEE_D3 = bisectIEEE 1 4 @?= (2 :: D)+test_bisectIEEE_D4 = bisectIEEE (2*1.013) (8*1.013) @?= (4*1.013 :: D)+test_bisectIEEE_D5 = bisectIEEE (-1) (-4) @?= (-2 :: D)+test_bisectIEEE_D6 = bisectIEEE (-1) (-2) @?= (-1.5 :: D)+test_bisectIEEE_D7 =+ bisectIEEE (-1*(1+8*epsilon)) (-2*(1+8*epsilon))+ @?= (-1.5*(1+5*epsilon) :: D)+test_bisectIEEE_D8 =+ bisectIEEE (encodeFloat 0x100000 60) (encodeFloat 0x100000 (-10))+ @?= (encodeFloat 0x100000 25 :: D)+test_bisectIEEE_D9 =+ bisectIEEE 0 infinity @?= (1.5 :: D)++test_bisectIEEE_F1 = bisectIEEE (-0) (-1e-20) < (0 :: F) @?= True+test_bisectIEEE_F2 = bisectIEEE (0) (1e-20) > (0 :: F) @?= True+test_bisectIEEE_F3 = bisectIEEE 1 4 @?= (2 :: F)+test_bisectIEEE_F4 = bisectIEEE (2*1.013) (8*1.013) @?= (4*1.013 :: F)+test_bisectIEEE_F5 = bisectIEEE (-1) (-4) @?= (-2 :: F)+test_bisectIEEE_F6 = bisectIEEE (-1) (-2) @?= (-1.5 :: F)+test_bisectIEEE_F7 =+ bisectIEEE (-1*(1+8*epsilon)) (-2*(1+8*epsilon))+ @?= (-1.5*(1+5*epsilon) :: F)+test_bisectIEEE_F8 =+ bisectIEEE (encodeFloat 0x100000 60) (encodeFloat 0x100000 (-10))+ @?= (encodeFloat 0x100000 25 :: F)+test_bisectIEEE_F9 =+ bisectIEEE 0 infinity @?= (1.5 :: F)+++test_sameSignificandBits = testGroup "sameSignificandBits" $+ [ testCase "exact D1" test_sameSignificandBits_exact_D1+ , testCase "exact D2" test_sameSignificandBits_exact_D2+ , testCase "exact D3" test_sameSignificandBits_exact_D3+ , testCase "exact D4" test_sameSignificandBits_exact_D4+ , testCase "fewbits D1" test_sameSignificandBits_fewbits_D1+ , testCase "fewbits D2" test_sameSignificandBits_fewbits_D2+ , testCase "fewbits D3" test_sameSignificandBits_fewbits_D3+ , testCase "fewbits D4" test_sameSignificandBits_fewbits_D4+ , testCase "fewbits D5" test_sameSignificandBits_fewbits_D5+ , testCase "fewbits D6" test_sameSignificandBits_fewbits_D6+ , testCase "fewbits D7" test_sameSignificandBits_fewbits_D7+ , testCase "close D1" test_sameSignificandBits_close_D1+ , testCase "close D2" test_sameSignificandBits_close_D2+ , testCase "close D3" test_sameSignificandBits_close_D3+ , testCase "close D4" test_sameSignificandBits_close_D4+ , testCase "close D5" test_sameSignificandBits_close_D5+ , testCase "2factors D1" test_sameSignificandBits_2factors_D1+ , testCase "2factors D2" test_sameSignificandBits_2factors_D2+ , testCase "2factors D3" test_sameSignificandBits_2factors_D3+ , testCase "2factors D4" test_sameSignificandBits_2factors_D4+ , testCase "extreme D1" test_sameSignificandBits_extreme_D1+ , testCase "extreme D2" test_sameSignificandBits_extreme_D2+ , testCase "extreme D3" test_sameSignificandBits_extreme_D3+ , testCase "extreme D4" test_sameSignificandBits_extreme_D4+ , testCase "extreme D5" test_sameSignificandBits_extreme_D5+ , testCase "extreme D6" test_sameSignificandBits_extreme_D6+ , testCase "exact F1" test_sameSignificandBits_exact_F1+ , testCase "exact F2" test_sameSignificandBits_exact_F2+ , testCase "exact F3" test_sameSignificandBits_exact_F3+ , testCase "exact F4" test_sameSignificandBits_exact_F4+ , testCase "fewbits F1" test_sameSignificandBits_fewbits_F1+ , testCase "fewbits F2" test_sameSignificandBits_fewbits_F2+ , testCase "fewbits F3" test_sameSignificandBits_fewbits_F3+ , testCase "fewbits F4" test_sameSignificandBits_fewbits_F4+ , testCase "fewbits F5" test_sameSignificandBits_fewbits_F5+ , testCase "fewbits F6" test_sameSignificandBits_fewbits_F6+ , testCase "fewbits F7" test_sameSignificandBits_fewbits_F7+ , testCase "close F1" test_sameSignificandBits_close_F1+ , testCase "close F2" test_sameSignificandBits_close_F2+ , testCase "close F3" test_sameSignificandBits_close_F3+ , testCase "close F4" test_sameSignificandBits_close_F4+ , testCase "close F5" test_sameSignificandBits_close_F5+ , testCase "2factors F1" test_sameSignificandBits_2factors_F1+ , testCase "2factors F2" test_sameSignificandBits_2factors_F2+ , testCase "2factors F3" test_sameSignificandBits_2factors_F3+ , testCase "2factors F4" test_sameSignificandBits_2factors_F4+ , testCase "extreme F1" test_sameSignificandBits_extreme_F1+ , testCase "extreme F2" test_sameSignificandBits_extreme_F2+ , testCase "extreme F3" test_sameSignificandBits_extreme_F3+ , testCase "extreme F4" test_sameSignificandBits_extreme_F4+ , testCase "extreme F5" test_sameSignificandBits_extreme_F5+ , testCase "extreme F6" test_sameSignificandBits_extreme_F6+ ]++test_sameSignificandBits_exact_D1 =+ sameSignificandBits (maxFinite :: D) maxFinite+ @?= floatDigits (undefined :: D)+test_sameSignificandBits_exact_D2 =+ sameSignificandBits (0 :: D) 0+ @?= floatDigits (undefined :: D)+test_sameSignificandBits_exact_D3 =+ sameSignificandBits (7.1824 :: D) 7.1824+ @?= floatDigits (undefined :: D)+test_sameSignificandBits_exact_D4 =+ sameSignificandBits (infinity :: D) infinity+ @?= floatDigits (undefined :: D)++test_sameSignificandBits_fewbits_D1 =+ forM_ [ 0..mantDig-1 ] $ \i ->+ sameSignificandBits (1 + 2^^i * epsilon) (1 :: D) @?= mantDig - i - 1+ where+ mantDig = floatDigits (undefined :: D)++test_sameSignificandBits_fewbits_D2 =+ forM_ [ 0..mantDig-3 ] $ \i ->+ sameSignificandBits (1 - 2^^i * epsilon) (1 :: D) @?= mantDig - i - 1+ where+ mantDig = floatDigits (undefined :: D)++test_sameSignificandBits_fewbits_D3 =+ forM_ [ 0..mantDig-1 ] $ \i ->+ sameSignificandBits (1 :: D) (1 + (2^^i - 1) * epsilon)+ @?= mantDig - i+ where+ mantDig = floatDigits (undefined :: D)++test_sameSignificandBits_fewbits_D4 =+ sameSignificandBits (1.5 + epsilon) (1.5 :: D)+ @?= floatDigits (undefined :: D) - 1++test_sameSignificandBits_fewbits_D5 =+ sameSignificandBits (1.5 - epsilon) (1.5 :: D)+ @?= floatDigits (undefined :: D) - 1++test_sameSignificandBits_fewbits_D6 =+ sameSignificandBits (1.5 - epsilon) (1.5 + epsilon :: D)+ @?= floatDigits (undefined :: D) - 2++test_sameSignificandBits_fewbits_D7 =+ sameSignificandBits (minNormal / 8) (minNormal / 17 :: D)+ @?= 3++test_sameSignificandBits_close_D1 =+ sameSignificandBits (encodeFloat 0x1B0000 84) (encodeFloat 0x1B8000 84 :: D)+ @?= 5++test_sameSignificandBits_close_D2 =+ sameSignificandBits (encodeFloat 0x180000 10) (encodeFloat 0x1C0000 10 :: D)+ @?= 2++test_sameSignificandBits_close_D3 =+ sameSignificandBits (1.5 * (1 - epsilon)) (1 :: D) @?= 2++test_sameSignificandBits_close_D4 =+ sameSignificandBits 1.5 (1 :: D) @?= 1++test_sameSignificandBits_close_D5 =+ sameSignificandBits (2 * (1 - epsilon)) (1 :: D) @?= 1++test_sameSignificandBits_2factors_D1 =+ sameSignificandBits maxFinite (infinity :: D) @?= 0++test_sameSignificandBits_2factors_D2 =+ sameSignificandBits (2 * (1 - epsilon)) (1 :: D) @?= 1++test_sameSignificandBits_2factors_D3 =+ sameSignificandBits 1 (2 :: D) @?= 0++test_sameSignificandBits_2factors_D4 =+ sameSignificandBits 4 (1 :: D) @?= 0++test_sameSignificandBits_extreme_D1 =+ sameSignificandBits nan (nan :: D) @?= 0++test_sameSignificandBits_extreme_D2 =+ sameSignificandBits 0 (-nan :: D) @?= 0++test_sameSignificandBits_extreme_D3 =+ sameSignificandBits nan (infinity :: D) @?= 0++test_sameSignificandBits_extreme_D4 =+ sameSignificandBits infinity (-infinity :: D) @?= 0++test_sameSignificandBits_extreme_D5 =+ sameSignificandBits (-maxFinite) (infinity :: D) @?= 0++test_sameSignificandBits_extreme_D6 =+ sameSignificandBits (maxFinite) (-maxFinite :: D) @?= 0++test_sameSignificandBits_exact_F1 =+ sameSignificandBits (maxFinite :: F) maxFinite+ @?= floatDigits (undefined :: F)+test_sameSignificandBits_exact_F2 =+ sameSignificandBits (0 :: F) 0+ @?= floatDigits (undefined :: F)+test_sameSignificandBits_exact_F3 =+ sameSignificandBits (7.1824 :: F) 7.1824+ @?= floatDigits (undefined :: F)+test_sameSignificandBits_exact_F4 =+ sameSignificandBits (infinity :: F) infinity+ @?= floatDigits (undefined :: F)++test_sameSignificandBits_fewbits_F1 =+ forM_ [ 0..mantFig-1 ] $ \i ->+ sameSignificandBits (1 + 2^^i * epsilon) (1 :: F) @?= mantFig - i - 1+ where+ mantFig = floatDigits (undefined :: F)++test_sameSignificandBits_fewbits_F2 =+ forM_ [ 0..mantFig-3 ] $ \i ->+ sameSignificandBits (1 - 2^^i * epsilon) (1 :: F) @?= mantFig - i - 1+ where+ mantFig = floatDigits (undefined :: F)++test_sameSignificandBits_fewbits_F3 =+ forM_ [ 0..mantFig-1 ] $ \i ->+ sameSignificandBits (1 :: F) (1 + (2^^i - 1) * epsilon)+ @?= mantFig - i+ where+ mantFig = floatDigits (undefined :: F)++test_sameSignificandBits_fewbits_F4 =+ sameSignificandBits (1.5 + epsilon) (1.5 :: F)+ @?= floatDigits (undefined :: F) - 1++test_sameSignificandBits_fewbits_F5 =+ sameSignificandBits (1.5 - epsilon) (1.5 :: F)+ @?= floatDigits (undefined :: F) - 1++test_sameSignificandBits_fewbits_F6 =+ sameSignificandBits (1.5 - epsilon) (1.5 + epsilon :: F)+ @?= floatDigits (undefined :: F) - 2++test_sameSignificandBits_fewbits_F7 =+ sameSignificandBits (minNormal / 8) (minNormal / 17 :: F)+ @?= 3++test_sameSignificandBits_close_F1 =+ sameSignificandBits (encodeFloat 0x1B0000 84) (encodeFloat 0x1B8000 84 :: F)+ @?= 5++test_sameSignificandBits_close_F2 =+ sameSignificandBits (encodeFloat 0x180000 10) (encodeFloat 0x1C0000 10 :: F)+ @?= 2++test_sameSignificandBits_close_F3 =+ sameSignificandBits (1.5 * (1 - epsilon)) (1 :: F) @?= 2++test_sameSignificandBits_close_F4 =+ sameSignificandBits 1.5 (1 :: F) @?= 1++test_sameSignificandBits_close_F5 =+ sameSignificandBits (2 * (1 - epsilon)) (1 :: F) @?= 1++test_sameSignificandBits_2factors_F1 =+ sameSignificandBits maxFinite (infinity :: F) @?= 0++test_sameSignificandBits_2factors_F2 =+ sameSignificandBits (2 * (1 - epsilon)) (1 :: F) @?= 1++test_sameSignificandBits_2factors_F3 =+ sameSignificandBits 1 (2 :: F) @?= 0++test_sameSignificandBits_2factors_F4 =+ sameSignificandBits 4 (1 :: F) @?= 0++test_sameSignificandBits_extreme_F1 =+ sameSignificandBits nan (nan :: F) @?= 0++test_sameSignificandBits_extreme_F2 =+ sameSignificandBits 0 (-nan :: F) @?= 0++test_sameSignificandBits_extreme_F3 =+ sameSignificandBits nan (infinity :: F) @?= 0++test_sameSignificandBits_extreme_F4 =+ sameSignificandBits infinity (-infinity :: F) @?= 0++test_sameSignificandBits_extreme_F5 =+ sameSignificandBits (-maxFinite) (infinity :: F) @?= 0++test_sameSignificandBits_extreme_F6 =+ sameSignificandBits (maxFinite) (-maxFinite :: F) @?= 0+++test_nanWithPayload = testGroup "nanWithPayload"+ [ testCase "D1" test_nanWithPayload_D1+ , testCase "D2" test_nanWithPayload_D2+ , testCase "F1" test_nanWithPayload_F1+ , testCase "F2" test_nanWithPayload_F2+ ]++test_nanWithPayload_D1 =+ isNaN (nanWithPayload 1 :: D) @?= True++test_nanWithPayload_D2 =+ isNaN (nanWithPayload maxPayload :: D) @?= True+ where+ maxPayload = maxNaNPayload (undefined :: D)++test_nanWithPayload_F1 =+ isNaN (nanWithPayload 1 :: F) @?= True++test_nanWithPayload_F2 =+ isNaN (nanWithPayload maxPayload :: F) @?= True+ where+ maxPayload = maxNaNPayload (undefined :: F)+++test_nanPayload = testGroup "nanPayload"+ [ testCase "D1" test_nanPayload_D1+ , testCase "D2" test_nanPayload_D2+ , testCase "D3" test_nanPayload_D3+ , testCase "F1" test_nanPayload_F1+ , testCase "F2" test_nanPayload_F2+ , testCase "F3" test_nanPayload_F3 + ]++test_nanPayload_D1 =+ nanPayload (nanWithPayload 1 :: D) @?= 1++test_nanPayload_D2 =+ nanPayload (nanWithPayload maxPayload :: D) @?= maxPayload+ where+ maxPayload = maxNaNPayload (undefined :: D)++test_nanPayload_D3 =+ nanPayload (nanWithPayload (maxPayload + 1) :: D) @?= 0+ where+ maxPayload = maxNaNPayload (undefined :: D)++test_nanPayload_F1 =+ nanPayload (nanWithPayload 1 :: F) @?= 1++test_nanPayload_F2 =+ nanPayload (nanWithPayload maxPayload :: F) @?= maxPayload+ where+ maxPayload = maxNaNPayload (undefined :: F)++test_nanPayload_F3 =+ nanPayload (nanWithPayload (maxPayload + 1) :: F) @?= 0+ where+ maxPayload = maxNaNPayload (undefined :: F)++test_copySign = testGroup "copySign"+ [ testCase "D1" test_copySign_D1+ , testCase "D2" test_copySign_D2+ , testCase "D3" test_copySign_D3 + , testCase "D4" test_copySign_D4 + , testCase "D5" test_copySign_D5 + , testCase "D6" test_copySign_D6 + , testCase "F1" test_copySign_F1+ , testCase "F2" test_copySign_F2+ , testCase "F3" test_copySign_F3 + , testCase "F4" test_copySign_F4 + , testCase "F5" test_copySign_F5 + , testCase "F6" test_copySign_F6 + ]++test_copySign_D1 =+ copySign 0.9 (-1.2) @?= (-0.9 :: D)+test_copySign_D2 =+ copySign 0.9 (1.2) @?= (0.9 :: D)+test_copySign_D3 =+ copySign (-0.9 )(1.2) @?= (0.9 :: D)+test_copySign_D4 =+ copySign (-0.9) (-1.2) @?= (-0.9 :: D)+test_copySign_D5 =+ copySign 1 (copySign nan 1) @?= (1 :: D)+test_copySign_D6 =+ copySign 1 (copySign nan (-1)) @?= (-1 :: D)++test_copySign_F1 =+ copySign 0.9 (-1.2) @?= (-0.9 :: F)+test_copySign_F2 =+ copySign 0.9 (1.2) @?= (0.9 :: F)+test_copySign_F3 =+ copySign (-0.9 )(1.2) @?= (0.9 :: F)+test_copySign_F4 =+ copySign (-0.9) (-1.2) @?= (-0.9 :: F)+test_copySign_F5 =+ copySign 1 (copySign nan 1) @?= (1 :: F)+test_copySign_F6 =+ copySign 1 (copySign nan (-1)) @?= (-1 :: F)++++test_IEEE = testGroup "IEEE"+ [ test_infinity+ , test_copySign+ , test_succIEEE+ , test_predIEEE+ , test_bisectIEEE+ , test_sameSignificandBits+ , test_maxNum+ , test_minNum+ , test_maxNaN+ , test_minNaN+ , test_nan+ , test_nanWithPayload+ , test_nanPayload+ ]++main :: IO ()+main = defaultMain [ test_IEEE+ ]