├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── .hlint.yaml ├── CHANGELOG.markdown ├── LICENSE ├── README.markdown ├── Setup.lhs ├── cabal.haskell-ci ├── cabal.project ├── intervals.cabal ├── src └── Numeric │ ├── Interval.hs │ └── Interval │ ├── Exception.hs │ ├── Internal.hs │ ├── Kaucher.hs │ ├── NonEmpty.hs │ └── NonEmpty │ └── Internal.hs └── tests └── doctests.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250115 12 | # 13 | # REGENDATA ("0.19.20250115",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.1 32 | compilerKind: ghc 33 | compilerVersion: 9.12.1 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.10.1 37 | compilerKind: ghc 38 | compilerVersion: 9.10.1 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.8.4 42 | compilerKind: ghc 43 | compilerVersion: 9.8.4 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.6.6 47 | compilerKind: ghc 48 | compilerVersion: 9.6.6 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.4.8 52 | compilerKind: ghc 53 | compilerVersion: 9.4.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.2.8 57 | compilerKind: ghc 58 | compilerVersion: 9.2.8 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-9.0.2 62 | compilerKind: ghc 63 | compilerVersion: 9.0.2 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.10.7 67 | compilerKind: ghc 68 | compilerVersion: 8.10.7 69 | setup-method: ghcup 70 | allow-failure: false 71 | - compiler: ghc-8.8.4 72 | compilerKind: ghc 73 | compilerVersion: 8.8.4 74 | setup-method: ghcup 75 | allow-failure: false 76 | - compiler: ghc-8.6.5 77 | compilerKind: ghc 78 | compilerVersion: 8.6.5 79 | setup-method: ghcup 80 | allow-failure: false 81 | - compiler: ghc-8.4.4 82 | compilerKind: ghc 83 | compilerVersion: 8.4.4 84 | setup-method: ghcup 85 | allow-failure: false 86 | - compiler: ghc-8.2.2 87 | compilerKind: ghc 88 | compilerVersion: 8.2.2 89 | setup-method: ghcup 90 | allow-failure: false 91 | - compiler: ghc-8.0.2 92 | compilerKind: ghc 93 | compilerVersion: 8.0.2 94 | setup-method: ghcup 95 | allow-failure: false 96 | fail-fast: false 97 | steps: 98 | - name: apt-get install 99 | run: | 100 | apt-get update 101 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 102 | - name: Install GHCup 103 | run: | 104 | mkdir -p "$HOME/.ghcup/bin" 105 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 106 | chmod a+x "$HOME/.ghcup/bin/ghcup" 107 | - name: Install cabal-install 108 | run: | 109 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 110 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 111 | - name: Install GHC (GHCup) 112 | if: matrix.setup-method == 'ghcup' 113 | run: | 114 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 115 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 116 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 117 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 118 | echo "HC=$HC" >> "$GITHUB_ENV" 119 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 120 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 121 | env: 122 | HCKIND: ${{ matrix.compilerKind }} 123 | HCNAME: ${{ matrix.compiler }} 124 | HCVER: ${{ matrix.compilerVersion }} 125 | - name: Set PATH and environment variables 126 | run: | 127 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 128 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 129 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 130 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 131 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 132 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 133 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 134 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 135 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 136 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 137 | env: 138 | HCKIND: ${{ matrix.compilerKind }} 139 | HCNAME: ${{ matrix.compiler }} 140 | HCVER: ${{ matrix.compilerVersion }} 141 | - name: env 142 | run: | 143 | env 144 | - name: write cabal config 145 | run: | 146 | mkdir -p $CABAL_DIR 147 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 180 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 181 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 182 | rm -f cabal-plan.xz 183 | chmod a+x $HOME/.cabal/bin/cabal-plan 184 | cabal-plan --version 185 | - name: install cabal-docspec 186 | run: | 187 | mkdir -p $HOME/.cabal/bin 188 | curl -sL https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20240703/cabal-docspec-0.0.0.20240703-x86_64-linux.xz > cabal-docspec.xz 189 | echo '48bf3b7fd2f7f0caa6162afee57a755be8523e7f467b694900eb420f5f9a7b76 cabal-docspec.xz' | sha256sum -c - 190 | xz -d < cabal-docspec.xz > $HOME/.cabal/bin/cabal-docspec 191 | rm -f cabal-docspec.xz 192 | chmod a+x $HOME/.cabal/bin/cabal-docspec 193 | cabal-docspec --version 194 | - name: checkout 195 | uses: actions/checkout@v4 196 | with: 197 | path: source 198 | - name: initial cabal.project for sdist 199 | run: | 200 | touch cabal.project 201 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 202 | cat cabal.project 203 | - name: sdist 204 | run: | 205 | mkdir -p sdist 206 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 207 | - name: unpack 208 | run: | 209 | mkdir -p unpacked 210 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 211 | - name: generate cabal.project 212 | run: | 213 | PKGDIR_intervals="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/intervals-[0-9.]*')" 214 | echo "PKGDIR_intervals=${PKGDIR_intervals}" >> "$GITHUB_ENV" 215 | rm -f cabal.project cabal.project.local 216 | touch cabal.project 217 | touch cabal.project.local 218 | echo "packages: ${PKGDIR_intervals}" >> cabal.project 219 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package intervals" >> cabal.project ; fi 220 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi 221 | cat >> cabal.project <> cabal.project.local 224 | cat cabal.project 225 | cat cabal.project.local 226 | - name: dump install plan 227 | run: | 228 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 229 | cabal-plan 230 | - name: restore cache 231 | uses: actions/cache/restore@v4 232 | with: 233 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 234 | path: ~/.cabal/store 235 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 236 | - name: install dependencies 237 | run: | 238 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 239 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 240 | - name: build 241 | run: | 242 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 243 | - name: tests 244 | run: | 245 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 246 | - name: docspec 247 | run: | 248 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all 249 | cabal-docspec $ARG_COMPILER 250 | - name: cabal check 251 | run: | 252 | cd ${PKGDIR_intervals} || false 253 | ${CABAL} -vnormal check 254 | - name: haddock 255 | run: | 256 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 257 | - name: save cache 258 | if: always() 259 | uses: actions/cache/save@v4 260 | with: 261 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 262 | path: ~/.cabal/store 263 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | .hsenv/ 4 | docs 5 | wiki 6 | TAGS 7 | tags 8 | wip 9 | .DS_Store 10 | .*.swp 11 | .*.swo 12 | *.o 13 | *.hi 14 | *~ 15 | *# 16 | .cabal-sandbox/ 17 | cabal.sandbox.config 18 | .stack-work/ 19 | stack.yaml 20 | cabal-dev 21 | *.chi 22 | *.chs.h 23 | *.dyn_o 24 | *.dyn_hi 25 | .hpc 26 | .hsenv 27 | *.prof 28 | *.aux 29 | *.hp 30 | *.eventlog 31 | cabal.project.local 32 | cabal.project.local~ 33 | .HTF/ 34 | .ghc.environment.* 35 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - arguments: [--cpp-define=HLINT, --cpp-ansi] 2 | 3 | # not viable 4 | - ignore: {name: Reduce duplication} 5 | 6 | # don't want to! 7 | - ignore: {name: Use infix} 8 | 9 | # these don't consider the corner cases when using doubles 10 | - ignore: {name: "Use >"} 11 | - ignore: {name: "Use <="} 12 | - ignore: {name: "Use >="} 13 | -------------------------------------------------------------------------------- /CHANGELOG.markdown: -------------------------------------------------------------------------------- 1 | 0.9.3 [2024.12.04] 2 | ------------------ 3 | * Drop support for pre-8.0 versions of GHC. 4 | 5 | 0.9.2 [2021.02.17] 6 | ------------------ 7 | * Export `(/=!)` and `(/=?)` operators. 8 | * The build-type has been changed from `Custom` to `Simple`. 9 | To achieve this, the `doctests` test suite has been removed in favor of using 10 | [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) 11 | to run the doctests. 12 | 13 | 0.9.1 [2020.01.29] 14 | ------------------ 15 | * Add `Semigroup` instances for the `Interval` types in `Numeric.Interval`, 16 | `Numeric.Interval.Kaucher`, and `Numeric.Interval.NonEmpty`. 17 | Add a `Monoid` instance for the `Interval` type in `Numeric.Interval`. 18 | 19 | 0.9 [2019.05.10] 20 | ---------------- 21 | * Remove the `Foldable` instances for the `Interval` types from 22 | `Numeric.Interval` and `Numeric.Interval.NonEmpty`. 23 | 24 | 0.8.1 25 | ----- 26 | * Support `doctest-0.12` 27 | 28 | 0.8 29 | --- 30 | * `Eq` and `Ord` instances are now structural 31 | * Deprecate `elem` and `notElem` in favor of `member` and `nonMember` 32 | * Add `iquot`, `irem`, `idiv`, and `imod` functions 33 | * Relax `Fractional` constraint in `deflate` to `Num` 34 | * Revamp `Setup.hs` to use `cabal-doctest`. This makes it build 35 | with `Cabal-2.0`, and makes the `doctest`s work with `cabal new-build` and 36 | sandboxes. 37 | 38 | 0.7.2 39 | ----- 40 | * Redundant constraint cleanup 41 | * GHC 8 support 42 | * Added a flag for building with 'herbie' 43 | 44 | 0.7.1.1 45 | ------- 46 | * Redundant import cleanup 47 | 48 | 0.7.1 49 | ----- 50 | * Now compatible with GHC 7.10.1-rc1 51 | * Fixed a number of broken `#if` pragmas, fixing previously missing instances. 52 | 53 | 0.7.0.1 54 | ------- 55 | * Removed a couple of unnecessary `Fractional` constraints. 56 | 57 | 0.7 58 | --- 59 | * Corrected the definition of `mignitude`. 60 | * Added a notion of `distance` between intervals 61 | 62 | 0.6 63 | --- 64 | * Added `Numeric.Interval.Exception`. For consistency, we tend to throw exceptions now instead of rely on `NaN` when working with empty intervals. 65 | 66 | 0.5.1.1 67 | ------- 68 | * Misc `doctest` fixes. 69 | 70 | 0.5.1 71 | ----- 72 | * Added `interval` to facilitate the construction of known non-empty intervals. 73 | 74 | 0.5 75 | --- 76 | * The default `Numeric.Interval` now deals more conventionally with empty intervals. 77 | * The old "Kaucher directed interval" behavior is available as `Numeric.Interval.Kaucher`. 78 | * Strictly Non-Empty intervals are now contained in `Numeric.Interval.NonEmpty` 79 | * Renamed `bisection` to `bisect`. 80 | * Added `bisectIntegral`. 81 | 82 | 0.4.2 83 | ----- 84 | * Added `clamp` 85 | 86 | 0.4 87 | --- 88 | * Distributive Interval 89 | 90 | 0.3 91 | --- 92 | * Removed dependency on `numeric-extras` 93 | 94 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010-2013, Edward Kmett 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 18 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 19 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 20 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 21 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 22 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 23 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 24 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 25 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 26 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | intervals 2 | ========== 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/intervals.svg)](https://hackage.haskell.org/package/intervals) [![Build Status](https://github.com/ekmett/intervals/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/intervals/actions?query=workflow%3AHaskell-CI) 5 | 6 | Basic interval arithmetic 7 | 8 | Contact Information 9 | ------------------- 10 | 11 | Contributions and bug reports are welcome! 12 | 13 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 14 | 15 | -Edward Kmett 16 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | > module Main (main) where 3 | 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | no-tests-no-benchmarks: False 2 | unconstrained: False 3 | -- irc-channels: irc.freenode.org#haskell-lens 4 | irc-if-in-origin-repo: True 5 | docspec: True 6 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /intervals.cabal: -------------------------------------------------------------------------------- 1 | name: intervals 2 | version: 0.9.3 3 | synopsis: Interval Arithmetic 4 | description: 5 | A 'Numeric.Interval.Interval' is a closed, convex set of floating point values. 6 | . 7 | We do not control the rounding mode of the end points of the interval when 8 | using floating point arithmetic, so be aware that in order to get precise 9 | containment of the result, you will need to use an underlying type with 10 | both lower and upper bounds like 'CReal' 11 | homepage: http://github.com/ekmett/intervals 12 | bug-reports: http://github.com/ekmett/intervals/issues 13 | license: BSD3 14 | license-file: LICENSE 15 | author: Edward Kmett 16 | maintainer: ekmett@gmail.com 17 | category: Math 18 | build-type: Simple 19 | cabal-version: >=1.10 20 | tested-with: GHC == 8.0.2 21 | , GHC == 8.2.2 22 | , GHC == 8.4.4 23 | , GHC == 8.6.5 24 | , GHC == 8.8.4 25 | , GHC == 8.10.7 26 | , GHC == 9.0.2 27 | , GHC == 9.2.8 28 | , GHC == 9.4.8 29 | , GHC == 9.6.6 30 | , GHC == 9.8.4 31 | , GHC == 9.10.1 32 | , GHC == 9.12.1 33 | extra-source-files: 34 | .hlint.yaml 35 | CHANGELOG.markdown 36 | README.markdown 37 | 38 | source-repository head 39 | type: git 40 | location: git://github.com/ekmett/intervals.git 41 | 42 | flag herbie 43 | default: False 44 | manual: True 45 | 46 | library 47 | hs-source-dirs: src 48 | 49 | exposed-modules: 50 | Numeric.Interval 51 | Numeric.Interval.Exception 52 | Numeric.Interval.Internal 53 | Numeric.Interval.Kaucher 54 | Numeric.Interval.NonEmpty 55 | Numeric.Interval.NonEmpty.Internal 56 | 57 | build-depends: 58 | array >= 0.3 && < 0.6, 59 | base >= 4.9 && < 5, 60 | distributive >= 0.2 && < 1, 61 | ghc-prim 62 | 63 | ghc-options: -Wall -O2 64 | 65 | if flag(herbie) 66 | build-depends: HerbiePlugin >= 0.1 && < 0.2 67 | cpp-options: -DHERBIE 68 | ghc-options: -fplugin=Herbie 69 | 70 | default-language: Haskell2010 71 | x-docspec-options: --check-properties 72 | x-docspec-property-variables: i x y xs ys 73 | 74 | test-suite doctests 75 | type: exitcode-stdio-1.0 76 | main-is: doctests.hs 77 | ghc-options: -Wall -threaded 78 | hs-source-dirs: tests 79 | build-depends: base >= 4.9 && < 5 80 | , QuickCheck >=2.14.2 81 | default-language: Haskell2010 82 | -------------------------------------------------------------------------------- /src/Numeric/Interval.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Numeric.Interval 4 | -- Copyright : (c) Edward Kmett 2010-2014 5 | -- License : BSD3 6 | -- Maintainer : ekmett@gmail.com 7 | -- Stability : experimental 8 | -- Portability : DeriveDataTypeable 9 | -- 10 | -- Interval arithmetic 11 | ----------------------------------------------------------------------------- 12 | module Numeric.Interval 13 | ( Interval 14 | , (...) 15 | , (+/-) 16 | , interval 17 | , whole 18 | , empty 19 | , null 20 | , singleton 21 | , member 22 | , notMember 23 | , elem 24 | , notElem 25 | , inf 26 | , sup 27 | , singular 28 | , width 29 | , midpoint 30 | , intersection 31 | , hull 32 | , bisect 33 | , bisectIntegral 34 | , magnitude 35 | , mignitude 36 | , distance 37 | , inflate, deflate 38 | , scale, symmetric 39 | , contains 40 | , isSubsetOf 41 | , certainly, (=!), (>!) 42 | , possibly, (=?), (>?) 43 | , idouble 44 | , ifloat 45 | , iquot 46 | , irem 47 | , idiv 48 | , imod 49 | ) where 50 | 51 | import Numeric.Interval.Internal 52 | import Prelude () 53 | -------------------------------------------------------------------------------- /src/Numeric/Interval/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module Numeric.Interval.Exception 3 | ( EmptyInterval(..) 4 | , AmbiguousComparison(..) 5 | ) where 6 | 7 | import Control.Exception 8 | import Data.Data 9 | 10 | data EmptyInterval = EmptyInterval 11 | deriving (Eq,Ord,Data) 12 | 13 | instance Show EmptyInterval where 14 | show EmptyInterval = "empty interval" 15 | 16 | instance Exception EmptyInterval 17 | 18 | data AmbiguousComparison = AmbiguousComparison 19 | deriving (Eq,Ord,Data) 20 | 21 | instance Show AmbiguousComparison where 22 | show AmbiguousComparison = "ambiguous comparison" 23 | 24 | instance Exception AmbiguousComparison 25 | -------------------------------------------------------------------------------- /src/Numeric/Interval/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# OPTIONS_HADDOCK not-home #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Numeric.Interval.Internal 9 | -- Copyright : (c) Edward Kmett 2010-2013 10 | -- License : BSD3 11 | -- Maintainer : ekmett@gmail.com 12 | -- Stability : experimental 13 | -- Portability : DeriveDataTypeable 14 | -- 15 | -- Interval arithmetic 16 | -- 17 | ----------------------------------------------------------------------------- 18 | module Numeric.Interval.Internal 19 | ( Interval(..) 20 | , (...) 21 | , (+/-) 22 | , interval 23 | , whole 24 | , empty 25 | , null 26 | , singleton 27 | , member 28 | , notMember 29 | , elem 30 | , notElem 31 | , inf 32 | , sup 33 | , singular 34 | , width 35 | , midpoint 36 | , intersection 37 | , hull 38 | , bisect 39 | , bisectIntegral 40 | , magnitude 41 | , mignitude 42 | , distance 43 | , inflate, deflate 44 | , scale, symmetric 45 | , contains 46 | , isSubsetOf 47 | , certainly, (=!), (>!) 48 | , possibly, (=?), (>?) 49 | , idouble 50 | , ifloat 51 | , iquot 52 | , irem 53 | , idiv 54 | , imod 55 | ) where 56 | 57 | import Control.Exception as Exception 58 | import Data.Data 59 | import Data.Function (on) 60 | import GHC.Generics 61 | import Numeric.Interval.Exception 62 | import Prelude hiding (null, elem, notElem) 63 | 64 | import qualified Data.Semigroup 65 | import qualified Data.Monoid 66 | 67 | -- $setup 68 | -- >>> :set -XScopedTypeVariables 69 | -- >>> :set -Wno-deprecations 70 | -- >>> import Control.Exception (ArithException(DivideByZero), catch, evaluate) 71 | -- >>> import Control.Monad (guard) 72 | -- >>> import Numeric.Interval.Exception (EmptyInterval(..)) 73 | -- >>> let null = Numeric.Interval.Internal.null 74 | -- >>> let elem = Numeric.Interval.Internal.elem 75 | -- >>> let notElem = Numeric.Interval.Internal.notElem 76 | 77 | data Interval a = I !a !a | Empty deriving 78 | (Eq, Ord, Data, Generic, Generic1) 79 | 80 | -- | 'Data.Semigroup.<>' is 'hull' 81 | instance Ord a => Data.Semigroup.Semigroup (Interval a) where 82 | (<>) = hull 83 | 84 | instance Ord a => Data.Monoid.Monoid (Interval a) where 85 | mempty = empty 86 | mappend = (Data.Semigroup.<>) 87 | 88 | infix 3 ... 89 | infixl 6 +/- 90 | 91 | (+/-) :: (Num a, Ord a) => a -> a -> Interval a 92 | a +/- b = a - b ... a + b 93 | 94 | negInfinity :: Fractional a => a 95 | negInfinity = (-1)/0 96 | {-# INLINE negInfinity #-} 97 | 98 | posInfinity :: Fractional a => a 99 | posInfinity = 1/0 100 | {-# INLINE posInfinity #-} 101 | 102 | interval :: Ord a => a -> a -> Maybe (Interval a) 103 | interval a b 104 | | a <= b = Just $ I a b 105 | | otherwise = Nothing 106 | {-# INLINE interval #-} 107 | 108 | fmod :: RealFrac a => a -> a -> a 109 | fmod a b = a - q*b where 110 | q = realToFrac (truncate $ a / b :: Integer) 111 | {-# INLINE fmod #-} 112 | 113 | (...) :: Ord a => a -> a -> Interval a 114 | a ... b 115 | | a <= b = I a b 116 | | otherwise = Empty 117 | {-# INLINE (...) #-} 118 | 119 | -- | The whole real number line 120 | -- 121 | -- >>> whole 122 | -- -Infinity ... Infinity 123 | whole :: Fractional a => Interval a 124 | whole = I negInfinity posInfinity 125 | {-# INLINE whole #-} 126 | 127 | -- | An empty interval 128 | -- 129 | -- >>> empty 130 | -- Empty 131 | empty :: Interval a 132 | empty = Empty 133 | {-# INLINE empty #-} 134 | 135 | -- | Check if an interval is empty 136 | -- 137 | -- >>> null (1 ... 5) 138 | -- False 139 | -- 140 | -- >>> null (1 ... 1) 141 | -- False 142 | -- 143 | -- >>> null empty 144 | -- True 145 | null :: Interval a -> Bool 146 | null Empty = True 147 | null _ = False 148 | {-# INLINE null #-} 149 | 150 | -- | A singleton point 151 | -- 152 | -- >>> singleton 1 153 | -- 1 ... 1 154 | singleton :: a -> Interval a 155 | singleton a = I a a 156 | {-# INLINE singleton #-} 157 | 158 | -- | The infimum (lower bound) of an interval 159 | -- 160 | -- >>> inf (1.0 ... 20.0) 161 | -- 1.0 162 | -- 163 | -- >>> (evaluate (inf empty) *> pure "not caught") `catch` \(_ :: EmptyInterval) -> pure "caught" 164 | -- "caught" 165 | inf :: Interval a -> a 166 | inf (I a _) = a 167 | inf Empty = Exception.throw EmptyInterval 168 | {-# INLINE inf #-} 169 | 170 | -- | The supremum (upper bound) of an interval 171 | -- 172 | -- >>> sup (1.0 ... 20.0) 173 | -- 20.0 174 | -- 175 | -- >>> (evaluate (sup empty) *> pure "not caught") `catch` \(_ :: EmptyInterval) -> pure "caught" 176 | -- "caught" 177 | sup :: Interval a -> a 178 | sup (I _ b) = b 179 | sup Empty = Exception.throw EmptyInterval 180 | {-# INLINE sup #-} 181 | 182 | -- | Is the interval a singleton point? 183 | -- N.B. This is fairly fragile and likely will not hold after 184 | -- even a few operations that only involve singletons 185 | -- 186 | -- >>> singular (singleton 1) 187 | -- True 188 | -- 189 | -- >>> singular (1.0 ... 20.0) 190 | -- False 191 | singular :: Ord a => Interval a -> Bool 192 | singular Empty = False 193 | singular (I a b) = a == b 194 | {-# INLINE singular #-} 195 | 196 | instance Show a => Show (Interval a) where 197 | showsPrec _ Empty = showString "Empty" 198 | showsPrec n (I a b) = 199 | showParen (n > 3) $ 200 | showsPrec 3 a . 201 | showString " ... " . 202 | showsPrec 3 b 203 | 204 | -- | Calculate the width of an interval. 205 | -- 206 | -- >>> width (1 ... 20) 207 | -- 19 208 | -- 209 | -- >>> width (singleton 1) 210 | -- 0 211 | -- 212 | -- >>> width empty 213 | -- 0 214 | width :: Num a => Interval a -> a 215 | width (I a b) = b - a 216 | width Empty = 0 217 | {-# INLINE width #-} 218 | 219 | -- | Magnitude 220 | -- 221 | -- >>> magnitude (1 ... 20) 222 | -- 20 223 | -- 224 | -- >>> magnitude (-20 ... 10) 225 | -- 20 226 | -- 227 | -- >>> magnitude (singleton 5) 228 | -- 5 229 | -- 230 | -- throws 'EmptyInterval' if the interval is empty. 231 | -- 232 | -- >>> (evaluate (magnitude empty) *> pure "not caught") `catch` \(_ :: EmptyInterval) -> pure "caught" 233 | -- "caught" 234 | magnitude :: (Num a, Ord a) => Interval a -> a 235 | magnitude = sup . abs 236 | {-# INLINE magnitude #-} 237 | 238 | -- | \"mignitude\" 239 | -- 240 | -- >>> mignitude (1 ... 20) 241 | -- 1 242 | -- 243 | -- >>> mignitude (-20 ... 10) 244 | -- 0 245 | -- 246 | -- >>> mignitude (singleton 5) 247 | -- 5 248 | -- 249 | -- throws 'EmptyInterval' if the interval is empty. 250 | -- 251 | -- >>> (evaluate (mignitude empty) *> pure "not caught") `catch` \(_ :: EmptyInterval) -> pure "caught" 252 | -- "caught" 253 | mignitude :: (Num a, Ord a) => Interval a -> a 254 | mignitude = inf . abs 255 | {-# INLINE mignitude #-} 256 | 257 | -- | Hausdorff distance between intervals. 258 | -- 259 | -- >>> distance (1 ... 7) (6 ... 10) 260 | -- 0 261 | -- 262 | -- >>> distance (1 ... 7) (15 ... 24) 263 | -- 8 264 | -- 265 | -- >>> distance (1 ... 7) (-10 ... -2) 266 | -- 3 267 | -- 268 | -- >>> (evaluate (distance Empty (1 ... 1)) *> pure "not caught") `catch` \(_ :: EmptyInterval) -> pure "caught" 269 | -- "caught" 270 | distance :: (Num a, Ord a) => Interval a -> Interval a -> a 271 | distance i1 i2 = mignitude (i1 - i2) 272 | 273 | -- | Inflate an interval by enlarging it at both ends. 274 | -- 275 | -- >>> inflate 3 (-1 ... 7) 276 | -- -4 ... 10 277 | -- 278 | -- >>> inflate (-2) (0 ... 4) 279 | -- -2 ... 6 280 | -- 281 | -- >>> inflate 1 empty 282 | -- Empty 283 | inflate :: (Num a, Ord a) => a -> Interval a -> Interval a 284 | inflate x y = symmetric x + y 285 | 286 | -- | Deflate an interval by shrinking it from both ends. 287 | -- 288 | -- >>> deflate 3.0 (-4.0 ... 10.0) 289 | -- -1.0 ... 7.0 290 | -- 291 | -- >>> deflate 2.0 (-1.0 ... 1.0) 292 | -- Empty 293 | -- 294 | -- >>> deflate 1.0 empty 295 | -- Empty 296 | deflate :: (Num a, Ord a) => a -> Interval a -> Interval a 297 | deflate _ Empty = Empty 298 | deflate x (I a b) | a' <= b' = I a' b' 299 | | otherwise = Empty 300 | where 301 | a' = a + x 302 | b' = b - x 303 | 304 | -- | Scale an interval about its midpoint. 305 | -- 306 | -- >>> scale 1.1 (-6.0 ... 4.0) 307 | -- -6.5 ... 4.5 308 | -- 309 | -- >>> scale (-2.0) (-1.0 ... 1.0) 310 | -- Empty 311 | -- 312 | -- >>> scale 3.0 empty 313 | -- Empty 314 | scale :: (Fractional a, Ord a) => a -> Interval a -> Interval a 315 | scale _ Empty = Empty 316 | scale x i = a ... b where 317 | h = x * width i / 2 318 | mid = midpoint i 319 | a = mid - h 320 | b = mid + h 321 | 322 | -- | Construct a symmetric interval. 323 | -- 324 | -- >>> symmetric 3 325 | -- -3 ... 3 326 | -- 327 | -- >>> symmetric (-2) 328 | -- -2 ... 2 329 | symmetric :: (Num a, Ord a) => a -> Interval a 330 | symmetric x | a <= b = I a b 331 | | otherwise = I b a 332 | where 333 | a = negate x 334 | b = x 335 | 336 | instance (Num a, Ord a) => Num (Interval a) where 337 | I a b + I a' b' = (a + a') ... (b + b') 338 | _ + _ = Empty 339 | {-# INLINE (+) #-} 340 | I a b - I a' b' = (a - b') ... (b - a') 341 | _ - _ = Empty 342 | {-# INLINE (-) #-} 343 | I a b * I a' b' = 344 | minimum [a * a', a * b', b * a', b * b'] 345 | ... 346 | maximum [a * a', a * b', b * a', b * b'] 347 | _ * _ = Empty 348 | {-# INLINE (*) #-} 349 | abs x@(I a b) 350 | | a >= 0 = x 351 | | b <= 0 = negate x 352 | | otherwise = 0 ... max (- a) b 353 | abs Empty = Empty 354 | {-# INLINE abs #-} 355 | 356 | signum = increasing signum 357 | {-# INLINE signum #-} 358 | 359 | fromInteger i = singleton (fromInteger i) 360 | {-# INLINE fromInteger #-} 361 | 362 | -- | Bisect an interval at its midpoint. 363 | -- 364 | -- >>> bisect (10.0 ... 20.0) 365 | -- (10.0 ... 15.0,15.0 ... 20.0) 366 | -- 367 | -- >>> bisect (singleton 5.0) 368 | -- (5.0 ... 5.0,5.0 ... 5.0) 369 | -- 370 | -- >>> bisect Empty 371 | -- (Empty,Empty) 372 | bisect :: Fractional a => Interval a -> (Interval a, Interval a) 373 | bisect Empty = (Empty,Empty) 374 | bisect (I a b) = (I a m, I m b) where m = a + (b - a) / 2 375 | {-# INLINE bisect #-} 376 | 377 | bisectIntegral :: Integral a => Interval a -> (Interval a, Interval a) 378 | bisectIntegral Empty = (Empty, Empty) 379 | bisectIntegral (I a b) 380 | | a == m || b == m = (I a a, I b b) 381 | | otherwise = (I a m, I m b) 382 | where m = a + (b - a) `div` 2 383 | 384 | -- | Nearest point to the midpoint of the interval. 385 | -- 386 | -- >>> midpoint (10.0 ... 20.0) 387 | -- 15.0 388 | -- 389 | -- >>> midpoint (singleton 5.0) 390 | -- 5.0 391 | -- 392 | -- >>> (evaluate (midpoint empty) *> pure "not caught") `catch` \(_ :: EmptyInterval) -> pure "caught" 393 | -- "caught" 394 | midpoint :: Fractional a => Interval a -> a 395 | midpoint (I a b) = a + (b - a) / 2 396 | midpoint Empty = Exception.throw EmptyInterval 397 | {-# INLINE midpoint #-} 398 | 399 | -- | Determine if a point is in the interval. 400 | -- 401 | -- >>> member 3.2 (1.0 ... 5.0) 402 | -- True 403 | -- 404 | -- >>> member 5 (1.0 ... 5.0) 405 | -- True 406 | -- 407 | -- >>> member 1 (1.0 ... 5.0) 408 | -- True 409 | -- 410 | -- >>> member 8 (1.0 ... 5.0) 411 | -- False 412 | -- 413 | -- >>> member 5 empty 414 | -- False 415 | -- 416 | member :: Ord a => a -> Interval a -> Bool 417 | member x (I a b) = x >= a && x <= b 418 | member _ Empty = False 419 | {-# INLINE member #-} 420 | 421 | -- | Determine if a point is not included in the interval 422 | -- 423 | -- >>> notMember 8 (1.0 ... 5.0) 424 | -- True 425 | -- 426 | -- >>> notMember 1.4 (1.0 ... 5.0) 427 | -- False 428 | -- 429 | -- And of course, nothing is a member of the empty interval. 430 | -- 431 | -- >>> notMember 5 empty 432 | -- True 433 | notMember :: Ord a => a -> Interval a -> Bool 434 | notMember x xs = not (member x xs) 435 | {-# INLINE notMember #-} 436 | 437 | -- | Determine if a point is in the interval. 438 | -- 439 | -- >>> elem 3.2 (1.0 ... 5.0) 440 | -- True 441 | -- 442 | -- >>> elem 5 (1.0 ... 5.0) 443 | -- True 444 | -- 445 | -- >>> elem 1 (1.0 ... 5.0) 446 | -- True 447 | -- 448 | -- >>> elem 8 (1.0 ... 5.0) 449 | -- False 450 | -- 451 | -- >>> elem 5 empty 452 | -- False 453 | -- 454 | elem :: Ord a => a -> Interval a -> Bool 455 | elem = member 456 | {-# INLINE elem #-} 457 | {-# DEPRECATED elem "Use `member` instead." #-} 458 | 459 | -- | Determine if a point is not included in the interval 460 | -- 461 | -- >>> notElem 8 (1.0 ... 5.0) 462 | -- True 463 | -- 464 | -- >>> notElem 1.4 (1.0 ... 5.0) 465 | -- False 466 | -- 467 | -- And of course, nothing is a member of the empty interval. 468 | -- 469 | -- >>> notElem 5 empty 470 | -- True 471 | notElem :: Ord a => a -> Interval a -> Bool 472 | notElem = notMember 473 | {-# INLINE notElem #-} 474 | {-# DEPRECATED notElem "Use `notMember` instead." #-} 475 | 476 | -- | 'realToFrac' will use the midpoint 477 | instance Real a => Real (Interval a) where 478 | toRational Empty = Exception.throw EmptyInterval 479 | toRational (I ra rb) = a + (b - a) / 2 where 480 | a = toRational ra 481 | b = toRational rb 482 | {-# INLINE toRational #-} 483 | 484 | -- @'divNonZero' X Y@ assumes @0 `'notElem'` Y@ 485 | divNonZero :: (Fractional a, Ord a) => Interval a -> Interval a -> Interval a 486 | divNonZero (I a b) (I a' b') = 487 | minimum [a / a', a / b', b / a', b / b'] 488 | ... 489 | maximum [a / a', a / b', b / a', b / b'] 490 | divNonZero _ _ = Empty 491 | 492 | -- @'divPositive' X y@ assumes y > 0, and divides @X@ by [0 ... y] 493 | divPositive :: (Fractional a, Ord a) => Interval a -> a -> Interval a 494 | divPositive Empty _ = Empty 495 | divPositive x@(I a b) y 496 | | a == 0 && b == 0 = x 497 | -- b < 0 || isNegativeZero b = negInfinity ... ( b / y) 498 | | b < 0 = negInfinity ... (b / y) 499 | | a < 0 = whole 500 | | otherwise = (a / y) ... posInfinity 501 | {-# INLINE divPositive #-} 502 | 503 | -- divNegative assumes y < 0 and divides the interval @X@ by [y ... 0] 504 | divNegative :: (Fractional a, Ord a) => Interval a -> a -> Interval a 505 | divNegative Empty _ = Empty 506 | divNegative x@(I a b) y 507 | | a == 0 && b == 0 = - x -- flip negative zeros 508 | -- b < 0 || isNegativeZero b = (b / y) ... posInfinity 509 | | b < 0 = (b / y) ... posInfinity 510 | | a < 0 = whole 511 | | otherwise = negInfinity ... (a / y) 512 | {-# INLINE divNegative #-} 513 | 514 | divZero :: (Fractional a, Ord a) => Interval a -> Interval a 515 | divZero x@(I a b) 516 | | a == 0 && b == 0 = x 517 | | otherwise = whole 518 | divZero Empty = Empty 519 | {-# INLINE divZero #-} 520 | 521 | instance (Fractional a, Ord a) => Fractional (Interval a) where 522 | -- TODO: check isNegativeZero properly 523 | _ / Empty = Empty 524 | x / y@(I a b) 525 | | 0 `notElem` y = divNonZero x y 526 | | iz && sz = Exception.throw DivideByZero 527 | | iz = divPositive x a 528 | | sz = divNegative x b 529 | | otherwise = divZero x 530 | where 531 | iz = a == 0 532 | sz = b == 0 533 | recip Empty = Empty 534 | recip (I a b) = on min recip a b ... on max recip a b 535 | {-# INLINE recip #-} 536 | fromRational r = let r' = fromRational r in I r' r' 537 | {-# INLINE fromRational #-} 538 | 539 | instance RealFrac a => RealFrac (Interval a) where 540 | properFraction x = (b, x - fromIntegral b) 541 | where 542 | b = truncate (midpoint x) 543 | {-# INLINE properFraction #-} 544 | ceiling x = ceiling (sup x) 545 | {-# INLINE ceiling #-} 546 | floor x = floor (inf x) 547 | {-# INLINE floor #-} 548 | round x = round (midpoint x) 549 | {-# INLINE round #-} 550 | truncate x = truncate (midpoint x) 551 | {-# INLINE truncate #-} 552 | 553 | instance (RealFloat a, Ord a) => Floating (Interval a) where 554 | pi = singleton pi 555 | {-# INLINE pi #-} 556 | exp = increasing exp 557 | {-# INLINE exp #-} 558 | log (I a b) = (if a > 0 then log a else negInfinity) ... log b 559 | log Empty = Empty 560 | {-# INLINE log #-} 561 | cos Empty = Empty 562 | cos x 563 | | width t >= pi = (-1) ... 1 564 | | inf t >= pi = - cos (t - pi) 565 | | sup t <= pi = decreasing cos t 566 | | sup t <= 2 * pi = (-1) ... cos ((pi * 2 - sup t) `min` inf t) 567 | | otherwise = (-1) ... 1 568 | where 569 | t = fmod x (pi * 2) 570 | {-# INLINE cos #-} 571 | sin Empty = Empty 572 | sin x = cos (x - pi / 2) 573 | {-# INLINE sin #-} 574 | tan Empty = Empty 575 | tan x 576 | | inf t' <= - pi / 2 || sup t' >= pi / 2 = whole 577 | | otherwise = increasing tan x 578 | where 579 | t = x `fmod` pi 580 | t' | t >= pi / 2 = t - pi 581 | | otherwise = t 582 | {-# INLINE tan #-} 583 | asin Empty = Empty 584 | asin (I a b) 585 | | b < -1 || a > 1 = Empty 586 | | otherwise = 587 | (if a <= -1 then -halfPi else asin a) 588 | ... 589 | (if b >= 1 then halfPi else asin b) 590 | where 591 | halfPi = pi / 2 592 | {-# INLINE asin #-} 593 | acos Empty = Empty 594 | acos (I a b) 595 | | b < -1 || a > 1 = Empty 596 | | otherwise = 597 | (if b >= 1 then 0 else acos b) 598 | ... 599 | (if a < -1 then pi else acos a) 600 | {-# INLINE acos #-} 601 | atan = increasing atan 602 | {-# INLINE atan #-} 603 | sinh = increasing sinh 604 | {-# INLINE sinh #-} 605 | cosh Empty = Empty 606 | cosh x@(I a b) 607 | | b < 0 = decreasing cosh x 608 | | a >= 0 = increasing cosh x 609 | | otherwise = I 0 $ cosh $ if - a > b 610 | then a 611 | else b 612 | {-# INLINE cosh #-} 613 | tanh = increasing tanh 614 | {-# INLINE tanh #-} 615 | asinh = increasing asinh 616 | {-# INLINE asinh #-} 617 | acosh Empty = Empty 618 | acosh (I a b) 619 | | b < 1 = Empty 620 | | otherwise = I lo $ acosh b 621 | where lo | a <= 1 = 0 622 | | otherwise = acosh a 623 | {-# INLINE acosh #-} 624 | atanh Empty = Empty 625 | atanh (I a b) 626 | | b < -1 || a > 1 = Empty 627 | | otherwise = 628 | (if a <= - 1 then negInfinity else atanh a) 629 | ... 630 | (if b >= 1 then posInfinity else atanh b) 631 | {-# INLINE atanh #-} 632 | 633 | -- | lift a monotone increasing function over a given interval 634 | increasing :: (a -> b) -> Interval a -> Interval b 635 | increasing f (I a b) = I (f a) (f b) 636 | increasing _ Empty = Empty 637 | 638 | -- | lift a monotone decreasing function over a given interval 639 | decreasing :: (a -> b) -> Interval a -> Interval b 640 | decreasing f (I a b) = I (f b) (f a) 641 | decreasing _ Empty = Empty 642 | 643 | -- | We have to play some semantic games to make these methods make sense. 644 | -- Most compute with the midpoint of the interval. 645 | instance RealFloat a => RealFloat (Interval a) where 646 | floatRadix = floatRadix . midpoint 647 | 648 | floatDigits = floatDigits . midpoint 649 | floatRange = floatRange . midpoint 650 | decodeFloat = decodeFloat . midpoint 651 | encodeFloat m e = singleton (encodeFloat m e) 652 | exponent = exponent . midpoint 653 | significand x = min a b ... max a b 654 | where 655 | (_ ,em) = decodeFloat (midpoint x) 656 | (mi,ei) = decodeFloat (inf x) 657 | (ms,es) = decodeFloat (sup x) 658 | a = encodeFloat mi (ei - em - floatDigits x) 659 | b = encodeFloat ms (es - em - floatDigits x) 660 | scaleFloat _ Empty = Empty 661 | scaleFloat n (I a b) = I (scaleFloat n a) (scaleFloat n b) 662 | isNaN (I a b) = isNaN a || isNaN b 663 | isNaN Empty = True 664 | isInfinite (I a b) = isInfinite a || isInfinite b 665 | isInfinite Empty = False 666 | isDenormalized (I a b) = isDenormalized a || isDenormalized b 667 | isDenormalized Empty = False 668 | -- contains negative zero 669 | isNegativeZero (I a b) = not (a > 0) 670 | && not (b < 0) 671 | && ( (b == 0 && (a < 0 || isNegativeZero a)) 672 | || (a == 0 && isNegativeZero a) 673 | || (a < 0 && b >= 0)) 674 | isNegativeZero Empty = False 675 | isIEEE _ = False 676 | 677 | atan2 = error "unimplemented" 678 | 679 | -- TODO: (^), (^^) to give tighter bounds 680 | 681 | -- | Calculate the intersection of two intervals. 682 | -- 683 | -- >>> intersection (1 ... 10 :: Interval Double) (5 ... 15 :: Interval Double) 684 | -- 5.0 ... 10.0 685 | intersection :: Ord a => Interval a -> Interval a -> Interval a 686 | intersection x@(I a b) y@(I a' b') 687 | | x /=! y = Empty 688 | | otherwise = I (max a a') (min b b') 689 | intersection _ _ = Empty 690 | {-# INLINE intersection #-} 691 | 692 | -- | Calculate the convex hull of two intervals 693 | -- 694 | -- >>> hull (0 ... 10 :: Interval Double) (5 ... 15 :: Interval Double) 695 | -- 0.0 ... 15.0 696 | -- 697 | -- >>> hull (15 ... 85 :: Interval Double) (0 ... 10 :: Interval Double) 698 | -- 0.0 ... 85.0 699 | hull :: Ord a => Interval a -> Interval a -> Interval a 700 | hull (I a b) (I a' b') = I (min a a') (max b b') 701 | hull Empty x = x 702 | hull x Empty = x 703 | {-# INLINE hull #-} 704 | 705 | -- | For all @x@ in @X@, @y@ in @Y@. @x '<' y@ 706 | -- 707 | -- >>> (5 ... 10 :: Interval Double) >> (5 ... 10 :: Interval Double) >> (20 ... 30 :: Interval Double) Interval a -> Interval a -> Bool 716 | Empty >> (5 ... 10 :: Interval Double) <=! (20 ... 30 :: Interval Double) 724 | -- True 725 | -- 726 | -- >>> (5 ... 10 :: Interval Double) <=! (10 ... 30 :: Interval Double) 727 | -- True 728 | -- 729 | -- >>> (20 ... 30 :: Interval Double) <=! (5 ... 10 :: Interval Double) 730 | -- False 731 | (<=!) :: Ord a => Interval a -> Interval a -> Bool 732 | Empty <=! _ = True 733 | _ <=! Empty = True 734 | I _ bx <=! I ay _ = bx <= ay 735 | {-# INLINE (<=!) #-} 736 | 737 | -- | For all @x@ in @X@, @y@ in @Y@. @x '==' y@ 738 | -- 739 | -- Only singleton intervals or empty intervals can return true 740 | -- 741 | -- >>> (singleton 5 :: Interval Double) ==! (singleton 5 :: Interval Double) 742 | -- True 743 | -- 744 | -- >>> (5 ... 10 :: Interval Double) ==! (5 ... 10 :: Interval Double) 745 | -- False 746 | (==!) :: Eq a => Interval a -> Interval a -> Bool 747 | Empty ==! _ = True 748 | _ ==! Empty = True 749 | I ax bx ==! I ay by = bx == ay && ax == by 750 | {-# INLINE (==!) #-} 751 | 752 | -- | For all @x@ in @X@, @y@ in @Y@. @x '/=' y@ 753 | -- 754 | -- >>> (5 ... 15 :: Interval Double) /=! (20 ... 40 :: Interval Double) 755 | -- True 756 | -- 757 | -- >>> (5 ... 15 :: Interval Double) /=! (15 ... 40 :: Interval Double) 758 | -- False 759 | (/=!) :: Ord a => Interval a -> Interval a -> Bool 760 | Empty /=! _ = True 761 | _ /=! Empty = True 762 | I ax bx /=! I ay by = bx < ay || ax > by 763 | {-# INLINE (/=!) #-} 764 | 765 | -- | For all @x@ in @X@, @y@ in @Y@. @x '>' y@ 766 | -- 767 | -- >>> (20 ... 40 :: Interval Double) >! (10 ... 19 :: Interval Double) 768 | -- True 769 | -- 770 | -- >>> (5 ... 20 :: Interval Double) >! (15 ... 40 :: Interval Double) 771 | -- False 772 | (>!) :: Ord a => Interval a -> Interval a -> Bool 773 | Empty >! _ = True 774 | _ >! Empty = True 775 | I ax _ >! I _ by = ax > by 776 | {-# INLINE (>!) #-} 777 | 778 | -- | For all @x@ in @X@, @y@ in @Y@. @x '>=' y@ 779 | -- 780 | -- >>> (20 ... 40 :: Interval Double) >=! (10 ... 20 :: Interval Double) 781 | -- True 782 | -- 783 | -- >>> (5 ... 20 :: Interval Double) >=! (15 ... 40 :: Interval Double) 784 | -- False 785 | (>=!) :: Ord a => Interval a -> Interval a -> Bool 786 | Empty >=! _ = True 787 | _ >=! Empty = True 788 | I ax _ >=! I _ by = ax >= by 789 | {-# INLINE (>=!) #-} 790 | 791 | -- | For all @x@ in @X@, @y@ in @Y@. @x `op` y@ 792 | certainly :: Ord a => (forall b. Ord b => b -> b -> Bool) -> Interval a -> Interval a -> Bool 793 | certainly cmp l r 794 | | lt && eq && gt = True 795 | | lt && eq = l <=! r 796 | | lt && gt = l /=! r 797 | | lt = l =! r 799 | | eq = l ==! r 800 | | gt = l >! r 801 | | otherwise = False 802 | where 803 | lt = cmp False True 804 | eq = cmp True True 805 | gt = cmp True False 806 | {-# INLINE certainly #-} 807 | 808 | -- | Check if interval @X@ totally contains interval @Y@ 809 | -- 810 | -- >>> (20 ... 40 :: Interval Double) `contains` (25 ... 35 :: Interval Double) 811 | -- True 812 | -- 813 | -- >>> (20 ... 40 :: Interval Double) `contains` (15 ... 35 :: Interval Double) 814 | -- False 815 | contains :: Ord a => Interval a -> Interval a -> Bool 816 | contains _ Empty = True 817 | contains (I ax bx) (I ay by) = ax <= ay && by <= bx 818 | contains Empty I{} = False 819 | {-# INLINE contains #-} 820 | 821 | -- | Flipped version of `contains`. Check if interval @X@ a subset of interval @Y@ 822 | -- 823 | -- >>> (25 ... 35 :: Interval Double) `isSubsetOf` (20 ... 40 :: Interval Double) 824 | -- True 825 | -- 826 | -- >>> (20 ... 40 :: Interval Double) `isSubsetOf` (15 ... 35 :: Interval Double) 827 | -- False 828 | isSubsetOf :: Ord a => Interval a -> Interval a -> Bool 829 | isSubsetOf = flip contains 830 | {-# INLINE isSubsetOf #-} 831 | 832 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@? 833 | ( Interval a -> Interval a -> Bool 834 | Empty Interval a -> Interval a -> Bool 841 | Empty <=? _ = False 842 | _ <=? Empty = False 843 | I ax _ <=? I _ by = ax <= by 844 | {-# INLINE (<=?) #-} 845 | 846 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@? 847 | (==?) :: Ord a => Interval a -> Interval a -> Bool 848 | I ax bx ==? I ay by = ax <= by && bx >= ay 849 | _ ==? _ = False 850 | {-# INLINE (==?) #-} 851 | 852 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@? 853 | (/=?) :: Eq a => Interval a -> Interval a -> Bool 854 | I ax bx /=? I ay by = ax /= by || bx /= ay 855 | _ /=? _ = False 856 | {-# INLINE (/=?) #-} 857 | 858 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@? 859 | (>?) :: Ord a => Interval a -> Interval a -> Bool 860 | I _ bx >? I ay _ = bx > ay 861 | _ >? _ = False 862 | {-# INLINE (>?) #-} 863 | 864 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@? 865 | (>=?) :: Ord a => Interval a -> Interval a -> Bool 866 | I _ bx >=? I ay _ = bx >= ay 867 | _ >=? _ = False 868 | {-# INLINE (>=?) #-} 869 | 870 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x `op` y@? 871 | possibly :: Ord a => (forall b. Ord b => b -> b -> Bool) -> Interval a -> Interval a -> Bool 872 | possibly cmp l r 873 | | lt && eq && gt = True 874 | | lt && eq = l <=? r 875 | | lt && gt = l /=? r 876 | | lt = l =? r 878 | | eq = l ==? r 879 | | gt = l >? r 880 | | otherwise = False 881 | where 882 | lt = cmp LT EQ 883 | eq = cmp EQ EQ 884 | gt = cmp GT EQ 885 | {-# INLINE possibly #-} 886 | 887 | -- | id function. Useful for type specification 888 | -- 889 | -- >>> :t idouble (1 ... 3) 890 | -- idouble (1 ... 3) :: Interval Double 891 | idouble :: Interval Double -> Interval Double 892 | idouble = id 893 | 894 | -- | id function. Useful for type specification 895 | -- 896 | -- >>> :t ifloat (1 ... 3) 897 | -- ifloat (1 ... 3) :: Interval Float 898 | ifloat :: Interval Float -> Interval Float 899 | ifloat = id 900 | 901 | -- Bugs: 902 | -- sin 1 :: Interval Double 903 | 904 | default (Integer,Double) 905 | 906 | -- | an interval containing all x `quot` y 907 | -- >>> (5 `quot` 3) `member` ((4...6) `iquot` (2...4)) 908 | -- True 909 | -- >>> (evaluate ((1...10) `iquot` ((-5)...4)) *> pure "not caught") `catch` \e -> "caught" <$ guard (e == DivideByZero) 910 | -- "caught" 911 | iquot :: Integral a => Interval a -> Interval a -> Interval a 912 | iquot i j = case (i,j) of 913 | (Empty,_) -> Empty 914 | (_,Empty) -> Empty 915 | (I l u , I l' u') -> 916 | if l' <= 0 && 0 <= u' then throw DivideByZero else I 917 | (minimum [a `quot` b | a <- [l,u], b <- [l',u']]) 918 | (maximum [a `quot` b | a <- [l,u], b <- [l',u']]) 919 | 920 | -- | an interval containing all x `rem` y 921 | -- >>> (5 `rem` 3) `member` ((4...6) `irem` (2...4)) 922 | -- True 923 | -- >>> (evaluate ((1...10) `irem` ((-5)...4)) *> pure "not caught") `catch` \e -> "caught" <$ guard (e == DivideByZero) 924 | -- "caught" 925 | irem :: Integral a => Interval a -> Interval a -> Interval a 926 | irem i j = case (i,j) of 927 | (Empty,_) -> Empty 928 | (_,Empty) -> Empty 929 | (I l u , I l' u') -> 930 | if l' <= 0 && 0 <= u' then throw DivideByZero else I 931 | (minimum [0, signum l * (abs u' - 1), signum l * (abs l' - 1)]) 932 | (maximum [0, signum u * (abs u' - 1), signum u * (abs l' - 1)]) 933 | 934 | -- | an interval containing all x `div` y 935 | -- >>> (5 `div` 3) `member` ((4...6) `idiv` (2...4)) 936 | -- True 937 | -- >>> (evaluate ((1...10) `idiv` ((-5)...4)) *> pure "not caught") `catch` \e -> "caught" <$ guard (e == DivideByZero) 938 | -- "caught" 939 | idiv :: Integral a => Interval a -> Interval a -> Interval a 940 | idiv i j = case (i,j) of 941 | (Empty,_) -> Empty 942 | (_,Empty) -> Empty 943 | (I l u , I l' u') -> 944 | if l' <= 0 && 0 <= u' then throw DivideByZero else I 945 | (min (l `Prelude.div` max 1 l') (u `Prelude.div` min (-1) u')) 946 | (max (u `Prelude.div` max 1 l') (l `Prelude.div` min (-1) u')) 947 | 948 | -- | an interval containing all x `mod` y 949 | -- >>> (5 `mod` 3) `member` ((4...6) `imod` (2...4)) 950 | -- True 951 | -- >>> (evaluate ((1...10) `imod` ((-5)...4)) *> pure "not caught") `catch` \e -> "caught" <$ guard (e == DivideByZero) 952 | -- "caught" 953 | imod :: Integral a => Interval a -> Interval a -> Interval a 954 | imod i j = case (i,j) of 955 | (Empty,_) -> Empty 956 | (_,Empty) -> Empty 957 | (_ , I l' u') -> 958 | if l' <= 0 && 0 <= u' then throw DivideByZero else 959 | I (min (l'+1) 0) (max 0 (u'-1)) 960 | -------------------------------------------------------------------------------- /src/Numeric/Interval/Kaucher.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Numeric.Interval 8 | -- Copyright : (c) Edward Kmett 2010-2014 9 | -- License : BSD3 10 | -- Maintainer : ekmett@gmail.com 11 | -- Stability : experimental 12 | -- Portability : DeriveDataTypeable 13 | -- 14 | -- \"Directed\" Interval arithmetic 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module Numeric.Interval.Kaucher 19 | ( Interval(..) 20 | , (...) 21 | , interval 22 | , whole 23 | , empty 24 | , null 25 | , singleton 26 | , member 27 | , notMember 28 | , elem 29 | , notElem 30 | , inf 31 | , sup 32 | , singular 33 | , width 34 | , midpoint 35 | , intersection 36 | , hull 37 | , bisect 38 | , magnitude 39 | , mignitude 40 | , distance 41 | , inflate, deflate 42 | , scale, symmetric 43 | , contains 44 | , isSubsetOf 45 | , certainly, (=!), (>!) 46 | , possibly, (=?), (>?) 47 | , clamp 48 | , idouble 49 | , ifloat 50 | , iquot 51 | , irem 52 | , idiv 53 | , imod 54 | ) where 55 | 56 | import Control.Applicative hiding (empty) 57 | import Control.Exception as Exception 58 | import Data.Data 59 | import Data.Distributive 60 | import Data.Foldable hiding (minimum, maximum, elem, notElem, null) 61 | import Data.Function (on) 62 | import Data.Traversable 63 | import GHC.Generics 64 | import Numeric.Interval.Exception 65 | import Prelude hiding (null, elem, notElem) 66 | 67 | import qualified Data.Semigroup 68 | import qualified Data.Monoid 69 | 70 | -- $setup 71 | -- >>> :set -Wno-deprecations 72 | -- >>> import Control.Exception (ArithException(DivideByZero), catch, evaluate) 73 | -- >>> import Control.Monad (guard) 74 | -- >>> let null = Numeric.Interval.Kaucher.null 75 | -- >>> let elem = Numeric.Interval.Kaucher.elem 76 | -- >>> let notElem = Numeric.Interval.Kaucher.notElem 77 | 78 | data Interval a = I !a !a deriving 79 | (Eq, Ord, Data, Generic, Generic1) 80 | 81 | -- | 'Data.Semigroup.<>' is 'hull' 82 | instance Ord a => Data.Semigroup.Semigroup (Interval a) where 83 | (<>) = hull 84 | 85 | instance Functor Interval where 86 | fmap f (I a b) = I (f a) (f b) 87 | {-# INLINE fmap #-} 88 | 89 | instance Foldable Interval where 90 | foldMap f (I a b) = f a `Data.Monoid.mappend` f b 91 | {-# INLINE foldMap #-} 92 | 93 | instance Traversable Interval where 94 | traverse f (I a b) = I <$> f a <*> f b 95 | {-# INLINE traverse #-} 96 | 97 | instance Applicative Interval where 98 | pure a = I a a 99 | {-# INLINE pure #-} 100 | I f g <*> I a b = I (f a) (g b) 101 | {-# INLINE (<*>) #-} 102 | 103 | instance Monad Interval where 104 | #if !(MIN_VERSION_base(4,11,0)) 105 | return a = I a a 106 | {-# INLINE return #-} 107 | #endif 108 | I a b >>= f = I a' b' where 109 | I a' _ = f a 110 | I _ b' = f b 111 | {-# INLINE (>>=) #-} 112 | 113 | instance Distributive Interval where 114 | distribute f = fmap inf f ... fmap sup f 115 | {-# INLINE distribute #-} 116 | 117 | infix 3 ... 118 | 119 | negInfinity :: Fractional a => a 120 | negInfinity = (-1)/0 121 | {-# INLINE negInfinity #-} 122 | 123 | posInfinity :: Fractional a => a 124 | posInfinity = 1/0 125 | {-# INLINE posInfinity #-} 126 | 127 | nan :: Fractional a => a 128 | nan = 0/0 129 | 130 | fmod :: RealFrac a => a -> a -> a 131 | fmod a b = a - q*b where 132 | q = realToFrac (truncate $ a / b :: Integer) 133 | {-# INLINE fmod #-} 134 | 135 | -- | Create a directed interval. 136 | (...) :: a -> a -> Interval a 137 | (...) = I 138 | {-# INLINE (...) #-} 139 | 140 | -- | Try to create a non-empty interval. 141 | interval :: Ord a => a -> a -> Maybe (Interval a) 142 | interval a b 143 | | a <= b = Just $ I a b 144 | | otherwise = Nothing 145 | 146 | 147 | -- | The whole real number line 148 | -- 149 | -- >>> whole 150 | -- -Infinity ... Infinity 151 | whole :: Fractional a => Interval a 152 | whole = negInfinity ... posInfinity 153 | {-# INLINE whole #-} 154 | 155 | -- | An empty interval 156 | -- 157 | -- >>> empty 158 | -- NaN ... NaN 159 | empty :: Fractional a => Interval a 160 | empty = nan ... nan 161 | {-# INLINE empty #-} 162 | 163 | -- | negation handles NaN properly 164 | -- 165 | -- >>> null (1 ... 5) 166 | -- False 167 | -- 168 | -- >>> null (1 ... 1) 169 | -- False 170 | -- 171 | -- >>> null empty 172 | -- True 173 | null :: Ord a => Interval a -> Bool 174 | null x = not (inf x <= sup x) 175 | {-# INLINE null #-} 176 | 177 | -- | A singleton point 178 | -- 179 | -- >>> singleton 1 180 | -- 1 ... 1 181 | singleton :: a -> Interval a 182 | singleton a = a ... a 183 | {-# INLINE singleton #-} 184 | 185 | -- | The infinumum (lower bound) of an interval 186 | -- 187 | -- >>> inf (1 ... 20) 188 | -- 1 189 | inf :: Interval a -> a 190 | inf (I a _) = a 191 | {-# INLINE inf #-} 192 | 193 | -- | The supremum (upper bound) of an interval 194 | -- 195 | -- >>> sup (1 ... 20) 196 | -- 20 197 | sup :: Interval a -> a 198 | sup (I _ b) = b 199 | {-# INLINE sup #-} 200 | 201 | -- | Is the interval a singleton point? 202 | -- N.B. This is fairly fragile and likely will not hold after 203 | -- even a few operations that only involve singletons 204 | -- 205 | -- >>> singular (singleton 1) 206 | -- True 207 | -- 208 | -- >>> singular (1.0 ... 20.0) 209 | -- False 210 | singular :: Ord a => Interval a -> Bool 211 | singular x = not (null x) && inf x == sup x 212 | {-# INLINE singular #-} 213 | 214 | instance Show a => Show (Interval a) where 215 | showsPrec n (I a b) = 216 | showParen (n > 3) $ 217 | showsPrec 3 a . 218 | showString " ... " . 219 | showsPrec 3 b 220 | 221 | -- | Calculate the width of an interval. 222 | -- 223 | -- >>> width (1 ... 20) 224 | -- 19 225 | -- 226 | -- >>> width (singleton 1) 227 | -- 0 228 | -- 229 | -- >>> width empty 230 | -- NaN 231 | width :: Num a => Interval a -> a 232 | width (I a b) = b - a 233 | {-# INLINE width #-} 234 | 235 | -- | Magnitude 236 | -- 237 | -- >>> magnitude (1 ... 20) 238 | -- 20 239 | -- 240 | -- >>> magnitude (-20 ... 10) 241 | -- 20 242 | -- 243 | -- >>> magnitude (singleton 5) 244 | -- 5 245 | magnitude :: (Num a, Ord a) => Interval a -> a 246 | magnitude = sup . abs 247 | {-# INLINE magnitude #-} 248 | 249 | -- | \"mignitude\" 250 | -- 251 | -- >>> mignitude (1 ... 20) 252 | -- 1 253 | -- 254 | -- >>> mignitude (-20 ... 10) 255 | -- 0 256 | -- 257 | -- >>> mignitude (singleton 5) 258 | -- 5 259 | -- 260 | -- >>> mignitude empty 261 | -- NaN 262 | mignitude :: (Num a, Ord a) => Interval a -> a 263 | mignitude = inf . abs 264 | {-# INLINE mignitude #-} 265 | 266 | -- | Hausdorff distance between non-empty intervals. 267 | -- 268 | -- >>> distance (1 ... 7) (6 ... 10) 269 | -- 0 270 | -- 271 | -- >>> distance (1 ... 7) (15 ... 24) 272 | -- 8 273 | -- 274 | -- >>> distance (1 ... 7) (-10 ... -2) 275 | -- 3 276 | -- 277 | -- >>> distance empty (1 ... 1) 278 | -- NaN 279 | distance :: (Num a, Ord a) => Interval a -> Interval a -> a 280 | distance i1 i2 = mignitude (i1 - i2) 281 | 282 | -- | Inflate an interval by enlarging it at both ends. 283 | -- 284 | -- >>> inflate 3 (-1 ... 7) 285 | -- -4 ... 10 286 | -- 287 | -- >>> inflate (-2) (0 ... 4) 288 | -- 2 ... 2 289 | inflate :: (Num a, Ord a) => a -> Interval a -> Interval a 290 | inflate x y = symmetric x + y 291 | 292 | -- | Deflate an interval by shrinking it from both ends. 293 | -- 294 | -- >>> deflate 3.0 (-4.0 ... 10.0) 295 | -- -1.0 ... 7.0 296 | -- 297 | -- >>> deflate 2.0 (-1.0 ... 1.0) 298 | -- 1.0 ... -1.0 299 | deflate :: Fractional a => a -> Interval a -> Interval a 300 | deflate x (I a b) = I a' b' 301 | where 302 | a' = a + x 303 | b' = b - x 304 | 305 | -- | Scale an interval about its midpoint. 306 | -- 307 | -- >>> scale 1.1 (-6.0 ... 4.0) 308 | -- -6.5 ... 4.5 309 | -- 310 | -- >>> scale (-2.0) (-1.0 ... 1.0) 311 | -- 2.0 ... -2.0 312 | scale :: Fractional a => a -> Interval a -> Interval a 313 | scale x i = I a b where 314 | h = x * width i / 2 315 | mid = midpoint i 316 | a = mid - h 317 | b = mid + h 318 | 319 | -- | Construct a symmetric interval. 320 | -- 321 | -- >>> symmetric 3 322 | -- -3 ... 3 323 | -- 324 | -- >>> symmetric (-2) 325 | -- 2 ... -2 326 | symmetric :: Num a => a -> Interval a 327 | symmetric x = negate x ... x 328 | 329 | instance (Num a, Ord a) => Num (Interval a) where 330 | I a b + I a' b' = (a + a') ... (b + b') 331 | {-# INLINE (+) #-} 332 | I a b - I a' b' = (a - b') ... (b - a') 333 | {-# INLINE (-) #-} 334 | I a b * I a' b' = 335 | minimum [a * a', a * b', b * a', b * b'] 336 | ... 337 | maximum [a * a', a * b', b * a', b * b'] 338 | {-# INLINE (*) #-} 339 | abs x@(I a b) 340 | | a >= 0 = x 341 | | b <= 0 = negate x 342 | | b > 0 && a < 0 = 0 ... max (- a) b 343 | | otherwise = x -- preserve the empty interval 344 | {-# INLINE abs #-} 345 | 346 | signum = increasing signum 347 | {-# INLINE signum #-} 348 | 349 | fromInteger i = singleton (fromInteger i) 350 | {-# INLINE fromInteger #-} 351 | 352 | -- | Bisect an interval at its midpoint. 353 | -- 354 | -- >>> bisect (10.0 ... 20.0) 355 | -- (10.0 ... 15.0,15.0 ... 20.0) 356 | -- 357 | -- >>> bisect (singleton 5.0) 358 | -- (5.0 ... 5.0,5.0 ... 5.0) 359 | -- 360 | -- >>> bisect empty 361 | -- (NaN ... NaN,NaN ... NaN) 362 | bisect :: Fractional a => Interval a -> (Interval a, Interval a) 363 | bisect x = (inf x ... m, m ... sup x) where m = midpoint x 364 | {-# INLINE bisect #-} 365 | 366 | -- | Nearest point to the midpoint of the interval. 367 | -- 368 | -- >>> midpoint (10.0 ... 20.0) 369 | -- 15.0 370 | -- 371 | -- >>> midpoint (singleton 5.0) 372 | -- 5.0 373 | -- 374 | -- >>> midpoint empty 375 | -- NaN 376 | midpoint :: Fractional a => Interval a -> a 377 | midpoint x = inf x + (sup x - inf x) / 2 378 | {-# INLINE midpoint #-} 379 | 380 | -- | Determine if a point is in the interval. 381 | -- 382 | -- >>> member 3.2 (1.0 ... 5.0) 383 | -- True 384 | -- 385 | -- >>> member 5 (1.0 ... 5.0) 386 | -- True 387 | -- 388 | -- >>> member 1 (1.0 ... 5.0) 389 | -- True 390 | -- 391 | -- >>> member 8 (1.0 ... 5.0) 392 | -- False 393 | -- 394 | -- >>> member 5 empty 395 | -- False 396 | -- 397 | member :: Ord a => a -> Interval a -> Bool 398 | member x (I a b) = x >= a && x <= b 399 | {-# INLINE member #-} 400 | 401 | -- | Determine if a point is not included in the interval 402 | -- 403 | -- >>> notMember 8 (1.0 ... 5.0) 404 | -- True 405 | -- 406 | -- >>> notMember 1.4 (1.0 ... 5.0) 407 | -- False 408 | -- 409 | -- And of course, nothing is a member of the empty interval. 410 | -- 411 | -- >>> notMember 5 empty 412 | -- True 413 | notMember :: Ord a => a -> Interval a -> Bool 414 | notMember x xs = not (member x xs) 415 | {-# INLINE notMember #-} 416 | 417 | -- | Determine if a point is in the interval. 418 | -- 419 | -- >>> elem 3.2 (1.0 ... 5.0) 420 | -- True 421 | -- 422 | -- >>> elem 5 (1.0 ... 5.0) 423 | -- True 424 | -- 425 | -- >>> elem 1 (1.0 ... 5.0) 426 | -- True 427 | -- 428 | -- >>> elem 8 (1.0 ... 5.0) 429 | -- False 430 | -- 431 | -- >>> elem 5 empty 432 | -- False 433 | -- 434 | elem :: Ord a => a -> Interval a -> Bool 435 | elem = member 436 | {-# INLINE elem #-} 437 | {-# DEPRECATED elem "Use `member` instead." #-} 438 | 439 | -- | Determine if a point is not included in the interval 440 | -- 441 | -- >>> notElem 8 (1.0 ... 5.0) 442 | -- True 443 | -- 444 | -- >>> notElem 1.4 (1.0 ... 5.0) 445 | -- False 446 | -- 447 | -- And of course, nothing is a member of the empty interval. 448 | -- 449 | -- >>> notElem 5 empty 450 | -- True 451 | notElem :: Ord a => a -> Interval a -> Bool 452 | notElem = notMember 453 | {-# INLINE notElem #-} 454 | {-# DEPRECATED notElem "Use `notMember` instead." #-} 455 | 456 | -- | 'realToFrac' will use the midpoint 457 | instance Real a => Real (Interval a) where 458 | toRational x 459 | | null x = Exception.throw EmptyInterval 460 | | otherwise = a + (b - a) / 2 461 | where 462 | a = toRational (inf x) 463 | b = toRational (sup x) 464 | {-# INLINE toRational #-} 465 | 466 | -- @'divNonZero' X Y@ assumes @0 `'notElem'` Y@ 467 | divNonZero :: (Fractional a, Ord a) => Interval a -> Interval a -> Interval a 468 | divNonZero (I a b) (I a' b') = 469 | minimum [a / a', a / b', b / a', b / b'] 470 | ... 471 | maximum [a / a', a / b', b / a', b / b'] 472 | 473 | -- @'divPositive' X y@ assumes y > 0, and divides @X@ by [0 ... y] 474 | divPositive :: (Fractional a, Ord a) => Interval a -> a -> Interval a 475 | divPositive x@(I a b) y 476 | | a == 0 && b == 0 = x 477 | -- b < 0 || isNegativeZero b = negInfinity ... ( b / y) 478 | | b < 0 = negInfinity ... ( b / y) 479 | | a < 0 = whole 480 | | otherwise = (a / y) ... posInfinity 481 | {-# INLINE divPositive #-} 482 | 483 | -- divNegative assumes y < 0 and divides the interval @X@ by [y ... 0] 484 | divNegative :: (Fractional a, Ord a) => Interval a -> a -> Interval a 485 | divNegative x@(I a b) y 486 | | a == 0 && b == 0 = - x -- flip negative zeros 487 | -- b < 0 || isNegativeZero b = (b / y) ... posInfinity 488 | | b < 0 = (b / y) ... posInfinity 489 | | a < 0 = whole 490 | | otherwise = negInfinity ... (a / y) 491 | {-# INLINE divNegative #-} 492 | 493 | divZero :: (Fractional a, Ord a) => Interval a -> Interval a 494 | divZero x 495 | | inf x == 0 && sup x == 0 = x 496 | | otherwise = whole 497 | {-# INLINE divZero #-} 498 | 499 | instance (Fractional a, Ord a) => Fractional (Interval a) where 500 | -- TODO: check isNegativeZero properly 501 | x / y 502 | | 0 `notElem` y = divNonZero x y 503 | | iz && sz = empty -- division by 0 504 | | iz = divPositive x (inf y) 505 | | sz = divNegative x (sup y) 506 | | otherwise = divZero x 507 | where 508 | iz = inf y == 0 509 | sz = sup y == 0 510 | recip (I a b) = on min recip a b ... on max recip a b 511 | {-# INLINE recip #-} 512 | fromRational r = let r' = fromRational r in r' ... r' 513 | {-# INLINE fromRational #-} 514 | 515 | instance RealFrac a => RealFrac (Interval a) where 516 | properFraction x = (b, x - fromIntegral b) 517 | where 518 | b = truncate (midpoint x) 519 | {-# INLINE properFraction #-} 520 | ceiling x = ceiling (sup x) 521 | {-# INLINE ceiling #-} 522 | floor x = floor (inf x) 523 | {-# INLINE floor #-} 524 | round x = round (midpoint x) 525 | {-# INLINE round #-} 526 | truncate x = truncate (midpoint x) 527 | {-# INLINE truncate #-} 528 | 529 | instance (RealFloat a, Ord a) => Floating (Interval a) where 530 | pi = singleton pi 531 | {-# INLINE pi #-} 532 | exp = increasing exp 533 | {-# INLINE exp #-} 534 | log (I a b) = (if a > 0 then log a else negInfinity) ... log b 535 | {-# INLINE log #-} 536 | cos x 537 | | null x = empty 538 | | width t >= pi = (-1) ... 1 539 | | inf t >= pi = - cos (t - pi) 540 | | sup t <= pi = decreasing cos t 541 | | sup t <= 2 * pi = (-1) ... cos ((pi * 2 - sup t) `min` inf t) 542 | | otherwise = (-1) ... 1 543 | where 544 | t = fmod x (pi * 2) 545 | {-# INLINE cos #-} 546 | sin x 547 | | null x = empty 548 | | otherwise = cos (x - pi / 2) 549 | {-# INLINE sin #-} 550 | tan x 551 | | null x = empty 552 | | inf t' <= - pi / 2 || sup t' >= pi / 2 = whole 553 | | otherwise = increasing tan x 554 | where 555 | t = x `fmod` pi 556 | t' | t >= pi / 2 = t - pi 557 | | otherwise = t 558 | {-# INLINE tan #-} 559 | asin x@(I a b) 560 | | null x || b < -1 || a > 1 = empty 561 | | otherwise = 562 | (if a <= -1 then -halfPi else asin a) 563 | ... 564 | (if b >= 1 then halfPi else asin b) 565 | where 566 | halfPi = pi / 2 567 | {-# INLINE asin #-} 568 | acos x@(I a b) 569 | | null x || b < -1 || a > 1 = empty 570 | | otherwise = 571 | (if b >= 1 then 0 else acos b) 572 | ... 573 | (if a < -1 then pi else acos a) 574 | {-# INLINE acos #-} 575 | atan = increasing atan 576 | {-# INLINE atan #-} 577 | sinh = increasing sinh 578 | {-# INLINE sinh #-} 579 | cosh x@(I a b) 580 | | null x = empty 581 | | b < 0 = decreasing cosh x 582 | | a >= 0 = increasing cosh x 583 | | otherwise = I 0 $ cosh $ if - a > b 584 | then a 585 | else b 586 | {-# INLINE cosh #-} 587 | tanh = increasing tanh 588 | {-# INLINE tanh #-} 589 | asinh = increasing asinh 590 | {-# INLINE asinh #-} 591 | acosh x@(I a b) 592 | | null x || b < 1 = empty 593 | | otherwise = I lo $ acosh b 594 | where lo | a <= 1 = 0 595 | | otherwise = acosh a 596 | {-# INLINE acosh #-} 597 | atanh x@(I a b) 598 | | null x || b < -1 || a > 1 = empty 599 | | otherwise = 600 | (if a <= - 1 then negInfinity else atanh a) 601 | ... 602 | (if b >= 1 then posInfinity else atanh b) 603 | {-# INLINE atanh #-} 604 | 605 | -- | lift a monotone increasing function over a given interval 606 | increasing :: (a -> b) -> Interval a -> Interval b 607 | increasing f (I a b) = f a ... f b 608 | 609 | -- | lift a monotone decreasing function over a given interval 610 | decreasing :: (a -> b) -> Interval a -> Interval b 611 | decreasing f (I a b) = f b ... f a 612 | 613 | -- | We have to play some semantic games to make these methods make sense. 614 | -- Most compute with the midpoint of the interval. 615 | instance RealFloat a => RealFloat (Interval a) where 616 | floatRadix = floatRadix . midpoint 617 | 618 | floatDigits = floatDigits . midpoint 619 | floatRange = floatRange . midpoint 620 | decodeFloat = decodeFloat . midpoint 621 | encodeFloat m e = singleton (encodeFloat m e) 622 | exponent = exponent . midpoint 623 | significand x = min a b ... max a b 624 | where 625 | (_ ,em) = decodeFloat (midpoint x) 626 | (mi,ei) = decodeFloat (inf x) 627 | (ms,es) = decodeFloat (sup x) 628 | a = encodeFloat mi (ei - em - floatDigits x) 629 | b = encodeFloat ms (es - em - floatDigits x) 630 | scaleFloat n x = scaleFloat n (inf x) ... scaleFloat n (sup x) 631 | isNaN x = isNaN (inf x) || isNaN (sup x) 632 | isInfinite x = isInfinite (inf x) || isInfinite (sup x) 633 | isDenormalized x = isDenormalized (inf x) || isDenormalized (sup x) 634 | -- contains negative zero 635 | isNegativeZero x = not (inf x > 0) 636 | && not (sup x < 0) 637 | && ( (sup x == 0 && (inf x < 0 || isNegativeZero (inf x))) 638 | || (inf x == 0 && isNegativeZero (inf x)) 639 | || (inf x < 0 && sup x >= 0)) 640 | isIEEE x = isIEEE (inf x) && isIEEE (sup x) 641 | atan2 = error "unimplemented" 642 | 643 | -- TODO: (^), (^^) to give tighter bounds 644 | 645 | -- | Calculate the intersection of two intervals. 646 | -- 647 | -- >>> intersection (1 ... 10 :: Interval Double) (5 ... 15 :: Interval Double) 648 | -- 5.0 ... 10.0 649 | intersection :: (Fractional a, Ord a) => Interval a -> Interval a -> Interval a 650 | intersection x@(I a b) y@(I a' b') 651 | | x /=! y = empty 652 | | otherwise = max a a' ... min b b' 653 | {-# INLINE intersection #-} 654 | 655 | -- | Calculate the convex hull of two intervals 656 | -- 657 | -- >>> hull (0 ... 10 :: Interval Double) (5 ... 15 :: Interval Double) 658 | -- 0.0 ... 15.0 659 | -- 660 | -- >>> hull (15 ... 85 :: Interval Double) (0 ... 10 :: Interval Double) 661 | -- 0.0 ... 85.0 662 | -- 663 | -- >>> hull (10 ... 20 :: Interval Double) (15 ... 0 :: Interval Double) 664 | -- 10.0 ... 20.0 665 | -- 666 | hull :: Ord a => Interval a -> Interval a -> Interval a 667 | hull x@(I a b) y@(I a' b') 668 | | null x = y 669 | | null y = x 670 | | otherwise = min a a' ... max b b' 671 | {-# INLINE hull #-} 672 | 673 | -- | For all @x@ in @X@, @y@ in @Y@. @x '<' y@ 674 | -- 675 | -- >>> (5 ... 10 :: Interval Double) >> (5 ... 10 :: Interval Double) >> (20 ... 30 :: Interval Double) Interval a -> Interval a -> Bool 684 | x >> (5 ... 10 :: Interval Double) <=! (20 ... 30 :: Interval Double) 690 | -- True 691 | -- 692 | -- >>> (5 ... 10 :: Interval Double) <=! (10 ... 30 :: Interval Double) 693 | -- True 694 | -- 695 | -- >>> (20 ... 30 :: Interval Double) <=! (5 ... 10 :: Interval Double) 696 | -- False 697 | (<=!) :: Ord a => Interval a -> Interval a -> Bool 698 | x <=! y = sup x <= inf y 699 | {-# INLINE (<=!) #-} 700 | 701 | -- | For all @x@ in @X@, @y@ in @Y@. @x '==' y@ 702 | -- 703 | -- Only singleton intervals return true 704 | -- 705 | -- >>> (singleton 5 :: Interval Double) ==! (singleton 5 :: Interval Double) 706 | -- True 707 | -- 708 | -- >>> (5 ... 10 :: Interval Double) ==! (5 ... 10 :: Interval Double) 709 | -- False 710 | (==!) :: Eq a => Interval a -> Interval a -> Bool 711 | x ==! y = sup x == inf y && inf x == sup y 712 | {-# INLINE (==!) #-} 713 | 714 | -- | For all @x@ in @X@, @y@ in @Y@. @x '/=' y@ 715 | -- 716 | -- >>> (5 ... 15 :: Interval Double) /=! (20 ... 40 :: Interval Double) 717 | -- True 718 | -- 719 | -- >>> (5 ... 15 :: Interval Double) /=! (15 ... 40 :: Interval Double) 720 | -- False 721 | (/=!) :: Ord a => Interval a -> Interval a -> Bool 722 | x /=! y = sup x < inf y || inf x > sup y 723 | {-# INLINE (/=!) #-} 724 | 725 | -- | For all @x@ in @X@, @y@ in @Y@. @x '>' y@ 726 | -- 727 | -- >>> (20 ... 40 :: Interval Double) >! (10 ... 19 :: Interval Double) 728 | -- True 729 | -- 730 | -- >>> (5 ... 20 :: Interval Double) >! (15 ... 40 :: Interval Double) 731 | -- False 732 | (>!) :: Ord a => Interval a -> Interval a -> Bool 733 | x >! y = inf x > sup y 734 | {-# INLINE (>!) #-} 735 | 736 | -- | For all @x@ in @X@, @y@ in @Y@. @x '>=' y@ 737 | -- 738 | -- >>> (20 ... 40 :: Interval Double) >=! (10 ... 20 :: Interval Double) 739 | -- True 740 | -- 741 | -- >>> (5 ... 20 :: Interval Double) >=! (15 ... 40 :: Interval Double) 742 | -- False 743 | (>=!) :: Ord a => Interval a -> Interval a -> Bool 744 | x >=! y = inf x >= sup y 745 | {-# INLINE (>=!) #-} 746 | 747 | -- | For all @x@ in @X@, @y@ in @Y@. @x `op` y@ 748 | -- 749 | -- 750 | certainly :: Ord a => (forall b. Ord b => b -> b -> Bool) -> Interval a -> Interval a -> Bool 751 | certainly cmp l r 752 | | lt && eq && gt = True 753 | | lt && eq = l <=! r 754 | | lt && gt = l /=! r 755 | | lt = l =! r 757 | | eq = l ==! r 758 | | gt = l >! r 759 | | otherwise = False 760 | where 761 | lt = cmp LT EQ 762 | eq = cmp EQ EQ 763 | gt = cmp GT EQ 764 | {-# INLINE certainly #-} 765 | 766 | -- | Check if interval @X@ totally contains interval @Y@ 767 | -- 768 | -- >>> (20 ... 40 :: Interval Double) `contains` (25 ... 35 :: Interval Double) 769 | -- True 770 | -- 771 | -- >>> (20 ... 40 :: Interval Double) `contains` (15 ... 35 :: Interval Double) 772 | -- False 773 | contains :: Ord a => Interval a -> Interval a -> Bool 774 | contains x y = null y 775 | || (not (null x) && inf x <= inf y && sup y <= sup x) 776 | {-# INLINE contains #-} 777 | 778 | -- | Flipped version of `contains`. Check if interval @X@ a subset of interval @Y@ 779 | -- 780 | -- >>> (25 ... 35 :: Interval Double) `isSubsetOf` (20 ... 40 :: Interval Double) 781 | -- True 782 | -- 783 | -- >>> (20 ... 40 :: Interval Double) `isSubsetOf` (15 ... 35 :: Interval Double) 784 | -- False 785 | isSubsetOf :: Ord a => Interval a -> Interval a -> Bool 786 | isSubsetOf = flip contains 787 | {-# INLINE isSubsetOf #-} 788 | 789 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@? 790 | ( Interval a -> Interval a -> Bool 791 | x Interval a -> Interval a -> Bool 796 | x <=? y = inf x <= sup y 797 | {-# INLINE (<=?) #-} 798 | 799 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@? 800 | (==?) :: Ord a => Interval a -> Interval a -> Bool 801 | x ==? y = inf x <= sup y && sup x >= inf y 802 | {-# INLINE (==?) #-} 803 | 804 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@? 805 | (/=?) :: Eq a => Interval a -> Interval a -> Bool 806 | x /=? y = inf x /= sup y || sup x /= inf y 807 | {-# INLINE (/=?) #-} 808 | 809 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@? 810 | (>?) :: Ord a => Interval a -> Interval a -> Bool 811 | x >? y = sup x > inf y 812 | {-# INLINE (>?) #-} 813 | 814 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@? 815 | (>=?) :: Ord a => Interval a -> Interval a -> Bool 816 | x >=? y = sup x >= inf y 817 | {-# INLINE (>=?) #-} 818 | 819 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x `op` y@? 820 | possibly :: Ord a => (forall b. Ord b => b -> b -> Bool) -> Interval a -> Interval a -> Bool 821 | possibly cmp l r 822 | | lt && eq && gt = True 823 | | lt && eq = l <=? r 824 | | lt && gt = l /=? r 825 | | lt = l =? r 827 | | eq = l ==? r 828 | | gt = l >? r 829 | | otherwise = False 830 | where 831 | lt = cmp LT EQ 832 | eq = cmp EQ EQ 833 | gt = cmp GT EQ 834 | {-# INLINE possibly #-} 835 | 836 | -- | The nearest value to that supplied which is contained in the interval. 837 | clamp :: Ord a => Interval a -> a -> a 838 | clamp (I a b) x | x < a = a 839 | | x > b = b 840 | | otherwise = x 841 | 842 | -- | id function. Useful for type specification 843 | -- 844 | -- >>> :t idouble (1 ... 3) 845 | -- idouble (1 ... 3) :: Interval Double 846 | idouble :: Interval Double -> Interval Double 847 | idouble = id 848 | 849 | -- | id function. Useful for type specification 850 | -- 851 | -- >>> :t ifloat (1 ... 3) 852 | -- ifloat (1 ... 3) :: Interval Float 853 | ifloat :: Interval Float -> Interval Float 854 | ifloat = id 855 | 856 | -- Bugs: 857 | -- sin 1 :: Interval Double 858 | 859 | 860 | default (Integer,Double) 861 | 862 | -- | an interval containing all x `quot` y 863 | -- >>> (5 `quot` 3) `member` ((4...6) `iquot` (2...4)) 864 | -- True 865 | -- >>> (evaluate ((1...10) `iquot` ((-5)...4)) *> pure "not caught") `catch` \e -> "caught" <$ guard (e == DivideByZero) 866 | -- "caught" 867 | iquot :: Integral a => Interval a -> Interval a -> Interval a 868 | iquot (I l u) (I l' u') = 869 | if l' <= 0 && 0 <= u' then throw DivideByZero else I 870 | (minimum [a `quot` b | a <- [l,u], b <- [l',u']]) 871 | (maximum [a `quot` b | a <- [l,u], b <- [l',u']]) 872 | 873 | -- | an interval containing all x `rem` y 874 | -- >>> (5 `rem` 3) `member` ((4...6) `irem` (2...4)) 875 | -- True 876 | -- >>> (evaluate ((1...10) `irem` ((-5)...4)) *> pure "not caught") `catch` \e -> "caught" <$ guard (e == DivideByZero) 877 | -- "caught" 878 | irem :: Integral a => Interval a -> Interval a -> Interval a 879 | irem (I l u) (I l' u') = 880 | if l' <= 0 && 0 <= u' then throw DivideByZero else I 881 | (minimum [0, signum l * (abs u' - 1), signum l * (abs l' - 1)]) 882 | (maximum [0, signum u * (abs u' - 1), signum u * (abs l' - 1)]) 883 | 884 | -- | an interval containing all x `div` y 885 | -- >>> (5 `div` 3) `member` ((4...6) `idiv` (2...4)) 886 | -- True 887 | -- >>> (evaluate ((1...10) `idiv` ((-5)...4)) *> pure "not caught") `catch` \e -> "caught" <$ guard (e == DivideByZero) 888 | -- "caught" 889 | idiv :: Integral a => Interval a -> Interval a -> Interval a 890 | idiv (I l u) (I l' u') = 891 | if l' <= 0 && 0 <= u' then throw DivideByZero else I 892 | (min (l `Prelude.div` max 1 l') (u `Prelude.div` min (-1) u')) 893 | (max (u `Prelude.div` max 1 l') (l `Prelude.div` min (-1) u')) 894 | 895 | -- | an interval containing all x `mod` y 896 | -- >>> (5 `mod` 3) `member` ((4...6) `imod` (2...4)) 897 | -- True 898 | -- >>> (evaluate ((1...10) `imod` ((-5)...4)) *> pure "not caught") `catch` \e -> "caught" <$ guard (e == DivideByZero) 899 | -- "caught" 900 | imod :: Integral a => Interval a -> Interval a -> Interval a 901 | imod _ (I l' u') = 902 | if l' <= 0 && 0 <= u' then throw DivideByZero else 903 | I (min (l'+1) 0) (max 0 (u'-1)) 904 | -------------------------------------------------------------------------------- /src/Numeric/Interval/NonEmpty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Numeric.Interval.NonEmpty 7 | -- Copyright : (c) Edward Kmett 2010-2013 8 | -- License : BSD3 9 | -- Maintainer : ekmett@gmail.com 10 | -- Stability : experimental 11 | -- Portability : DeriveDataTypeable 12 | -- 13 | -- Interval arithmetic 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module Numeric.Interval.NonEmpty 18 | ( Interval 19 | , (...) 20 | , interval 21 | , whole 22 | , singleton 23 | , member 24 | , notMember 25 | , elem 26 | , notElem 27 | , inf 28 | , sup 29 | , singular 30 | , width 31 | , midpoint 32 | , distance 33 | , intersection 34 | , hull 35 | , bisect 36 | , bisectIntegral 37 | , magnitude 38 | , mignitude 39 | , contains 40 | , isSubsetOf 41 | , certainly, (=!), (>!) 42 | , possibly, (=?), (>?) 43 | , clamp 44 | , inflate, deflate 45 | , scale, symmetric 46 | , idouble 47 | , ifloat 48 | , iquot 49 | , irem 50 | , idiv 51 | , imod 52 | ) where 53 | 54 | import Numeric.Interval.NonEmpty.Internal 55 | import Prelude () 56 | -------------------------------------------------------------------------------- /src/Numeric/Interval/NonEmpty/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# OPTIONS_HADDOCK not-home #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Numeric.Interval.NonEmpty.Internal 9 | -- Copyright : (c) Edward Kmett 2010-2014 10 | -- License : BSD3 11 | -- Maintainer : ekmett@gmail.com 12 | -- Stability : experimental 13 | -- Portability : DeriveDataTypeable 14 | -- 15 | -- Interval arithmetic 16 | ----------------------------------------------------------------------------- 17 | module Numeric.Interval.NonEmpty.Internal 18 | ( Interval(..) 19 | , (...) 20 | , interval 21 | , whole 22 | , singleton 23 | , member 24 | , notMember 25 | , elem 26 | , notElem 27 | , inf 28 | , sup 29 | , singular 30 | , width 31 | , midpoint 32 | , distance 33 | , intersection 34 | , hull 35 | , bisect 36 | , bisectIntegral 37 | , magnitude 38 | , mignitude 39 | , contains 40 | , isSubsetOf 41 | , certainly, (=!), (>!) 42 | , possibly, (=?), (>?) 43 | , clamp 44 | , inflate, deflate 45 | , scale, symmetric 46 | , idouble 47 | , ifloat 48 | , iquot 49 | , irem 50 | , idiv 51 | , imod 52 | ) where 53 | 54 | import Control.Exception as Exception 55 | import Data.Data 56 | import GHC.Generics 57 | import Prelude hiding (null, elem, notElem) 58 | 59 | import qualified Data.Semigroup 60 | 61 | -- $setup 62 | -- >>> import Test.QuickCheck.Arbitrary 63 | -- >>> import Test.QuickCheck.Gen hiding (scale) 64 | -- >>> import Test.QuickCheck.Property 65 | -- >>> import Control.Applicative 66 | -- >>> import Control.Exception 67 | -- >>> :set -XNoMonomorphismRestriction 68 | -- >>> :set -XExtendedDefaultRules 69 | -- >>> default (Integer,Double) 70 | -- >>> instance (Ord a, Arbitrary a) => Arbitrary (Interval a) where arbitrary = (...) <$> arbitrary <*> arbitrary 71 | -- >>> let memberOf xs = sized $ \n -> case n of { 0 -> pure $ inf xs; 1 -> pure $ sup xs; _ -> choose (inf xs, sup xs); } 72 | -- >>> let conservative sf f xs = forAll (choose (inf xs, sup xs)) $ \x -> (sf x) `member` (f xs) 73 | -- >>> let conservative2 sf f xs ys = forAll ((,) <$> choose (inf xs, sup xs) <*> choose (inf ys, sup ys)) $ \(x,y) -> (sf x y) `member` (f xs ys) 74 | -- >>> let conservativeExceptNaN sf f xs = forAll (choose (inf xs, sup xs)) $ \x -> isNaN (sf x) || (sf x) `member` (f xs) 75 | -- >>> let compose2 = fmap . fmap 76 | -- >>> let commutative op a b = (a `op` b) == (b `op` a) 77 | -- 78 | -- >>> :set -Wno-deprecations 79 | -- >>> let elem = Numeric.Interval.NonEmpty.Internal.elem 80 | -- >>> let notElem = Numeric.Interval.NonEmpty.Internal.notElem 81 | 82 | data Interval a = I !a !a deriving 83 | (Eq, Ord, Data, Generic, Generic1) 84 | 85 | -- | 'Data.Semigroup.<>' is 'hull' 86 | instance Ord a => Data.Semigroup.Semigroup (Interval a) where 87 | (<>) = hull 88 | 89 | infix 3 ... 90 | 91 | negInfinity :: Fractional a => a 92 | negInfinity = (-1)/0 93 | {-# INLINE negInfinity #-} 94 | 95 | posInfinity :: Fractional a => a 96 | posInfinity = 1/0 97 | {-# INLINE posInfinity #-} 98 | 99 | -- the sign of a number, but as an Ordering so that we can pattern match over it. 100 | -- GT means greater than zero, etc. 101 | signum' :: (Ord a, Num a) => a -> Ordering 102 | signum' x = compare x 0 103 | 104 | -- arguments are period, range, derivative, function, and interval 105 | -- we require that each period of the function include precisely one local minimum and one local maximum 106 | periodic :: (Num a, Ord a) => a -> Interval a -> (a -> Ordering) -> (a -> a) -> Interval a -> Interval a 107 | periodic p r _ _ x | width x > p = r 108 | periodic _ r d f (I a b) = periodic' r (d a) (d b) (f a) (f b) 109 | 110 | -- arguments are global range, derivatives at endpoints, values at endpoints 111 | periodic' :: (Ord a) => Interval a -> Ordering -> Ordering -> a -> a -> Interval a 112 | periodic' r GT GT a b | a <= b = I a b -- stays in increasing zone 113 | | otherwise = r -- goes from increasing zone, all the way through decreasing zone, and back to increasing zone 114 | periodic' r LT LT a b | a >= b = I b a -- stays in decreasing zone 115 | | otherwise = r -- goes from decreasing zone, all the way through increasing zone, and back to decreasing zone 116 | periodic' r GT _ a b = I (min a b) (sup r) -- was going up, started going down 117 | periodic' r LT _ a b = I (inf r) (max a b) -- was going down, started going up 118 | periodic' r EQ GT a b | a < b = I a b -- stays in increasing zone 119 | | otherwise = r -- goes from increasing zone, all the way through decreasing zone, and back to increasing zone 120 | periodic' r EQ LT a b | a > b = I b a -- stays in decreasing zone 121 | | otherwise = r -- goes from decreasing zone, all the way through increasing zone, and back to decreasing zone 122 | periodic' _ _ _ a b = a ... b -- precisely begins and ends at local extremes, so it's either a singleton or whole 123 | 124 | -- | Create a non-empty interval, turning it around if necessary 125 | (...) :: Ord a => a -> a -> Interval a 126 | a ... b 127 | | a <= b = I a b 128 | | otherwise = I b a 129 | {-# INLINE (...) #-} 130 | 131 | -- | Try to create a non-empty interval. 132 | interval :: Ord a => a -> a -> Maybe (Interval a) 133 | interval a b 134 | | a <= b = Just $ I a b 135 | | otherwise = Nothing 136 | 137 | 138 | -- | The whole real number line 139 | -- 140 | -- >>> whole 141 | -- -Infinity ... Infinity 142 | -- 143 | -- prop> (x :: Double) `elem` whole 144 | whole :: Fractional a => Interval a 145 | whole = I negInfinity posInfinity 146 | {-# INLINE whole #-} 147 | 148 | -- | A singleton point 149 | -- 150 | -- >>> singleton 1 151 | -- 1 ... 1 152 | -- 153 | -- prop> x `elem` (singleton x) 154 | -- prop> x /= y ==> y `notElem` (singleton x) 155 | singleton :: a -> Interval a 156 | singleton a = I a a 157 | {-# INLINE singleton #-} 158 | 159 | -- | The infinumum (lower bound) of an interval 160 | -- 161 | -- >>> inf (1 ... 20) 162 | -- 1 163 | -- 164 | -- prop> min x y == inf (x ... y) 165 | -- prop> inf x <= sup x 166 | inf :: Interval a -> a 167 | inf (I a _) = a 168 | {-# INLINE inf #-} 169 | 170 | -- | The supremum (upper bound) of an interval 171 | -- 172 | -- >>> sup (1 ... 20) 173 | -- 20 174 | -- 175 | -- prop> sup x `elem` x 176 | -- prop> max x y == sup (x ... y) 177 | -- prop> inf x <= sup x 178 | sup :: Interval a -> a 179 | sup (I _ b) = b 180 | {-# INLINE sup #-} 181 | 182 | -- | Is the interval a singleton point? 183 | -- N.B. This is fairly fragile and likely will not hold after 184 | -- even a few operations that only involve singletons 185 | -- 186 | -- >>> singular (singleton 1) 187 | -- True 188 | -- 189 | -- >>> singular (1.0 ... 20.0) 190 | -- False 191 | singular :: Ord a => Interval a -> Bool 192 | singular (I a b) = a == b 193 | {-# INLINE singular #-} 194 | 195 | instance Show a => Show (Interval a) where 196 | showsPrec n (I a b) = 197 | showParen (n > 3) $ 198 | showsPrec 3 a . 199 | showString " ... " . 200 | showsPrec 3 b 201 | 202 | -- | Calculate the width of an interval. 203 | -- 204 | -- >>> width (1 ... 20) 205 | -- 19 206 | -- 207 | -- >>> width (singleton 1) 208 | -- 0 209 | -- 210 | -- prop> 0 <= width x 211 | width :: Num a => Interval a -> a 212 | width (I a b) = b - a 213 | {-# INLINE width #-} 214 | 215 | -- | Magnitude 216 | -- 217 | -- >>> magnitude (1 ... 20) 218 | -- 20 219 | -- 220 | -- >>> magnitude (-20 ... 10) 221 | -- 20 222 | -- 223 | -- >>> magnitude (singleton 5) 224 | -- 5 225 | -- 226 | -- prop> 0 <= magnitude x 227 | magnitude :: (Num a, Ord a) => Interval a -> a 228 | magnitude = sup . abs 229 | {-# INLINE magnitude #-} 230 | 231 | -- | \"mignitude\" 232 | -- 233 | -- >>> mignitude (1 ... 20) 234 | -- 1 235 | -- 236 | -- >>> mignitude (-20 ... 10) 237 | -- 0 238 | -- 239 | -- >>> mignitude (singleton 5) 240 | -- 5 241 | -- 242 | -- prop> 0 <= mignitude x 243 | mignitude :: (Num a, Ord a) => Interval a -> a 244 | mignitude = inf . abs 245 | {-# INLINE mignitude #-} 246 | 247 | -- | Num instance for intervals. 248 | -- 249 | -- prop> conservative2 ((+) :: Double -> Double -> Double) (+) 250 | -- prop> conservative2 ((-) :: Double -> Double -> Double) (-) 251 | -- prop> conservative2 ((*) :: Double -> Double -> Double) (*) 252 | -- prop> conservative (abs :: Double -> Double) abs 253 | instance (Num a, Ord a) => Num (Interval a) where 254 | I a b + I a' b' = (a + a') ... (b + b') 255 | {-# INLINE (+) #-} 256 | I a b - I a' b' = (a - b') ... (b - a') 257 | {-# INLINE (-) #-} 258 | I a b * I a' b' = 259 | minimum [a * a', a * b', b * a', b * b'] 260 | ... 261 | maximum [a * a', a * b', b * a', b * b'] 262 | {-# INLINE (*) #-} 263 | abs x@(I a b) 264 | | a >= 0 = x 265 | | b <= 0 = negate x 266 | | otherwise = 0 ... max (- a) b 267 | {-# INLINE abs #-} 268 | 269 | signum = increasing signum 270 | {-# INLINE signum #-} 271 | 272 | fromInteger i = singleton (fromInteger i) 273 | {-# INLINE fromInteger #-} 274 | 275 | -- | Bisect an interval at its midpoint. 276 | -- 277 | -- >>> bisect (10.0 ... 20.0) 278 | -- (10.0 ... 15.0,15.0 ... 20.0) 279 | -- 280 | -- >>> bisect (singleton 5.0) 281 | -- (5.0 ... 5.0,5.0 ... 5.0) 282 | -- 283 | -- prop> let (a, b) = bisect (x :: Interval Double) in sup a == inf b 284 | -- prop> let (a, b) = bisect (x :: Interval Double) in inf a == inf x 285 | -- prop> let (a, b) = bisect (x :: Interval Double) in sup b == sup x 286 | bisect :: Fractional a => Interval a -> (Interval a, Interval a) 287 | bisect (I a b) = (I a m, I m b) where m = a + (b - a) / 2 288 | {-# INLINE bisect #-} 289 | 290 | bisectIntegral :: Integral a => Interval a -> (Interval a, Interval a) 291 | bisectIntegral (I a b) 292 | | a == m || b == m = (I a a, I b b) 293 | | otherwise = (I a m, I m b) 294 | where m = a + (b - a) `div` 2 295 | {-# INLINE bisectIntegral #-} 296 | 297 | -- | Nearest point to the midpoint of the interval. 298 | -- 299 | -- >>> midpoint (10.0 ... 20.0) 300 | -- 15.0 301 | -- 302 | -- >>> midpoint (singleton 5.0) 303 | -- 5.0 304 | -- 305 | -- prop> midpoint x `elem` (x :: Interval Double) 306 | midpoint :: Fractional a => Interval a -> a 307 | midpoint (I a b) = a + (b - a) / 2 308 | {-# INLINE midpoint #-} 309 | 310 | -- | Hausdorff distance between intervals. 311 | -- 312 | -- >>> distance (1 ... 7) (6 ... 10) 313 | -- 0 314 | -- 315 | -- >>> distance (1 ... 7) (15 ... 24) 316 | -- 8 317 | -- 318 | -- >>> distance (1 ... 7) (-10 ... -2) 319 | -- 3 320 | -- 321 | -- prop> commutative (distance :: Interval Double -> Interval Double -> Double) 322 | -- prop> 0 <= distance x y 323 | distance :: (Num a, Ord a) => Interval a -> Interval a -> a 324 | distance i1 i2 = mignitude (i1 - i2) 325 | 326 | -- | Determine if a point is in the interval. 327 | -- 328 | -- >>> member 3.2 (1.0 ... 5.0) 329 | -- True 330 | -- 331 | -- >>> member 5 (1.0 ... 5.0) 332 | -- True 333 | -- 334 | -- >>> member 1 (1.0 ... 5.0) 335 | -- True 336 | -- 337 | -- >>> member 8 (1.0 ... 5.0) 338 | -- False 339 | member :: Ord a => a -> Interval a -> Bool 340 | member x (I a b) = x >= a && x <= b 341 | {-# INLINE member #-} 342 | 343 | -- | Determine if a point is not included in the interval 344 | -- 345 | -- >>> notMember 8 (1.0 ... 5.0) 346 | -- True 347 | -- 348 | -- >>> notMember 1.4 (1.0 ... 5.0) 349 | -- False 350 | notMember :: Ord a => a -> Interval a -> Bool 351 | notMember x xs = not (member x xs) 352 | {-# INLINE notMember #-} 353 | 354 | -- | Determine if a point is in the interval. 355 | -- 356 | -- >>> elem 3.2 (1.0 ... 5.0) 357 | -- True 358 | -- 359 | -- >>> elem 5 (1.0 ... 5.0) 360 | -- True 361 | -- 362 | -- >>> elem 1 (1.0 ... 5.0) 363 | -- True 364 | -- 365 | -- >>> elem 8 (1.0 ... 5.0) 366 | -- False 367 | elem :: Ord a => a -> Interval a -> Bool 368 | elem = member 369 | {-# INLINE elem #-} 370 | {-# DEPRECATED elem "Use `member` instead." #-} 371 | 372 | -- | Determine if a point is not included in the interval 373 | -- 374 | -- >>> notElem 8 (1.0 ... 5.0) 375 | -- True 376 | -- 377 | -- >>> notElem 1.4 (1.0 ... 5.0) 378 | -- False 379 | notElem :: Ord a => a -> Interval a -> Bool 380 | notElem = notMember 381 | {-# INLINE notElem #-} 382 | {-# DEPRECATED notElem "Use `notMember` instead." #-} 383 | 384 | -- | 'realToFrac' will use the midpoint 385 | instance Real a => Real (Interval a) where 386 | toRational (I ra rb) = a + (b - a) / 2 where 387 | a = toRational ra 388 | b = toRational rb 389 | {-# INLINE toRational #-} 390 | 391 | -- @'divNonZero' X Y@ assumes @0 `'notElem'` Y@ 392 | divNonZero :: (Fractional a, Ord a) => Interval a -> Interval a -> Interval a 393 | divNonZero (I a b) (I a' b') = 394 | minimum [a / a', a / b', b / a', b / b'] 395 | ... 396 | maximum [a / a', a / b', b / a', b / b'] 397 | 398 | -- @'divPositive' X y@ assumes y > 0, and divides @X@ by [0 ... y] 399 | divPositive :: (Fractional a, Ord a) => Interval a -> a -> Interval a 400 | divPositive x@(I a b) y 401 | | a == 0 && b == 0 = x 402 | -- b < 0 || isNegativeZero b = negInfinity ... ( b / y) 403 | | b < 0 = negInfinity ... (b / y) 404 | | a < 0 = whole 405 | | otherwise = (a / y) ... posInfinity 406 | {-# INLINE divPositive #-} 407 | 408 | -- divNegative assumes y < 0 and divides the interval @X@ by [y ... 0] 409 | divNegative :: (Fractional a, Ord a) => Interval a -> a -> Interval a 410 | divNegative x@(I a b) y 411 | | a == 0 && b == 0 = - x -- flip negative zeros 412 | -- b < 0 || isNegativeZero b = (b / y) ... posInfinity 413 | | b < 0 = (b / y) ... posInfinity 414 | | a < 0 = whole 415 | | otherwise = negInfinity ... (a / y) 416 | {-# INLINE divNegative #-} 417 | 418 | divZero :: (Fractional a, Ord a) => Interval a -> Interval a 419 | divZero x@(I a b) 420 | | a == 0 && b == 0 = x 421 | | otherwise = whole 422 | {-# INLINE divZero #-} 423 | 424 | -- | Fractional instance for intervals. 425 | -- 426 | -- -- The property tests below are currently disabled (#66). 427 | -- -- prop> ys /= singleton 0 ==> conservative2 ((/) :: Double -> Double -> Double) (/) xs ys 428 | -- -- prop> xs /= singleton 0 ==> conservative (recip :: Double -> Double) recip xs 429 | instance (Fractional a, Ord a) => Fractional (Interval a) where 430 | -- TODO: check isNegativeZero properly 431 | x / y@(I a b) 432 | | 0 `notElem` y = divNonZero x y 433 | | iz && sz = Exception.throw DivideByZero 434 | | iz = divPositive x a 435 | | sz = divNegative x b 436 | | otherwise = divZero x 437 | where 438 | iz = a == 0 439 | sz = b == 0 440 | fromRational r = let r' = fromRational r in I r' r' 441 | {-# INLINE fromRational #-} 442 | 443 | instance RealFrac a => RealFrac (Interval a) where 444 | properFraction x = (b, x - fromIntegral b) 445 | where 446 | b = truncate (midpoint x) 447 | {-# INLINE properFraction #-} 448 | ceiling x = ceiling (sup x) 449 | {-# INLINE ceiling #-} 450 | floor x = floor (inf x) 451 | {-# INLINE floor #-} 452 | round x = round (midpoint x) 453 | {-# INLINE round #-} 454 | truncate x = truncate (midpoint x) 455 | {-# INLINE truncate #-} 456 | 457 | -- | Transcendental functions for intervals. 458 | -- 459 | -- prop> conservative (exp :: Double -> Double) exp 460 | -- prop> conservativeExceptNaN (log :: Double -> Double) log 461 | -- prop> conservative (sin :: Double -> Double) sin 462 | -- prop> conservative (cos :: Double -> Double) cos 463 | -- prop> conservative (tan :: Double -> Double) tan 464 | -- prop> conservativeExceptNaN (asin :: Double -> Double) asin 465 | -- prop> conservativeExceptNaN (acos :: Double -> Double) acos 466 | -- prop> conservative (atan :: Double -> Double) atan 467 | -- prop> conservative (sinh :: Double -> Double) sinh 468 | -- prop> conservative (cosh :: Double -> Double) cosh 469 | -- prop> conservative (tanh :: Double -> Double) tanh 470 | -- prop> conservativeExceptNaN (asinh :: Double -> Double) asinh 471 | -- prop> conservativeExceptNaN (acosh :: Double -> Double) acosh 472 | -- prop> conservativeExceptNaN (atanh :: Double -> Double) atanh 473 | -- 474 | -- >>> cos (0 ... (pi + 0.1)) 475 | -- -1.0 ... 1.0 476 | instance (RealFloat a, Ord a) => Floating (Interval a) where 477 | pi = singleton pi 478 | {-# INLINE pi #-} 479 | exp = increasing exp 480 | {-# INLINE exp #-} 481 | log (I a b) = (if a > 0 then log a else negInfinity) ... (if b > 0 then log b else negInfinity) 482 | {-# INLINE log #-} 483 | sin = periodic (2 * pi) (symmetric 1) (signum' . cos) sin 484 | cos = periodic (2 * pi) (symmetric 1) (signum' . negate . sin) cos 485 | tan = periodic pi whole (const GT) tan -- derivative only has to have correct sign 486 | asin (I a b) = (asin' a) ... (asin' b) 487 | where 488 | asin' x | x >= 1 = halfPi 489 | | x <= -1 = -halfPi 490 | | otherwise = asin x 491 | halfPi = pi / 2 492 | {-# INLINE asin #-} 493 | acos (I a b) = (acos' a) ... (acos' b) 494 | where 495 | acos' x | x >= 1 = 0 496 | | x <= -1 = pi 497 | | otherwise = acos x 498 | {-# INLINE acos #-} 499 | atan = increasing atan 500 | {-# INLINE atan #-} 501 | sinh = increasing sinh 502 | {-# INLINE sinh #-} 503 | cosh x@(I a b) 504 | | b < 0 = decreasing cosh x 505 | | a >= 0 = increasing cosh x 506 | | otherwise = I 0 $ cosh $ if - a > b 507 | then a 508 | else b 509 | {-# INLINE cosh #-} 510 | tanh = increasing tanh 511 | {-# INLINE tanh #-} 512 | asinh = increasing asinh 513 | {-# INLINE asinh #-} 514 | acosh (I a b) = (acosh' a) ... (acosh' b) 515 | where 516 | acosh' x | x <= 1 = 0 517 | | otherwise = acosh x 518 | {-# INLINE acosh #-} 519 | atanh (I a b) = (atanh' a) ... (atanh' b) 520 | where 521 | atanh' x | x <= -1 = negInfinity 522 | | x >= 1 = posInfinity 523 | | otherwise = atanh x 524 | {-# INLINE atanh #-} 525 | 526 | -- | lift a monotone increasing function over a given interval 527 | increasing :: (a -> b) -> Interval a -> Interval b 528 | increasing f (I a b) = I (f a) (f b) 529 | 530 | -- | lift a monotone decreasing function over a given interval 531 | decreasing :: (a -> b) -> Interval a -> Interval b 532 | decreasing f (I a b) = I (f b) (f a) 533 | 534 | -- | We have to play some semantic games to make these methods make sense. 535 | -- Most compute with the midpoint of the interval. 536 | instance RealFloat a => RealFloat (Interval a) where 537 | floatRadix = floatRadix . midpoint 538 | 539 | floatDigits = floatDigits . midpoint 540 | floatRange = floatRange . midpoint 541 | decodeFloat = decodeFloat . midpoint 542 | encodeFloat m e = singleton (encodeFloat m e) 543 | exponent = exponent . midpoint 544 | significand x = min a b ... max a b 545 | where 546 | (_ ,em) = decodeFloat (midpoint x) 547 | (mi,ei) = decodeFloat (inf x) 548 | (ms,es) = decodeFloat (sup x) 549 | a = encodeFloat mi (ei - em - floatDigits x) 550 | b = encodeFloat ms (es - em - floatDigits x) 551 | scaleFloat n (I a b) = I (scaleFloat n a) (scaleFloat n b) 552 | isNaN (I a b) = isNaN a || isNaN b 553 | isInfinite (I a b) = isInfinite a || isInfinite b 554 | isDenormalized (I a b) = isDenormalized a || isDenormalized b 555 | -- contains negative zero 556 | isNegativeZero (I a b) = not (a > 0) 557 | && not (b < 0) 558 | && ( (b == 0 && (a < 0 || isNegativeZero a)) 559 | || (a == 0 && isNegativeZero a) 560 | || (a < 0 && b >= 0)) 561 | isIEEE _ = False 562 | 563 | atan2 = error "unimplemented" 564 | 565 | -- TODO: (^), (^^) to give tighter bounds 566 | 567 | -- | Calculate the intersection of two intervals. 568 | -- 569 | -- >>> intersection (1 ... 10 :: Interval Double) (5 ... 15 :: Interval Double) 570 | -- Just (5.0 ... 10.0) 571 | intersection :: Ord a => Interval a -> Interval a -> Maybe (Interval a) 572 | intersection x@(I a b) y@(I a' b') 573 | | x /=! y = Nothing 574 | | otherwise = Just $ I (max a a') (min b b') 575 | {-# INLINE intersection #-} 576 | 577 | -- | Calculate the convex hull of two intervals 578 | -- 579 | -- >>> hull (0 ... 10 :: Interval Double) (5 ... 15 :: Interval Double) 580 | -- 0.0 ... 15.0 581 | -- 582 | -- >>> hull (15 ... 85 :: Interval Double) (0 ... 10 :: Interval Double) 583 | -- 0.0 ... 85.0 584 | -- 585 | -- prop> conservative2 const hull 586 | -- prop> conservative2 (flip const) hull 587 | hull :: Ord a => Interval a -> Interval a -> Interval a 588 | hull (I a b) (I a' b') = I (min a a') (max b b') 589 | {-# INLINE hull #-} 590 | 591 | -- | For all @x@ in @X@, @y@ in @Y@. @x '<' y@ 592 | -- 593 | -- >>> (5 ... 10 :: Interval Double) >> (5 ... 10 :: Interval Double) >> (20 ... 30 :: Interval Double) Interval a -> Interval a -> Bool 602 | I _ bx >> (5 ... 10 :: Interval Double) <=! (20 ... 30 :: Interval Double) 608 | -- True 609 | -- 610 | -- >>> (5 ... 10 :: Interval Double) <=! (10 ... 30 :: Interval Double) 611 | -- True 612 | -- 613 | -- >>> (20 ... 30 :: Interval Double) <=! (5 ... 10 :: Interval Double) 614 | -- False 615 | (<=!) :: Ord a => Interval a -> Interval a -> Bool 616 | I _ bx <=! I ay _ = bx <= ay 617 | {-# INLINE (<=!) #-} 618 | 619 | -- | For all @x@ in @X@, @y@ in @Y@. @x '==' y@ 620 | -- 621 | -- Only singleton intervals or empty intervals can return true 622 | -- 623 | -- >>> (singleton 5 :: Interval Double) ==! (singleton 5 :: Interval Double) 624 | -- True 625 | -- 626 | -- >>> (5 ... 10 :: Interval Double) ==! (5 ... 10 :: Interval Double) 627 | -- False 628 | (==!) :: Eq a => Interval a -> Interval a -> Bool 629 | I ax bx ==! I ay by = bx == ay && ax == by 630 | {-# INLINE (==!) #-} 631 | 632 | -- | For all @x@ in @X@, @y@ in @Y@. @x '/=' y@ 633 | -- 634 | -- >>> (5 ... 15 :: Interval Double) /=! (20 ... 40 :: Interval Double) 635 | -- True 636 | -- 637 | -- >>> (5 ... 15 :: Interval Double) /=! (15 ... 40 :: Interval Double) 638 | -- False 639 | (/=!) :: Ord a => Interval a -> Interval a -> Bool 640 | I ax bx /=! I ay by = bx < ay || ax > by 641 | {-# INLINE (/=!) #-} 642 | 643 | -- | For all @x@ in @X@, @y@ in @Y@. @x '>' y@ 644 | -- 645 | -- >>> (20 ... 40 :: Interval Double) >! (10 ... 19 :: Interval Double) 646 | -- True 647 | -- 648 | -- >>> (5 ... 20 :: Interval Double) >! (15 ... 40 :: Interval Double) 649 | -- False 650 | (>!) :: Ord a => Interval a -> Interval a -> Bool 651 | I ax _ >! I _ by = ax > by 652 | {-# INLINE (>!) #-} 653 | 654 | -- | For all @x@ in @X@, @y@ in @Y@. @x '>=' y@ 655 | -- 656 | -- >>> (20 ... 40 :: Interval Double) >=! (10 ... 20 :: Interval Double) 657 | -- True 658 | -- 659 | -- >>> (5 ... 20 :: Interval Double) >=! (15 ... 40 :: Interval Double) 660 | -- False 661 | (>=!) :: Ord a => Interval a -> Interval a -> Bool 662 | I ax _ >=! I _ by = ax >= by 663 | {-# INLINE (>=!) #-} 664 | 665 | -- | For all @x@ in @X@, @y@ in @Y@. @x `op` y@ 666 | certainly :: Ord a => (forall b. Ord b => b -> b -> Bool) -> Interval a -> Interval a -> Bool 667 | certainly cmp l r 668 | | lt && eq && gt = True 669 | | lt && eq = l <=! r 670 | | lt && gt = l /=! r 671 | | lt = l =! r 673 | | eq = l ==! r 674 | | gt = l >! r 675 | | otherwise = False 676 | where 677 | lt = cmp False True 678 | eq = cmp True True 679 | gt = cmp True False 680 | {-# INLINE certainly #-} 681 | 682 | -- | Check if interval @X@ totally contains interval @Y@ 683 | -- 684 | -- >>> (20 ... 40 :: Interval Double) `contains` (25 ... 35 :: Interval Double) 685 | -- True 686 | -- 687 | -- >>> (20 ... 40 :: Interval Double) `contains` (15 ... 35 :: Interval Double) 688 | -- False 689 | contains :: Ord a => Interval a -> Interval a -> Bool 690 | contains (I ax bx) (I ay by) = ax <= ay && by <= bx 691 | {-# INLINE contains #-} 692 | 693 | -- | Flipped version of `contains`. Check if interval @X@ a subset of interval @Y@ 694 | -- 695 | -- >>> (25 ... 35 :: Interval Double) `isSubsetOf` (20 ... 40 :: Interval Double) 696 | -- True 697 | -- 698 | -- >>> (20 ... 40 :: Interval Double) `isSubsetOf` (15 ... 35 :: Interval Double) 699 | -- False 700 | isSubsetOf :: Ord a => Interval a -> Interval a -> Bool 701 | isSubsetOf = flip contains 702 | {-# INLINE isSubsetOf #-} 703 | 704 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@? 705 | ( Interval a -> Interval a -> Bool 706 | I ax _ Interval a -> Interval a -> Bool 711 | I ax _ <=? I _ by = ax <= by 712 | {-# INLINE (<=?) #-} 713 | 714 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@? 715 | (==?) :: Ord a => Interval a -> Interval a -> Bool 716 | I ax bx ==? I ay by = ax <= by && bx >= ay 717 | {-# INLINE (==?) #-} 718 | 719 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@? 720 | (/=?) :: Eq a => Interval a -> Interval a -> Bool 721 | I ax bx /=? I ay by = ax /= by || bx /= ay 722 | {-# INLINE (/=?) #-} 723 | 724 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@? 725 | (>?) :: Ord a => Interval a -> Interval a -> Bool 726 | I _ bx >? I ay _ = bx > ay 727 | {-# INLINE (>?) #-} 728 | 729 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@? 730 | (>=?) :: Ord a => Interval a -> Interval a -> Bool 731 | I _ bx >=? I ay _ = bx >= ay 732 | {-# INLINE (>=?) #-} 733 | 734 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x `op` y@? 735 | possibly :: Ord a => (forall b. Ord b => b -> b -> Bool) -> Interval a -> Interval a -> Bool 736 | possibly cmp l r 737 | | lt && eq && gt = True 738 | | lt && eq = l <=? r 739 | | lt && gt = l /=? r 740 | | lt = l =? r 742 | | eq = l ==? r 743 | | gt = l >? r 744 | | otherwise = False 745 | where 746 | lt = cmp LT EQ 747 | eq = cmp EQ EQ 748 | gt = cmp GT EQ 749 | {-# INLINE possibly #-} 750 | 751 | -- | The nearest value to that supplied which is contained in the interval. 752 | -- 753 | -- prop> (clamp xs y) `elem` xs 754 | clamp :: Ord a => Interval a -> a -> a 755 | clamp (I a b) x 756 | | x < a = a 757 | | x > b = b 758 | | otherwise = x 759 | 760 | -- | Inflate an interval by enlarging it at both ends. 761 | -- 762 | -- >>> inflate 3 (-1 ... 7) 763 | -- -4 ... 10 764 | -- 765 | -- >>> inflate (-2) (0 ... 4) 766 | -- -2 ... 6 767 | -- 768 | -- prop> inflate x i `contains` i 769 | inflate :: (Num a, Ord a) => a -> Interval a -> Interval a 770 | inflate x y = symmetric x + y 771 | 772 | -- | Deflate an interval by shrinking it from both ends. 773 | -- Note that in cases that would result in an empty interval, the result is a singleton interval at the midpoint. 774 | -- 775 | -- >>> deflate 3.0 (-4.0 ... 10.0) 776 | -- -1.0 ... 7.0 777 | -- 778 | -- >>> deflate 2.0 (-1.0 ... 1.0) 779 | -- 0.0 ... 0.0 780 | deflate :: (Fractional a, Ord a) => a -> Interval a -> Interval a 781 | deflate x i@(I a b) | a' <= b' = I a' b' 782 | | otherwise = singleton m 783 | where 784 | a' = a + x 785 | b' = b - x 786 | m = midpoint i 787 | 788 | -- | Scale an interval about its midpoint. 789 | -- 790 | -- >>> scale 1.1 (-6.0 ... 4.0) 791 | -- -6.5 ... 4.5 792 | -- 793 | -- >>> scale (-2.0) (-1.0 ... 1.0) 794 | -- -2.0 ... 2.0 795 | -- 796 | -- -- The property test below is currently disabled (#66). 797 | -- -- prop> abs x >= 1 ==> (scale (x :: Double) i) `contains` i 798 | -- prop> forAll (choose (0,1)) $ \x -> abs x <= 1 ==> i `contains` (scale (x :: Double) i) 799 | scale :: (Fractional a, Ord a) => a -> Interval a -> Interval a 800 | scale x i = a ... b where 801 | h = x * width i / 2 802 | mid = midpoint i 803 | a = mid - h 804 | b = mid + h 805 | 806 | -- | Construct a symmetric interval. 807 | -- 808 | -- >>> symmetric 3 809 | -- -3 ... 3 810 | -- 811 | -- >>> symmetric (-2) 812 | -- -2 ... 2 813 | -- 814 | -- prop> x `elem` symmetric x 815 | -- prop> 0 `elem` symmetric x 816 | symmetric :: (Num a, Ord a) => a -> Interval a 817 | symmetric x = negate x ... x 818 | 819 | -- | id function. Useful for type specification 820 | -- 821 | -- >>> :t idouble (1 ... 3) 822 | -- idouble (1 ... 3) :: Interval Double 823 | idouble :: Interval Double -> Interval Double 824 | idouble = id 825 | 826 | -- | id function. Useful for type specification 827 | -- 828 | -- >>> :t ifloat (1 ... 3) 829 | -- ifloat (1 ... 3) :: Interval Float 830 | ifloat :: Interval Float -> Interval Float 831 | ifloat = id 832 | 833 | -- Bugs: 834 | -- sin 1 :: Interval Double 835 | 836 | default (Integer,Double) 837 | 838 | -- | an interval containing all x `quot` y 839 | -- prop> forAll (memberOf xs) $ \ x -> forAll (memberOf ys) $ \ y -> 0 `notMember` ys ==> (x `quot` y) `member` (xs `iquot` ys) 840 | -- prop> 0 `member` ys ==> ioProperty $ do z <- try (evaluate (xs `iquot` ys)); return $ z === Left DivideByZero 841 | iquot :: Integral a => Interval a -> Interval a -> Interval a 842 | iquot (I l u) (I l' u') = 843 | if l' <= 0 && 0 <= u' then throw DivideByZero else I 844 | (minimum [a `quot` b | a <- [l,u], b <- [l',u']]) 845 | (maximum [a `quot` b | a <- [l,u], b <- [l',u']]) 846 | 847 | -- | an interval containing all x `rem` y 848 | -- prop> forAll (memberOf xs) $ \ x -> forAll (memberOf ys) $ \ y -> 0 `notMember` ys ==> (x `rem` y) `member` (xs `irem` ys) 849 | -- prop> 0 `member` ys ==> ioProperty $ do z <- try (evaluate (xs `irem` ys)); return $ z === Left DivideByZero 850 | irem :: Integral a => Interval a -> Interval a -> Interval a 851 | irem (I l u) (I l' u') = 852 | if l' <= 0 && 0 <= u' then throw DivideByZero else I 853 | (minimum [0, signum l * (abs u' - 1), signum l * (abs l' - 1)]) 854 | (maximum [0, signum u * (abs u' - 1), signum u * (abs l' - 1)]) 855 | 856 | -- | an interval containing all x `div` y 857 | -- prop> forAll (memberOf xs) $ \ x -> forAll (memberOf ys) $ \ y -> 0 `notMember` ys ==> (x `div` y) `member` (xs `idiv` ys) 858 | -- prop> 0 `member` ys ==> ioProperty $ do z <- try (evaluate (xs `idiv` ys)); return $ z === Left DivideByZero 859 | idiv :: Integral a => Interval a -> Interval a -> Interval a 860 | idiv (I l u) (I l' u') = 861 | if l' <= 0 && 0 <= u' then throw DivideByZero else I 862 | (min (l `Prelude.div` max 1 l') (u `Prelude.div` min (-1) u')) 863 | (max (u `Prelude.div` max 1 l') (l `Prelude.div` min (-1) u')) 864 | 865 | -- | an interval containing all x `mod` y 866 | -- prop> forAll (memberOf xs) $ \ x -> forAll (memberOf ys) $ \ y -> 0 `notMember` ys ==> (x `mod` y) `member` (xs `imod` ys) 867 | -- prop> 0 `member` ys ==> ioProperty $ do z <- try (evaluate (xs `imod` ys)); return $ z === Left DivideByZero 868 | imod :: Integral a => Interval a -> Interval a -> Interval a 869 | imod _ (I l' u') = 870 | if l' <= 0 && 0 <= u' then throw DivideByZero else 871 | I (min (l'+1) 0) (max 0 (u'-1)) 872 | -------------------------------------------------------------------------------- /tests/doctests.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Main (doctests) 4 | -- Copyright : (C) 2012-14 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : provisional 8 | -- Portability : portable 9 | -- 10 | -- This module exists to add dependencies 11 | ----------------------------------------------------------------------------- 12 | module Main where 13 | 14 | main :: IO () 15 | main = do 16 | putStrLn "This test-suite exists only to add dependencies" 17 | putStrLn "To run doctests: " 18 | putStrLn " cabal build all --enable-tests" 19 | putStrLn " cabal-docspec" 20 | --------------------------------------------------------------------------------