exact-real (empty) → 0.2.0.0

raw patch · 16 files changed

+596/−0 lines, 16 filesdep +QuickCheckdep +basedep +checkerssetup-changed

Dependencies added: QuickCheck, base, checkers, directory, doctest, exact-real, filepath, groups, integer-gmp, random, tasty, tasty-quickcheck, tasty-th

Files

• .gitignore +16/−0
• LICENSE +20/−0
• Setup.hs +2/−0
• exact-real.cabal +80/−0
• readme.md +4/−0
• src/Data/CReal.hs +7/−0
• src/Data/CReal/Internal.hs +187/−0
• test/Data/CReal/Extra.hs +13/−0
• test/Data/Monoid/Extra.hs +21/−0
• test/DocTest.hs +22/−0
• test/Fractional.hs +25/−0
• test/Num.hs +26/−0
• test/Test.hs +41/−0
• test/Test/QuickCheck/Classes/Extra.hs +68/−0
• test/Test/QuickCheck/Extra.hs +48/−0
• test/Test/Tasty/Extra.hs +16/−0

@@ -0,0 +1,16 @@+dist+cabal-dev+*.o+*.hi+*.chi+*.chs.h+*.dyn_o+*.dyn_hi+.hpc+.hsenv+.cabal-sandbox/+cabal.sandbox.config+*.prof+*.aux+*.hp+.stack-work/

@@ -0,0 +1,20 @@+Copyright (c) 2015 Joe Hermaszewski++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,80 @@+name:                exact-real+version:             0.2.0.0+synopsis:            Exact real arithmetic+description:         please see readme.md+license:             MIT+license-file:        LICENSE+author:              Joe Hermaszewski+maintainer:          keep.it.real@monoid.al+copyright:           2015 Joe Hermaszewski+category:            Math+build-type:          Simple+extra-source-files:+  .gitignore+  readme.md+cabal-version:       >=1.10++library+  exposed-modules:+    Data.CReal+    Data.CReal.Internal+  build-depends:+    base >=4.8 && <4.9,+    integer-gmp < 1.1.0.0+  hs-source-dirs:+    src+  default-language:+    Haskell2010+  ghc-options:+    -Wall++test-suite test+  default-language:+    Haskell2010+  type:+    exitcode-stdio-1.0+  ghc-options:+    -Wall -threaded+  hs-source-dirs:+    test+  main-is:+    Test.hs+  other-modules:+    Fractional,+    Num,+    Data.CReal.Extra,+    Data.Monoid.Extra,+    Test.QuickCheck.Classes.Extra+    Test.QuickCheck.Extra+    Test.Tasty.Extra+  build-depends:+    base             >= 4    && < 5,+    groups           >= 0.3  && < 0.5,+    tasty            >= 0.10 && < 0.12,+    tasty-th         >= 0.1  && < 0.2,+    tasty-quickcheck >= 0.8  && < 0.9,+    QuickCheck       >= 2.8  && < 2.9,+    checkers         >= 0.4  && < 0.5,+    random           >= 1.0  && < 1.2,+    exact-real++test-suite doctest+  default-language:+    Haskell2010+  type:+    exitcode-stdio-1.0+  ghc-options:+    -Wall -threaded+  hs-source-dirs:+    test+  main-is:+    DocTest.hs+  build-depends:+    base      >= 4   && < 5,+    directory >= 1.0 && < 1.3,+    doctest   >= 0.8 && < 0.11,+    filepath  >= 1.3 && < 1.5++source-repository head+  type: git+  location: https://github.com/expipiplus1/exact-real

@@ -0,0 +1,4 @@+exact-real+==========++Exact real arithmetic implemented by fast binary Cauchy sequences.

@@ -0,0 +1,7 @@+module Data.CReal+  ( CReal+  , atPrecision+  , crealPrecision+  ) where++import Data.CReal.Internal

