log-domain-0.13.2/0000755000000000000000000000000007346545000012014 5ustar0000000000000000log-domain-0.13.2/.ghci0000644000000000000000000000014507346545000012727 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h -optP-Iincludes log-domain-0.13.2/.gitignore0000644000000000000000000000043007346545000014001 0ustar0000000000000000dist dist-newstyle docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# .stack-work/ cabal-dev *.chi *.chs.h *.dyn_o *.dyn_hi .hpc .hsenv .cabal-sandbox/ cabal.sandbox.config *.prof *.aux *.hp *.eventlog cabal.project.local cabal.project.local~ .HTF/ .ghc.environment.* log-domain-0.13.2/.hlint.yaml0000644000000000000000000000007307346545000014074 0ustar0000000000000000- arguments: [--cpp-ansi] - ignore: {name: Use camelCase} log-domain-0.13.2/.vim.custom0000644000000000000000000000137707346545000014131 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.13.2/AUTHORS.markdown0000644000000000000000000000055407346545000014711 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.13.2/CHANGELOG.markdown0000644000000000000000000000607707346545000015061 0ustar00000000000000000.13.2 [2021.11.15] ------------------- * Add an `Eq1 Log` instance. * Allow building with `hashable-1.4.*`. 0.13.1 [2021.02.17] ------------------- * The build-type has been changed from `Custom` to `Simple`. To achieve this, the `doctests` test suite has been removed in favor of using [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) to run the doctests. 0.13 [2019.11.21] ----------------- * Replace dependency on `Precise` with standard functions available from `base` 4.9 onward. 0.12 [2018.01.18] ----------------- * Add `Semigroup` instance for `Log`. * Drop `safecopy` support * Removed some unused constraints. 0.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.13.2/LICENSE0000644000000000000000000000236407346545000013026 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.13.2/README.markdown0000644000000000000000000000166607346545000014526 0ustar0000000000000000log-domain ========== [![Hackage](https://img.shields.io/hackage/v/log-domain.svg)](https://hackage.haskell.org/package/log-domain) [![Build Status](https://github.com/ekmett/log-domain/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/log-domain/actions?query=workflow%3AHaskell-CI) > 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.13.2/Setup.lhs0000644000000000000000000000016507346545000013626 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain log-domain-0.13.2/log-domain.cabal0000644000000000000000000000327307346545000015033 0ustar0000000000000000name: log-domain category: Numeric version: 0.13.2 license: BSD3 cabal-version: >= 1.10 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: Simple tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.1 , GHC == 9.2.1 synopsis: Log-domain arithmetic description: This package provides log-domain floats, doubles and complex numbers. extra-source-files: .ghci .gitignore .hlint.yaml .vim.custom AUTHORS.markdown README.markdown CHANGELOG.markdown source-repository head type: git location: https://github.com/analytics/log-domain library build-depends: base >= 4.9 && < 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.5, semigroupoids >= 4 && < 6, semigroups >= 0.8.4 && < 1, vector >= 0.11 && < 0.13 exposed-modules: Numeric.Log Numeric.Log.Signed ghc-options: -Wall -Wtabs -O2 hs-source-dirs: src default-language: Haskell2010 log-domain-0.13.2/src/Numeric/0000755000000000000000000000000007346545000014205 5ustar0000000000000000log-domain-0.13.2/src/Numeric/Log.hs0000644000000000000000000003136007346545000015265 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Trustworthy #-} -------------------------------------------------------------------- -- | -- Copyright : (c) Edward Kmett 2013-2015 -- License : BSD3 -- Maintainer: Edward Kmett -- Stability : experimental -- Portability: non-portable -- -------------------------------------------------------------------- module Numeric.Log ( Log(..) , sum ) where import Prelude hiding (maximum, sum) import Control.Comonad import Control.DeepSeq import Data.Binary as Binary import Data.Bytes.Serial import Data.Data import Data.Distributive import Data.Foldable as Foldable hiding (sum) import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Extend import Data.Hashable import Data.Hashable.Lifted import Data.Int import qualified Data.List as List import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Serialize as Serialize import qualified Data.Vector.Unboxed as U import Data.Vector.Unboxed (Unbox) import qualified Data.Vector.Generic as G import qualified Data.Vector.Generic.Mutable as M import Foreign.Ptr import Foreign.Storable import GHC.Generics import Numeric import Text.Read as T import Text.Show as T -- $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,Generic) 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 Eq1 Log where liftEq eq (Exp a) (Exp b) = eq a b 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, 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 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 RealFloat 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 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 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 #-} {-# INLINE basicInitialize #-} {-# 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 <$> M.basicUnsafeNew n basicUnsafeReplicate n (Exp x) = MV_Log <$> M.basicUnsafeReplicate n x basicUnsafeRead (MV_Log v) i = Exp <$> M.basicUnsafeRead v i basicUnsafeWrite (MV_Log v) i (Exp x) = M.basicUnsafeWrite v i x basicClear (MV_Log v) = M.basicClear v basicInitialize (MV_Log v) = M.basicInitialize v 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 <$> 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 <$> G.basicUnsafeFreeze v basicUnsafeThaw (V_Log v) = MV_Log <$> 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 <$> G.basicUnsafeIndexM v i basicUnsafeCopy (MV_Log mv) (V_Log v) = G.basicUnsafeCopy mv v elemseq _ (Exp x) = G.elemseq (undefined :: U.Vector a) x instance (RealFloat a, Ord a) => Real (Log a) where toRational (Exp a) = toRational (exp a) {-# INLINE toRational #-} data Acc1 a = Acc1 {-# UNPACK #-} !Int64 !a instance RealFloat a => Semigroup (Log a) where (<>) = (+) {-# INLINE (<>) #-} sconcat (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 sconcat #-} instance RealFloat a => Monoid (Log a) where mempty = Exp negInf {-# INLINE mempty #-} #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif mconcat [] = 0 mconcat (x:xs) = sconcat (x :| xs) 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, 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 => 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 #-} log-domain-0.13.2/src/Numeric/Log/0000755000000000000000000000000007346545000014726 5ustar0000000000000000log-domain-0.13.2/src/Numeric/Log/Signed.hs0000644000000000000000000001627307346545000016504 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# 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 Data.Data (Data(..)) import GHC.Generics (Generic(..)) import Numeric import Text.Read as T import Text.Show as T -- | @Log@-domain @Float@ and @Double@ values, with a sign bit. data SignedLog a = SLExp { signSL :: Bool, lnSL :: a} deriving (Data, 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 (RealFloat a, Read a) => Read (SignedLog a) where readPrec = (realToFrac :: a -> SignedLog a) <$> step T.readPrec nxor :: Bool -> Bool -> Bool nxor = (==) -- $SignedLogNumTests -- -- Repeating internals, add testing function (~=) -- -- >>> let nxor = (==) -- >>> let multSign b = if b then id else (*) (-1) -- -- >>> let SLExp sX x ~= SLExp sY y = abs ((exp x-(multSign (nxor sX sY) (exp y))) / exp x) < 0.01 -- -- 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 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 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 (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 => 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 RealFloat a => RealFrac (SignedLog a) where properFraction slX@(SLExp sX x) | x < 0 = (0, slX) | otherwise = case properFraction $ multSign sX $ exp x of (b,a) -> (b, SLExp sX $ log $ abs a)