log-domain-0.10.3.1/0000755000000000000000000000000012627146454012161 5ustar0000000000000000log-domain-0.10.3.1/.ghci0000644000000000000000000000014512627146454013074 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h -optP-Iincludes log-domain-0.10.3.1/.gitignore0000644000000000000000000000015012627146454014145 0ustar0000000000000000.cabal-sandbox cabal.sandbox.config dist docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# log-domain-0.10.3.1/.travis.yml0000644000000000000000000000123312627146454014271 0ustar0000000000000000language: haskell before_install: # Uncomment whenever hackage is down. # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update - cabal update # Try installing some of the build-deps with apt-get for speed. - travis/cabal-apt-install $mode install: - cabal configure -flib-Werror $mode - cabal build script: - $script && hlint src --cpp-define HLINT notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313log-domain\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" env: - mode="--enable-tests" script="cabal test --show-details=always" log-domain-0.10.3.1/.vim.custom0000644000000000000000000000137712627146454014276 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.10.3.1/AUTHORS.markdown0000644000000000000000000000055412627146454015056 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.10.3.1/CHANGELOG.markdown0000644000000000000000000000353612627146454015223 0ustar00000000000000000.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.10.3.1/HLint.hs0000644000000000000000000000002712627146454013532 0ustar0000000000000000ignore "Use camelCase" log-domain-0.10.3.1/LICENSE0000644000000000000000000000236412627146454013173 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.10.3.1/log-domain.cabal0000644000000000000000000000452312627146454015177 0ustar0000000000000000name: log-domain category: Numeric version: 0.10.3.1 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.1, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.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 source-repository head type: git location: git://github.com/analytics/log-domain.git -- 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.3 && < 5, binary >= 0.5 && < 0.8, bytes >= 0.7 && < 1, cereal >= 0.3.5 && < 0.6, comonad >= 4 && < 5, deepseq >= 1.3 && < 1.5, distributive >= 0.3 && < 1, hashable >= 1.1.2.3 && < 1.3, hashable-extras >= 0.2 && < 1, semigroupoids >= 4 && < 6, semigroups >= 0.8.4 && < 1, safecopy >= 0.8.1 && < 0.10, vector >= 0.9 && < 0.12 exposed-modules: Numeric.Log Numeric.Log.Signed if impl(ghc < 7.6) build-depends: generic-deriving >= 1.4 && < 1.9 if flag(ffi) && !os(windows) 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, directory >= 1.0, doctest >= 0.9.1, filepath, generic-deriving, semigroups >= 0.9, simple-reflect >= 0.3.1 log-domain-0.10.3.1/README.markdown0000644000000000000000000000162112627146454014662 0ustar0000000000000000log === [![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.10.3.1/Setup.lhs0000644000000000000000000000464412627146454014001 0ustar0000000000000000#!/usr/bin/runhaskell \begin{code} {-# OPTIONS_GHC -Wall #-} module Main (main) where import Data.List ( nub ) import Data.Version ( showVersion ) import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName ) import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles ) import Distribution.Simple.BuildPaths ( autogenModulesDir ) import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref)) import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity, normal ) import System.FilePath ( () ) main :: IO () main = defaultMainWithHooks simpleUserHooks { buildHook = \pkg lbi hooks flags -> do generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi buildHook simpleUserHooks pkg lbi hooks flags , postHaddock = \args flags pkg lbi -> do copyFiles normal (haddockOutputDir flags pkg) [] postHaddock simpleUserHooks args flags pkg lbi } haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath haddockOutputDir flags pkg = destDir where baseDir = case haddockDistPref flags of NoFlag -> "." Flag x -> x destDir = baseDir "doc" "html" display (packageName pkg) generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () generateBuildModule verbosity pkg lbi = do let dir = autogenModulesDir lbi createDirectoryIfMissingVerbose verbosity True dir withLibLBI pkg lbi $ \_ libcfg -> do withTestLBI pkg lbi $ \suite suitecfg -> do rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines [ "module Build_" ++ testName suite ++ " where" , "deps :: [String]" , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) ] where formatdeps = map (formatone . snd) formatone p = case packageName p of PackageName n -> n ++ "-" ++ showVersion (packageVersion p) testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys \end{code} log-domain-0.10.3.1/src/0000755000000000000000000000000012627146454012750 5ustar0000000000000000log-domain-0.10.3.1/src/Numeric/0000755000000000000000000000000012627146454014352 5ustar0000000000000000log-domain-0.10.3.1/src/Numeric/Log.hs0000644000000000000000000004027612627146454015440 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.Extras 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 #if __GLASGOW_HASKELL__ < 706 import Generics.Deriving #else import GHC.Generics #endif 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 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.10.3.1/src/Numeric/Log/0000755000000000000000000000000012627146454015073 5ustar0000000000000000log-domain-0.10.3.1/src/Numeric/Log/Signed.hs0000644000000000000000000001717612627146454016654 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(..)) #if __GLASGOW_HASKELL__ < 706 import Generics.Deriving (Generic(..)) #else import GHC.Generics (Generic(..)) #endif 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.10.3.1/tests/0000755000000000000000000000000012627146454013323 5ustar0000000000000000log-domain-0.10.3.1/tests/doctests.hsc0000644000000000000000000000452212627146454015655 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | -- Module : Main (doctests) -- Copyright : (C) 2012-13 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 (deps) import Control.Applicative import Control.Monad import Data.List import System.Directory import System.FilePath import Test.DocTest ##if defined(mingw32_HOST_OS) ##if defined(i386_HOST_ARCH) ##define USE_CP import Control.Applicative import Control.Exception import Foreign.C.Types foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt ##elif defined(x86_64_HOST_ARCH) ##define USE_CP import Control.Applicative import Control.Exception import Foreign.C.Types foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt ##endif ##endif -- | Run in a modified codepage where we can print UTF-8 values on Windows. withUnicode :: IO a -> IO a ##ifdef USE_CP withUnicode m = do cp <- c_GetConsoleCP (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp ##else withUnicode m = m ##endif main :: IO () main = withUnicode $ getSources >>= \sources -> doctest $ "-isrc" : "-idist/build/autogen" : "-optP-include" : "-optPdist/build/autogen/cabal_macros.h" : "-hide-all-packages" : "-Iincludes" : map ("-package="++) deps ++ sources getSources :: IO [FilePath] getSources = filter (isSuffixOf ".hs") <$> go "src" where go dir = do (dirs, files) <- getFilesAndDirectories dir (files ++) . concat <$> mapM go dirs getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) getFilesAndDirectories dir = do c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c log-domain-0.10.3.1/travis/0000755000000000000000000000000012627146454013471 5ustar0000000000000000log-domain-0.10.3.1/travis/cabal-apt-install0000755000000000000000000000127212627146454016711 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 log-domain-0.10.3.1/travis/config0000644000000000000000000000120612627146454014660 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