├── .github └── workflows │ ├── bump-command.yml │ ├── ci.yml │ ├── command-dispatch.yml │ ├── release.yml │ └── tag-release.yml ├── .gitignore ├── LICENSE ├── Setup.hs ├── bench └── Bench.hs ├── changelog.md ├── default.nix ├── exact-real.cabal ├── package.yaml ├── readme.md ├── release.nix ├── src └── Data │ ├── CReal.hs │ └── CReal │ ├── Converge.hs │ └── Internal.hs ├── stack.yaml ├── stack.yaml.lock └── test ├── BoundedFunctions.hs ├── Data └── CReal │ └── Extra.hs ├── Doctests.hs ├── Floating.hs ├── Fractional.hs ├── Num.hs ├── Ord.hs ├── Random.hs ├── Read.hs ├── Real.hs ├── RealFloat.hs ├── RealFrac.hs ├── Test.hs └── Test ├── QuickCheck ├── Classes │ └── Extra.hs └── Extra.hs └── Tasty └── Extra.hs /.github/workflows/bump-command.yml: -------------------------------------------------------------------------------- 1 | name: Bump command 2 | 3 | on: issue_comment 4 | 5 | jobs: 6 | bump: 7 | runs-on: ubuntu-20.04 8 | 9 | # Only run if we're invoked with a new command comment on a pull request. 10 | if: | 11 | github.event_name == 'issue_comment' && github.event.action == 'created' 12 | && github.event.issue.pull_request != null 13 | && startsWith(github.event.comment.body, '/bump') 14 | 15 | steps: 16 | - name: Check for Command 17 | id: command 18 | uses: xt0rted/slash-command-action@v1 19 | continue-on-error: true 20 | with: 21 | repo-token: ${{ secrets.GITHUB_TOKEN }} 22 | command: bump 23 | reaction: 'true' 24 | reaction-type: eyes 25 | allow-edits: 'true' 26 | permission-level: write 27 | 28 | - name: Get PR Branch 29 | id: comment-branch 30 | uses: xt0rted/pull-request-comment-branch@v1 31 | with: 32 | repo_token: ${{ secrets.GITHUB_TOKEN }} 33 | 34 | - uses: cachix/install-nix-action@v12 35 | with: 36 | nix_path: nixpkgs=channel:nixos-unstable 37 | 38 | # Checkout the pull request branch 39 | - uses: actions/checkout@v2 40 | with: 41 | ssh-key: ${{ secrets.DEPLOY_KEY }} 42 | repository: ${{ github.event.client_payload.pull_request.head.repo.full_name 43 | }} 44 | ref: ${{ steps.comment-branch.outputs.ref }} 45 | 46 | - uses: expipiplus1/action-automation/bump-version@HEAD 47 | with: 48 | packageInfos: | 49 | exact-real v . 50 | packageVersions: | 51 | { "exact-real": "${{ steps.command.outputs.command-arguments }}" } 52 | 53 | - run: | 54 | git push origin HEAD:"${{ steps.comment-branch.outputs.ref }}" 55 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | # Based on https://kodimensional.dev/github-actions 2 | 3 | name: CI 4 | 5 | # Trigger the workflow on push or pull request, but only for the master branch 6 | on: 7 | pull_request: 8 | push: 9 | branches: [master] 10 | 11 | env: 12 | cabalConfig: --enable-tests --enable-benchmarks --disable-optimization --enable-deterministic 13 | --write-ghc-environment-files=always 14 | 15 | jobs: 16 | cabal: 17 | name: ghc ${{ matrix.ghc }} 18 | runs-on: ${{ matrix.os }} 19 | strategy: 20 | matrix: 21 | os: [ubuntu-latest] 22 | cabal: [latest] 23 | ghc: ['8.8', '8.10', '9.0', '9.2'] 24 | fail-fast: false 25 | 26 | steps: 27 | - uses: cachix/install-nix-action@v12 28 | with: 29 | nix_path: nixpkgs=channel:nixos-unstable 30 | 31 | - uses: haskell/actions/setup@v1 32 | id: setup-haskell-cabal 33 | name: Setup Haskell 34 | with: 35 | ghc-version: ${{ matrix.ghc }} 36 | cabal-version: ${{ matrix.cabal }} 37 | 38 | - uses: actions/checkout@v2 39 | 40 | - name: Install system dependencies 41 | run: sudo apt-get install libsodium-dev 42 | 43 | - name: Install Nix dependencies 44 | run: nix-env -f '' -iA git nix-prefetch-git 45 | 46 | - name: Repository update 47 | run: | 48 | cabal v2-update 49 | 50 | # NOTE: Freeze is for the caching 51 | - name: Configuration freeze 52 | run: | 53 | cabal v2-freeze $cabalConfig 54 | 55 | - uses: actions/cache@v1 56 | name: Cache cabal-store 57 | with: 58 | path: | 59 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 60 | dist-newstyle 61 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') 62 | }} 63 | restore-keys: ${{ runner.os }}-${{ matrix.ghc }}- 64 | 65 | - name: Build dependencies 66 | run: | 67 | cabal build all --only-dependencies $cabalConfig 68 | 69 | - name: Build 70 | run: | 71 | cabal build all $cabalConfig 72 | 73 | - name: Test 74 | run: | 75 | cabal test all $cabalConfig 76 | 77 | - name: Haddock 78 | if: ${{ matrix.ghc == '8.10' }} 79 | run: | 80 | cabal v2-haddock $cabalConfig 81 | 82 | - name: Source distribution file 83 | if: ${{ matrix.ghc == '8.10' }} 84 | run: | 85 | cabal v2-sdist 86 | 87 | 88 | stack: 89 | name: stack / ghc ${{ matrix.ghc }} 90 | runs-on: ubuntu-latest 91 | strategy: 92 | matrix: 93 | stack: [2.1.3] 94 | ghc: [8.8.4] 95 | 96 | steps: 97 | - uses: actions/checkout@v2 98 | if: github.event.action == 'opened' || github.event.action == 'synchronize' 99 | || github.event.ref == 'refs/heads/master' 100 | 101 | - uses: haskell/actions/setup@v1 102 | id: setup-haskell-cabal 103 | name: Setup Haskell 104 | with: 105 | ghc-version: ${{ matrix.ghc }} 106 | stack-version: ${{ matrix.stack }} 107 | 108 | - uses: actions/cache@v1 109 | name: Cache ~/.stack 110 | with: 111 | path: ~/.stack 112 | key: ${{ runner.os }}-${{ matrix.ghc }}-stack 113 | 114 | - name: Build 115 | run: | 116 | stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks 117 | - name: Test 118 | run: | 119 | stack test --system-ghc 120 | 121 | nix: 122 | runs-on: ubuntu-latest 123 | steps: 124 | - uses: cachix/install-nix-action@v12 125 | - uses: actions/checkout@v2 126 | - run: | 127 | drvs=$(nix-instantiate | sed 's/!.*//') 128 | nix-build --no-out-link $drvs 129 | -------------------------------------------------------------------------------- /.github/workflows/command-dispatch.yml: -------------------------------------------------------------------------------- 1 | name: Slash Command Dispatch 2 | on: 3 | issue_comment: 4 | types: [created] 5 | jobs: 6 | slashCommandDispatch: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: tibdex/github-app-token@v1 10 | id: generate-token 11 | with: 12 | app_id: ${{ secrets.APP_ID }} 13 | private_key: ${{ secrets.APP_PRIVATE_KEY }} 14 | 15 | - name: Slash Command Dispatch 16 | id: scd 17 | uses: peter-evans/slash-command-dispatch@v2 18 | with: 19 | issue-type: pull-request 20 | dispatch-type: repository 21 | allow-edits: true 22 | token: ${{ steps.generate-token.outputs.token }} 23 | commands: | 24 | bump 25 | -------------------------------------------------------------------------------- /.github/workflows/release.yml: -------------------------------------------------------------------------------- 1 | name: Create Release 2 | 3 | on: 4 | push: 5 | tags: 6 | - v* 7 | 8 | jobs: 9 | build: 10 | name: Create Release 11 | runs-on: ubuntu-20.04 12 | steps: 13 | - uses: cachix/install-nix-action@v12 14 | with: 15 | nix_path: nixpkgs=channel:nixos-unstable 16 | extra_nix_config: | 17 | trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= orion:s0C06f1M46DCpHUUP2r8iIrhfytkCbXWltMeMMa4jbw= expipiplus1/update-nix-fetchgit:Z33K0KEImsos+kVTFvZxfLxaBi+D1jEeB6cX0uCo7B0= 18 | substituters = https://cache.nixos.org/ s3://nix-cache?region=ap-southeast-1&scheme=https&endpoint=binarycache.home.monoid.al 19 | - uses: actions/checkout@v2 20 | 21 | - name: Build project 22 | run: | 23 | mkdir assets 24 | nix-build ./release.nix -A sdistTest --no-out-link 25 | ln -s "$(nix-build release.nix -A tarball --no-out-link)"/*.tar.gz assets/ 26 | ln -s "$(nix-build release.nix -A docs --no-out-link)"/*.tar.gz assets/ 27 | ref="${{ github.ref }}" 28 | printf "Release ${ref#"refs/tags/"}\n\n" >release-note.md 29 | # Get the section after the WIP section 30 | awk '/## WIP/{flag=0;next};/##/{flag=flag+1};flag==1' >"release-note.md" 32 | 33 | - name: Create Release 34 | env: 35 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} 36 | run: | 37 | if [ -f release-note.md ]; then 38 | hub release create \ 39 | $(find assets -type f -o -type l -printf "--attach %p ") \ 40 | --file release-note.md \ 41 | ${{ github.ref }} 42 | fi 43 | -------------------------------------------------------------------------------- /.github/workflows/tag-release.yml: -------------------------------------------------------------------------------- 1 | name: Tag Latest Release 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | 8 | jobs: 9 | update: 10 | runs-on: ubuntu-20.04 11 | steps: 12 | - uses: cachix/install-nix-action@v12 13 | with: 14 | nix_path: nixpkgs=channel:nixos-unstable 15 | - uses: actions/checkout@v2 16 | with: 17 | fetch-depth: 0 # Fetch everything 18 | ssh-key: ${{ secrets.DEPLOY_KEY }} 19 | - uses: expipiplus1/tag-latest-release/tag-latest-release@HEAD 20 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | .ghc.environment.* 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | *~ 22 | result 23 | result-* 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Ellie Hermaszewska 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Distribution.Extra.Doctest (defaultMainWithDoctests) 4 | 5 | main :: IO () 6 | main = defaultMainWithDoctests "doctests" 7 | -------------------------------------------------------------------------------- /bench/Bench.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Criterion.Main 4 | import Data.CReal.Internal 5 | 6 | main :: IO () 7 | main = defaultMain [ bgroup "pi" [ bench "0" $ whnf (pi `atPrecision`) 0 8 | , bench "4" $ whnf (pi `atPrecision`) 4 9 | , bench "16" $ whnf (pi `atPrecision`) 16 10 | , bench "64" $ whnf (pi `atPrecision`) 64 11 | , bench "256" $ whnf (pi `atPrecision`) 256 12 | , bench "1024" $ whnf (pi `atPrecision`) 1024 13 | ] 14 | , bgroup "sin 1" [ bench "0" $ whnf (sin 1 `atPrecision`) 0 15 | , bench "4" $ whnf (sin 1 `atPrecision`) 4 16 | , bench "16" $ whnf (sin 1 `atPrecision`) 16 17 | , bench "64" $ whnf (sin 1 `atPrecision`) 64 18 | , bench "256" $ whnf (sin 1 `atPrecision`) 256 19 | , bench "1024" $ whnf (sin 1 `atPrecision`) 1024 20 | ] 21 | , bgroup "sin (π/4)" [ bench "0" $ whnf (sin (pi/4) `atPrecision`) 0 22 | , bench "4" $ whnf (sin (pi/4) `atPrecision`) 4 23 | , bench "16" $ whnf (sin (pi/4) `atPrecision`) 16 24 | , bench "64" $ whnf (sin (pi/4) `atPrecision`) 64 25 | , bench "256" $ whnf (sin (pi/4) `atPrecision`) 256 26 | , bench "1024" $ whnf (sin (pi/4) `atPrecision`) 1024 27 | ] 28 | , bgroup "asin (π/4)" [ bench "0" $ whnf (asin (pi/4) `atPrecision`) 0 29 | , bench "4" $ whnf (asin (pi/4) `atPrecision`) 4 30 | , bench "16" $ whnf (asin (pi/4) `atPrecision`) 16 31 | , bench "64" $ whnf (asin (pi/4) `atPrecision`) 64 32 | , bench "256" $ whnf (asin (pi/4) `atPrecision`) 256 33 | , bench "1024" $ whnf (asin (pi/4) `atPrecision`) 1024 34 | ] 35 | ] 36 | 37 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | # Change Log 2 | 3 | ## WIP 4 | 5 | ## [0.12.5.1] - 2021-12-13 6 | - Correct author name 7 | - Squash warnings for newer GHCs 8 | 9 | ## [0.12.5] - 2021-05-29 10 | - Tweak test suite to fix #35 11 | 12 | ## [0.12.4.1] - 2020-11-01 13 | - Use newer version of `checkers` 14 | 15 | ## [0.12.4] - 2020-06-07 16 | - Big speedup (orbits testsuite about 9 times faster) 17 | 18 | Big thanks for @Zemyla for the new memoization scheme 19 | 20 | ## [0.12.3] - 2020-05-29 21 | - More relaxed version bounds 22 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { nixpkgsSrc ? builtins.fetchTarball { 2 | url = 3 | "https://github.com/NixOS/nixpkgs/archive/e675946ecde5606c505540de2024e2732bae4185.tar.gz"; # nixos-unstable 4 | sha256 = "1xnqhz0wxkgkwpwkal93k5rj72j39pvck542i9jyxh9bm25rc4j5"; 5 | }, pkgs ? import nixpkgsSrc { }, compiler ? null }: 6 | 7 | let 8 | haskellPackages = if compiler == null then 9 | pkgs.haskellPackages 10 | else 11 | pkgs.haskell.packages.${compiler}; 12 | 13 | in haskellPackages.developPackage { 14 | name = ""; 15 | root = pkgs.nix-gitignore.gitignoreSource [ ] ./.; 16 | overrides = _self: _super: { }; 17 | } 18 | -------------------------------------------------------------------------------- /exact-real.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.24 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.5. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: exact-real 8 | version: 0.12.5.1 9 | synopsis: Exact real arithmetic 10 | description: A type to represent exact real numbers using fast binary Cauchy sequences. 11 | category: Math 12 | homepage: https://github.com/expipiplus1/exact-real#readme 13 | bug-reports: https://github.com/expipiplus1/exact-real/issues 14 | author: Ellie Hermaszewska 15 | maintainer: Ellie Hermaszewska 16 | copyright: 2020 Ellie Hermaszewska 17 | license: MIT 18 | license-file: LICENSE 19 | build-type: Custom 20 | extra-source-files: 21 | readme.md 22 | stack.yaml 23 | default.nix 24 | changelog.md 25 | package.yaml 26 | 27 | source-repository head 28 | type: git 29 | location: https://github.com/expipiplus1/exact-real 30 | 31 | custom-setup 32 | setup-depends: 33 | Cabal 34 | , base 35 | , cabal-doctest >=1 && <1.1 36 | 37 | library 38 | exposed-modules: 39 | Data.CReal 40 | Data.CReal.Converge 41 | Data.CReal.Internal 42 | other-modules: 43 | Paths_exact_real 44 | hs-source-dirs: 45 | src 46 | ghc-options: -Wall 47 | build-depends: 48 | base >=4.8 && <5 49 | , integer-gmp 50 | , random >=1.0 51 | default-language: Haskell2010 52 | 53 | test-suite doctests 54 | type: exitcode-stdio-1.0 55 | main-is: Doctests.hs 56 | other-modules: 57 | 58 | hs-source-dirs: 59 | test 60 | build-depends: 61 | base 62 | , doctest 63 | default-language: Haskell2010 64 | 65 | test-suite test 66 | type: exitcode-stdio-1.0 67 | main-is: Test.hs 68 | other-modules: 69 | BoundedFunctions 70 | Data.CReal.Extra 71 | Floating 72 | Fractional 73 | Num 74 | Ord 75 | Random 76 | Read 77 | Real 78 | RealFloat 79 | RealFrac 80 | Test.QuickCheck.Classes.Extra 81 | Test.QuickCheck.Extra 82 | Test.Tasty.Extra 83 | Paths_exact_real 84 | hs-source-dirs: 85 | test 86 | ghc-options: -Wall -threaded 87 | build-depends: 88 | QuickCheck >=2.9 89 | , base >=4 90 | , checkers >=0.5.6 91 | , exact-real 92 | , groups >=0.3 93 | , random >=1.0 94 | , tasty >=0.10 95 | , tasty-hunit >=0.9 96 | , tasty-quickcheck >=0.8 97 | , tasty-th >=0.1 98 | if impl(ghc < 8.0.0) 99 | buildable: False 100 | default-language: Haskell2010 101 | 102 | benchmark bench 103 | type: exitcode-stdio-1.0 104 | main-is: Bench.hs 105 | other-modules: 106 | Paths_exact_real 107 | hs-source-dirs: 108 | bench 109 | ghc-options: -Wall -threaded -O2 110 | build-depends: 111 | base >=4 112 | , criterion >=1.1 113 | , exact-real 114 | default-language: Haskell2010 115 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: exact-real 2 | version: "0.12.5.1" 3 | synopsis: Exact real arithmetic 4 | description: A type to represent exact real numbers using fast binary Cauchy sequences. 5 | category: Math 6 | author: Ellie Hermaszewska 7 | maintainer: Ellie Hermaszewska 8 | copyright: 2020 Ellie Hermaszewska 9 | github: expipiplus1/exact-real 10 | extra-source-files: 11 | - readme.md 12 | - stack.yaml 13 | - default.nix 14 | - changelog.md 15 | - package.yaml 16 | 17 | library: 18 | source-dirs: src 19 | ghc-options: -Wall 20 | exposed-modules: 21 | - Data.CReal 22 | - Data.CReal.Converge 23 | - Data.CReal.Internal 24 | dependencies: 25 | - base >=4.8 && < 5 26 | - integer-gmp 27 | - random >=1.0 28 | 29 | tests: 30 | test: 31 | main: Test.hs 32 | other-modules: 33 | - BoundedFunctions 34 | - Data.CReal.Extra 35 | - Floating 36 | - Fractional 37 | - Num 38 | - Ord 39 | - Random 40 | - Read 41 | - Real 42 | - RealFloat 43 | - RealFrac 44 | - Test.QuickCheck.Classes.Extra 45 | - Test.QuickCheck.Extra 46 | - Test.Tasty.Extra 47 | - Paths_exact_real 48 | source-dirs: test 49 | ghc-options: 50 | - -Wall 51 | - -threaded 52 | dependencies: 53 | - base >=4 54 | - groups >=0.3 55 | - tasty >=0.10 56 | - tasty-th >=0.1 57 | - tasty-quickcheck >=0.8 58 | - tasty-hunit >=0.9 59 | - QuickCheck >=2.9 60 | - random >=1.0 61 | - checkers >=0.5.6 62 | - exact-real 63 | when: 64 | condition: impl(ghc < 8.0.0) 65 | buildable: false 66 | 67 | doctests: 68 | main: Doctests.hs 69 | other-modules: "" 70 | source-dirs: 71 | - test 72 | dependencies: 73 | - base 74 | - doctest 75 | 76 | benchmarks: 77 | bench: 78 | main: Bench.hs 79 | source-dirs: bench 80 | ghc-options: 81 | - -Wall 82 | - -threaded 83 | - -O2 84 | dependencies: 85 | - base >=4 86 | - criterion >=1.1 87 | - exact-real 88 | 89 | custom-setup: 90 | dependencies: 91 | - base 92 | - Cabal 93 | - cabal-doctest >= 1 && <1.1 94 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | exact-real 2 | ========== 3 | 4 | Exact real arithmetic implemented by fast binary Cauchy sequences. 5 | 6 | Motivating Example 7 | ------------------- 8 | 9 | Compare evaluating Euler's identity with a `Float`: 10 | 11 | Note that you'll need the `DataKinds` extension turned on to evaluate the 12 | examples in this readme. 13 | 14 | ``` haskell 15 | λ> let i = 0 :+ 1 16 | λ> exp (i * pi) + 1 :: Complex Float 17 | 0.0 :+ (-8.742278e-8) 18 | ``` 19 | 20 | ... and with a `CReal`: 21 | 22 | ``` haskell 23 | λ> import Data.CReal 24 | λ> let i = 0 :+ 1 25 | λ> exp (i * pi) + 1 :: Complex (CReal 0) 26 | 0 :+ 0 27 | ``` 28 | 29 | Or: 30 | 31 | ```haskell 32 | λ> let f :: ∀ a. Fractional a => (a, a); f = iterate (\(x0, x1) -> let x2 = 111 - (1130-3000/x0) / x1 in (x1, x2)) (11/2, 61/11) !! 100 33 | λ> f @Double 34 | (100.0,100.0) 35 | λ> f @(CReal 10) 36 | (6.0000,6.0000) 37 | λ> f @(CReal 50) 38 | (5.9999999879253263,5.9999999899377725) 39 | ``` 40 | 41 | Implementation 42 | -------------- 43 | 44 | `CReal`'s phantom type parameter `n :: Nat` represents the precision at which 45 | values should be evaluated at when converting to a less precise representation. 46 | For instance the definition of `x == y` in the instance for `Eq` evaluates `x - 47 | y` at precision `n` and compares the resulting `Integer` to zero. I think that 48 | this is the most reasonable solution to the fact that lots of of operations 49 | (such as equality) are not computable on the reals but we want to pretend that 50 | they are for the sake of writing useful programs. Please see the 51 | [Caveats](#caveats) section for more information. 52 | 53 | The `CReal` type is an instance of `Num`, `Fractional`, `Floating`, `Real`, 54 | `RealFrac`, `RealFloat`, `Eq`, `Ord`, `Show` and `Read`. The only functions not 55 | implemented are a handful from `RealFloat` which assume the number is 56 | implemented with a mantissa and exponent. 57 | 58 | There is a comprehensive test suite to test the properties of these classes. 59 | 60 | The performance isn't terrible on most operations but it's obviously not nearly 61 | as speedy as performing the operations on `Float` or `Double`. The only two 62 | super slow functions are `asinh` and `atanh` at the moment. 63 | 64 | 65 | Caveats 66 | ------- 67 | 68 | The implementation is not without its caveats however. The big gotcha is that 69 | although internally the `CReal n`s are represented exactly, whenever a value is 70 | extracted to another type such as a `Rational` or `Float` it is evaluated to 71 | within `2^-p` of the true value. 72 | 73 | For example when using the `CReal 0` type (numbers within 1 of the true value) 74 | one can produce the following: 75 | 76 | ``` haskell 77 | λ> 0.5 == (1 :: CReal 0) 78 | True 79 | λ> 0.5 * 2 == (1 :: CReal 0) * 2 80 | False 81 | ``` 82 | 83 | Contributing 84 | ------------ 85 | 86 | Contributions and bug reports are welcome! 87 | 88 | [goldberg]: http://www.validlab.com/goldberg/paper.pdf "What Every Computer Scientist Should Know About Floating-Point Arithmetic" 89 | -------------------------------------------------------------------------------- /release.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import { }, compiler ? null }: 2 | 3 | with pkgs.haskell.lib; 4 | 5 | let 6 | drv = import ./default.nix { inherit pkgs compiler; }; 7 | 8 | docDrv = drv: 9 | (overrideCabal drv (drv: { 10 | doHaddock = true; 11 | haddockFlags = [ "--for-hackage" ]; 12 | postHaddock = '' 13 | mkdir -p "$doc" 14 | tar --format=ustar -czf "$doc/${drv.pname}-${drv.version}-docs.tar.gz" -C dist/doc/html "${drv.pname}-${drv.version}-docs" 15 | ''; 16 | })).doc; 17 | 18 | in { 19 | tarball = sdistTarball drv; 20 | docs = docDrv drv; 21 | sdistTest = buildFromSdist drv; 22 | } 23 | -------------------------------------------------------------------------------- /src/Data/CReal.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | This module exports everything you need to use exact real numbers 3 | ---------------------------------------------------------------------------- 4 | 5 | module Data.CReal 6 | ( CReal 7 | , atPrecision 8 | , crealPrecision 9 | ) where 10 | 11 | import Data.CReal.Internal 12 | -------------------------------------------------------------------------------- /src/Data/CReal/Converge.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE ConstrainedClassMethods #-} 7 | 8 | -- | The Converge type class. 9 | module Data.CReal.Converge 10 | ( Converge(..) 11 | ) where 12 | 13 | import Control.Arrow ((&&&)) 14 | import Data.Coerce (coerce) 15 | import Data.CReal.Internal (CReal(..), atPrecision, crMemoize) 16 | import Data.Function (on) 17 | import Data.Proxy (Proxy) 18 | import GHC.TypeLits (someNatVal, SomeNat(..)) 19 | 20 | -- $setup 21 | -- >>> :set -XFlexibleContexts 22 | -- >>> import Data.CReal.Internal 23 | 24 | -- | If a type is an instance of Converge then it represents a stream of values 25 | -- which are increasingly accurate approximations of a desired value 26 | class Converge a where 27 | -- | The type of the value the stream converges to. 28 | type Element a 29 | 30 | -- | 'converge' is a function that returns the value the stream is converging 31 | -- to. If given a stream which doens't converge to a single value then 32 | -- 'converge' will not terminate. 33 | -- 34 | -- If the stream is empty then it should return nothing. 35 | -- 36 | -- >>> let initialGuess = 1 :: Double 37 | -- >>> let improve x = (x + 121 / x) / 2 38 | -- >>> converge (iterate improve initialGuess) 39 | -- Just 11.0 40 | -- 41 | -- >>> converge [] :: Maybe [Int] 42 | -- Nothing 43 | converge :: a -> Maybe (Element a) 44 | 45 | -- | 'convergeErr' is a function that returns the value the stream is 46 | -- converging to. It also takes a function err which returns a value which 47 | -- varies monotonically with the error of the value in the stream. This can 48 | -- be used to ensure that when 'convergeErr' terminates when given a 49 | -- non-converging stream or a stream which enters a cycle close to the 50 | -- solution. See the documentation for the CReal instance for a caveat with 51 | -- that implementation. 52 | -- 53 | -- It's often the case that streams generated with approximation 54 | -- functions such as Newton's method will generate worse approximations for 55 | -- some number of steps until they find the "zone of convergence". For these 56 | -- cases it's necessary to drop some values of the stream before handing it 57 | -- to convergeErr. 58 | -- 59 | -- For example trying to find the root of the following funciton @f@ with a 60 | -- poor choice of starting point. Although this doesn't find the root, it 61 | -- doesn't fail to terminate. 62 | -- 63 | -- >>> let f x = x ^ 3 - 2 * x + 2 64 | -- >>> let f' x = 3 * x ^ 2 - 2 65 | -- >>> let initialGuess = 0.1 :: Float 66 | -- >>> let improve x = x - f x / f' x 67 | -- >>> let err x = abs (f x) 68 | -- >>> convergeErr err (iterate improve initialGuess) 69 | -- Just 1.0142132 70 | convergeErr :: Ord (Element a) => (Element a -> Element a) -> a -> Maybe (Element a) 71 | 72 | -- | Every list of equatable values is an instance of 'Converge'. 'converge' 73 | -- returns the first element which is equal to the succeeding element in the 74 | -- list. If the list ends before the sequence converges the last value is 75 | -- returned. 76 | instance {-# OVERLAPPABLE #-} Eq a => Converge [a] where 77 | type Element [a] = a 78 | 79 | converge = lastMay . takeWhilePairwise (/=) 80 | {-# INLINE converge #-} 81 | 82 | convergeErr err xs = fmap snd . lastMay . takeWhilePairwise ((>) `on` fst) $ es 83 | where es = (err &&& id) <$> xs 84 | {-# INLINE convergeErr #-} 85 | 86 | -- | The overlapping instance for @'CReal' n@ has a slightly different 87 | -- behavior. The instance for 'Eq' will cause 'converge' to return a value when 88 | -- the list converges to within 2^-n (due to the 'Eq' instance for @'CReal' n@) 89 | -- despite the precision the value is requested at by the surrounding 90 | -- computation. This instance will return a value approximated to the correct 91 | -- precision. 92 | -- 93 | -- It's important to note when the error function reaches zero this function 94 | -- behaves like 'converge' as it's not possible to determine the precision at 95 | -- which the error function should be evaluated at. 96 | -- 97 | -- Find where log x = π using Newton's method 98 | -- 99 | -- >>> let initialGuess = 1 100 | -- >>> let improve x = x - x * (log x - pi) 101 | -- >>> let Just y = converge (iterate improve initialGuess) 102 | -- >>> showAtPrecision 10 y 103 | -- "23.1406" 104 | -- >>> showAtPrecision 50 y 105 | -- "23.1406926327792686" 106 | instance {-# OVERLAPPING #-} Converge [CReal n] where 107 | type Element [CReal n] = CReal n 108 | 109 | converge [] = Nothing 110 | converge xs = 111 | Just $ crMemoize (\p -> 112 | case someNatVal (toInteger p) of 113 | Nothing -> error "Data.CReal.Converge p should be non negative" 114 | Just (SomeNat (_ :: Proxy p')) -> 115 | let modifyPrecision = coerce :: [CReal n] -> [CReal p'] 116 | in (last . takeWhilePairwise (/=) . modifyPrecision $ xs) `atPrecision` p) 117 | {-# INLINE converge #-} 118 | 119 | convergeErr _ [] = Nothing 120 | convergeErr err xs = 121 | Just $ crMemoize (\p -> 122 | case someNatVal (toInteger p) of 123 | Nothing -> error "Data.CReal.Converge p should be non negative" 124 | Just (SomeNat (_ :: Proxy p')) -> 125 | let modifyPrecision = coerce :: [CReal n] -> [CReal p'] 126 | modifyFunPrecision = coerce :: (CReal n -> CReal n) -> CReal p' -> CReal p' 127 | es = (modifyFunPrecision err &&& id) <$> modifyPrecision xs 128 | continue (e1, x1) (e2, x2) = if e1 == 0 then x1 /= x2 else e1 > e2 129 | in (snd . last . takeWhilePairwise continue $ es) `atPrecision` p) 130 | {-# INLINE convergeErr #-} 131 | 132 | takeWhilePairwise :: (a -> a -> Bool) -> [a] -> [a] 133 | takeWhilePairwise p (x1:x2:xs) = if x1 `p` x2 134 | then x1 : takeWhilePairwise p (x2:xs) 135 | else [x1] 136 | takeWhilePairwise _ xs = xs 137 | 138 | lastMay :: [a] -> Maybe a 139 | lastMay [] = Nothing 140 | lastMay xs = Just (last xs) 141 | 142 | 143 | -------------------------------------------------------------------------------- /src/Data/CReal/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE MultiWayIf #-} 6 | {-# LANGUAGE PostfixOperators #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE BangPatterns #-} 9 | 10 | ----------------------------------------------------------------------------- 11 | -- | This module exports a bunch of utilities for working inside the CReal 12 | -- datatype. One should be careful to maintain the CReal invariant when using 13 | -- these functions 14 | ---------------------------------------------------------------------------- 15 | module Data.CReal.Internal 16 | ( 17 | -- * The CReal type 18 | CReal(..) 19 | -- ** Memoization 20 | , Cache(..) 21 | -- ** Simple utilities 22 | , atPrecision 23 | , crealPrecision 24 | 25 | -- * More efficient variants of common functions 26 | -- Note that the preconditions to these functions are not checked 27 | -- ** Additive 28 | , plusInteger 29 | -- ** Multiplicative 30 | , mulBounded 31 | , (.*.) 32 | , mulBoundedL 33 | , (.*) 34 | , (*.) 35 | , recipBounded 36 | , shiftL 37 | , shiftR 38 | , square 39 | , squareBounded 40 | 41 | -- ** Exponential 42 | , expBounded 43 | , expPosNeg 44 | , logBounded 45 | 46 | -- ** Trigonometric 47 | , atanBounded 48 | , sinBounded 49 | , cosBounded 50 | 51 | -- * Utilities for operating inside CReals 52 | , crMemoize 53 | , powerSeries 54 | , alternateSign 55 | 56 | -- ** Integer operations 57 | , (/.) 58 | , (/^) 59 | , log2 60 | , log10 61 | , isqrt 62 | 63 | -- * Utilities for converting CReals to Strings 64 | , showAtPrecision 65 | , decimalDigitsAtPrecision 66 | , rationalToDecimal 67 | ) where 68 | 69 | import Data.List (scanl') 70 | import qualified Data.Bits as B 71 | import Data.Bits hiding (shiftL, shiftR) 72 | import GHC.Base (Int(..)) 73 | import GHC.Integer.Logarithms (integerLog2#, integerLogBase#) 74 | import GHC.Real (Ratio(..), (%)) 75 | import GHC.TypeLits 76 | import Text.Read 77 | import qualified Text.Read.Lex as L 78 | import System.Random (Random(..)) 79 | import Control.Concurrent.MVar 80 | import Control.Exception 81 | import System.IO.Unsafe (unsafePerformIO) 82 | 83 | {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} 84 | 85 | -- $setup 86 | -- >>> :set -XDataKinds 87 | -- >>> :set -XPostfixOperators 88 | 89 | default () 90 | 91 | -- | The Cache type represents a way to memoize a `CReal`. It holds the largest 92 | -- precision the number has been evaluated that, as well as the value. Rounding 93 | -- it down gives the value for lower numbers. 94 | data Cache 95 | = Never 96 | | Current {-# UNPACK #-} !Int !Integer 97 | deriving (Show) 98 | 99 | -- | The type CReal represents a fast binary Cauchy sequence. This is a Cauchy 100 | -- sequence with the invariant that the pth element divided by 2^p will be 101 | -- within 2^-p of the true value. Internally this sequence is represented as a 102 | -- function from Ints to Integers, as well as an `MVar` to hold the highest 103 | -- precision cached value. 104 | data CReal (n :: Nat) = CR {-# UNPACK #-} !(MVar Cache) (Int -> Integer) 105 | 106 | -- | 'crMemoize' takes a fast binary Cauchy sequence and returns a CReal 107 | -- represented by that sequence which will memoize the values at each 108 | -- precision. This is essential for getting good performance. 109 | crMemoize :: (Int -> Integer) -> CReal n 110 | crMemoize fn = unsafePerformIO $ do 111 | mvc <- newMVar Never 112 | return $ CR mvc fn 113 | 114 | -- | crealPrecision x returns the type level parameter representing x's default 115 | -- precision. 116 | -- 117 | -- >>> crealPrecision (1 :: CReal 10) 118 | -- 10 119 | crealPrecision :: KnownNat n => CReal n -> Int 120 | crealPrecision = fromInteger . natVal 121 | 122 | -- | @x \`atPrecision\` p@ returns the numerator of the pth element in the 123 | -- Cauchy sequence represented by x. The denominator is 2^p. 124 | -- 125 | -- >>> 10 `atPrecision` 10 126 | -- 10240 127 | atPrecision :: CReal n -> Int -> Integer 128 | (CR mvc f) `atPrecision` (!p) = unsafePerformIO $ modifyMVar mvc $ \vc -> do 129 | vc' <- evaluate vc 130 | case vc' of 131 | Current j v | j >= p -> 132 | pure (vc', v /^ (j - p)) 133 | _ -> do 134 | v <- evaluate $ f p 135 | let !vcn = Current p v 136 | pure (vcn, v) 137 | {-# INLINABLE atPrecision #-} 138 | 139 | -- | A CReal with precision p is shown as a decimal number d such that d is 140 | -- within 2^-p of the true value. 141 | -- 142 | -- >>> show (47176870 :: CReal 0) 143 | -- "47176870" 144 | -- 145 | -- >>> show (pi :: CReal 230) 146 | -- "3.1415926535897932384626433832795028841971693993751058209749445923078164" 147 | instance KnownNat n => Show (CReal n) where 148 | show x = showAtPrecision (crealPrecision x) x 149 | 150 | -- | The instance of Read will read an optionally signed number expressed in 151 | -- decimal scientific notation 152 | instance Read (CReal n) where 153 | readPrec = parens $ do 154 | lit <- lexP 155 | case lit of 156 | Number n -> return $ fromRational $ L.numberToRational n 157 | Symbol "-" -> prec 6 $ do 158 | lit' <- lexP 159 | case lit' of 160 | Number n -> return $ fromRational $ negate $ L.numberToRational n 161 | _ -> pfail 162 | _ -> pfail 163 | {-# INLINE readPrec #-} 164 | 165 | readListPrec = readListPrecDefault 166 | {-# INLINE readListPrec #-} 167 | 168 | readsPrec = readPrec_to_S readPrec 169 | {-# INLINE readsPrec #-} 170 | 171 | readList = readPrec_to_S readListPrec 0 172 | {-# INLINE readList #-} 173 | 174 | -- | @signum (x :: CReal p)@ returns the sign of @x@ at precision @p@. It's 175 | -- important to remember that this /may not/ represent the actual sign of @x@ if 176 | -- the distance between @x@ and zero is less than 2^-@p@. 177 | -- 178 | -- This is a little bit of a fudge, but it's probably better than failing to 179 | -- terminate when trying to find the sign of zero. The class still respects the 180 | -- abs-signum law though. 181 | -- 182 | -- >>> signum (0.1 :: CReal 2) 183 | -- 0.0 184 | -- 185 | -- >>> signum (0.1 :: CReal 3) 186 | -- 1.0 187 | instance Num (CReal n) where 188 | {-# INLINE fromInteger #-} 189 | fromInteger i = let 190 | !vc = Current 0 i 191 | in unsafePerformIO $ do 192 | mvc <- newMVar vc 193 | return $ CR mvc (B.shiftL i) 194 | 195 | -- @negate@ and @abs@ try to give initial guesses, but don't wait if the 196 | -- @\'MVar\'@ is being used elsewhere. 197 | {-# INLINE negate #-} 198 | negate (CR mvc fn) = unsafePerformIO $ do 199 | vcc <- tryReadMVar mvc 200 | let 201 | !vcn = case vcc of 202 | Nothing -> Never 203 | Just Never -> Never 204 | Just (Current p v) -> Current p (negate v) 205 | mvn <- newMVar vcn 206 | return $ CR mvn (negate . fn) 207 | 208 | {-# INLINE abs #-} 209 | abs (CR mvc fn) = unsafePerformIO $ do 210 | vcc <- tryReadMVar mvc 211 | let 212 | !vcn = case vcc of 213 | Nothing -> Never 214 | Just Never -> Never 215 | Just (Current p v) -> Current p (abs v) 216 | mvn <- newMVar vcn 217 | return $ CR mvn (abs . fn) 218 | 219 | {-# INLINE (+) #-} 220 | x1 + x2 = crMemoize (\p -> let n1 = atPrecision x1 (p + 2) 221 | n2 = atPrecision x2 (p + 2) 222 | in (n1 + n2) /^ 2) 223 | 224 | {-# INLINE (-) #-} 225 | x1 - x2 = crMemoize (\p -> let n1 = atPrecision x1 (p + 2) 226 | n2 = atPrecision x2 (p + 2) 227 | in (n1 - n2) /^ 2) 228 | 229 | {-# INLINE (*) #-} 230 | x1 * x2 = let 231 | s1 = log2 (abs (atPrecision x1 0) + 2) + 3 232 | s2 = log2 (abs (atPrecision x2 0) + 2) + 3 233 | in crMemoize (\p -> let n1 = atPrecision x1 (p + s2) 234 | n2 = atPrecision x2 (p + s1) 235 | in (n1 * n2) /^ (p + s1 + s2)) 236 | 237 | signum x = crMemoize (\p -> B.shiftL (signum (x `atPrecision` p)) p) 238 | 239 | -- | Taking the reciprocal of zero will not terminate 240 | instance Fractional (CReal n) where 241 | {-# INLINE fromRational #-} 242 | -- Use @roundD@ instead of @/.@ because we know @d > 0@ for a valid Rational. 243 | fromRational (n :% d) = crMemoize (\p -> roundD (B.shiftL n p) d) 244 | 245 | {-# INLINE recip #-} 246 | -- TODO: Make recip 0 throw an error (if, for example, it would take more 247 | -- than 4GB of memory to represent the result) 248 | recip x = let 249 | s = findFirstMonotonic ((3 <=) . abs . atPrecision x) 250 | in crMemoize (\p -> let n = atPrecision x (p + 2 * s + 2) 251 | in bit (2 * p + 2 * s + 2) /. n) 252 | 253 | instance Floating (CReal n) where 254 | -- TODO: Could we use something faster such as Ramanujan's formula 255 | pi = piBy4 `shiftL` 2 256 | 257 | exp x = let o = shiftL (x *. recipBounded (shiftL ln2 1)) 1 258 | l = atPrecision o 0 259 | y = x - fromInteger l *. ln2 260 | in if l == 0 261 | then expBounded x 262 | else expBounded y `shiftL` fromInteger l 263 | 264 | -- | Range reduction on the principle that ln (a * b) = ln a + ln b 265 | log x = let l = log2 (atPrecision x 2) - 2 266 | in if -- x <= 0.75 267 | | l < 0 -> - log (recip x) 268 | -- 0.75 <= x <= 2 269 | | l == 0 -> logBounded x 270 | -- x >= 2 271 | | otherwise -> let a = x `shiftR` l 272 | in logBounded a + fromIntegral l *. ln2 273 | 274 | sqrt x = crMemoize (\p -> let n = atPrecision x (2 * p) 275 | in isqrt n) 276 | 277 | -- | This will diverge when the base is not positive 278 | x ** y = exp (log x * y) 279 | 280 | logBase x y = log y / log x 281 | 282 | sin x = cos (x - piBy2) 283 | 284 | cos x = let o = shiftL (x *. recipBounded pi) 2 285 | s = atPrecision o 1 /^ 1 286 | octant = fromInteger $ s .&. 7 287 | offset = x - (fromIntegral s *. piBy4) 288 | fs = [ cosBounded 289 | , negate . sinBounded . subtract piBy4 290 | , negate . sinBounded 291 | , negate . cosBounded . (piBy4-) 292 | , negate . cosBounded 293 | , sinBounded . subtract piBy4 294 | , sinBounded 295 | , cosBounded . (piBy4-)] 296 | in (fs !! octant) offset 297 | 298 | tan x = sin x .* recip (cos x) 299 | 300 | asin x = atan (x .*. recipBounded (1 + sqrt (1 - squareBounded x))) `shiftL` 1 301 | 302 | acos x = piBy2 - asin x 303 | 304 | atan x = let -- q is 4 times x to within 1/4 305 | q = x `atPrecision` 2 306 | in if -- x <= -1 307 | | q < -4 -> atanBounded (negate (recipBounded x)) - piBy2 308 | -- -1.25 <= x <= -0.75 309 | | q == -4 -> -(piBy4 + atanBounded ((x + 1) .*. recipBounded (x - 1))) 310 | -- 0.75 <= x <= 1.25 311 | | q == 4 -> piBy4 + atanBounded ((x - 1) .*. recipBounded (x + 1)) 312 | -- x >= 1 313 | | q > 4 -> piBy2 - atanBounded (recipBounded x) 314 | -- -0.75 <= x <= 0.75 315 | | otherwise -> atanBounded x 316 | 317 | -- TODO: benchmark replacing these with their series expansion 318 | sinh x = let (expX, expNegX) = expPosNeg x 319 | in (expX - expNegX) `shiftR` 1 320 | cosh x = let (expX, expNegX) = expPosNeg x 321 | in (expX + expNegX) `shiftR` 1 322 | tanh x = let e2x = exp (x `shiftL` 1) 323 | in (e2x - 1) *. recipBounded (e2x + 1) 324 | 325 | asinh x = log (x + sqrt (square x + 1)) 326 | acosh x = log (x + sqrt (x + 1) * sqrt (x - 1)) 327 | atanh x = (log (1 + x) - log (1 - x)) `shiftR` 1 328 | 329 | -- | 'toRational' returns the CReal n evaluated at a precision of 2^-n 330 | instance KnownNat n => Real (CReal n) where 331 | toRational x = let p = crealPrecision x 332 | in x `atPrecision` p % bit p 333 | 334 | instance KnownNat n => RealFrac (CReal n) where 335 | properFraction x = let p = crealPrecision x 336 | v = x `atPrecision` p 337 | r = v .&. (bit p - 1) 338 | c = unsafeShiftR (v - r) p 339 | n = if c < 0 && r /= 0 then c + 1 else c 340 | f = plusInteger x (negate n) 341 | in (fromInteger n, f) 342 | 343 | truncate x = let p = crealPrecision x 344 | v = x `atPrecision` p 345 | r = v .&. (bit p - 1) 346 | c = unsafeShiftR (v - r) p 347 | n = if c < 0 && r /= 0 then c + 1 else c 348 | in fromInteger n 349 | 350 | round x = let p = crealPrecision x 351 | n = (x `atPrecision` p) /^ p 352 | in fromInteger n 353 | 354 | ceiling x = let p = crealPrecision x 355 | v = x `atPrecision` p 356 | r = v .&. (bit p - 1) 357 | n = unsafeShiftR (v - r) p 358 | in if r /= 0 then fromInteger $ n + 1 else fromInteger n 359 | 360 | floor x = let p = crealPrecision x 361 | v = x `atPrecision` p 362 | r = v .&. (bit p - 1) 363 | n = unsafeShiftR (v - r) p 364 | in fromInteger n 365 | 366 | -- | Several of the functions in this class ('floatDigits', 'floatRange', 367 | -- 'exponent', 'significand') only make sense for floats represented by a 368 | -- mantissa and exponent. These are bound to error. 369 | -- 370 | -- @atan2 y x `atPrecision` p@ performs the comparison to determine the 371 | -- quadrant at precision p. This can cause atan2 to be slightly slower than atan 372 | instance KnownNat n => RealFloat (CReal n) where 373 | floatRadix _ = 2 374 | floatDigits _ = error "Data.CReal.Internal floatDigits" 375 | floatRange _ = error "Data.CReal.Internal floatRange" 376 | decodeFloat x = let p = crealPrecision x 377 | in (x `atPrecision` p, -p) 378 | encodeFloat m n = if n <= 0 379 | then fromRational (m % bit (negate n)) 380 | else fromRational (unsafeShiftL m n :% 1) 381 | exponent = error "Data.CReal.Internal exponent" 382 | significand = error "Data.CReal.Internal significand" 383 | scaleFloat = flip shiftL 384 | isNaN _ = False 385 | isInfinite _ = False 386 | isDenormalized _ = False 387 | isNegativeZero _ = False 388 | isIEEE _ = False 389 | atan2 y x = crMemoize (\p -> 390 | let y' = y `atPrecision` p 391 | x' = x `atPrecision` p 392 | θ = if | x' > 0 -> atan (y/x) 393 | | x' == 0 && y' > 0 -> piBy2 394 | | x' < 0 && y' > 0 -> pi + atan (y/x) 395 | | x' <= 0 && y' < 0 -> -atan2 (-y) x 396 | | y' == 0 && x' < 0 -> pi -- must be after the previous test on zero y 397 | | x'==0 && y'==0 -> 0 -- must be after the other double zero tests 398 | | otherwise -> error "Data.CReal.Internal atan2" 399 | in θ `atPrecision` p) 400 | 401 | -- | Values of type @CReal p@ are compared for equality at precision @p@. This 402 | -- may cause values which differ by less than 2^-p to compare as equal. 403 | -- 404 | -- >>> 0 == (0.1 :: CReal 1) 405 | -- True 406 | instance KnownNat n => Eq (CReal n) where 407 | -- TODO, should this try smaller values first? 408 | CR mvx _ == CR mvy _ | mvx == mvy = True 409 | x == y = let p = crealPrecision x 410 | in ((x - y) `atPrecision` p) == 0 411 | 412 | 413 | -- | Like equality, values of type @CReal p@ are compared at precision @p@. 414 | instance KnownNat n => Ord (CReal n) where 415 | compare (CR mvx _) (CR mvy _) | mvx == mvy = EQ 416 | compare x y = 417 | let p = crealPrecision x 418 | in compare ((x - y) `atPrecision` p) 0 419 | max x y = crMemoize (\p -> max (atPrecision x p) (atPrecision y p)) 420 | min x y = crMemoize (\p -> min (atPrecision x p) (atPrecision y p)) 421 | 422 | -- | The 'Random' instance for @\'CReal\' p@ will return random number with at 423 | -- least @p@ digits of precision, every digit after that is zero. 424 | instance KnownNat n => Random (CReal n) where 425 | randomR (lo, hi) g = let d = hi - lo 426 | l = 1 + log2 (abs d `atPrecision` 0) 427 | p = l + crealPrecision lo 428 | (n, g') = randomR (0, 2^p) g 429 | r = fromRational (n % 2^p) 430 | in (r * d + lo, g') 431 | random g = let p = 1 + crealPrecision (undefined :: CReal n) 432 | (n, g') = randomR (0, max 0 (2^p - 2)) g 433 | r = fromRational (n % 2^p) 434 | in (r, g') 435 | 436 | -------------------------------------------------------------------------------- 437 | -- Some utility functions 438 | -------------------------------------------------------------------------------- 439 | 440 | -- 441 | -- Constants 442 | -- 443 | 444 | piBy4 :: CReal n 445 | piBy4 = atanBounded (recipBounded 5) `shiftL` 2 - atanBounded (recipBounded 239) -- Machin Formula 446 | 447 | piBy2 :: CReal n 448 | piBy2 = piBy4 `shiftL` 1 449 | 450 | ln2 :: CReal n 451 | ln2 = logBounded 2 452 | 453 | -- 454 | -- Bounded multiplication 455 | -- 456 | 457 | infixl 7 `mulBounded`, `mulBoundedL`, .*, *., .*. 458 | 459 | -- | Alias for @'mulBoundedL'@ 460 | (.*) :: CReal n -> CReal n -> CReal n 461 | (.*) = mulBoundedL 462 | 463 | -- | Alias for @flip 'mulBoundedL'@ 464 | (*.) :: CReal n -> CReal n -> CReal n 465 | (*.) = flip mulBoundedL 466 | 467 | -- | Alias for @'mulBounded'@ 468 | (.*.) :: CReal n -> CReal n -> CReal n 469 | (.*.) = mulBounded 470 | 471 | -- | A more efficient multiply with the restriction that the first argument 472 | -- must be in the closed range [-1..1] 473 | mulBoundedL :: CReal n -> CReal n -> CReal n 474 | mulBoundedL x1 x2 = let 475 | s1 = 4 476 | s2 = log2 (abs (atPrecision x2 0) + 2) + 3 477 | in crMemoize (\p -> let n1 = atPrecision x1 (p + s2) 478 | n2 = atPrecision x2 (p + s1) 479 | in (n1 * n2) /^ (p + s1 + s2)) 480 | 481 | -- | A more efficient multiply with the restriction that both values must be 482 | -- in the closed range [-1..1] 483 | mulBounded :: CReal n -> CReal n -> CReal n 484 | mulBounded x1 x2 = let 485 | s1 = 4 486 | s2 = 4 487 | in crMemoize (\p -> let n1 = atPrecision x1 (p + s2) 488 | n2 = atPrecision x2 (p + s1) 489 | in (n1 * n2) /^ (p + s1 + s2)) 490 | 491 | -- | A more efficient 'recip' with the restriction that the input must have 492 | -- absolute value greater than or equal to 1 493 | recipBounded :: CReal n -> CReal n 494 | recipBounded x = crMemoize (\p -> let s = 2 495 | n = atPrecision x (p + 2 * s + 2) 496 | in bit (2 * p + 2 * s + 2) /. n) 497 | 498 | -- | Return the square of the input, more efficient than @('*')@ 499 | {-# INLINABLE square #-} 500 | square :: CReal n -> CReal n 501 | square x = let 502 | s = log2 (abs (atPrecision x 0) + 2) + 3 503 | in crMemoize (\p -> let n = atPrecision x (p + s) 504 | in (n * n) /^ (p + 2 * s)) 505 | 506 | -- | A more efficient 'square' with the restrictuion that the value must be in 507 | -- the closed range [-1..1] 508 | {-# INLINABLE squareBounded #-} 509 | squareBounded :: CReal n -> CReal n 510 | squareBounded x@(CR mvc _) = unsafePerformIO $ do 511 | vcc <- tryReadMVar mvc 512 | let 513 | !s = 4 514 | !vcn = case vcc of 515 | Nothing -> Never 516 | Just Never -> Never 517 | Just (Current j n) -> case j - s of 518 | p | p < 0 -> Never 519 | p -> Current p ((n * n) /^ (p + 2 * s)) 520 | fn' !p = let n = atPrecision x (p + s) 521 | in (n * n) /^ (p + 2 * s) 522 | mvn <- newMVar vcn 523 | return $ CR mvn fn' 524 | 525 | -- 526 | -- Bounded exponential functions and expPosNeg 527 | -- 528 | 529 | -- | A more efficient 'exp' with the restriction that the input must be in the 530 | -- closed range [-1..1] 531 | expBounded :: CReal n -> CReal n 532 | expBounded x = let q = (1%) <$> scanl' (*) 1 [1..] 533 | in powerSeries q (max 5) x 534 | 535 | -- | A more efficient 'log' with the restriction that the input must be in the 536 | -- closed range [2/3..2] 537 | logBounded :: CReal n -> CReal n 538 | logBounded x = let q = [1 % n | n <- [1..]] 539 | y = (x - 1) .* recip x 540 | in y .* powerSeries q id y 541 | 542 | -- | @expPosNeg x@ returns @(exp x, exp (-x))# 543 | expPosNeg :: CReal n -> (CReal n, CReal n) 544 | expPosNeg x = let o = x / ln2 545 | l = atPrecision o 0 546 | y = x - fromInteger l * ln2 547 | in if l == 0 548 | then (expBounded x, expBounded (-x)) 549 | else (expBounded y `shiftL` fromInteger l, 550 | expBounded (negate y) `shiftR` fromInteger l) 551 | 552 | -- 553 | -- Bounded trigonometric functions 554 | -- 555 | 556 | -- | A more efficient 'sin' with the restriction that the input must be in the 557 | -- closed range [-1..1] 558 | sinBounded :: CReal n -> CReal n 559 | sinBounded x = let q = alternateSign (scanl' (*) 1 [ 1 % (n*(n+1)) | n <- [2,4..]]) 560 | in x .* powerSeries q (max 1) (squareBounded x) 561 | 562 | -- | A more efficient 'cos' with the restriction that the input must be in the 563 | -- closed range [-1..1] 564 | cosBounded :: CReal n -> CReal n 565 | cosBounded x = let q = alternateSign (scanl' (*) 1 [1 % (n*(n+1)) | n <- [1,3..]]) 566 | in powerSeries q (max 1) (squareBounded x) 567 | 568 | -- | A more efficient 'atan' with the restriction that the input must be in the 569 | -- closed range [-1..1] 570 | atanBounded :: CReal n -> CReal n 571 | atanBounded x = let q = scanl' (*) 1 [n % (n + 1) | n <- [2,4..]] 572 | s = squareBounded x 573 | rd = recipBounded (plusInteger s 1) 574 | in (x .*. rd) .* powerSeries q (+1) (s .*. rd) 575 | 576 | -- 577 | -- Integer addition 578 | -- 579 | 580 | infixl 6 `plusInteger` 581 | 582 | -- | @x \`plusInteger\` n@ is equal to @x + fromInteger n@, but more efficient 583 | {-# INLINE plusInteger #-} 584 | plusInteger :: CReal n -> Integer -> CReal n 585 | plusInteger x 0 = x 586 | plusInteger (CR mvc fn) n = unsafePerformIO $ do 587 | vcc <- tryReadMVar mvc 588 | let 589 | !vcn = case vcc of 590 | Nothing -> Never 591 | Just Never -> Never 592 | Just (Current j v) -> Current j (v + unsafeShiftL n j) 593 | fn' !p = fn p + B.shiftL n p 594 | mvc' <- newMVar vcn 595 | return $ CR mvc' fn' 596 | 597 | -- 598 | -- Multiplication with powers of two 599 | -- 600 | 601 | infixl 8 `shiftL`, `shiftR` 602 | 603 | -- | @x \`shiftR\` n@ is equal to @x@ divided by 2^@n@ 604 | -- 605 | -- @n@ can be negative or zero 606 | -- 607 | -- This can be faster than doing the division 608 | shiftR :: CReal n -> Int -> CReal n 609 | shiftR x n = crMemoize (\p -> let p' = p - n 610 | in if p' >= 0 611 | then atPrecision x p' 612 | else atPrecision x 0 /^ negate p') 613 | 614 | -- | @x \`shiftL\` n@ is equal to @x@ multiplied by 2^@n@ 615 | -- 616 | -- @n@ can be negative or zero 617 | -- 618 | -- This can be faster than doing the multiplication 619 | shiftL :: CReal n -> Int -> CReal n 620 | shiftL x = shiftR x . negate 621 | 622 | 623 | -- 624 | -- Showing CReals 625 | -- 626 | 627 | -- | Return a string representing a decimal number within 2^-p of the value 628 | -- represented by the given @CReal p@. 629 | showAtPrecision :: Int -> CReal n -> String 630 | showAtPrecision p x = let places = decimalDigitsAtPrecision p 631 | r = atPrecision x p % bit p 632 | in rationalToDecimal places r 633 | 634 | -- | How many decimal digits are required to represent a number to within 2^-p 635 | decimalDigitsAtPrecision :: Int -> Int 636 | decimalDigitsAtPrecision 0 = 0 637 | decimalDigitsAtPrecision p = log10 (bit p) + 1 638 | 639 | -- | @rationalToDecimal p x@ returns a string representing @x@ at @p@ decimal 640 | -- places. 641 | rationalToDecimal :: Int -> Rational -> String 642 | rationalToDecimal places (n :% d) = p ++ is ++ if places > 0 then "." ++ fs else "" 643 | where p = case signum n of 644 | -1 -> "-" 645 | _ -> "" 646 | ds = show (roundD (abs n * 10^places) d) 647 | l = length ds 648 | (is, fs) = if l <= places then ("0", replicate (places - l) '0' ++ ds) else splitAt (l - places) ds 649 | 650 | 651 | -- 652 | -- Integer operations 653 | -- 654 | 655 | divZeroErr :: a 656 | divZeroErr = error "Division by zero" 657 | {-# NOINLINE divZeroErr #-} 658 | 659 | roundD :: Integer -> Integer -> Integer 660 | roundD n d = case divMod n d of 661 | (q, r) -> case compare (unsafeShiftL r 1) d of 662 | LT -> q 663 | EQ -> if testBit q 0 then q + 1 else q 664 | GT -> q + 1 665 | {-# INLINE roundD #-} 666 | 667 | infixl 7 /. 668 | -- | Division rounding to the nearest integer and rounding half integers to the 669 | -- nearest even integer. 670 | (/.) :: Integer -> Integer -> Integer 671 | (!n) /. (!d) = case compare d 0 of 672 | LT -> roundD (negate n) (negate d) 673 | EQ -> divZeroErr 674 | GT -> roundD n d 675 | {-# INLINABLE (/.) #-} 676 | 677 | infixl 7 /^ 678 | -- | @n /^ p@ is equivalent to @n \'/.\' (2^p)@, but faster, and it works for 679 | -- negative values of p. 680 | (/^) :: Integer -> Int -> Integer 681 | (!n) /^ (!p) = case compare p 0 of 682 | LT -> unsafeShiftL n (negate p) 683 | EQ -> n 684 | GT -> let 685 | !bp = bit p 686 | !r = n .&. (bp - 1) 687 | !q = unsafeShiftR (n - r) p 688 | in case compare (unsafeShiftL r 1) bp of 689 | LT -> q 690 | EQ -> if testBit q 0 then q + 1 else q 691 | GT -> q + 1 692 | 693 | -- | @log2 x@ returns the base 2 logarithm of @x@ rounded towards zero. 694 | -- 695 | -- The input must be positive 696 | {-# INLINE log2 #-} 697 | log2 :: Integer -> Int 698 | log2 x = I# (integerLog2# x) 699 | 700 | -- | @log10 x@ returns the base 10 logarithm of @x@ rounded towards zero. 701 | -- 702 | -- The input must be positive 703 | {-# INLINE log10 #-} 704 | log10 :: Integer -> Int 705 | log10 x = I# (integerLogBase# 10 x) 706 | 707 | -- | @isqrt x@ returns the square root of @x@ rounded towards zero. 708 | -- 709 | -- The input must not be negative 710 | {-# INLINABLE isqrt #-} 711 | isqrt :: Integer -> Integer 712 | isqrt x | x < 0 = error "Sqrt applied to negative Integer" 713 | | x == 0 = 0 714 | | otherwise = until satisfied improve initialGuess 715 | where improve r = unsafeShiftR (r + x `div` r) 1 716 | satisfied r = let r2 = r * r in r2 <= x && r2 + unsafeShiftL r 1 >= x 717 | initialGuess = bit (unsafeShiftR (log2 x) 1) 718 | 719 | -- 720 | -- Searching 721 | -- 722 | 723 | -- | Given a monotonic function 724 | {-# INLINABLE findFirstMonotonic #-} 725 | findFirstMonotonic :: (Int -> Bool) -> Int 726 | findFirstMonotonic p = findBounds 0 1 727 | where findBounds !l !u = if p u then binarySearch l u 728 | else findBounds u (u * 2) 729 | binarySearch !l !u = let !m = l + (u - l) `div` 2 730 | in if | l+1 == u -> l 731 | | p m -> binarySearch l m 732 | | otherwise -> binarySearch m u 733 | 734 | 735 | -- 736 | -- Power series 737 | -- 738 | 739 | -- | Apply 'negate' to every other element, starting with the second 740 | -- 741 | -- >>> alternateSign [1..5] 742 | -- [1,-2,3,-4,5] 743 | {-# INLINABLE alternateSign #-} 744 | alternateSign :: Num a => [a] -> [a] 745 | alternateSign ls = foldr 746 | (\a r b -> if b then negate a : r False else a : r True) 747 | (const []) 748 | ls 749 | False 750 | 751 | -- | @powerSeries q f x `atPrecision` p@ will evaluate the power series with 752 | -- coefficients @q@ up to the coefficient at index @f p@ at value @x@ 753 | -- 754 | -- @f@ should be a function such that the CReal invariant is maintained. This 755 | -- means that if the power series @y = a[0] + a[1] + a[2] + ...@ is evaluated 756 | -- at precision @p@ then the sum of every @a[n]@ for @n > f p@ must be less than 757 | -- 2^-p. 758 | -- 759 | -- This is used by all the bounded transcendental functions. 760 | -- 761 | -- >>> let (!) x = product [2..x] 762 | -- >>> powerSeries [1 % (n!) | n <- [0..]] (max 5) 1 :: CReal 218 763 | -- 2.718281828459045235360287471352662497757247093699959574966967627724 764 | powerSeries :: [Rational] -> (Int -> Int) -> CReal n -> CReal n 765 | powerSeries q termsAtPrecision x = crMemoize 766 | (\p -> let t = termsAtPrecision p 767 | d = log2 (toInteger t) + 2 768 | p' = p + d 769 | p'' = p' + d 770 | m = atPrecision x p'' 771 | xs = (% 1) <$> iterate (\e -> m * e /^ p'') (bit p') 772 | r = sum . take (t + 1) . fmap (round . (* fromInteger (bit d))) $ zipWith (*) q xs 773 | in r /^ (2 * d)) 774 | 775 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.20 2 | packages: 3 | - '.' 4 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: memoize-0.8.1@sha256:2146197c639c126796d850cb4457b24cfeb6966d6d878825f855aafce31f8874,1601 9 | pantry-tree: 10 | size: 473 11 | sha256: 598188857937054d2cc4ac91aee580944d750e91120756507891d09e02056066 12 | original: 13 | hackage: memoize-0.8.1@sha256:2146197c639c126796d850cb4457b24cfeb6966d6d878825f855aafce31f8874,1601 14 | snapshots: 15 | - completed: 16 | size: 527836 17 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml 18 | sha256: 341870ac98d8a9f8f77c4adf2e9e0b22063e264a7fbeb4c85b7af5f380dac60e 19 | original: lts-11.22 20 | -------------------------------------------------------------------------------- /test/BoundedFunctions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | module BoundedFunctions 4 | ( boundedFunctions 5 | ) where 6 | 7 | import Test.Tasty (testGroup, TestTree) 8 | import Test.Tasty.QuickCheck ((==>), testProperty) 9 | import Test.QuickCheck.Extra (BiunitInterval(..), UnitInterval(..)) 10 | import Test.QuickCheck.Checkers ((=-=)) 11 | import GHC.TypeLits (KnownNat) 12 | 13 | import Data.CReal.Internal 14 | import Data.CReal.Extra () 15 | 16 | boundedFunctions :: forall a n. (KnownNat n, a ~ CReal n) => a -> TestTree 17 | boundedFunctions _ = testGroup "bounded functions" ts 18 | where ts = [ testProperty "mulBounded" 19 | (\(BiunitInterval x) (BiunitInterval y) -> 20 | (x :: a) * y =-= x .*. y) 21 | , testProperty "mulBoundedL" 22 | (\(BiunitInterval x) y -> 23 | (x :: a) * y =-= x .* y) 24 | , testProperty "mulBoundedR" 25 | (\x (BiunitInterval y) -> 26 | (x :: a) * y =-= x *. y) 27 | , testProperty "recipBounded" 28 | (\x -> (abs x >= 1) ==> recip (x::a) =-= recipBounded x) 29 | , testProperty "expBounded" 30 | (\(BiunitInterval x) -> 31 | exp (x :: a) =-= expBounded x) 32 | , testProperty "logBounded" 33 | (\(UnitInterval x) -> 34 | let x' = (x :: a) * (2 - 2/3) + 2/3 35 | in log x' =-= logBounded x') 36 | , testProperty "sinBounded" 37 | (\(BiunitInterval x) -> 38 | sin (x :: a) =-= sinBounded x) 39 | , testProperty "cosBounded" 40 | (\(BiunitInterval x) -> 41 | cos (x :: a) =-= cosBounded x) 42 | , testProperty "atanBounded" 43 | (\(BiunitInterval x) -> 44 | atan (x :: a) =-= atanBounded x) 45 | ] 46 | 47 | -------------------------------------------------------------------------------- /test/Data/CReal/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Data.CReal.Extra 4 | ( module Data.CReal 5 | ) where 6 | 7 | import Data.CReal 8 | import GHC.TypeLits 9 | import Test.QuickCheck (Arbitrary(..), chooseAny) 10 | import Test.QuickCheck.Checkers (EqProp(..), eq) 11 | 12 | instance KnownNat n => EqProp (CReal n) where 13 | (=-=) = eq 14 | 15 | instance KnownNat n => Arbitrary (CReal n) where 16 | arbitrary = do 17 | integralPart <- fromInteger <$> arbitrary 18 | fractionalPart <- (subtract 0.5) <$> chooseAny 19 | pure (integralPart + fractionalPart) 20 | 21 | -------------------------------------------------------------------------------- /test/Doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Build_doctests ( flags 4 | , module_sources 5 | , pkgs 6 | ) 7 | import Test.DocTest ( doctest ) 8 | 9 | main :: IO () 10 | main = doctest $ flags ++ pkgs ++ module_sources 11 | -------------------------------------------------------------------------------- /test/Floating.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Floating 5 | ( floating 6 | ) where 7 | 8 | import Fractional (fractional) 9 | import System.Random (Random) 10 | import Test.QuickCheck.Checkers (EqProp, (=-=), inverseL) 11 | import Test.QuickCheck.Extra (UnitInterval(..), Tiny(..), BiunitInterval) 12 | import Test.Tasty (testGroup, TestTree) 13 | import Test.Tasty.QuickCheck (testProperty, NonNegative(..), Positive(..), Arbitrary, (==>)) 14 | import Test.Tasty.HUnit (testCase, (@?=)) 15 | 16 | floating :: forall a. (Arbitrary a, EqProp a, Show a, Floating a, Ord a, Random a) => 17 | a -> TestTree 18 | floating _ = testGroup "Test Floating instance" ts 19 | where e = exp 1 20 | ts = [ fractional (undefined :: a) 21 | , testCase "π/4 = atan 1" ((pi::a) @?= 4 * atan 1) 22 | , testProperty "log == logBase e" 23 | (log =-= logBase (e :: Positive a)) 24 | , testProperty "exp == (e **)" (exp =-= ((e::a) **)) 25 | , testProperty "sqrt x * sqrt x = x" 26 | (\(NonNegative (x :: a)) -> let r = sqrt x 27 | in r * r == x) 28 | , testProperty "law of exponents" 29 | (\(Positive (base :: a)) x y -> 30 | base ** (x + y) =-= base ** x * base ** y) 31 | , testProperty "logarithm definition" 32 | (\(Positive (b :: a)) (Tiny c) -> 33 | let x = b ** c 34 | in b /= 1 ==> c =-= logBase b x) 35 | , testProperty "sine cosine definition" 36 | (\x (y :: a) -> 37 | cos (x - y) =-= cos x * cos y + sin x * sin y) 38 | -- TODO: Use open interval 39 | , testProperty "0 < x cos x" 40 | (\(x::UnitInterval a) -> 0 <= x * cos x) 41 | -- Use <= here because of precision issues :( 42 | , testProperty "x cos x < sin x" 43 | (\(x::UnitInterval a) -> x * cos x <= sin x) 44 | , testProperty "sin x < x" (\(x::UnitInterval a) -> sin x <= x) 45 | , testProperty "tangent definition" 46 | (\(x::a) -> cos x /= 0 ==> tan x =-= sin x / cos x) 47 | , testProperty "asin left inverse" 48 | (inverseL sin (asin :: BiunitInterval a -> BiunitInterval a)) 49 | , testProperty "acos left inverse" 50 | (inverseL cos (acos :: BiunitInterval a -> BiunitInterval a)) 51 | , testProperty "atan left inverse" (inverseL tan (atan :: a -> a)) 52 | , testProperty "sinh definition" 53 | (\(x::a) -> sinh x =-= (exp x - exp (-x)) / 2) 54 | , testProperty "cosh definition" 55 | (\(x::a) -> cosh x =-= (exp x + exp (-x)) / 2) 56 | , testProperty "tanh definition" 57 | (\(x::a) -> tanh x =-= sinh x / cosh x) 58 | , testProperty "sinh left inverse" 59 | (inverseL asinh (sinh :: a -> a)) 60 | , testProperty "cosh left inverse" 61 | (acosh . cosh =-= (abs :: a -> a)) 62 | , testProperty "tanh left inverse" 63 | (inverseL atanh (tanh :: Tiny a -> Tiny a)) 64 | ] 65 | 66 | 67 | -------------------------------------------------------------------------------- /test/Fractional.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Fractional 4 | ( fractional 5 | ) where 6 | 7 | import Data.Ratio ((%)) 8 | import Test.QuickCheck (Arbitrary) 9 | import Test.QuickCheck.Checkers (EqProp, (=-=)) 10 | import Test.QuickCheck.Classes.Extra (field) 11 | import Test.QuickCheck.Modifiers (NonZero(..)) 12 | import Test.QuickCheck.Extra () 13 | import Test.Tasty (testGroup, TestTree) 14 | import Test.Tasty.QuickCheck (testProperty) 15 | import Num (numAuxTests) 16 | 17 | -- TODO: Reduce Ord to Eq on the new quickcheck release 18 | -- TODO: Write a program to email me for todo's like that when the conditions 19 | -- are met 20 | fractional :: forall a. (Arbitrary a, EqProp a, Show a, Fractional a, Ord a) => 21 | a -> TestTree 22 | fractional _ = testGroup "Test Fractional instance" ts 23 | where 24 | ts = [ field "field" (undefined :: a) 25 | , numAuxTests (undefined :: a) 26 | , testProperty "x * recip y = x / y" (\x (NonZero (y :: a)) -> x * recip y =-= x / y) 27 | , testProperty "fromRational (x % y) = fromInteger x / fromInteger y" 28 | (\x (NonZero y) -> fromRational (x % y) =-= fromInteger x / (fromInteger y :: a)) 29 | ] 30 | -------------------------------------------------------------------------------- /test/Num.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Num 4 | ( num 5 | , numAuxTests 6 | ) where 7 | 8 | import Test.QuickCheck (Arbitrary) 9 | import Test.QuickCheck.Checkers (idempotent, EqProp, (=-=)) 10 | import Test.QuickCheck.Classes.Extra (commutativeRing) 11 | import Test.Tasty (testGroup, TestTree) 12 | import Test.Tasty.QuickCheck (testProperty) 13 | 14 | num :: forall a. (Arbitrary a, EqProp a, Show a, Num a) => a -> TestTree 15 | num _ = testGroup "Test Num instance" ts 16 | where 17 | ts = [commutativeRing "commutativeRing" (undefined :: a), numAuxTests (undefined :: a)] 18 | 19 | numAuxTests :: forall a. (Arbitrary a, EqProp a, Show a, Num a) => a -> TestTree 20 | numAuxTests _ = testGroup "Num instance aux tests" ts 21 | where 22 | ts = [ testProperty "x + negate y = x - y" (\x (y :: a) -> x + negate y =-= x - y) 23 | , testProperty "abs is idempotent" (idempotent (abs :: a -> a)) 24 | , testProperty "abs-signum law" (\(x :: a) -> abs x * signum x =-= x) 25 | ] 26 | 27 | -------------------------------------------------------------------------------- /test/Ord.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Ord 4 | ( ord 5 | ) where 6 | 7 | import Test.QuickCheck (Arbitrary) 8 | import Test.QuickCheck.Checkers (EqProp) 9 | import Test.QuickCheck.Classes.Extra (complement, strictTotalOrd) 10 | import Test.Tasty.Extra (testGroup, TestTree) 11 | import Test.Tasty.QuickCheck (Gen, arbitrary, testProperty, property) 12 | 13 | ord :: forall a. (Arbitrary a, Show a, EqProp a, Ord a) => a -> TestTree 14 | ord _ = testGroup "Test Ord instance" ts 15 | where 16 | gen :: a -> Gen a 17 | gen = const arbitrary 18 | ts = [ -- It's a bit of a pain, but basically the arbitrary instance could 19 | -- generate for precision p: 20 | -- 21 | -- 2, 1, 3. Where 2 <= 1 and 2<=3 (because they compare equal at the low 22 | -- precision p) and hence 1 <= 3 (which is detected and fails the test). 23 | -- 24 | -- testTreeFromNamedBatch "<= is a total ordering" (ordRel (<=) gen) 25 | -- testTreeFromNamedBatch ">= is a total ordering" (ordRel (>=) gen) 26 | strictTotalOrd "< is a strict total ordering" gen (<) 27 | , strictTotalOrd "< is a strict total ordering" gen (>) 28 | , complement "< is the complement of >=" gen (<) (>=) 29 | , complement "> is the complement of <=" gen (>) (<=) 30 | , testProperty "max x y >= x and y" (property $ \x y -> 31 | let m = max x y :: a 32 | in m >= x && m >= y) 33 | , testProperty "max x y == x or y" (property $ \x y -> 34 | let m = max x y :: a 35 | in m == x || m == y) 36 | , testProperty "min x y >= x and y" (property $ \x y -> 37 | let m = min x y :: a 38 | in m <= x && m <= y) 39 | , testProperty "min x y == x or y" (property $ \x y -> 40 | let m = min x y :: a 41 | in m == x || m == y) 42 | ] 43 | -------------------------------------------------------------------------------- /test/Random.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Random 4 | ( random 5 | ) where 6 | 7 | import Test.Tasty (testGroup, TestTree) 8 | import Test.Tasty.QuickCheck (testProperty, Arbitrary, (==>)) 9 | import System.Random (Random, randoms, randomRs, mkStdGen) 10 | 11 | random :: forall a. (Arbitrary a, Show a, Ord a, Fractional a, Random a) => a -> TestTree 12 | random _ = testGroup "Test Random instance" ts 13 | where ts = [ testProperty "randomR range" 14 | (\s l u -> let rs = take 100 (randomRs (l :: a, u) (mkStdGen s)) 15 | in l <= u ==> (all (>= l) rs && all (<= u) rs)) 16 | , testProperty "randomR zero bounds" 17 | (\s l -> let rs = take 100 (randomRs (l :: a, l) (mkStdGen s)) 18 | in all (== l) rs) 19 | , testProperty "random range" 20 | (\s -> let rs = take 100 (randoms (mkStdGen s)) :: [a] 21 | in all (>= 0) rs && all (< 1) rs) 22 | ] 23 | -------------------------------------------------------------------------------- /test/Read.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Read 4 | ( read' 5 | ) where 6 | 7 | import Test.QuickCheck.Checkers (EqProp, inverseL) 8 | import Test.Tasty (testGroup, TestTree) 9 | import Test.Tasty.QuickCheck (testProperty, Arbitrary) 10 | 11 | read' :: forall a. (Arbitrary a, EqProp a, Show a, Read a) => a -> TestTree 12 | read' _ = testGroup "Test Read instance" ts 13 | where ts = [ testProperty "read show left inverse" 14 | (inverseL read (show :: a -> String)) 15 | ] 16 | -------------------------------------------------------------------------------- /test/Real.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Real 4 | ( real 5 | ) where 6 | 7 | import Test.QuickCheck.Checkers (EqProp, inverseL) 8 | import Test.Tasty (testGroup, TestTree) 9 | import Test.Tasty.QuickCheck (testProperty, Arbitrary) 10 | 11 | real :: forall a. (Arbitrary a, EqProp a, Show a, Fractional a, Real a) => 12 | (a -> Rational) -> TestTree 13 | real maxError = testGroup "Test Real instance" ts 14 | where ts = [ testProperty "fromRational toRational left inverse" 15 | (inverseL fromRational (toRational :: a -> Rational)) 16 | , testProperty "toRational fromRational left inverse (within error)" 17 | (\r -> let x :: a 18 | x = fromRational r 19 | r' = toRational x 20 | in r - r' <= maxError x) 21 | ] 22 | -------------------------------------------------------------------------------- /test/RealFloat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module RealFloat 4 | ( realFloat 5 | ) where 6 | 7 | import Test.QuickCheck.Checkers (EqProp, (=-=), inverseL) 8 | import Test.Tasty (testGroup, TestTree) 9 | import Test.Tasty.QuickCheck (testProperty, Arbitrary, (==>)) 10 | 11 | realFloat :: forall a. (Arbitrary a, EqProp a, Show a, RealFloat a) => 12 | a -> TestTree 13 | realFloat x = testGroup "Test RealFloat instance" ts 14 | where ts = [ decodeFloatLaws "decodeFloat laws" x 15 | , testProperty "encodeFloat decodeFloat left inverse" 16 | (inverseL (uncurry encodeFloat) (decodeFloat :: a -> (Integer, Int))) 17 | , testProperty "scaleFloat definition" 18 | (\y i -> let r = floatRadix y 19 | in scaleFloat i (y::a) =-= y * fromIntegral r ^^ i) 20 | , atan2Laws "atan2 laws" x 21 | ] 22 | 23 | decodeFloatLaws :: forall a. (Arbitrary a, EqProp a, Show a, RealFloat a) => 24 | String -> a -> TestTree 25 | decodeFloatLaws s _ = testGroup s ts 26 | where ts = [ testProperty "x = m*b^^n" 27 | (\x -> let (m, n) = decodeFloat (x :: a) 28 | b = floatRadix x 29 | in not (isNaN x || isInfinite x) ==> 30 | (x =-= fromInteger m * fromInteger b ^^ n)) 31 | ] 32 | 33 | atan2Laws :: forall a. (Arbitrary a, EqProp a, Show a, RealFloat a) => 34 | String -> a -> TestTree 35 | atan2Laws s _ = testGroup s ts 36 | where ts = [ testProperty "atan2 range" (\y x -> let θ = atan2 y (x :: a) 37 | in abs θ <= pi) 38 | , testProperty "atan2 y 1 = atan y" (\y -> let θ = atan2 y (1 :: a) 39 | in θ =-= atan y) 40 | ] 41 | 42 | -------------------------------------------------------------------------------- /test/RealFrac.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module RealFrac 4 | ( realFrac 5 | ) where 6 | 7 | import Data.Function (on) 8 | import Test.QuickCheck.Checkers (EqProp, (=-=)) 9 | import Test.Tasty (testGroup, TestTree) 10 | import Test.Tasty.QuickCheck (testProperty, Arbitrary) 11 | 12 | -- TODO: Test the other functions 13 | realFrac :: forall a. (Arbitrary a, EqProp a, Show a, RealFrac a) => 14 | a -> TestTree 15 | realFrac x = testGroup "Test RealFrac instance" ts 16 | where ts = [ properFractionLaws "properFraction laws" x 17 | , truncateLaws "truncate laws" x 18 | , roundLaws "round laws" x 19 | , ceilingLaws "ceiling laws" x 20 | , floorLaws "floor laws" x 21 | ] 22 | 23 | -- Thses are used to cope with CReal 0 being a little weird with comparisons 24 | -- between non-integers 25 | infix 4 <., >. 26 | (<.), (>.) :: (Ord a, Num a) => a -> a -> Bool 27 | (<.) = (<) `on` (*2) 28 | (>.) = (>) `on` (*2) 29 | 30 | -- | This tests a slightly different law for n having the same sign as x 31 | properFractionLaws :: forall a. (Arbitrary a, EqProp a, Show a, RealFrac a) => 32 | String -> a -> TestTree 33 | properFractionLaws s _ = testGroup s ts 34 | where ts = [ testProperty "x = n + f" 35 | (\x -> let (n, f) = properFraction (x :: a) 36 | in x =-= fromInteger n + f) 37 | , testProperty "n has same sign or is zero" 38 | (\x -> let (n, _) = properFraction (x :: a) 39 | in n == 0 || sign x == sign (n::Integer)) 40 | , testProperty "abs f < 1" 41 | (\x -> let (_::Int, f) = properFraction (x :: a) 42 | in abs f <. 1) 43 | , testProperty "f has same sign or is zero" 44 | (\x -> let (_::Int, f) = properFraction (x :: a) 45 | in f == 0 || sign x == sign f) 46 | ] 47 | 48 | truncateLaws :: forall a. (Arbitrary a, EqProp a, Show a, RealFrac a) => 49 | String -> a -> TestTree 50 | truncateLaws s _ = testGroup s ts 51 | where ts = [ testProperty "abs (truncate x) <= abs x" 52 | (\x -> let t = truncate (x :: a) 53 | in fromInteger (abs t) <= abs x) 54 | , testProperty "abs (truncate x) + 1 > abs x" 55 | (\x -> let t = truncate (x :: a) 56 | in fromInteger (abs t + 1) >. abs x) 57 | , testProperty "truncate x has same sign or is zero" 58 | (\x -> let t = truncate (x :: a) 59 | in t == 0 || sign x == sign (t::Integer)) 60 | ] 61 | 62 | roundLaws :: forall a. (Arbitrary a, EqProp a, Show a, RealFrac a) => 63 | String -> a -> TestTree 64 | roundLaws s _ = testGroup s ts 65 | where ts = [ testProperty "abs (round x - x) <= 0.5" 66 | (\x -> let r = round (x :: a) 67 | in abs (fromInteger r - x) <= 0.5) 68 | , testProperty "round to even if eqiudistant" 69 | (\i -> let x = fromInteger i + 0.5 :: a 70 | in even (round x :: Integer)) 71 | ] 72 | 73 | ceilingLaws :: forall a. (Arbitrary a, EqProp a, Show a, RealFrac a) => 74 | String -> a -> TestTree 75 | ceilingLaws s _ = testGroup s ts 76 | where ts = [ testProperty "ceiling x - 1 < x" 77 | (\x -> let c = ceiling (x :: a) 78 | in fromInteger c - 1 <. x) 79 | , testProperty "ceiling x >= x" 80 | (\x -> let c = ceiling (x :: a) 81 | in fromInteger c >= x) 82 | ] 83 | 84 | floorLaws :: forall a. (Arbitrary a, EqProp a, Show a, RealFrac a) => 85 | String -> a -> TestTree 86 | floorLaws s _ = testGroup s ts 87 | where ts = [ testProperty "floor x + 1 > x" 88 | (\x -> let f = floor (x :: a) 89 | in fromInteger f + 1 >. x) 90 | , testProperty "floor x <= x" 91 | (\x -> let f = floor (x :: a) 92 | in fromInteger f <= x) 93 | ] 94 | 95 | data Sign = Positive 96 | | Negative 97 | deriving (Eq, Show) 98 | 99 | -- | Note that this returns Positive on zero rather than 0 like signum 100 | sign :: (Ord a, Num a) => a -> Sign 101 | sign x = if x < 0 then Negative 102 | else Positive 103 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | 7 | module Main (main) where 8 | 9 | import Data.CReal.Converge 10 | import Data.CReal.Extra () 11 | import Data.CReal.Internal 12 | import Data.List (inits) 13 | import Data.Maybe (fromJust) 14 | import Data.Proxy 15 | import Data.Ratio ((%)) 16 | import GHC.TypeNats 17 | import Numeric.Natural 18 | import Test.Tasty (TestTree, defaultMain, testGroup) 19 | import Test.Tasty.HUnit (Assertion, testCase, (@=?)) 20 | import Test.Tasty.QuickCheck (Positive (..), Property, testProperty, 21 | (.&&.), (===), (==>)) 22 | 23 | import BoundedFunctions (boundedFunctions) 24 | import Floating (floating) 25 | import Ord (ord) 26 | import Random (random) 27 | import Read (read') 28 | import Real (real) 29 | import RealFloat (realFloat) 30 | import RealFrac (realFrac) 31 | 32 | {-# ANN test_floating "HLint: ignore Use camelCase" #-} 33 | test_floating :: forall p proxy. KnownNat p => proxy p -> TestTree 34 | test_floating _ = floating (undefined :: CReal p) 35 | 36 | {-# ANN test_ord "HLint: ignore Use camelCase" #-} 37 | test_ord :: forall p proxy. KnownNat p => proxy p -> TestTree 38 | test_ord _ = ord (undefined :: CReal p) 39 | 40 | {-# ANN test_real "HLint: ignore Use camelCase" #-} 41 | test_real :: forall p proxy . KnownNat p => proxy p -> TestTree 42 | test_real _ = 43 | real (\x -> 1 % toInteger (max 1 (crealPrecision (x :: CReal p)))) 44 | 45 | {-# ANN test_realFrac "HLint: ignore Use camelCase" #-} 46 | test_realFrac :: forall p proxy. KnownNat p => proxy p -> TestTree 47 | test_realFrac _ = realFrac (undefined :: CReal p) 48 | 49 | {-# ANN test_realFloat "HLint: ignore Use camelCase" #-} 50 | test_realFloat :: forall p proxy. KnownNat p => proxy p -> TestTree 51 | test_realFloat _ = realFloat (undefined :: CReal p) 52 | 53 | {-# ANN test_read "HLint: ignore Use camelCase" #-} 54 | test_read :: forall p proxy. KnownNat p => proxy p -> TestTree 55 | test_read _ = read' (undefined :: CReal p) 56 | 57 | {-# ANN test_random "HLint: ignore Use camelCase" #-} 58 | test_random :: forall p proxy. KnownNat p => proxy p -> TestTree 59 | test_random _ = random (undefined :: CReal p) 60 | 61 | prop_decimalDigits :: Positive Int -> Property 62 | prop_decimalDigits (Positive p) = let d = decimalDigitsAtPrecision p 63 | in 10^d >= (2^p :: Integer) .&&. 64 | (d > 0 ==> 10^(d-1) < (2^p :: Integer)) 65 | 66 | prop_showIntegral :: Integer -> Property 67 | prop_showIntegral i = show i === show (fromInteger i :: CReal 0) 68 | 69 | prop_shiftL :: forall p . KnownNat p => CReal p -> Int -> Property 70 | prop_shiftL x s = x `shiftL` s === x * 2 ** fromIntegral s 71 | 72 | prop_shiftR :: forall p . KnownNat p => CReal p -> Int -> Property 73 | prop_shiftR x s = x `shiftR` s === x / 2 ** fromIntegral s 74 | 75 | prop_showNumDigits :: Positive Int -> Rational -> Property 76 | prop_showNumDigits (Positive places) x = 77 | let s = rationalToDecimal places x 78 | in length (dropWhile (/= '.') s) === places + 1 79 | 80 | -- 81 | -- Testing Data.CReal.Converge 82 | -- 83 | 84 | case_convergeErrEmptyCReal :: Assertion 85 | case_convergeErrEmptyCReal = convergeErr undefined [] @=? (Nothing :: Maybe (CReal 0)) 86 | 87 | case_convergeErrEmptyUnit :: Assertion 88 | case_convergeErrEmptyUnit = convergeErr undefined [] @=? (Nothing :: Maybe ()) 89 | 90 | case_convergeEmptyCReal :: Assertion 91 | case_convergeEmptyCReal = converge [] @=? (Nothing :: Maybe (CReal 0)) 92 | 93 | case_convergeEmptyUnit :: Assertion 94 | case_convergeEmptyUnit = converge [] @=? (Nothing :: Maybe ()) 95 | 96 | prop_convergeCollatzInteger :: Positive Integer -> Property 97 | prop_convergeCollatzInteger (Positive x) = converge (iterate collatz x) === Just 1 98 | where collatz :: Integer -> Integer 99 | collatz c | c == 1 = 1 100 | | even c = c `div` 2 101 | | otherwise = c * 3 + 1 102 | 103 | 104 | case_convergePointNineRecurringCReal 105 | :: forall p proxy . KnownNat p => proxy p -> Assertion 106 | case_convergePointNineRecurringCReal _ = (Just 1 :: Maybe (CReal p)) @=? 107 | converge (read <$> pointNineRecurring) 108 | where pointNineRecurring = ("0.9" ++) <$> inits (repeat '9') 109 | 110 | prop_convergeErrSqrtCReal 111 | :: forall p . KnownNat p => Positive (CReal p) -> Property 112 | prop_convergeErrSqrtCReal (Positive x) = sqrt' (x ^ (2::Int)) === x 113 | where sqrt' x' = let initialGuess = x' 114 | improve y = (y + x' / y) / 2 115 | err y = abs (x' - y * y) 116 | in fromJust $ convergeErr err (tail $ iterate improve initialGuess) 117 | 118 | -- Test that the behavior when error is too small is correct 119 | prop_convergeErrSmallSqrtCReal 120 | :: forall p . KnownNat p => Positive (CReal p) -> Property 121 | prop_convergeErrSmallSqrtCReal (Positive x) = sqrt' (x ^ (2::Int)) === x 122 | where sqrt' x' = let initialGuess = x' 123 | improve y = (y + x' / y) / 2 124 | err y = abs (x' - y * y) / 128 125 | in fromJust $ convergeErr err (tail $ iterate improve initialGuess) 126 | 127 | prop_convergeErrSqrtInteger :: Positive Integer -> Property 128 | prop_convergeErrSqrtInteger (Positive x) = sqrt' (x ^ (2::Int)) === x 129 | where sqrt' x' = let initialGuess = x' 130 | improve y = (y + x' `quot` y) `quot` 2 131 | err y = abs (x' - y * y) 132 | in fromJust $ convergeErr err (tail $ iterate improve initialGuess) 133 | 134 | 135 | {-# ANN test_boundedFunctions "HLint: ignore Use camelCase" #-} 136 | test_boundedFunctions :: forall p proxy. KnownNat p => proxy p -> TestTree 137 | test_boundedFunctions _ = boundedFunctions (undefined :: CReal p) 138 | 139 | prop_expPosNeg :: KnownNat p => CReal p -> Property 140 | prop_expPosNeg x = expPosNeg x === (exp x, exp (-x)) 141 | 142 | prop_square :: KnownNat p => CReal p -> Property 143 | prop_square x = square x === x * x 144 | 145 | -- 146 | -- 147 | -- 148 | 149 | precisionTests :: Natural -> TestTree 150 | precisionTests n = case someNatVal n of 151 | SomeNat (_ :: Proxy p) -> testGroup 152 | ("Precision Tests @" <> show n) 153 | [ test_floating (Proxy @p) 154 | , test_ord (Proxy @p) 155 | , test_real (Proxy @p) 156 | , test_realFrac (Proxy @p) 157 | , test_realFloat (Proxy @p) 158 | , test_read (Proxy @p) 159 | , test_random (Proxy @p) 160 | , testProperty "shiftL" (prop_shiftL @p) 161 | , testProperty "shiftR" (prop_shiftR @p) 162 | , testCase "convergePointNineRecurringCReal" 163 | (case_convergePointNineRecurringCReal (Proxy @p)) 164 | , testProperty "convergeErrSqrtCReal" (prop_convergeErrSqrtCReal @p) 165 | , testProperty "convergeErrSmallSqrtCReal" 166 | (prop_convergeErrSmallSqrtCReal @p) 167 | , test_boundedFunctions (Proxy @p) 168 | , testProperty "expPosNeg" (prop_expPosNeg @p) 169 | , testProperty "square" (prop_square @p) 170 | ] 171 | 172 | nonPrecisionTests :: TestTree 173 | nonPrecisionTests = testGroup 174 | "Non precision Tests" 175 | [ testProperty "decimalDigits" prop_decimalDigits 176 | , testProperty "showIntegral" prop_showIntegral 177 | , testProperty "showNumDigits" prop_showNumDigits 178 | , testCase "convergeErrEmptyCReal" case_convergeErrEmptyCReal 179 | , testCase "convergeErrEmptyUnit" case_convergeErrEmptyUnit 180 | , testCase "convergeEmptyCReal" case_convergeEmptyCReal 181 | , testCase "convergeEmptyUnit" case_convergeEmptyUnit 182 | , testProperty "convergeCollatzInteger" prop_convergeCollatzInteger 183 | , testProperty "convergeErrSqrtInteger" prop_convergeErrSqrtInteger 184 | ] 185 | 186 | main :: IO () 187 | main = 188 | let precisions = [0, 1, 2, 10, 30] 189 | in defaultMain 190 | (testGroup "Main" (nonPrecisionTests : (precisionTests <$> precisions))) 191 | -------------------------------------------------------------------------------- /test/Test/QuickCheck/Classes/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | -- | Add a bunch of checkers for testing properties of different algebraic 4 | -- structures and relations 5 | module Test.QuickCheck.Classes.Extra 6 | ( module Test.QuickCheck.Classes 7 | -- | Algebraic structures 8 | , group 9 | , abelian 10 | , ring 11 | , commutativeRing 12 | , field 13 | 14 | -- | Relations 15 | , complement 16 | , strictTotalOrd 17 | ) where 18 | 19 | import Data.Group (invert, Group, Abelian) 20 | import Data.Monoid (Sum(..), Product) 21 | import Test.QuickCheck.Extra (Arbitrary, (<=>), (==>)) 22 | import Test.QuickCheck.Modifiers (NonZero) 23 | import Test.QuickCheck.Checkers (commutes, transitive, EqProp, (=-=), BinRel) 24 | import Test.QuickCheck.Classes 25 | import Test.Tasty.Extra (testGroup, TestTree, testTreeFromBatch, testTreeFromNamedBatch) 26 | import Test.Tasty.QuickCheck (testProperty, Property, Gen, property, forAll) 27 | 28 | distributesL :: EqProp a => (a -> a -> a) -> (a -> a -> a) -> a -> a -> a -> Property 29 | distributesL (*:) (+:) a b c = a *: (b +: c) =-= (a *: b) +: (a *: c) 30 | 31 | distributesR :: EqProp a => (a -> a -> a) -> (a -> a -> a) -> a -> a -> a -> Property 32 | distributesR (*:) = distributesL (flip (*:)) 33 | 34 | distributes :: (Arbitrary a, EqProp a, Show a) => String -> (a -> a -> a) -> (a -> a -> a) -> TestTree 35 | distributes s (*:) (+:) = testGroup s ts 36 | where ts = [testProperty "left distributes" (distributesL (*:) (+:)), 37 | testProperty "right distributes" (distributesR (*:) (+:))] 38 | 39 | group :: forall a. (Arbitrary a, EqProp a, Group a, Show a) => String -> a -> TestTree 40 | group s _ = testGroup s ts 41 | where 42 | ts = [ testTreeFromBatch (monoid (undefined :: a)) 43 | , testProperty "left inverse element" (\(x :: a) -> x <> invert x =-= mempty) 44 | , testProperty "right inverse element" (\(x :: a) -> invert x <> x =-= mempty) 45 | ] 46 | 47 | abelian :: forall a. (Arbitrary a, EqProp a, Abelian a, Show a) => String -> a -> TestTree 48 | abelian s _ = testGroup s ts 49 | where 50 | ts = [ group "group" (undefined :: a) 51 | , testProperty "commutative" (commutes ((<>) :: a -> a -> a)) 52 | ] 53 | 54 | ring :: forall a. (Arbitrary a, EqProp a, Num a, Show a) => String -> a -> TestTree 55 | ring s _ = testGroup s ts 56 | where 57 | ts = [ abelian "abelian under Sum" (undefined :: Sum a) 58 | , testTreeFromNamedBatch "monoid under product" (monoid (undefined :: Product a)) 59 | , distributes "* distributes over +" (*) ((+) :: a -> a -> a) 60 | ] 61 | 62 | commutativeRing :: forall a. (Arbitrary a, EqProp a, Num a, Show a) => String -> a -> TestTree 63 | commutativeRing s _ = testGroup s ts 64 | where ts = [ring "ring" (undefined :: a), 65 | testProperty "* commutes" (commutes ((*) :: a -> a -> a))] 66 | 67 | -- TODO: Reduce the Ord constraint to an Eq constraint on the new quickcheck 68 | -- release 69 | field :: forall a. (Arbitrary a, EqProp a, Fractional a, Show a, Ord a) => String -> a -> TestTree 70 | field s _ = testGroup s ts 71 | where ts = [abelian "Abelian under Sum" (undefined :: Sum a), 72 | abelian "Abelian under Product NonZero" (undefined :: Product (NonZero a)), 73 | distributes "* distributes over +" (*) ((+) :: a -> a -> a)] 74 | 75 | complement :: forall a. (Arbitrary a, EqProp a, Show a) => 76 | String -> (a -> Gen a) -> BinRel a -> BinRel a -> TestTree 77 | complement s gen r1 r2 = testGroup s ts 78 | where ts = [testProperty "strictOrd" 79 | (property $ \ a -> 80 | forAll (gen a) $ \ b -> 81 | a `r1` b <=> not (a `r2` b)) 82 | ] 83 | 84 | strictTotalOrd 85 | :: forall a 86 | . (Arbitrary a, EqProp a, Eq a, Show a) 87 | => String 88 | -> (a -> Gen a) 89 | -> BinRel a 90 | -> TestTree 91 | strictTotalOrd s gen r = testGroup s ts 92 | where 93 | ts = 94 | [ testProperty "irreflexive" (property $ \a -> not (a `r` a)) 95 | , testProperty "transitive" $ transitive r gen 96 | , testProperty 97 | "connected" 98 | ( property 99 | $ \a -> forAll (gen a) $ \b -> (a /= b) ==> (a `r` b) || (b `r` a) 100 | ) 101 | ] 102 | -------------------------------------------------------------------------------- /test/Test/QuickCheck/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | -- | Add some more newtypes for restricting arbitrary instances 7 | module Test.QuickCheck.Extra 8 | ( module Test.QuickCheck 9 | , UnitInterval(..) 10 | , BiunitInterval(..) 11 | , Tiny(..) 12 | , (<=>) 13 | ) where 14 | 15 | import Test.QuickCheck 16 | import Test.QuickCheck.Checkers (EqProp) 17 | import System.Random (Random) 18 | 19 | deriving instance Num a => Num (NonZero a) 20 | deriving instance Fractional a => Fractional (NonZero a) 21 | deriving instance EqProp a => EqProp (NonZero a) 22 | 23 | deriving instance Num a => Num (Positive a) 24 | deriving instance Fractional a => Fractional (Positive a) 25 | deriving instance Floating a => Floating (Positive a) 26 | deriving instance EqProp a => EqProp (Positive a) 27 | 28 | deriving instance Num a => Num (NonNegative a) 29 | deriving instance Fractional a => Fractional (NonNegative a) 30 | deriving instance Floating a => Floating (NonNegative a) 31 | deriving instance EqProp a => EqProp (NonNegative a) 32 | 33 | newtype UnitInterval a = UnitInterval a 34 | deriving(Eq, Ord, Show, Read, Num, Integral, Fractional, Floating, Real, Enum, Functor, Random, EqProp) 35 | 36 | instance (Arbitrary a, Num a, Random a) => Arbitrary (UnitInterval a) where 37 | arbitrary = choose (0, 1) 38 | shrink (UnitInterval a) = UnitInterval <$> shrink a 39 | 40 | newtype BiunitInterval a = BiunitInterval a 41 | deriving(Eq, Ord, Show, Read, Num, Integral, Fractional, Floating, Real, Enum, Functor, Random, EqProp) 42 | 43 | instance (Arbitrary a, Num a, Random a) => Arbitrary (BiunitInterval a) where 44 | arbitrary = choose (-1, 1) 45 | shrink (BiunitInterval a) = BiunitInterval <$> shrink a 46 | 47 | newtype Tiny a = Tiny a 48 | deriving(Eq, Ord, Show, Read, Num, Integral, Fractional, Floating, Real, Enum, Functor, Random, EqProp) 49 | 50 | -- | Chosen rather arbitrarily just so the tests involving exponentiation don't take too long 51 | tinyBound :: Num a => a 52 | tinyBound = 1000000000 53 | 54 | instance (Num a, Ord a, Arbitrary a) => Arbitrary (Tiny a) where 55 | arbitrary = Tiny <$> arbitrary `suchThat` ((< tinyBound) . abs) 56 | 57 | (<=>) :: Bool -> Bool -> Bool 58 | (<=>) = (==) 59 | -------------------------------------------------------------------------------- /test/Test/Tasty/Extra.hs: -------------------------------------------------------------------------------- 1 | module Test.Tasty.Extra 2 | ( module Test.Tasty 3 | , testTreeFromBatch 4 | , testTreeFromNamedBatch) where 5 | 6 | import Test.Tasty (testGroup, TestTree) 7 | import Test.Tasty.QuickCheck (testProperty) 8 | import Test.QuickCheck.Checkers (TestBatch) 9 | 10 | testTreeFromBatch :: TestBatch -> TestTree 11 | testTreeFromBatch (n, ts) = testTreeFromNamedBatch n (n, ts) 12 | 13 | testTreeFromNamedBatch :: String -> TestBatch -> TestTree 14 | testTreeFromNamedBatch n (_, ts) = testGroup n ts' 15 | where ts' = uncurry testProperty <$> ts 16 | 17 | --------------------------------------------------------------------------------