log-domain-0.11.2/0000755000000000000000000000000013136745772012026 5ustar0000000000000000log-domain-0.11.2/.ghci0000644000000000000000000000014513136745772012741 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h -optP-Iincludes log-domain-0.11.2/CHANGELOG.markdown0000644000000000000000000000464513136745772015072 0ustar00000000000000000.11.2 ------ * Support `doctest-0.12` 0.11.1 ------ * Revamp `Setup.hs` to use `cabal-doctest`. This makes it build with `Cabal-2.0`, and makes the `doctest`s work with `cabal new-build` and sandboxes. 0.11 ---- * Replace use of `Hashable1` from `hashable-extras` in favor of `Hashable` from `hashable-1.2.5.0`. As a result, the `hashable-extras` dependency has been removed. * On Windows, we now use the FFI to link against the C math library if building with GHC 8.0 or later, which features a much improved runtime linker story. * Remove `generic-deriving` dependency 0.10.3.1 -------- * Support `safecopy` 0.9 0.10.3 ------ * Work around an issue with `safecopy` on GHC 7.10 * Changed the repository link to my `ekmett` github account from `analytics`. 0.10.2.1 -------- * Add `vector` 0.11 support. 0.10.2 ------ * Add `generic-deriving` 1.8 support. We also no longer incur a `generic-deriving` dependency at all on GHC 7.6+ 0.10.1.1 -------- * Compiles warning-free on GHC 7.10 0.10.1 ------ * `semigroupoids` 5 support. 0.10.0.1 -------- * Improved the stability and portability of the `doctest` test suite 0.10 ---- * `(**)` is now much more accurately defined. * We now avoid comparisons for equality with infinities. * Fixed a bug in `negate`. * On windows we avoid FFI into the math library, and accept less accurate results. (Sorry!) 0.9.3 ------- * Fixed subtraction again. For real this time. 0.9.2.1 ------- * Support `generic-deriving` 1.7 0.9.2 ----- * Fixed subtraction better. 0.9.1 ----- * Fixed subtraction. 0.8 --- * Updated to `comonad` and `semigroupoids` 4. 0.7.2 ----- * Dependency bump to allow `comonad` and `semigroupoids` 4.0 0.7.1 ----- * Marked `Numeric.Log` `Trustworthy`. 0.6 --- * Renamed the data constructor to `Exp` and the field accessor to `ln` per issue #1. 0.5.0.1 ------- * Wider bounds for `generic-deriving` so we can build with GHC HEAD. 0.5 --- * Switched the `Hashable1` instance to use the new, lighter, `hashable-extras` 0.4 --- * `instance Hashable1 Log` 0.3.0.1 ------- * Wider `binary` version bound 0.3 --- * Added support for `cereal`. 0.2 --- * Added an `Enum` instance. * Added `sum` to calculate using the `log-sum-exp` trick. 0.1.0.1 ------- * Minor packaging changes 0.1 --- * Renamed from `log` to `log-domain` due to internal hackage issues rendering that name inaccessible. * Ported `Numeric.Log` from [analytics](http://github.com/analytics) at the request of @bgamari log-domain-0.11.2/AUTHORS.markdown0000644000000000000000000000055413136745772014723 0ustar0000000000000000`log-domain` was inspired by the `LogFloat` package by Wren Thornton. A variant of that code was introduced into `Data.Analytics.Numeric.Log` in the [analytics](http://github.com/analytics) project by * [Edward Kmett](mailto:ekmett@gmail.com) [@ekmett](https://github.com/ekmett) This package is an attempt to open that version up to more users. -Edward Kmett log-domain-0.11.2/README.markdown0000644000000000000000000000162113136745772014527 0ustar0000000000000000log-domain ========== [![Hackage](https://img.shields.io/hackage/v/log-domain.svg)](https://hackage.haskell.org/package/log-domain) [![Build Status](https://secure.travis-ci.org/ekmett/log-domain.png?branch=master)](http://travis-ci.org/ekmett/log-domain) > What rolls down stairs alone or in pairs > Rolls over your neighbor's dog? > What's great for a snack and fits on your back? > It's Log, Log, Log! > It's Log, Log, it's big, it's heavy, it's wood. > It's Log, Log, it's better than bad, it's good! > Everyone wants a log! You're gonna love it, Log! > Come on and get your log! Everyone needs a Log!" > -- Ren & Stimpy, The Log Song This package provides log-domain floats, doubles and complex numbers. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett log-domain-0.11.2/Setup.lhs0000644000000000000000000000124113136745772013634 0ustar0000000000000000\begin{code} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} module Main (main) where #ifndef MIN_VERSION_cabal_doctest #define MIN_VERSION_cabal_doctest(x,y,z) 0 #endif #if MIN_VERSION_cabal_doctest(1,0,0) import Distribution.Extra.Doctest ( defaultMainWithDoctests ) main :: IO () main = defaultMainWithDoctests "doctests" #else #ifdef MIN_VERSION_Cabal -- If the macro is defined, we have new cabal-install, -- but for some reason we don't have cabal-doctest in package-db -- -- Probably we are running cabal sdist, when otherwise using new-build -- workflow import Warning () #endif import Distribution.Simple main :: IO () main = defaultMain #endif \end{code} log-domain-0.11.2/.vim.custom0000644000000000000000000000137713136745772014143 0ustar0000000000000000" Add the following to your .vimrc to automatically load this on startup " if filereadable(".vim.custom") " so .vim.custom " endif function StripTrailingWhitespace() let myline=line(".") let mycolumn = col(".") silent %s/ *$// call cursor(myline, mycolumn) endfunction " enable syntax highlighting syntax on " search for the tags file anywhere between here and / set tags=TAGS;/ " highlight tabs and trailing spaces set listchars=tab:‗‗,trail:‗ set list " f2 runs hasktags map :exec ":!hasktags -x -c --ignore src" " strip trailing whitespace before saving " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() " rebuild hasktags after saving au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" log-domain-0.11.2/Warning.hs0000644000000000000000000000040013136745772013761 0ustar0000000000000000module Warning {-# WARNING ["You are configuring this package without cabal-doctest installed.", "The doctests test-suite will not work as a result.", "To fix this, install cabal-doctest before configuring."] #-} () where log-domain-0.11.2/log-domain.cabal0000644000000000000000000000462013136745772015042 0ustar0000000000000000name: log-domain category: Numeric version: 0.11.2 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/log-domain/ bug-reports: http://github.com/ekmett/log-domain/issues copyright: Copyright (C) 2013-2015 Edward A. Kmett build-type: Custom tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2 synopsis: Log-domain arithmetic description: This package provides log-domain floats, doubles and complex numbers. extra-source-files: .travis.yml .ghci .gitignore .vim.custom travis/cabal-apt-install travis/config AUTHORS.markdown README.markdown CHANGELOG.markdown HLint.hs Warning.hs source-repository head type: git location: https://github.com/analytics/log-domain custom-setup setup-depends: base >= 4 && < 5, Cabal, cabal-doctest >= 1 && < 1.1 -- You can disable the doctests test suite with -f-test-doctests flag test-doctests default: True manual: True flag ffi default: True manual: True library build-depends: base >= 4.5 && < 5, binary >= 0.5 && < 0.9, bytes >= 0.7 && < 1, cereal >= 0.3.5 && < 0.6, comonad >= 4 && < 6, deepseq >= 1.3 && < 1.5, distributive >= 0.3 && < 1, hashable >= 1.2.5 && < 1.3, semigroupoids >= 4 && < 6, semigroups >= 0.8.4 && < 1, safecopy >= 0.8.1 && < 0.10, vector >= 0.9 && < 0.13 exposed-modules: Numeric.Log Numeric.Log.Signed if impl(ghc < 7.6) build-depends: ghc-prim if flag(ffi) && !(os(windows) && !impl(ghc >= 8.0)) cpp-options: -D__USE_FFI__ ghc-options: -Wall -fwarn-tabs -O2 hs-source-dirs: src test-suite doctests type: exitcode-stdio-1.0 main-is: doctests.hs ghc-options: -Wall -threaded hs-source-dirs: tests if !flag(test-doctests) buildable: False else build-depends: base, doctest >= 0.11.1 && < 0.13, generic-deriving, log-domain, semigroups >= 0.9, simple-reflect >= 0.3.1 log-domain-0.11.2/.travis.yml0000644000000000000000000000742113136745772014143 0ustar0000000000000000# This file has been generated -- see https://github.com/hvr/multi-ghc-travis language: c sudo: false cache: directories: - $HOME/.cabsnap - $HOME/.cabal/packages before_cache: - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar matrix: include: - env: CABALVER=1.24 GHCVER=7.4.2 compiler: ": #GHC 7.4.2" addons: {apt: {packages: [cabal-install-1.24,ghc-7.4.2,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=7.6.3 compiler: ": #GHC 7.6.3" addons: {apt: {packages: [cabal-install-1.24,ghc-7.6.3,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=7.8.4 compiler: ": #GHC 7.8.4" addons: {apt: {packages: [cabal-install-1.24,ghc-7.8.4,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=7.10.3 compiler: ": #GHC 7.10.3" addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=8.0.2 compiler: ": #GHC 8.0.2" addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=head compiler: ": #GHC head" addons: {apt: {packages: [cabal-install-1.24,ghc-head,hlint], sources: [hvr-ghc]}} allow_failures: - env: CABALVER=1.24 GHCVER=head before_install: - unset CC - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH install: - cabal --version - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; then zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; fi - travis_retry cabal update -v - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt # check whether current requested install-plan matches cached package-db snapshot - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; then echo "cabal build-cache HIT"; rm -rfv .ghc; cp -a $HOME/.cabsnap/ghc $HOME/.ghc; cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; else echo "cabal build-cache MISS"; rm -rf $HOME/.cabsnap; mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; cabal install -j --only-dependencies --enable-tests --enable-benchmarks; fi # snapshot package-db on cache miss - if [ ! -d $HOME/.cabsnap ]; then echo "snapshotting package-db to build-cache"; mkdir $HOME/.cabsnap; cp -a $HOME/.ghc $HOME/.cabsnap/ghc; cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; fi # Here starts the actual work to be performed for the package under test; # any command which exits with a non-zero exit code causes the build to fail. script: - cabal configure -v2 --enable-tests --enable-benchmarks # -v2 provides useful information for debugging - cabal build # this builds all libraries and executables (including tests/benchmarks) - cabal test --show-details=always - cabal sdist # tests that a source-distribution can be generated - hlint src --cpp-define HLINT - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; cd dist/; if [ -f "$SRC_TGZ" ]; then cabal install "$SRC_TGZ"; else echo "expected '$SRC_TGZ' not found"; exit 1; fi notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313log-domain\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f" # EOF log-domain-0.11.2/.gitignore0000644000000000000000000000016613136745772014021 0ustar0000000000000000.cabal-sandbox cabal.sandbox.config dist dist-newstyle docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# log-domain-0.11.2/LICENSE0000644000000000000000000000236413136745772013040 0ustar0000000000000000Copyright 2011-2015 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. log-domain-0.11.2/HLint.hs0000644000000000000000000000002713136745772013377 0ustar0000000000000000ignore "Use camelCase" log-domain-0.11.2/src/0000755000000000000000000000000013136745772012615 5ustar0000000000000000log-domain-0.11.2/src/Numeric/0000755000000000000000000000000013136745772014217 5ustar0000000000000000log-domain-0.11.2/src/Numeric/Log.hs0000644000000000000000000004031513136745772015277 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Trustworthy #-} -------------------------------------------------------------------- -- | -- Copyright : (c) Edward Kmett 2013-2015 -- License : BSD3 -- Maintainer: Edward Kmett -- Stability : experimental -- Portability: non-portable -- -------------------------------------------------------------------- module Numeric.Log ( Log(..) , Precise(..) , sum ) where import Prelude hiding (maximum, sum) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Comonad import Control.DeepSeq import Control.Monad import Data.Binary as Binary import Data.Bytes.Serial import Data.Complex import Data.Data import Data.Distributive import Data.Foldable as Foldable hiding (sum) import Data.Functor.Bind import Data.Functor.Extend import Data.Hashable import Data.Hashable.Lifted import Data.Int import Data.List as List hiding (sum) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import Data.SafeCopy import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Serialize as Serialize #if __GLASGOW_HASKELL__ < 710 import Data.Traversable #endif import Data.Vector.Unboxed as U hiding (sum) import Data.Vector.Generic as G hiding (sum) import Data.Vector.Generic.Mutable as M import Foreign.Ptr import Foreign.Storable import GHC.Generics import Text.Read as T import Text.Show as T {-# ANN module "HLint: ignore Eta reduce" #-} -- $setup -- >>> let Exp x ~= Exp y = abs ((exp x-exp y) / exp x) < 0.01 -- | @Log@-domain @Float@ and @Double@ values. newtype Log a = Exp { ln :: a } deriving (Eq,Ord,Data,Typeable,Generic) --deriveSafeCopy 1 'base ''Log instance SafeCopy a => SafeCopy (Log a) where putCopy (Exp arg_afqB) = contain (do { safePut_a_afqC <- getSafePut; safePut_a_afqC arg_afqB; return () }) getCopy = contain (label "Numeric.Log.Log:" (do { safeGet_a_afqD <- getSafeGet; ((return Exp) <*> safeGet_a_afqD) })) version = 1 kind = base errorTypeName _ = "Numeric.Log.Log" instance (Floating a, Show a) => Show (Log a) where showsPrec d (Exp a) = T.showsPrec d (exp a) instance (Floating a, Read a) => Read (Log a) where readPrec = Exp . log <$> step T.readPrec instance Binary a => Binary (Log a) where put = Binary.put . ln {-# INLINE put #-} get = Exp <$> Binary.get {-# INLINE get #-} instance Serialize a => Serialize (Log a) where put = Serialize.put . ln {-# INLINE put #-} get = Exp <$> Serialize.get {-# INLINE get #-} instance Serial a => Serial (Log a) where serialize = serialize . ln deserialize = Exp <$> deserialize instance Serial1 Log where serializeWith f = f . ln deserializeWith m = Exp <$> m instance Functor Log where fmap f (Exp a) = Exp (f a) {-# INLINE fmap #-} instance Hashable a => Hashable (Log a) where hashWithSalt i (Exp a) = hashWithSalt i a {-# INLINE hashWithSalt #-} instance Hashable1 Log where liftHashWithSalt hws i (Exp a) = hws i a {-# INLINE liftHashWithSalt #-} instance Storable a => Storable (Log a) where sizeOf = sizeOf . ln {-# INLINE sizeOf #-} alignment = alignment . ln {-# INLINE alignment #-} peek ptr = Exp <$> peek (castPtr ptr) {-# INLINE peek #-} poke ptr (Exp a) = poke (castPtr ptr) a {-# INLINE poke #-} instance NFData a => NFData (Log a) where rnf (Exp a) = rnf a {-# INLINE rnf #-} instance Foldable Log where foldMap f (Exp a) = f a {-# INLINE foldMap #-} instance Foldable1 Log where foldMap1 f (Exp a) = f a {-# INLINE foldMap1 #-} instance Traversable Log where traverse f (Exp a) = Exp <$> f a {-# INLINE traverse #-} instance Traversable1 Log where traverse1 f (Exp a) = Exp <$> f a {-# INLINE traverse1 #-} instance Distributive Log where distribute = Exp . fmap ln {-# INLINE distribute #-} instance Extend Log where extended f w@Exp{} = Exp (f w) {-# INLINE extended #-} instance Comonad Log where extract (Exp a) = a {-# INLINE extract #-} extend f w@Exp{} = Exp (f w) {-# INLINE extend #-} instance Applicative Log where pure = Exp {-# INLINE pure #-} Exp f <*> Exp a = Exp (f a) {-# INLINE (<*>) #-} instance ComonadApply Log where Exp f <@> Exp a = Exp (f a) {-# INLINE (<@>) #-} instance Apply Log where Exp f <.> Exp a = Exp (f a) {-# INLINE (<.>) #-} instance Bind Log where Exp a >>- f = f a {-# INLINE (>>-) #-} instance Monad Log where return = pure {-# INLINE return #-} Exp a >>= f = f a {-# INLINE (>>=) #-} instance (RealFloat a, Precise a, Enum a) => Enum (Log a) where succ a = a + 1 {-# INLINE succ #-} pred a = a - 1 {-# INLINE pred #-} toEnum = fromIntegral {-# INLINE toEnum #-} fromEnum = round . exp . ln {-# INLINE fromEnum #-} enumFrom (Exp a) = [ Exp (log b) | b <- Prelude.enumFrom (exp a) ] {-# INLINE enumFrom #-} enumFromThen (Exp a) (Exp b) = [ Exp (log c) | c <- Prelude.enumFromThen (exp a) (exp b) ] {-# INLINE enumFromThen #-} enumFromTo (Exp a) (Exp b) = [ Exp (log c) | c <- Prelude.enumFromTo (exp a) (exp b) ] {-# INLINE enumFromTo #-} enumFromThenTo (Exp a) (Exp b) (Exp c) = [ Exp (log d) | d <- Prelude.enumFromThenTo (exp a) (exp b) (exp c) ] {-# INLINE enumFromThenTo #-} -- | Negative infinity negInf :: Fractional a => a negInf = -(1/0) {-# INLINE negInf #-} -- $LogNumTests -- -- Subtraction -- -- >>> (3 - 1 :: Log Double) ~= 2 -- True -- -- >>> 1 - 3 :: Log Double -- NaN -- -- >>> (3 - 2 :: Log Float) ~= 1 -- True -- -- >>> 1 - 3 :: Log Float -- NaN -- -- >>> (Exp (1/0)) - (Exp (1/0)) :: Log Double -- NaN -- -- >>> 0 - 0 :: Log Double -- 0.0 -- -- >>> 0 - (Exp (1/0)) :: Log Double -- NaN -- -- >>> (Exp (1/0)) - 0.0 :: Log Double -- Infinity -- -- Multiplication -- -- >>> (3 * 2 :: Log Double) ~= 6 -- True -- -- >>> 0 * (Exp (1/0)) :: Log Double -- NaN -- -- >>> (Exp (1/0)) * (Exp (1/0)) :: Log Double -- Infinity -- -- >>> 0 * 0 :: Log Double -- 0.0 -- -- >>> (Exp (0/0)) * 0 :: Log Double -- NaN -- -- >>> (Exp (0/0)) * (Exp (1/0)) :: Log Double -- NaN -- -- Addition -- -- >>> (3 + 1 :: Log Double) ~= 4 -- True -- -- >>> 0 + 0 :: Log Double -- 0.0 -- -- >>> (Exp (1/0)) + (Exp (1/0)) :: Log Double -- Infinity -- -- >>> (Exp (1/0)) + 0 :: Log Double -- Infinity -- -- Division -- -- >>> (3 / 2 :: Log Double) ~= 1.5 -- True -- -- >>> 3 / 0 :: Log Double -- Infinity -- -- >>> (Exp (1/0)) / 0 :: Log Double -- Infinity -- -- >>> 0 / (Exp (1/0)) :: Log Double -- 0.0 -- -- >>> (Exp (1/0)) / (Exp (1/0)) :: Log Double -- NaN -- -- >>> 0 / 0 :: Log Double -- NaN -- -- Negation -- -- >>> ((-3) + 8 :: Log Double) ~= 8 -- False -- -- >>> (-0) :: Log Double -- 0.0 -- -- >>> (-(0/0)) :: Log Double -- NaN -- -- Signum -- -- >>> signum 0 :: Log Double -- 0.0 -- -- >>> signum 3 :: Log Double -- 1.0 -- -- >>> signum (Exp (0/0)) :: Log Double -- NaN instance (Precise a, RealFloat a) => Num (Log a) where Exp a * Exp b = Exp (a + b) {-# INLINE (*) #-} Exp a + Exp b | a == b && isInfinite a && isInfinite b = Exp a | a >= b = Exp (a + log1pexp (b - a)) | otherwise = Exp (b + log1pexp (a - b)) {-# INLINE (+) #-} Exp a - Exp b | isInfinite a && isInfinite b && a < 0 && b < 0 = Exp negInf | otherwise = Exp (a + log1mexp (b - a)) {-# INLINE (-) #-} signum a | a == 0 = Exp negInf -- 0 | a > 0 = Exp 0 -- 1 | otherwise = Exp (0/0) -- NaN {-# INLINE signum #-} negate (Exp a) | isInfinite a && a < 0 = Exp negInf | otherwise = Exp (0/0) {-# INLINE negate #-} abs = id {-# INLINE abs #-} fromInteger = Exp . log . fromInteger {-# INLINE fromInteger #-} instance (Precise a, RealFloat a, Eq a) => Fractional (Log a) where -- n/0 == infinity is handled seamlessly for us, as is 0/0 and infinity/infinity NaNs, and 0/infinity == 0. Exp a / Exp b = Exp (a-b) {-# INLINE (/) #-} fromRational = Exp . log . fromRational {-# INLINE fromRational #-} -- $LogProperFractionTests -- -- >>> (properFraction 3.5 :: (Integer, Log Double)) -- (3,0.5) -- -- >>> (properFraction 0.5 :: (Integer, Log Double)) -- (0,0.5) instance (Precise a, RealFloat a) => RealFrac (Log a) where properFraction l | ln l < 0 = (0, l) | otherwise = (\(b,a) -> (b, Exp $ log a)) $ properFraction $ exp (ln l) newtype instance U.MVector s (Log a) = MV_Log (U.MVector s a) newtype instance U.Vector (Log a) = V_Log (U.Vector a) instance (RealFloat a, Unbox a) => Unbox (Log a) instance (RealFloat a, Unbox a) => M.MVector U.MVector (Log a) where {-# INLINE basicLength #-} {-# INLINE basicUnsafeSlice #-} {-# INLINE basicOverlaps #-} {-# INLINE basicUnsafeNew #-} {-# INLINE basicUnsafeReplicate #-} {-# INLINE basicUnsafeRead #-} {-# INLINE basicUnsafeWrite #-} {-# INLINE basicClear #-} #if MIN_VERSION_vector(0,11,0) {-# INLINE basicInitialize #-} #endif {-# INLINE basicSet #-} {-# INLINE basicUnsafeCopy #-} {-# INLINE basicUnsafeGrow #-} basicLength (MV_Log v) = M.basicLength v basicUnsafeSlice i n (MV_Log v) = MV_Log $ M.basicUnsafeSlice i n v basicOverlaps (MV_Log v1) (MV_Log v2) = M.basicOverlaps v1 v2 basicUnsafeNew n = MV_Log `liftM` M.basicUnsafeNew n basicUnsafeReplicate n (Exp x) = MV_Log `liftM` M.basicUnsafeReplicate n x basicUnsafeRead (MV_Log v) i = Exp `liftM` M.basicUnsafeRead v i basicUnsafeWrite (MV_Log v) i (Exp x) = M.basicUnsafeWrite v i x basicClear (MV_Log v) = M.basicClear v #if MIN_VERSION_vector(0,11,0) basicInitialize (MV_Log v) = M.basicInitialize v #endif basicSet (MV_Log v) (Exp x) = M.basicSet v x basicUnsafeCopy (MV_Log v1) (MV_Log v2) = M.basicUnsafeCopy v1 v2 basicUnsafeGrow (MV_Log v) n = MV_Log `liftM` M.basicUnsafeGrow v n instance (RealFloat a, Unbox a) => G.Vector U.Vector (Log a) where {-# INLINE basicUnsafeFreeze #-} {-# INLINE basicUnsafeThaw #-} {-# INLINE basicLength #-} {-# INLINE basicUnsafeSlice #-} {-# INLINE basicUnsafeIndexM #-} {-# INLINE elemseq #-} basicUnsafeFreeze (MV_Log v) = V_Log `liftM` G.basicUnsafeFreeze v basicUnsafeThaw (V_Log v) = MV_Log `liftM` G.basicUnsafeThaw v basicLength (V_Log v) = G.basicLength v basicUnsafeSlice i n (V_Log v) = V_Log $ G.basicUnsafeSlice i n v basicUnsafeIndexM (V_Log v) i = Exp `liftM` G.basicUnsafeIndexM v i basicUnsafeCopy (MV_Log mv) (V_Log v) = G.basicUnsafeCopy mv v elemseq _ (Exp x) z = G.elemseq (undefined :: U.Vector a) x z instance (Precise a, RealFloat a, Ord a) => Real (Log a) where toRational (Exp a) = toRational (exp a) {-# INLINE toRational #-} data Acc1 a = Acc1 {-# UNPACK #-} !Int64 !a instance (Precise a, RealFloat a) => Monoid (Log a) where mempty = Exp negInf {-# INLINE mempty #-} mappend = (+) {-# INLINE mappend #-} mconcat [] = 0 mconcat (Exp z:zs) = Exp $ case List.foldl' step1 (Acc1 0 z) zs of Acc1 nm1 a | isInfinite a -> a | otherwise -> a + log1p (List.foldl' (step2 a) 0 zs + fromIntegral nm1) where step1 (Acc1 n y) (Exp x) = Acc1 (n + 1) (max x y) step2 a r (Exp x) = r + expm1 (x - a) {-# INLINE mconcat #-} logMap :: Floating a => (a -> a) -> Log a -> Log a logMap f = Exp . log . f . exp . ln {-# INLINE logMap #-} data Acc a = Acc {-# UNPACK #-} !Int64 !a | None -- | Efficiently and accurately compute the sum of a set of log-domain numbers -- -- While folding with @(+)@ accomplishes the same end, it requires an -- additional @n-2@ logarithms to sum @n@ terms. In addition, -- here we introduce fewer opportunities for round-off error. -- -- While for small quantities the naive sum accumulates error, -- -- >>> let xs = Prelude.replicate 40000 (Exp 1e-4) :: [Log Float] -- >>> Prelude.sum xs ~= 4.00e4 -- True -- -- This sum gives a more accurate result, -- -- >>> Numeric.Log.sum xs ~= 4.00e4 -- True -- -- /NB:/ This does require two passes over the data. sum :: (RealFloat a, Ord a, Precise a, Foldable f) => f (Log a) -> Log a sum xs = Exp $ case Foldable.foldl' step1 None xs of None -> negInf Acc nm1 a | isInfinite a -> a | otherwise -> a + log1p (Foldable.foldl' (step2 a) 0 xs + fromIntegral nm1) where step1 None (Exp x) = Acc 0 x step1 (Acc n y) (Exp x) = Acc (n + 1) (max x y) step2 a r (Exp x) = r + expm1 (x - a) {-# INLINE sum #-} instance (RealFloat a, Precise a) => Floating (Log a) where pi = Exp (log pi) {-# INLINE pi #-} exp (Exp a) = Exp (exp a) {-# INLINE exp #-} log (Exp a) = Exp (log a) {-# INLINE log #-} Exp b ** Exp e = Exp (b * exp e) {-# INLINE (**) #-} sqrt (Exp a) = Exp (a / 2) {-# INLINE sqrt #-} logBase (Exp a) (Exp b) = Exp (log (logBase (exp a) (exp b))) {-# INLINE logBase #-} sin = logMap sin {-# INLINE sin #-} cos = logMap cos {-# INLINE cos #-} tan = logMap tan {-# INLINE tan #-} asin = logMap asin {-# INLINE asin #-} acos = logMap acos {-# INLINE acos #-} atan = logMap atan {-# INLINE atan #-} sinh = logMap sinh {-# INLINE sinh #-} cosh = logMap cosh {-# INLINE cosh #-} tanh = logMap tanh {-# INLINE tanh #-} asinh = logMap asinh {-# INLINE asinh #-} acosh = logMap acosh {-# INLINE acosh #-} atanh = logMap atanh {-# INLINE atanh #-} {-# RULES "realToFrac" realToFrac = Exp . realToFrac . ln :: Log Double -> Log Float "realToFrac" realToFrac = Exp . realToFrac . ln :: Log Float -> Log Double "realToFrac" realToFrac = exp . ln :: Log Double -> Double "realToFrac" realToFrac = exp . ln :: Log Float -> Float "realToFrac" realToFrac = Exp . log :: Double -> Log Double "realToFrac" realToFrac = Exp . log :: Float -> Log Float #-} -- | This provides @log1p@ and @expm1@ for working more accurately with small numbers. class Floating a => Precise a where -- | Computes @log(1 + x)@ -- -- This is far enough from 0 that the Taylor series is defined. -- -- This can provide much more accurate answers for logarithms of numbers close to 1 (x near 0). -- -- These arise when working wth log-scale probabilities a lot. log1p :: a -> a -- | The Taylor series for exp(x) is given by -- -- > exp(x) = 1 + x + x^2/2! + ... -- -- When @x@ is small, the leading 1 consumes all of the available precision. -- -- This computes: -- -- > exp(x) - 1 = x + x^2/2! + .. -- -- which can afford you a great deal of additional precision if you move things around -- algebraically to provide the 1 by other means. expm1 :: a -> a log1pexp :: a -> a log1pexp a = log1p (exp a) log1mexp :: a -> a log1mexp a = log1p (negate (exp a)) instance Precise Double where log1p = c_log1p {-# INLINE log1p #-} expm1 = c_expm1 {-# INLINE expm1 #-} log1mexp a | a <= log 2 = log (negate (expm1 a)) | otherwise = log1p (negate (exp a)) {-# INLINE log1mexp #-} log1pexp a | a <= 18 = log1p (exp a) | a <= 100 = a + exp (negate a) | otherwise = a {-# INLINE log1pexp #-} instance Precise Float where log1p = c_log1pf {-# INLINE log1p #-} expm1 = c_expm1f {-# INLINE expm1 #-} log1mexp a | a <= log 2 = log (negate (expm1 a)) | otherwise = log1p (negate (exp a)) {-# INLINE log1mexp #-} log1pexp a | a <= 18 = log1p (exp a) | a <= 100 = a + exp (negate a) | otherwise = a {-# INLINE log1pexp #-} instance (RealFloat a, Precise a) => Precise (Complex a) where expm1 x@(a :+ b) | a*a + b*b < 1, u <- expm1 a, v <- sin (b/2), w <- -2*v*v = (u*w+u+w) :+ (u+1)*sin b | otherwise = exp x - 1 {-# INLINE expm1 #-} log1p x@(a :+ b) | abs a < 0.5 && abs b < 0.5, u <- 2*a+a*a+b*b = log1p (u/(1+sqrt (u+1))) :+ atan2 (1 + a) b | otherwise = log (1 + x) {-# INLINE log1p #-} #ifdef __USE_FFI__ foreign import ccall unsafe "math.h log1p" c_log1p :: Double -> Double foreign import ccall unsafe "math.h expm1" c_expm1 :: Double -> Double foreign import ccall unsafe "math.h expm1f" c_expm1f :: Float -> Float foreign import ccall unsafe "math.h log1pf" c_log1pf :: Float -> Float #else c_log1p :: Double -> Double {-# INLINE c_log1p #-} c_log1p x = log (1 + x) c_expm1 :: Double -> Double {-# INLINE c_expm1 #-} c_expm1 x = exp x - 1 c_expm1f :: Float -> Float {-# INLINE c_expm1f #-} c_expm1f x = exp x - 1 c_log1pf :: Float -> Float {-# INLINE c_log1pf #-} c_log1pf x = log (1 + x) #endif log-domain-0.11.2/src/Numeric/Log/0000755000000000000000000000000013136745772014740 5ustar0000000000000000log-domain-0.11.2/src/Numeric/Log/Signed.hs0000644000000000000000000001705413136745772016514 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------- -- | -- Copyright : (c) Edward Kmett 2013-2015 -- License : BSD3 -- Maintainer: Edward Kmett -- Stability : experimental -- Portability: non-portable -- -------------------------------------------------------------------- module Numeric.Log.Signed ( SignedLog(..) ) where import Numeric.Log (Precise(..)) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(..)) #endif import Data.Data (Data(..)) import GHC.Generics (Generic(..)) import Data.Typeable (Typeable) import Text.Read as T import Text.Show as T #if __GLASGOW_HASKELL__ < 710 import Data.Functor ((<$>)) #endif -- $setup -- >>> let SLExp sX x ~= SLExp sY y = abs ((exp x-(multSign (nxor sX sY) (exp y))) / exp x) < 0.01 -- | @Log@-domain @Float@ and @Double@ values, with a sign bit. data SignedLog a = SLExp { signSL :: Bool, lnSL :: a} deriving (Data, Typeable, Generic) negInf :: Fractional a => a negInf = (-1)/0 nan :: Fractional a => a nan = 0/0 multSign :: (Num a) => Bool -> a -> a multSign True = id multSign False = (*) (-1) -- $SignedLogCompTests -- -- >>> (-7) < (3 :: SignedLog Double) -- True -- -- >>> 0 == (0 :: SignedLog Double) -- True instance (Eq a, Fractional a) => Eq (SignedLog a) where (SLExp sA a) == (SLExp sB b) = (a == b) && (sA == sB || a == negInf) -- Does not necissarily handle NaNs in the same way as 'a' for >=, etc. instance (Ord a, Fractional a) => Ord (SignedLog a) where compare (SLExp _ a) (SLExp _ b) | a == b && a == negInf = EQ compare (SLExp sA a) (SLExp sB b) = mappend (compare sA sB) $ compare a b -- $SignedLogShowTests -- -- >>> show (-0 :: SignedLog Double) -- "0.0" -- -- >>> show (1 :: SignedLog Double) -- "1.0" -- -- >>> show (-1 :: SignedLog Double) -- "-1.0" instance (Show a, RealFloat a, Eq a, Fractional a) => Show (SignedLog a) where showsPrec d (SLExp s a) = (if not s && a /= negInf && not (isNaN a) then T.showChar '-' else id) . T.showsPrec d (exp a) instance (Precise a, RealFloat a, Fractional a, Read a) => Read (SignedLog a) where readPrec = (realToFrac :: a -> SignedLog a) <$> step T.readPrec nxor :: Bool -> Bool -> Bool nxor = (==) -- $SignedLogNumTests -- -- Subtraction -- -- >>> (3 - 1 :: SignedLog Double) ~= 2 -- True -- -- >>> (1 - 3 :: SignedLog Double) ~= (-2) -- True -- -- >>> (3 - 2 :: SignedLog Float) ~= 1 -- True -- -- >>> (1 - 3 :: SignedLog Float) ~= (-2) -- True -- -- >>> (SLExp True (1/0)) - (SLExp True (1/0)) :: SignedLog Double -- NaN -- -- >>> 0 - 0 :: SignedLog Double -- 0.0 -- -- >>> 0 - (SLExp True (1/0)) :: SignedLog Double -- -Infinity -- -- >>> (SLExp True (1/0)) - 0.0 :: SignedLog Double -- Infinity -- -- Multiplication -- -- >>> (3 * 2 :: SignedLog Double) ~= 6 -- True -- -- >>> 0 * (SLExp True (1/0)) :: SignedLog Double -- NaN -- -- >>> (SLExp True (1/0)) * (SLExp True (1/0)) :: SignedLog Double -- Infinity -- -- >>> 0 * 0 :: SignedLog Double -- 0.0 -- -- >>> (SLExp True (0/0)) * 0 :: SignedLog Double -- NaN -- -- >>> (SLExp True (0/0)) * (SLExp True (1/0)) :: SignedLog Double -- NaN -- -- Addition -- -- >>> (3 + 1 :: SignedLog Double) ~= 4 -- True -- -- >>> 0 + 0 :: SignedLog Double -- 0.0 -- -- >>> (SLExp True (1/0)) + (SLExp True (1/0)) :: SignedLog Double -- Infinity -- -- >>> (SLExp True (1/0)) + 0 :: SignedLog Double -- Infinity -- -- Division -- -- >>> (3 / 2 :: SignedLog Double) ~= 1.5 -- True -- -- >>> 3 / 0 :: SignedLog Double -- Infinity -- -- >>> (SLExp True (1/0)) / 0 :: SignedLog Double -- Infinity -- -- >>> 0 / (SLExp True (1/0)) :: SignedLog Double -- 0.0 -- -- >>> (SLExp True (1/0)) / (SLExp True (1/0)) :: SignedLog Double -- NaN -- -- >>> 0 / 0 :: SignedLog Double -- NaN -- -- Negation -- -- >>> ((-3) + 8 :: SignedLog Double) ~= 8 -- False -- -- >>> (-0) :: SignedLog Double -- 0.0 -- -- >>> (-(0/0)) :: SignedLog Double -- NaN -- -- Signum -- -- >>> signum 0 :: SignedLog Double -- 0.0 -- -- >>> signum 3 :: SignedLog Double -- 1.0 -- -- >>> signum (SLExp True (0/0)) :: SignedLog Double -- NaN instance (Precise a, RealFloat a) => Num (SignedLog a) where (SLExp sA a) * (SLExp sB b) = SLExp (nxor sA sB) (a+b) {-# INLINE (*) #-} (SLExp sA a) + (SLExp sB b) | a == b && isInfinite a && (a < 0 || nxor sA sB) = SLExp True a | sA == sB && a >= b = SLExp sA (a + log1pexp (b - a)) | sA == sB && otherwise = SLExp sA (b + log1pexp (a - b)) | sA /= sB && a == b && not (isInfinite a) = SLExp True negInf | sA /= sB && a > b = SLExp sA (a + log1mexp (b - a)) | otherwise = SLExp sB (b + log1mexp (a - b)) {-# INLINE (+) #-} abs (SLExp _ a) = SLExp True a {-# INLINE abs #-} signum (SLExp sA a) | isInfinite a && a < 0 = SLExp True negInf | isNaN a = SLExp True nan -- signum(0/0::Double) == -1.0, this doesn't seem like a behavior worth replicating. | otherwise = SLExp sA 0 {-# INLINE signum #-} fromInteger i = SLExp (i >= 0) $ log $ fromInteger $ abs i {-# INLINE fromInteger #-} negate (SLExp sA a) = SLExp (not sA) a {-# INLINE negate #-} instance (Precise a, RealFloat a) => Fractional (SignedLog a) where (SLExp sA a) / (SLExp sB b) = SLExp (nxor sA sB) (a-b) {-# INLINE (/) #-} fromRational a = SLExp (a >= 0) $ log $ fromRational $ abs a {-# INLINE fromRational #-} -- $SignedLogToRationalTest -- -- >>> (toRational (-3.5 :: SignedLog Double)) -- (-7) % 2 instance (Precise a, RealFloat a, Ord a) => Real (SignedLog a) where toRational (SLExp sA a) = toRational $ multSign sA $ exp a {-# INLINE toRational #-} logMap :: (Floating a, Ord a) => (a -> a) -> SignedLog a -> SignedLog a logMap f (SLExp sA a) = SLExp (value >= 0) $ log $ abs value where value = f $ multSign sA $ exp a {-# INLINE logMap #-} instance (RealFloat a, Precise a) => Floating (SignedLog a) where pi = SLExp True (log pi) {-# INLINE pi #-} exp (SLExp sA a) = SLExp True (multSign sA $ exp a) {-# INLINE exp #-} log (SLExp True a) = SLExp (a >= 0) (log $ abs a) log (SLExp False _) = nan {-# INLINE log #-} (SLExp sB b) ** (SLExp sE e) | sB || e == 0 || isInfinite e = SLExp sB (b * (multSign sE $ exp e)) _ ** _ = nan {-# INLINE (**) #-} sqrt (SLExp True a) = SLExp True (a / 2) sqrt (SLExp False _) = nan {-# INLINE sqrt #-} logBase slA@(SLExp _ a) slB@(SLExp _ b) | slA >= 0 && slB >= 0 = SLExp (value >= 0) (log $ abs value) where value = logBase (exp a) (exp b) logBase _ _ = nan {-# INLINE logBase #-} sin = logMap sin {-# INLINE sin #-} cos = logMap cos {-# INLINE cos #-} tan = logMap tan {-# INLINE tan #-} asin = logMap asin {-# INLINE asin #-} acos = logMap acos {-# INLINE acos #-} atan = logMap atan {-# INLINE atan #-} sinh = logMap sinh {-# INLINE sinh #-} cosh = logMap cosh {-# INLINE cosh #-} tanh = logMap tanh {-# INLINE tanh #-} asinh = logMap asinh {-# INLINE asinh #-} acosh = logMap acosh {-# INLINE acosh #-} atanh = logMap atanh {-# INLINE atanh #-} -- $SignedLogProperFractionTests -- -- >>> (properFraction (-1.5) :: (Integer, SignedLog Double)) -- (-1,-0.5) -- -- >>> (properFraction (-0.5) :: (Integer, SignedLog Double)) -- (0,-0.5) instance (Precise a, RealFloat a) => RealFrac (SignedLog a) where properFraction slX@(SLExp sX x) | x < 0 = (0, slX) | otherwise = (\(b,a) -> (b, SLExp sX $ log $ abs a)) $ properFraction $ multSign sX $ exp x log-domain-0.11.2/tests/0000755000000000000000000000000013136745772013170 5ustar0000000000000000log-domain-0.11.2/tests/doctests.hs0000644000000000000000000000147213136745772015360 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Main (doctests) -- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- This module provides doctests for a project based on the actual versions -- of the packages it was built with. It requires a corresponding Setup.lhs -- to be added to the project ----------------------------------------------------------------------------- module Main where import Build_doctests (flags, pkgs, module_sources) import Data.Foldable (traverse_) import Test.DocTest main :: IO () main = do traverse_ putStrLn args doctest args where args = flags ++ pkgs ++ module_sources log-domain-0.11.2/travis/0000755000000000000000000000000013136745772013336 5ustar0000000000000000log-domain-0.11.2/travis/config0000644000000000000000000000120613136745772014525 0ustar0000000000000000-- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix -- -- This is particularly useful for travis-ci to get it to stop complaining -- about a broken build when everything is still correct on our end. -- -- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead -- -- To enable this, uncomment the before_script in .travis.yml remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive remote-repo-cache: ~/.cabal/packages world-file: ~/.cabal/world build-summary: ~/.cabal/logs/build.log remote-build-reporting: anonymous install-dirs user install-dirs global log-domain-0.11.2/travis/cabal-apt-install0000755000000000000000000000127213136745772016556 0ustar0000000000000000#! /bin/bash set -eu APT="sudo apt-get -q -y" CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall" $APT update $APT install dctrl-tools # Find potential system packages to satisfy cabal dependencies deps() { local M='^\([^ ]\+\)-[0-9.]\+ (.*$' local G=' -o ( -FPackage -X libghc-\L\1\E-dev )' local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \ | sed -ne "s/$M/$G/p" | sort -u)" grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u } $APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special $CABAL_INSTALL_DEPS "$@" # Install the rest via Hackage if ! $APT install hlint ; then $APT install $(deps hlint) cabal install hlint fi