diff --git a/exact-real.cabal b/exact-real.cabal --- a/exact-real.cabal +++ b/exact-real.cabal @@ -1,17 +1,21 @@ name: exact-real -version: 0.5.0.0 +version: 0.7.1.0 synopsis: Exact real arithmetic -description: please see readme.md +description: + A type to represent exact real number using a fast binary Cauchy sequence license: MIT license-file: LICENSE author: Joe Hermaszewski -maintainer: keep.it.real@monoid.al +maintainer: Joe Hermaszewski +homepage: http://github.com/expipiplus1/exact-real +bug-reports: http://github.com/expipiplus1/exact-real/issues copyright: 2015 Joe Hermaszewski category: Math build-type: Simple extra-source-files: .gitignore readme.md + stack.yaml cabal-version: >=1.10 library @@ -47,7 +51,10 @@ Fractional, Num, Ord, + Read, Real, + RealFloat, + RealFrac, Test.QuickCheck.Classes.Extra Test.QuickCheck.Extra Test.Tasty.Extra @@ -83,3 +90,5 @@ source-repository head type: git location: https://github.com/expipiplus1/exact-real + + diff --git a/src/Data/CReal/Internal.hs b/src/Data/CReal/Internal.hs --- a/src/Data/CReal/Internal.hs +++ b/src/Data/CReal/Internal.hs @@ -42,6 +42,7 @@ import GHC.Base (Int(..)) import GHC.Integer.Logarithms (integerLog2#, integerLogBase#) import GHC.TypeLits +import Numeric (readSigned, readFloat) -- $setup -- >>> :set -XDataKinds @@ -80,6 +81,9 @@ instance KnownNat n => Show (CReal n) where show x = showAtPrecision (crealPrecision x) x +instance KnownNat n => Read (CReal n) where + readsPrec _ = readSigned readFloat + -- | @signum (x :: CReal p)@ returns the sign of @x@ at precision @p@. It's -- important to remember that this /may not/ represent the actual sign of @x@ if -- the distance between @x@ and zero is less than 2^-@p@. @@ -198,6 +202,44 @@ instance KnownNat n => Real (CReal n) where toRational x = let p = crealPrecision x in x `atPrecision` p % 2^p + +instance KnownNat n => RealFrac (CReal n) where + properFraction x = let n = x `atPrecision` 0 + f = x - fromIntegral n + in (fromInteger n, f) + +-- | Several of the functions in this class ('floatDigits', 'floatRange', +-- 'exponent', 'significand') only make sense for floats represented by a +-- mantissa and exponent. These are bound to error. +-- +-- @atan2 y x `atPrecision` p@ performs the comparison to determine the +-- quadrant at precision p. This can cause atan2 to be slightly slower than atan +instance KnownNat n => RealFloat (CReal n) where + floatRadix _ = 2 + floatDigits _ = error "Data.CReal.Internal floatDigits" + floatRange _ = error "Data.CReal.Internal floatRange" + decodeFloat x = let p = crealPrecision x + in (x `atPrecision` p, -p) + encodeFloat m n = fromRational (m % 2^(-n)) + exponent = error "Data.CReal.Internal exponent" + significand = error "Data.CReal.Internal significand" + scaleFloat = flip shiftL + isNaN _ = False + isInfinite _ = False + isDenormalized _ = False + isNegativeZero _ = False + isIEEE _ = False + atan2 y x = CR (\p -> + let y' = y `atPrecision` p + x' = x `atPrecision` p + θ = if | x' > 0 -> atan (y/x) + | x' == 0 && y' > 0 -> pi/2 + | x' < 0 && y' > 0 -> pi + atan (y/x) + | x' <= 0 && y' < 0 -> -atan2 (-y) x + | y' == 0 && x' < 0 -> pi -- must be after the previous test on zero y + | x'==0 && y'==0 -> 0 -- must be after the other double zero tests + | otherwise -> error "Data.CReal.Internal atan2" + in θ `atPrecision` p) -- | Values of type @CReal p@ are compared for equality at precision @p@. This -- may cause values which differ by less than 2^-p to compare as equal. diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,15 @@ +# For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md + +# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) +resolver: lts-3.13 + +# Local packages, usually specified by relative directory name +packages: +- '.' + +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + diff --git a/test/Read.hs b/test/Read.hs new file mode 100644 --- /dev/null +++ b/test/Read.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Read + ( read' + ) where + +import Test.QuickCheck.Checkers (EqProp, inverseL) +import Test.Tasty (testGroup, TestTree) +import Test.Tasty.QuickCheck (testProperty, Arbitrary) + +read' :: forall a. (Arbitrary a, EqProp a, Show a, Read a) => a -> TestTree +read' _ = testGroup "Test Read instance" ts + where ts = [ testProperty "read show left inverse" + (inverseL read (show :: a -> String)) + ] diff --git a/test/RealFloat.hs b/test/RealFloat.hs new file mode 100644 --- /dev/null +++ b/test/RealFloat.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module RealFloat + ( realFloat + ) where + +import Data.Ratio.Extra () +import Test.QuickCheck.Checkers (EqProp, (=-=), inverseL) +import Test.Tasty (testGroup, TestTree) +import Test.Tasty.QuickCheck (testProperty, Arbitrary, (==>)) + +realFloat :: forall a. (Arbitrary a, EqProp a, Show a, RealFloat a) => + a -> TestTree +realFloat x = testGroup "Test RealFloat instance" ts + where ts = [ decodeFloatLaws "decodeFloat laws" x + , testProperty "encodeFloat decodeFloat left inverse" + (inverseL (uncurry encodeFloat) (decodeFloat :: a -> (Integer, Int))) + , testProperty "scaleFloat definition" + (\y i -> let r = floatRadix y + in scaleFloat i (y::a) =-= y * fromIntegral r ^^ i) + , atan2Laws "atan2 laws" x + ] + +decodeFloatLaws :: forall a. (Arbitrary a, EqProp a, Show a, RealFloat a) => + String -> a -> TestTree +decodeFloatLaws s _ = testGroup s ts + where ts = [ testProperty "x = m*b^^n" + (\x -> let (m, n) = decodeFloat (x :: a) + b = floatRadix x + in not (isNaN x || isInfinite x) ==> + (x =-= fromInteger m * fromInteger b ^^ n)) + ] + +atan2Laws :: forall a. (Arbitrary a, EqProp a, Show a, RealFloat a) => + String -> a -> TestTree +atan2Laws s _ = testGroup s ts + where ts = [ testProperty "atan2 range" (\y x -> let θ = atan2 y (x :: a) + in abs θ <= pi) + , testProperty "atan2 y 1 = atan y" (\y -> let θ = atan2 y (1 :: a) + in θ =-= atan y) + ] + diff --git a/test/RealFrac.hs b/test/RealFrac.hs new file mode 100644 --- /dev/null +++ b/test/RealFrac.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module RealFrac + ( realFrac + ) where + +import Data.Ratio.Extra () +import Test.QuickCheck.Checkers (EqProp, (=-=)) +import Test.Tasty (testGroup, TestTree) +import Test.Tasty.QuickCheck (testProperty, Arbitrary) + +-- TODO: Test the other functions +realFrac :: forall a. (Arbitrary a, EqProp a, Show a, RealFrac a) => + a -> TestTree +realFrac x = testGroup "Test RealFrac instance" ts + where ts = [ properFractionLaws "properFraction laws" x ] + +-- | This tests a slightly different law for n having the same sign as x +properFractionLaws :: forall a. (Arbitrary a, EqProp a, Show a, RealFrac a) => + String -> a -> TestTree +properFractionLaws s _ = testGroup s ts + where ts = [ testProperty "x = n + f" + (\x -> let (n, f) = properFraction (x :: a) + in x =-= fromInteger n + f) + , testProperty "n has same sign or is zero" + (\x -> let (n, _) = properFraction (x :: a) + in n == 0 || sign x == sign (n::Int)) + , testProperty "abs f < 1" + (\x -> let (_::Int, f) = properFraction (x :: a) + in abs f < 1) + ] + +data Sign = Positive + | Negative + deriving (Eq, Show) + +-- | Note that this returns Positive on zero rather than 0 like signum +sign :: (Ord a, Num a) => a -> Sign +sign x = if x < 0 then Negative + else Positive diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -14,7 +14,10 @@ import Floating (floating) import Ord (ord) +import Read (read') import Real (real) +import RealFrac (realFrac) +import RealFloat (realFloat) -- How many binary digits to use for comparisons TODO: Test with many different -- precisions @@ -36,6 +39,18 @@ {-# ANN test_real "HLint: ignore Use camelCase" #-} test_real :: [TestTree] test_real = [ real (\x -> 1 % toInteger (crealPrecision (x::CReal Precision))) ] + +{-# ANN test_realFrac "HLint: ignore Use camelCase" #-} +test_realFrac :: [TestTree] +test_realFrac = [ realFrac (undefined :: CReal Precision) ] + +{-# ANN test_realFloat "HLint: ignore Use camelCase" #-} +test_realFloat :: [TestTree] +test_realFloat = [ realFloat (undefined :: CReal Precision) ] + +{-# ANN test_read "HLint: ignore Use camelCase" #-} +test_read :: [TestTree] +test_read = [ read' (undefined :: CReal Precision) ] prop_decimalDigits :: Positive Int -> Bool prop_decimalDigits (Positive p) = let d = decimalDigitsAtPrecision p