@@ -0,0 +1,187 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}++module Data.CReal.Internal+  ( CReal(..)+  , atPrecision+  , crealPrecision++  , (/.)+  , log2+  , log10+  , decimalDigitsAtPrecision+  , rationalToDecimal+  ) where++import Data.Ratio (numerator,denominator,(%))+import GHC.Base (Int(..))+import GHC.Integer.Logarithms (integerLog2#, integerLogBase#)+import GHC.TypeLits++-- $setup+-- >>> :set -XDataKinds++infixl 7 /.++default ()++-- | The type CReal represents a fast binary Cauchy sequence. This is+-- a Cauchy sequence with the property that the pth element will be within+-- 2^-p of the true value. Internally this sequence is represented as+-- a function from Ints to Integers.+newtype CReal (n :: Nat) = CR (Int -> Integer)++-- | crealPrecision x returns the type level parameter representing x's default+-- precision.+--+-- >>> crealPrecision (1 :: CReal 10)+-- 10+crealPrecision :: KnownNat n => CReal n -> Int+crealPrecision = fromInteger . natVal++-- | @x \`atPrecision\` p@ returns the numerator of the pth element in the+-- Cauchy sequence represented by x. The denominator is 2^p.+--+-- >>> 10 `atPrecision` 10+-- 10240+atPrecision :: CReal n -> Int -> Integer+(CR x) `atPrecision` p = x p++-- | A CReal with precision p is shown as a decimal number d such that d is+-- within 2^-p of the true value.+--+-- >>> show (47176870 :: CReal 0)+-- "47176870"+instance KnownNat n => Show (CReal n) where+  show x = showAtPrecision (crealPrecision x) x++-- | @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@.+--+-- This is a little bit of a fudge, but it's probably better than failing to+-- terminate when trying to find the sign of zero. The class still respects the+-- abs-signum law though.+--+-- >>> signum (0.1 :: CReal 2)+-- 0.0+--+-- >>> signum (0.1 :: CReal 3)+-- 1.0+instance Num (CReal n) where+  fromInteger i = CR (\p -> i * 2 ^ p)++  negate (CR x) = CR (negate . x)++  abs (CR x) = CR (abs . x)++  {-# INLINE (+) #-}+  CR x1 + CR x2 = CR (\p -> let n1 = x1 (p + 2)+                                n2 = x2 (p + 2)+                            in (n1 + n2) /. 4)++  {-# INLINE (*) #-}+  CR x1 * CR x2 = CR (\p -> let s1 = log2 (abs (x1 0) + 2) + 3+                                s2 = log2 (abs (x2 0) + 2) + 3+                                n1 = x1 (p + s2)+                                n2 = x2 (p + s1)+                            in (n1 * n2) /. 2^(p + s1 + s2)  )++  signum x = CR (\p -> signum (x `atPrecision` p) * 2^p)++-- | Taking the reciprocal of zero will not terminate+instance Fractional (CReal n) where+  -- This should be in base+  fromRational n = fromInteger (numerator n) / fromInteger (denominator n)++  {-# INLINE recip #-}+  -- TODO: Make recip 0 throw an error (if, for example, it would take more+  -- than 4GB of memory to represent the result)+  recip (CR x) = CR (\p -> let s = findFirstMonotonic ((3 <=) . abs . x)+                               n = x (p + 2 * s + 2)+                           in 2^(2 * p + 2 * s + 2) /. n)++-- | 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.+--+-- >>> 0 == (0.1 :: CReal 1)+-- True+instance KnownNat n => Eq (CReal n) where+  -- TODO, should this try smaller values first?+  x == y = let p = crealPrecision x+           in (x - y) `atPrecision` p == 0++-- | Like equality values of type @CReal p@ are compared at precision @p@.+instance KnownNat n => Ord (CReal n) where+  compare x y = let p = crealPrecision x+                in compare ((x - y) `atPrecision` p) 0++--------------------------------------------------------------------------------+-- Some utility functions+--------------------------------------------------------------------------------++--+-- Showing CReals+--++-- | Return a string representing a decimal number within 2^-p of the value+-- represented by the given @CReal p@.+showAtPrecision :: Int -> CReal n -> String+showAtPrecision p (CR x) = let places = decimalDigitsAtPrecision p+                               r = x p % 2^p+                           in rationalToDecimal places r++-- | How many decimal digits are required to represent a number to within 2^-p+decimalDigitsAtPrecision :: Int -> Int+decimalDigitsAtPrecision 0 = 0+decimalDigitsAtPrecision p = log10 (2^p) + 1++-- | @rationalToDecimal p x@ returns a string representing @x@ at @p@ decimal+-- places.+rationalToDecimal :: Int -> Rational -> String+rationalToDecimal places r = s+  where ds = show ((numerator r * 10^places) /. denominator r)+        (is, fs) = splitAt (length ds - places) ds+        is' = case is of+                ""  -> "0"+                "-" -> "-0"+                _   -> is+        suff = case places of+                 0 -> ""+                 _ -> '.' : take places (fs ++ repeat '0')+        s = is' ++ suff++--+-- Integer operations+--++-- | Division rounding to the nearest integer and rounding half integers to the+-- nearest even integer.+(/.) :: Integer -> Integer -> Integer+n /. d = round (n % d)++-- | @log2 x@ returns the base 2 logarithm of @x@ rounded towards zero.+log2 :: Integer -> Int+log2 x = I# (integerLog2# x)++-- | @log10 x@ returns the base 10 logarithm of @x@ rounded towards zero.+log10 :: Integer -> Int+log10 x = I# (integerLogBase# 10 x)++--+-- Searching+--++-- | Given a monotonic function+findFirstMonotonic :: (Int -> Bool) -> Int+findFirstMonotonic p = binarySearch l' u'+  where (l', u') = findBounds 0 1+        findBounds l u = if p u then (l, u)+                                else findBounds u (u*2)+        binarySearch l u = let m = l + ((u - l) `div` 2)+                           in if | l+1 == u  -> l+                                 | p m       -> binarySearch l m+                                 | otherwise -> binarySearch m u+

@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.CReal.Extra+  ( module Data.CReal+  ) where++import Test.QuickCheck.Checkers (EqProp(..), eq)+import Data.CReal+import GHC.TypeLits++instance KnownNat n => EqProp (CReal n) where+  (=-=) = eq+

@@ -0,0 +1,21 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Add instances for Arbitrary and EqProp for Sum and Product+module Data.Monoid.Extra+  ( module Data.Monoid+  ) where++import Data.Monoid (Sum(..), Product(..))+import Test.QuickCheck (Arbitrary)+import Test.QuickCheck.Checkers (EqProp)++deriving instance Arbitrary a => Arbitrary (Sum a)++deriving instance EqProp a => EqProp (Sum a)++deriving instance Arbitrary a => Arbitrary (Product a)++deriving instance EqProp a => EqProp (Product a)

@@ -0,0 +1,22 @@+module Main where++import Control.Monad (filterM)+import Data.List (isSuffixOf)+import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)+import System.FilePath ((</>))+import Test.DocTest (doctest)++main :: IO ()+main = doctest =<< getSources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+  where go dir = do+          (dirs, files) <- getFilesAndDirectories dir+          (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c+

@@ -0,0 +1,25 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Fractional+  ( fractional+  ) where++import Data.Ratio ((%))+import Test.QuickCheck (Arbitrary)+import Test.QuickCheck.Checkers (EqProp, (=-=))+import Test.QuickCheck.Classes.Extra (field)+import Test.QuickCheck.Modifiers (NonZero(..))+import Test.QuickCheck.Extra ()+import Test.Tasty (testGroup, TestTree)+import Test.Tasty.QuickCheck (testProperty)+import Num (numAuxTests)++fractional :: forall a. (Arbitrary a, EqProp a, Show a, Fractional a, Ord a) => a -> TestTree+fractional _ = testGroup "Test Fractional instance" ts+  where+    ts = [ field "field" (undefined :: a)+         , numAuxTests (undefined :: a)+         , testProperty "x * recip y = x / y" (\x (NonZero (y :: a)) -> x * recip y =-= x / y)+         , testProperty "fromRational (x % y) = fromInteger x / fromInteger y"+             (\x (NonZero y) -> fromRational (x % y) =-= fromInteger x / (fromInteger y :: a))+         ]

@@ -0,0 +1,26 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Num+  ( num+  , numAuxTests+  ) where++import Test.QuickCheck (Arbitrary)+import Test.QuickCheck.Checkers (idempotent, EqProp, (=-=))+import Test.QuickCheck.Classes.Extra (commutativeRing)+import Test.Tasty (testGroup, TestTree)+import Test.Tasty.QuickCheck (testProperty)++num :: forall a. (Arbitrary a, EqProp a, Show a, Num a) => a -> TestTree+num _ = testGroup "Test Num instance" ts+  where+    ts = [commutativeRing "commutativeRing" (undefined :: a), numAuxTests (undefined :: a)]++numAuxTests :: forall a. (Arbitrary a, EqProp a, Show a, Num a) => a -> TestTree+numAuxTests _ = testGroup "Num instance aux tests" ts+  where+    ts = [ testProperty "x + negate y = x - y" (\x (y :: a) -> x + negate y =-= x - y)+         , testProperty "abs is idempotent" (idempotent (abs :: a -> a))+         , testProperty "abs-signum law" (\(x :: a) -> abs x * signum x =-= x)+         ]+

@@ -0,0 +1,41 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main (main) where++import Test.Tasty (testGroup, TestTree)+import Test.Tasty.TH (defaultMainGenerator)+import Test.Tasty.QuickCheck (Arbitrary(..), Positive(..), testProperty, (===), Property)++import Data.CReal.Internal+import Data.CReal.Extra ()++import Fractional (fractional)++-- How many binary digits to use for comparisons TODO: Test with many different+-- precisions+type Precision = 10++instance Arbitrary (CReal n) where+  arbitrary = fromInteger <$> arbitrary++infixr 1 ==>+(==>) :: Bool -> Bool -> Bool+False ==> _ = True+True ==> b = b++{-# ANN test_fractional "HLint: ignore Use camelCase" #-}+test_fractional :: [TestTree]+test_fractional = [fractional (undefined :: CReal Precision)]++prop_decimalDigits :: Positive Int -> Bool+prop_decimalDigits (Positive p) = let d = decimalDigitsAtPrecision p+                                  in 10^d >= (2^p :: Integer) &&+                                     (d > 0 ==> 10^(d-1) < (2^p :: Integer))++prop_showIntegral :: Integer -> Property+prop_showIntegral i = show i === show (fromInteger i :: CReal 0)++main :: IO ()+main = $(defaultMainGenerator)

@@ -0,0 +1,68 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | Add a bunch of checkers for testing properties of different algebraic+-- structures+module Test.QuickCheck.Classes.Extra+  ( module Test.QuickCheck.Classes+  , group+  , abelian+  , ring+  , commutativeRing+  , field+  ) where++import Data.Group (invert, Group, Abelian)+import Data.Monoid ((<>), Sum(..), Product)+import Data.Monoid.Extra ()+import Test.QuickCheck.Extra (Arbitrary)+import Test.QuickCheck.Modifiers (NonZero)+import Test.QuickCheck.Checkers (commutes, EqProp, (=-=))+import Test.QuickCheck.Classes+import Test.Tasty.Extra (testGroup, TestTree, testTreeFromBatch, testTreeFromNamedBatch)+import Test.Tasty.QuickCheck (testProperty, Property)++distributesL :: EqProp a => (a -> a -> a) -> (a -> a -> a) -> a -> a -> a -> Property+distributesL (*:) (+:) a b c = a *: (b +: c) =-= (a *: b) +: (a *: c)++distributesR :: EqProp a => (a -> a -> a) -> (a -> a -> a) -> a -> a -> a -> Property+distributesR (*:) = distributesL (flip (*:))++distributes :: (Arbitrary a, EqProp a, Show a) => String -> (a -> a -> a) -> (a -> a -> a) -> TestTree+distributes s (*:) (+:) = testGroup s ts+  where ts = [testProperty "left distributes" (distributesL (*:) (+:)),+              testProperty "right distributes" (distributesR (*:) (+:))]++group :: forall a. (Arbitrary a, EqProp a, Group a, Show a) => String -> a -> TestTree+group s _ = testGroup s ts+  where+    ts = [ testTreeFromBatch (monoid (undefined :: a))+         , testProperty "left inverse element" (\(x :: a) -> x <> invert x =-= mempty)+         , testProperty "right inverse element" (\(x :: a) -> invert x <> x =-= mempty)+         ]++abelian :: forall a. (Arbitrary a, EqProp a, Abelian a, Show a) => String -> a -> TestTree+abelian s _ = testGroup s ts+  where+    ts = [ group "group" (undefined :: a)+         , testProperty "commutative" (commutes ((<>) :: a -> a -> a))+         ]++ring :: forall a. (Arbitrary a, EqProp a, Num a, Show a) => String -> a -> TestTree+ring s _ = testGroup s ts+  where+    ts = [ abelian "abelian under Sum" (undefined :: Sum a)+         , testTreeFromNamedBatch "monoid under product" (monoid (undefined :: Product a))+         , distributes "* distributes over +" (*) ((+) :: a -> a -> a)+         ]++commutativeRing :: forall a. (Arbitrary a, EqProp a, Num a, Show a) => String -> a -> TestTree+commutativeRing s _ = testGroup s ts+  where ts = [ring "ring" (undefined :: a),+             testProperty "* commutes" (commutes ((*) :: a -> a -> a))]++field :: forall a. (Arbitrary a, EqProp a, Fractional a, Show a, Ord a) => String -> a -> TestTree+field s _ = testGroup s ts+  where ts = [abelian "Abelian under Sum" (undefined :: Sum a),+              abelian "Abelian under Product NonZero" (undefined :: Product (NonZero a)),+              distributes "* distributes over +" (*) ((+) :: a -> a -> a)]+

@@ -0,0 +1,48 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Add some more newtypes for restricting arbitrary instances+module Test.QuickCheck.Extra+  ( module Test.QuickCheck+  , UnitInterval(..)+  , BiunitInterval(..)+  , Tiny(..)+  ) where++import Test.QuickCheck (Arbitrary(..), choose, suchThat)+import Test.QuickCheck.Checkers (EqProp)+import Test.QuickCheck.Modifiers (NonZero(..))+import System.Random (Random)++deriving instance Num a => Num (NonZero a)+deriving instance Fractional a => Fractional (NonZero a)+deriving instance EqProp a => EqProp (NonZero a)++newtype UnitInterval a = UnitInterval a+  deriving(Eq, Ord, Show, Read, Num, Integral, Fractional, Floating, Real, Enum, Functor, Random, EqProp)++instance (Arbitrary a, Num a, Random a) => Arbitrary (UnitInterval a) where+  arbitrary = choose (0, 1)+  shrink (UnitInterval a) = UnitInterval <$> shrink a++newtype BiunitInterval a = BiunitInterval a+  deriving(Eq, Ord, Show, Read, Num, Integral, Fractional, Floating, Real, Enum, Functor, Random, EqProp)++instance (Arbitrary a, Num a, Random a) => Arbitrary (BiunitInterval a) where+  arbitrary = choose (-1, 1)+  shrink (BiunitInterval a) = BiunitInterval <$> shrink a++newtype Tiny a = Tiny a+  deriving(Eq, Ord, Show, Read, Num, Integral, Real, Enum, Functor)++-- | Chosen rather arbitrarily just so the tests involving exponentiation don't take too long+tinyBound :: Num a => a+tinyBound = 1000000000++instance (Num a, Ord a, Arbitrary a) => Arbitrary (Tiny a) where+  arbitrary = Tiny <$> arbitrary `suchThat` ((< tinyBound) . abs)+++

@@ -0,0 +1,16 @@+module Test.Tasty.Extra+  ( module Test.Tasty+  , testTreeFromBatch+  , testTreeFromNamedBatch) where++import Test.Tasty (testGroup, TestTree)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck.Checkers (TestBatch)++testTreeFromBatch :: TestBatch -> TestTree+testTreeFromBatch (n, ts) = testTreeFromNamedBatch n (n, ts)++testTreeFromNamedBatch :: String -> TestBatch -> TestTree+testTreeFromNamedBatch n (_, ts) = testGroup n ts'+  where ts' = uncurry testProperty <$> ts+