random-fu-0.2.7.0/0000755000000000000000000000000012724777671011760 5ustar0000000000000000random-fu-0.2.7.0/changelog.md0000644000000000000000000000214012724777671014226 0ustar0000000000000000* Changes in 0.2.7.0: Add Simplex, fix logBetaPdf, fix binomialPdf and binomialCdf to actually use the numerically stable method! * Changes in 2.6.1: now supports probability density functions and log probability density functions via the PDF class, similar to R and initially just for the Beta, Binomial, Normal and Uniform distributions. The log Binomial probability density function uses *Fast and Accurate Computation of Binomial Probabilities* by Catherine Loader (this is what is implemented in R and Octave) to minimize the occurrence of underflow. * Changes in 0.2.4.0: Added a Lift instance that resolves a common overlapping-instance issue in user code. * Changes in 0.2.3.1: Should now build on GHC 7.6 * Changes in 0.2.3.0: Added stretched exponential distribution, contributed by Ben Gamari. * Changes in 0.2.2.0: Bug fixes in Data.Random.Distribution.Categorical. * Changes in 0.2.1.1: Changed some one-field data types to newtypes, updated types for GHC 7.4's removal of Eq and Show from the context of Num, and added RVarT versions of random variables in Data.Random.List random-fu-0.2.7.0/random-fu.cabal0000644000000000000000000001107612724777671014641 0ustar0000000000000000name: random-fu version: 0.2.7.0 stability: provisional cabal-version: >= 1.6 build-type: Simple author: James Cook maintainer: Dominic Steinitz license: PublicDomain homepage: https://github.com/mokus0/random-fu category: Math synopsis: Random number generation description: Random number generation based on modeling random variables in two complementary ways: first, by the parameters of standard mathematical distributions and, second, by an abstract type ('RVar') which can be composed and manipulated monadically and sampled in either monadic or \"pure\" styles. . The primary purpose of this library is to support defining and sampling a wide variety of high quality random variables. Quality is prioritized over speed, but performance is an important goal too. . In my testing, I have found it capable of speed comparable to other Haskell libraries, but still a fair bit slower than straight C implementations of the same algorithms. tested-with: GHC == 7.10.3 extra-source-files: changelog.md source-repository head type: git location: https://github.com/mokus0/random-fu.git subdir: random-fu Flag base4_2 Description: base-4.2 has an incompatible change in Data.Fixed (HasResolution) Flag mtl2 Description: mtl-2 has State, etc., as "type" rather than "newtype" Library ghc-options: -Wall -funbox-strict-fields hs-source-dirs: src exposed-modules: Data.Random Data.Random.Distribution Data.Random.Distribution.Bernoulli Data.Random.Distribution.Beta Data.Random.Distribution.Binomial Data.Random.Distribution.Categorical Data.Random.Distribution.ChiSquare Data.Random.Distribution.Dirichlet Data.Random.Distribution.Exponential Data.Random.Distribution.StretchedExponential Data.Random.Distribution.Gamma Data.Random.Distribution.Multinomial Data.Random.Distribution.Normal Data.Random.Distribution.Pareto Data.Random.Distribution.Poisson Data.Random.Distribution.Rayleigh Data.Random.Distribution.Simplex Data.Random.Distribution.T Data.Random.Distribution.Triangular Data.Random.Distribution.Uniform Data.Random.Distribution.Weibull Data.Random.Distribution.Ziggurat Data.Random.Internal.Find Data.Random.Internal.Fixed Data.Random.Internal.TH Data.Random.Lift Data.Random.List Data.Random.RVar Data.Random.Sample Data.Random.Vector if flag(base4_2) build-depends: base >= 4.2 && <5 else cpp-options: -Dold_Fixed build-depends: base >= 4 && <4.2 if flag(mtl2) build-depends: mtl == 2.* cpp-options: -DMTL2 else build-depends: mtl == 1.* build-depends: math-functions, monad-loops >= 0.3.0.1, random-shuffle, random-source == 0.3.*, rvar == 0.2.*, syb, template-haskell, transformers, vector >= 0.7, log-domain >=0.9 && <1.0 if os(Windows) cpp-options: -Dwindows build-depends: erf-native else build-depends: erf if impl(ghc == 7.2.1) -- Doesn't work under GHC 7.2.1 due to -- http://hackage.haskell.org/trac/ghc/ticket/5410 -- (7.2.2 is fine though, as long as random-source is new enough) Buildable: False random-fu-0.2.7.0/Setup.lhs0000644000000000000000000000011612724777671013566 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain random-fu-0.2.7.0/src/0000755000000000000000000000000012724777671012547 5ustar0000000000000000random-fu-0.2.7.0/src/Data/0000755000000000000000000000000012724777671013420 5ustar0000000000000000random-fu-0.2.7.0/src/Data/Random.hs0000644000000000000000000000704512724777671015202 0ustar0000000000000000-- |Flexible modeling and sampling of random variables. -- -- The central abstraction in this library is the concept of a random -- variable. It is not fully formalized in the standard measure-theoretic -- language, but rather is informally defined as a \"thing you can get random -- values out of\". Different random variables may have different types of -- values they can return or the same types but different probabilities for -- each value they can return. The random values you get out of them are -- traditionally called \"random variates\". -- -- Most imperative-language random number libraries are all about obtaining -- and manipulating random variates. This one is about defining, manipulating -- and sampling random variables. Computationally, the distinction is small -- and mostly just a matter of perspective, but from a program design -- perspective it provides both a powerfully composable abstraction and a -- very useful separation of concerns. -- -- Abstract random variables as implemented by 'RVar' are composable. They can -- be defined in a monadic / \"imperative\" style that amounts to manipulating -- variates, but with strict type-level isolation. Concrete random variables -- are also provided, but they do not compose as generically. The 'Distribution' -- type class allows concrete random variables to \"forget\" their concreteness -- so that they can be composed. For examples of both, see the documentation -- for 'RVar' and 'Distribution', as well as the code for any of the concrete -- distributions such as 'Uniform', 'Gamma', etc. -- -- Both abstract and concrete random variables can be sampled (despite the -- types GHCi may list for the functions) by the functions in "Data.Random.Sample". -- -- Random variable sampling is done with regard to a generic basis of primitive -- random variables defined in "Data.Random.Internal.Primitives". This basis -- is very low-level and the actual set of primitives is still fairly experimental, -- which is why it is in the \"Internal\" sub-heirarchy. User-defined variables -- should use the existing high-level variables such as 'Uniform' and 'Normal' -- rather than these basis variables. "Data.Random.Source" defines classes for -- entropy sources that provide implementations of these primitive variables. -- Several implementations are available in the Data.Random.Source.* modules. module Data.Random ( -- * Random variables -- ** Abstract ('RVar') RVar, RVarT, runRVar, runRVarT, runRVarTWith, -- ** Concrete ('Distribution') Distribution(..), CDF(..), PDF(..), -- * Sampling random variables Sampleable(..), sample, sampleState, sampleStateT, -- * A few very common distributions Uniform(..), uniform, uniformT, StdUniform(..), stdUniform, stdUniformT, Normal(..), normal, stdNormal, normalT, stdNormalT, Gamma(..), gamma, gammaT, -- * Entropy Sources MonadRandom, RandomSource, StdRandom(..), -- * Useful list-based operations randomElement, shuffle, shuffleN, shuffleNofM ) where import Data.Random.Sample import Data.Random.Source (MonadRandom, RandomSource) import Data.Random.Source.IO () import Data.Random.Source.MWC () import Data.Random.Source.StdGen () import Data.Random.Source.PureMT () import Data.Random.Source.Std import Data.Random.Distribution import Data.Random.Distribution.Gamma import Data.Random.Distribution.Normal import Data.Random.Distribution.Uniform import Data.Random.Lift () import Data.Random.List import Data.Random.RVar random-fu-0.2.7.0/src/Data/Random/0000755000000000000000000000000012724777671014640 5ustar0000000000000000random-fu-0.2.7.0/src/Data/Random/Distribution.hs0000644000000000000000000001043012724777671017651 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} module Data.Random.Distribution where import Data.Random.Lift import Data.Random.RVar -- |A 'Distribution' is a data representation of a random variable's probability -- structure. For example, in "Data.Random.Distribution.Normal", the 'Normal' -- distribution is defined as: -- -- > data Normal a -- > = StdNormal -- > | Normal a a -- -- Where the two parameters of the 'Normal' data constructor are the mean and -- standard deviation of the random variable, respectively. To make use of -- the 'Normal' type, one can convert it to an 'rvar' and manipulate it or -- sample it directly: -- -- > x <- sample (rvar (Normal 10 2)) -- > x <- sample (Normal 10 2) -- -- A 'Distribution' is typically more transparent than an 'RVar' -- but less composable (precisely because of that transparency). There are -- several practical uses for types implementing 'Distribution': -- -- * Typically, a 'Distribution' will expose several parameters of a standard -- mathematical model of a probability distribution, such as mean and std deviation for -- the normal distribution. Thus, they can be manipulated analytically using -- mathematical insights about the distributions they represent. For example, -- a collection of bernoulli variables could be simplified into a (hopefully) smaller -- collection of binomial variables. -- -- * Because they are generally just containers for parameters, they can be -- easily serialized to persistent storage or read from user-supplied -- configurations (eg, initialization data for a simulation). -- -- * If a type additionally implements the 'CDF' subclass, which extends -- 'Distribution' with a cumulative density function, an arbitrary random -- variable 'x' can be tested against the distribution by testing -- @fmap (cdf dist) x@ for uniformity. -- -- On the other hand, most 'Distribution's will not be closed under all the -- same operations as 'RVar' (which, being a monad, has a fully turing-complete -- internal computational model). The sum of two uniformly-distributed -- variables, for example, is not uniformly distributed. To support general -- composition, the 'Distribution' class defines a function 'rvar' to -- construct the more-abstract and more-composable 'RVar' representation -- of a random variable. class Distribution d t where -- |Return a random variable with this distribution. rvar :: d t -> RVar t rvar = rvarT -- |Return a random variable with the given distribution, pre-lifted to an arbitrary 'RVarT'. -- Any arbitrary 'RVar' can also be converted to an 'RVarT m' for an arbitrary 'm', using -- either 'lift' or 'sample'. rvarT :: d t -> RVarT n t rvarT d = lift (rvar d) -- FIXME: I am not sure about giving default instances class Distribution d t => PDF d t where pdf :: d t -> t -> Double pdf d = exp . logPdf d logPdf :: d t -> t -> Double logPdf d = log . pdf d class Distribution d t => CDF d t where -- |Return the cumulative distribution function of this distribution. -- That is, a function taking @x :: t@ to the probability that the next -- sample will return a value less than or equal to x, according to some -- order or partial order (not necessarily an obvious one). -- -- In the case where 't' is an instance of Ord, 'cdf' should correspond -- to the CDF with respect to that order. -- -- In other cases, 'cdf' is only required to satisfy the following law: -- @fmap (cdf d) (rvar d)@ -- must be uniformly distributed over (0,1). Inclusion of either endpoint is optional, -- though the preferred range is (0,1]. -- -- Note that this definition requires that 'cdf' for a product type -- should _not_ be a joint CDF as commonly defined, as that definition -- violates both conditions. -- Instead, it should be a univariate CDF over the product type. That is, -- it should represent the CDF with respect to the lexicographic order -- of the product. -- -- The present specification is probably only really useful for testing -- conformance of a variable to its target distribution, and I am open to -- suggestions for more-useful specifications (especially with regard to -- the interaction with product types). cdf :: d t -> t -> Double random-fu-0.2.7.0/src/Data/Random/Lift.hs0000644000000000000000000000446212724777671016100 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, IncoherentInstances, CPP #-} module Data.Random.Lift where import Data.RVar import qualified Data.Functor.Identity as T import qualified Control.Monad.Trans.Class as T import Data.Random.Source.Std #ifndef MTL2 import qualified Control.Monad.Identity as MTL #endif -- | A class for \"liftable\" data structures. Conceptually -- an extension of 'T.MonadTrans' to allow deep lifting, -- but lifting need not be done between monads only. Eg lifting -- between 'Applicative's is allowed. -- -- For instances where 'm' and 'n' have 'return'/'pure' defined, -- these instances must satisfy -- @lift (return x) == return x@. -- -- This form of 'lift' has an extremely general type and is used primarily to -- support 'sample'. Its excessive generality is the main reason it's not -- exported from "Data.Random". 'RVarT' is, however, an instance of -- 'T.MonadTrans', which in most cases is the preferred way -- to do the lifting. class Lift m n where lift :: m a -> n a instance (Monad m, T.MonadTrans t) => Lift m (t m) where lift = T.lift instance Lift m m where lift = id -- | This instance is incoherent with the others. However, -- by the law @lift (return x) == return x@, the results -- must always be the same. instance Monad m => Lift T.Identity m where lift = return . T.runIdentity instance Lift (RVarT T.Identity) (RVarT m) where lift x = runRVar x StdRandom -- | This instance is again incoherent with the others, but provides a -- more-specific instance to resolve the overlap between the -- @Lift m (t m)@ and @Lift Identity m@ instances. instance T.MonadTrans t => Lift T.Identity (t T.Identity) where lift = T.lift #ifndef MTL2 -- | This instance is incoherent with the others. However, -- by the law @lift (return x) == return x@, the results -- must always be the same. instance Monad m => Lift MTL.Identity m where lift = return . MTL.runIdentity instance Lift (RVarT MTL.Identity) (RVarT m) where lift x = runRVarTWith (return . MTL.runIdentity) x StdRandom -- | This instance is again incoherent with the others, but provides a -- more-specific instance to resolve the overlap between the -- @Lift m (t m)@ and @Lift Identity m@ instances. instance T.MonadTrans t => Lift MTL.Identity (t MTL.Identity) where lift = T.lift #endif random-fu-0.2.7.0/src/Data/Random/List.hs0000644000000000000000000000357412724777671016120 0ustar0000000000000000module Data.Random.List where import Data.Random.RVar import Data.Random.Distribution.Uniform import qualified System.Random.Shuffle as SRS import Control.Monad -- | A random variable returning an arbitrary element of the given list. -- Every element has equal probability of being chosen. Because it is a -- pure 'RVar' it has no memory - that is, it \"draws with replacement.\" randomElement :: [a] -> RVar a randomElement = randomElementT randomElementT :: [a] -> RVarT m a randomElementT [] = error "randomElementT: empty list!" randomElementT xs = do n <- uniformT 0 (length xs - 1) return (xs !! n) -- | A random variable that returns the given list in an arbitrary shuffled -- order. Every ordering of the list has equal probability. shuffle :: [a] -> RVar [a] shuffle = shuffleT shuffleT :: [a] -> RVarT m [a] shuffleT [] = return [] shuffleT xs = do is <- zipWithM (\_ i -> uniformT 0 i) (tail xs) [1..] return (SRS.shuffle xs (reverse is)) -- | A random variable that shuffles a list of a known length (or a list -- prefix of the specified length). Useful for shuffling large lists when -- the length is known in advance. Avoids needing to traverse the list to -- discover its length. Each ordering has equal probability. shuffleN :: Int -> [a] -> RVar [a] shuffleN = shuffleNT shuffleNT :: Int -> [a] -> RVarT m [a] shuffleNT n xs = shuffleNofMT n n xs -- | A random variable that selects N arbitrary elements of a list of known length M. shuffleNofM :: Int -> Int -> [a] -> RVar [a] shuffleNofM = shuffleNofMT shuffleNofMT :: Int -> Int -> [a] -> RVarT m [a] shuffleNofMT 0 _ _ = return [] shuffleNofMT n m xs | n > m = error "shuffleNofMT: n > m" | n >= 0 = do is <- sequence [uniformT 0 i | i <- take n [m-1, m-2 ..1]] return (take n $ SRS.shuffle (take m xs) is) shuffleNofMT _ _ _ = error "shuffleNofMT: negative length specified" random-fu-0.2.7.0/src/Data/Random/RVar.hs0000644000000000000000000000067312724777671016054 0ustar0000000000000000{-# LANGUAGE RankNTypes, FlexibleInstances, MultiParamTypeClasses #-} module Data.Random.RVar ( RVar, runRVar , RVarT, runRVarT, runRVarTWith ) where import Data.Random.Lift import Data.Random.Internal.Source import Data.RVar hiding (runRVarT) -- |Like 'runRVarTWith', but using an implicit lifting (provided by the -- 'Lift' class) runRVarT :: (Lift n m, RandomSource m s) => RVarT n a -> s -> m a runRVarT = runRVarTWith lift random-fu-0.2.7.0/src/Data/Random/Sample.hs0000644000000000000000000000355012724777671016420 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, IncoherentInstances #-} module Data.Random.Sample where import Control.Monad.State import Data.Random.Distribution import Data.Random.Lift import Data.Random.RVar import Data.Random.Source import Data.Random.Source.Std -- |A typeclass allowing 'Distribution's and 'RVar's to be sampled. Both may -- also be sampled via 'runRVar' or 'runRVarT', but I find it psychologically -- pleasing to be able to sample both using this function, as they are two -- separate abstractions for one base concept: a random variable. class Sampleable d m t where -- |Directly sample from a distribution or random variable, using the given source of entropy. sampleFrom :: RandomSource m s => s -> d t -> m t instance Distribution d t => Sampleable d m t where sampleFrom src d = runRVarT (rvar d) src -- This instance overlaps with the other, but because RVarT is not a Distribution there is no conflict. instance Lift m n => Sampleable (RVarT m) n t where sampleFrom src x = runRVarT x src -- |Sample a random variable using the default source of entropy for the -- monad in which the sampling occurs. sample :: (Sampleable d m t, MonadRandom m) => d t -> m t sample = sampleFrom StdRandom -- |Sample a random variable in a \"functional\" style. Typical instantiations -- of @s@ are @System.Random.StdGen@ or @System.Random.Mersenne.Pure64.PureMT@. sampleState :: (Sampleable d (State s) t, MonadRandom (State s)) => d t -> s -> (t, s) sampleState thing = runState (sample thing) -- |Sample a random variable in a \"semi-functional\" style. Typical instantiations -- of @s@ are @System.Random.StdGen@ or @System.Random.Mersenne.Pure64.PureMT@. sampleStateT :: (Sampleable d (StateT s m) t, MonadRandom (StateT s m)) => d t -> s -> m (t, s) sampleStateT thing = runStateT (sample thing) random-fu-0.2.7.0/src/Data/Random/Vector.hs0000644000000000000000000000054012724777671016435 0ustar0000000000000000module Data.Random.Vector(randomElement) where import Data.Random.RVar import Data.Random.Distribution.Uniform import qualified Data.Vector as V import Control.Applicative -- | Take a random element of a vector. randomElement :: V.Vector a -> RVar a randomElement words = (words V.!) <$> uniform 0 (V.length words - 1) random-fu-0.2.7.0/src/Data/Random/Distribution/0000755000000000000000000000000012724777671017317 5ustar0000000000000000random-fu-0.2.7.0/src/Data/Random/Distribution/Bernoulli.hs0000644000000000000000000000732712724777671021617 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, TemplateHaskell #-} module Data.Random.Distribution.Bernoulli where import Data.Random.Internal.TH import Data.Random.RVar import Data.Random.Distribution import Data.Random.Distribution.Uniform import Data.Ratio import Data.Complex -- |Generate a Bernoulli variate with the given probability. For @Bool@ results, -- @bernoulli p@ will return True (p*100)% of the time and False otherwise. -- For numerical types, True is replaced by 1 and False by 0. bernoulli :: Distribution (Bernoulli b) a => b -> RVar a bernoulli p = rvar (Bernoulli p) -- |Generate a Bernoulli process with the given probability. For @Bool@ results, -- @bernoulli p@ will return True (p*100)% of the time and False otherwise. -- For numerical types, True is replaced by 1 and False by 0. bernoulliT :: Distribution (Bernoulli b) a => b -> RVarT m a bernoulliT p = rvarT (Bernoulli p) -- |A random variable whose value is 'True' the given fraction of the time -- and 'False' the rest. boolBernoulli :: (Fractional a, Ord a, Distribution StdUniform a) => a -> RVarT m Bool boolBernoulli p = do x <- stdUniformT return (x <= p) boolBernoulliCDF :: (Real a) => a -> Bool -> Double boolBernoulliCDF _ True = 1 boolBernoulliCDF p False = (1 - realToFrac p) -- | @generalBernoulli t f p@ generates a random variable whose value is @t@ -- with probability @p@ and @f@ with probability @1-p@. generalBernoulli :: Distribution (Bernoulli b) Bool => a -> a -> b -> RVarT m a generalBernoulli f t p = do x <- bernoulliT p return (if x then t else f) generalBernoulliCDF :: CDF (Bernoulli b) Bool => (a -> a -> Bool) -> a -> a -> b -> a -> Double generalBernoulliCDF gte f t p x | f `gte` t = error "generalBernoulliCDF: f >= t" | x `gte` t = cdf (Bernoulli p) True | x `gte` f = cdf (Bernoulli p) False | otherwise = 0 newtype Bernoulli b a = Bernoulli b instance (Fractional b, Ord b, Distribution StdUniform b) => Distribution (Bernoulli b) Bool where rvarT (Bernoulli p) = boolBernoulli p instance (Distribution (Bernoulli b) Bool, Real b) => CDF (Bernoulli b) Bool where cdf (Bernoulli p) = boolBernoulliCDF p $( replicateInstances ''Int integralTypes [d| instance Distribution (Bernoulli b) Bool => Distribution (Bernoulli b) Int where rvarT (Bernoulli p) = generalBernoulli 0 1 p instance CDF (Bernoulli b) Bool => CDF (Bernoulli b) Int where cdf (Bernoulli p) = generalBernoulliCDF (>=) 0 1 p |] ) $( replicateInstances ''Float realFloatTypes [d| instance Distribution (Bernoulli b) Bool => Distribution (Bernoulli b) Float where rvarT (Bernoulli p) = generalBernoulli 0 1 p instance CDF (Bernoulli b) Bool => CDF (Bernoulli b) Float where cdf (Bernoulli p) = generalBernoulliCDF (>=) 0 1 p |] ) instance (Distribution (Bernoulli b) Bool, Integral a) => Distribution (Bernoulli b) (Ratio a) where rvarT (Bernoulli p) = generalBernoulli 0 1 p instance (CDF (Bernoulli b) Bool, Integral a) => CDF (Bernoulli b) (Ratio a) where cdf (Bernoulli p) = generalBernoulliCDF (>=) 0 1 p instance (Distribution (Bernoulli b) Bool, RealFloat a) => Distribution (Bernoulli b) (Complex a) where rvarT (Bernoulli p) = generalBernoulli 0 1 p instance (CDF (Bernoulli b) Bool, RealFloat a) => CDF (Bernoulli b) (Complex a) where cdf (Bernoulli p) = generalBernoulliCDF (\x y -> realPart x >= realPart y) 0 1 p random-fu-0.2.7.0/src/Data/Random/Distribution/Beta.hs0000644000000000000000000000343612724777671020534 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, TemplateHaskell #-} module Data.Random.Distribution.Beta where import Data.Random.Internal.TH import Data.Random.RVar import Data.Random.Distribution import Data.Random.Distribution.Gamma import Data.Random.Distribution.Uniform import Numeric.SpecFunctions {-# SPECIALIZE fractionalBeta :: Float -> Float -> RVarT m Float #-} {-# SPECIALIZE fractionalBeta :: Double -> Double -> RVarT m Double #-} fractionalBeta :: (Fractional a, Eq a, Distribution Gamma a, Distribution StdUniform a) => a -> a -> RVarT m a fractionalBeta 1 1 = stdUniformT fractionalBeta a b = do x <- gammaT a 1 y <- gammaT b 1 return (x / (x + y)) {-# SPECIALIZE beta :: Float -> Float -> RVar Float #-} {-# SPECIALIZE beta :: Double -> Double -> RVar Double #-} beta :: Distribution Beta a => a -> a -> RVar a beta a b = rvar (Beta a b) {-# SPECIALIZE betaT :: Float -> Float -> RVarT m Float #-} {-# SPECIALIZE betaT :: Double -> Double -> RVarT m Double #-} betaT :: Distribution Beta a => a -> a -> RVarT m a betaT a b = rvarT (Beta a b) data Beta a = Beta a a -- FIXME: I am far from convinced that NaNs are a good idea. logBetaPdf :: Double -> Double -> Double -> Double logBetaPdf a b x | a <= 0 || b <= 0 = nan | x <= 0 = log 0 | x >= 1 = log 0 | otherwise = (a-1)*log x + (b-1)*log (1-x) - logBeta a b where nan = 0.0 / 0.0 instance PDF Beta Double where pdf (Beta a b) = exp . logBetaPdf a b instance PDF Beta Float where pdf (Beta a b) = realToFrac . exp . logBetaPdf (realToFrac a) (realToFrac b) . realToFrac $( replicateInstances ''Float realFloatTypes [d| instance Distribution Beta Float where rvarT (Beta a b) = fractionalBeta a b |]) random-fu-0.2.7.0/src/Data/Random/Distribution/Binomial.hs0000644000000000000000000001543712724777671021417 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, TemplateHaskell, BangPatterns #-} module Data.Random.Distribution.Binomial where import Data.Random.Internal.TH import Data.Random.RVar import Data.Random.Distribution import Data.Random.Distribution.Beta import Data.Random.Distribution.Uniform import Numeric.SpecFunctions ( stirlingError ) import Numeric.SpecFunctions.Extra ( bd0 ) import Numeric.Log ( log1p ) -- algorithm from Knuth's TAOCP, 3rd ed., p 136 -- specific choice of cutoff size taken from gsl source -- note that although it's fast enough for large (eg, 2^10000) -- @Integer@s, it's not accurate enough when using @Double@ as -- the @b@ parameter. integralBinomial :: (Integral a, Floating b, Ord b, Distribution Beta b, Distribution StdUniform b) => a -> b -> RVarT m a integralBinomial = bin 0 where bin :: (Integral a, Floating b, Ord b, Distribution Beta b, Distribution StdUniform b) => a -> a -> b -> RVarT m a bin !k !t !p | t > 10 = do let a = 1 + t `div` 2 b = 1 + t - a x <- betaT (fromIntegral a) (fromIntegral b) if x >= p then bin k (a - 1) (p / x) else bin (k + a) (b - 1) ((p - x) / (1 - x)) | otherwise = count k t where count !k' 0 = return k' count !k' n | n > 0 = do x <- stdUniformT count (if x < p then k' + 1 else k') (n-1) count _ _ = error "integralBinomial: negative number of trials specified" integralBinomialCDF :: (Integral a, Real b) => a -> b -> a -> Double integralBinomialCDF t p x = sum $ map (integralBinomialPDF t p) $ [0 .. x] -- | The probability of getting exactly k successes in n trials is -- given by the probability mass function: -- -- \[ -- f(k;n,p) = \Pr(X = k) = \binom n k p^k(1-p)^{n-k} -- \] -- -- Note that in `integralBinomialPDF` the parameters of the mass -- function are given first and the range of the random variable -- distributed according to the binomial distribution is given -- last. That is, \(f(2;4,0.5)\) is calculated by @integralBinomialPDF 4 0.5 2@. integralBinomialPDF :: (Integral a, Real b) => a -> b -> a -> Double integralBinomialPDF t p x = exp $ integralBinomialLogPdf t p x -- | We use the method given in \"Fast and accurate computation of -- binomial probabilities, Loader, C\", -- integralBinomialLogPdf :: (Integral a, Real b) => a -> b -> a -> Double integralBinomialLogPdf nI pR xI | p == 0.0 && xI == 0 = 1.0 | p == 0.0 = 0.0 | p == 1.0 && xI == nI = 1.0 | p == 1.0 = 0.0 | xI == 0 = n * log (1-p) | xI == nI = n * log p | otherwise = lc - 0.5 * lf where n = fromIntegral nI x = fromIntegral xI p = realToFrac pR lc = stirlingError n - stirlingError x - stirlingError (n - x) - bd0 x (n * p) - bd0 (n - x) (n * (1 - p)) lf = log (2 * pi) + log x + log1p (- x / n) -- would it be valid to repeat the above computation using fractional @t@? -- obviously something different would have to be done with @count@ as well... {-# SPECIALIZE floatingBinomial :: Float -> Float -> RVar Float #-} {-# SPECIALIZE floatingBinomial :: Float -> Double -> RVar Float #-} {-# SPECIALIZE floatingBinomial :: Double -> Float -> RVar Double #-} {-# SPECIALIZE floatingBinomial :: Double -> Double -> RVar Double #-} floatingBinomial :: (RealFrac a, Distribution (Binomial b) Integer) => a -> b -> RVar a floatingBinomial t p = fmap fromInteger (rvar (Binomial (truncate t) p)) floatingBinomialCDF :: (CDF (Binomial b) Integer, RealFrac a) => a -> b -> a -> Double floatingBinomialCDF t p x = cdf (Binomial (truncate t :: Integer) p) (floor x) floatingBinomialPDF :: (PDF (Binomial b) Integer, RealFrac a) => a -> b -> a -> Double floatingBinomialPDF t p x = pdf (Binomial (truncate t :: Integer) p) (floor x) floatingBinomialLogPDF :: (PDF (Binomial b) Integer, RealFrac a) => a -> b -> a -> Double floatingBinomialLogPDF t p x = logPdf (Binomial (truncate t :: Integer) p) (floor x) {-# SPECIALIZE binomial :: Int -> Float -> RVar Int #-} {-# SPECIALIZE binomial :: Int -> Double -> RVar Int #-} {-# SPECIALIZE binomial :: Integer -> Float -> RVar Integer #-} {-# SPECIALIZE binomial :: Integer -> Double -> RVar Integer #-} {-# SPECIALIZE binomial :: Float -> Float -> RVar Float #-} {-# SPECIALIZE binomial :: Float -> Double -> RVar Float #-} {-# SPECIALIZE binomial :: Double -> Float -> RVar Double #-} {-# SPECIALIZE binomial :: Double -> Double -> RVar Double #-} binomial :: Distribution (Binomial b) a => a -> b -> RVar a binomial t p = rvar (Binomial t p) {-# SPECIALIZE binomialT :: Int -> Float -> RVarT m Int #-} {-# SPECIALIZE binomialT :: Int -> Double -> RVarT m Int #-} {-# SPECIALIZE binomialT :: Integer -> Float -> RVarT m Integer #-} {-# SPECIALIZE binomialT :: Integer -> Double -> RVarT m Integer #-} {-# SPECIALIZE binomialT :: Float -> Float -> RVarT m Float #-} {-# SPECIALIZE binomialT :: Float -> Double -> RVarT m Float #-} {-# SPECIALIZE binomialT :: Double -> Float -> RVarT m Double #-} {-# SPECIALIZE binomialT :: Double -> Double -> RVarT m Double #-} binomialT :: Distribution (Binomial b) a => a -> b -> RVarT m a binomialT t p = rvarT (Binomial t p) data Binomial b a = Binomial a b $( replicateInstances ''Int integralTypes [d| instance ( Floating b, Ord b , Distribution Beta b , Distribution StdUniform b ) => Distribution (Binomial b) Int where rvarT (Binomial t p) = integralBinomial t p instance ( Real b , Distribution (Binomial b) Int ) => CDF (Binomial b) Int where cdf (Binomial t p) = integralBinomialCDF t p instance ( Real b , Distribution (Binomial b) Int ) => PDF (Binomial b) Int where pdf (Binomial t p) = integralBinomialPDF t p logPdf (Binomial t p) = integralBinomialLogPdf t p |]) $( replicateInstances ''Float realFloatTypes [d| instance Distribution (Binomial b) Integer => Distribution (Binomial b) Float where rvar (Binomial t p) = floatingBinomial t p instance CDF (Binomial b) Integer => CDF (Binomial b) Float where cdf (Binomial t p) = floatingBinomialCDF t p instance PDF (Binomial b) Integer => PDF (Binomial b) Float where pdf (Binomial t p) = floatingBinomialPDF t p logPdf (Binomial t p) = floatingBinomialLogPDF t p |]) random-fu-0.2.7.0/src/Data/Random/Distribution/Categorical.hs0000644000000000000000000002454612724777671022103 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, CPP #-} module Data.Random.Distribution.Categorical ( Categorical , categorical, categoricalT , weightedCategorical, weightedCategoricalT , fromList, toList, totalWeight, numEvents , fromWeightedList, fromObservations , mapCategoricalPs, normalizeCategoricalPs , collectEvents, collectEventsBy ) where import Data.Random.RVar import Data.Random.Distribution import Data.Random.Distribution.Uniform import Control.Arrow import Control.Monad import Control.Monad.ST import Control.Applicative import Data.Foldable (Foldable(foldMap)) import Data.STRef import Data.Traversable (Traversable(traverse, sequenceA)) import Data.List import Data.Function import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV -- |Construct a 'Categorical' random variable from a list of probabilities -- and categories, where the probabilities all sum to 1. categorical :: (Num p, Distribution (Categorical p) a) => [(p,a)] -> RVar a categorical = rvar . fromList -- |Construct a 'Categorical' random process from a list of probabilities -- and categories, where the probabilities all sum to 1. categoricalT :: (Num p, Distribution (Categorical p) a) => [(p,a)] -> RVarT m a categoricalT = rvarT . fromList -- |Construct a 'Categorical' random variable from a list of probabilities -- and categories, where the probabilities all sum to 1. weightedCategorical :: (Fractional p, Eq p, Distribution (Categorical p) a) => [(p,a)] -> RVar a weightedCategorical = rvar . fromWeightedList -- |Construct a 'Categorical' random process from a list of probabilities -- and categories, where the probabilities all sum to 1. weightedCategoricalT :: (Fractional p, Eq p, Distribution (Categorical p) a) => [(p,a)] -> RVarT m a weightedCategoricalT = rvarT . fromWeightedList -- | Construct a 'Categorical' distribution from a list of weighted categories. {-# INLINE fromList #-} fromList :: (Num p) => [(p,a)] -> Categorical p a fromList xs = Categorical (V.fromList (scanl1 f xs)) where f (p0, _) (p1, y) = (p0 + p1, y) {-# INLINE toList #-} toList :: (Num p) => Categorical p a -> [(p,a)] toList (Categorical ds) = V.foldr' g [] ds where g x [] = [x] g x@(p0,_) ((p1, y):xs) = x : (p1-p0,y) : xs totalWeight :: Num p => Categorical p a -> p totalWeight (Categorical ds) | V.null ds = 0 | otherwise = fst (V.last ds) numEvents :: Categorical p a -> Int numEvents (Categorical ds) = V.length ds -- |Construct a 'Categorical' distribution from a list of weighted categories, -- where the weights do not necessarily sum to 1. fromWeightedList :: (Fractional p, Eq p) => [(p,a)] -> Categorical p a fromWeightedList = normalizeCategoricalPs . fromList -- |Construct a 'Categorical' distribution from a list of observed outcomes. -- Equivalent events will be grouped and counted, and the probabilities of each -- event in the returned distribution will be proportional to the number of -- occurrences of that event. fromObservations :: (Fractional p, Eq p, Ord a) => [a] -> Categorical p a fromObservations = fromWeightedList . map (genericLength &&& head) . group . sort -- The following description refers to the public interface. For those reading -- the code, in the actual implementation Categorical is stored as a vector of -- (cumulative-probability, value) pairs, so that sampling can take advantage of -- binary search. -- |Categorical distribution; a list of events with corresponding probabilities. -- The sum of the probabilities must be 1, and no event should have a zero -- or negative probability (at least, at time of sampling; very clever users -- can do what they want with the numbers before sampling, just make sure -- that if you're one of those clever ones, you at least eliminate negative -- weights before sampling). newtype Categorical p a = Categorical (V.Vector (p, a)) deriving Eq instance (Num p, Show p, Show a) => Show (Categorical p a) where showsPrec p cat = showParen (p>10) ( showString "fromList " . showsPrec 11 (toList cat) ) instance (Num p, Read p, Read a) => Read (Categorical p a) where readsPrec p = readParen (p > 10) $ \str -> do ("fromList", valStr) <- lex str (vals, rest) <- readsPrec 11 valStr return (fromList vals, rest) instance (Fractional p, Ord p, Distribution Uniform p) => Distribution (Categorical p) a where rvarT (Categorical ds) | V.null ds = fail "categorical distribution over empty set cannot be sampled" | n == 1 = return (snd (V.head ds)) | otherwise = do u <- uniformT 0 (fst (V.last ds)) let -- by construction, p is monotone; (i < j) ==> (p i <= p j) p i = fst (ds V.! i) x i = snd (ds V.! i) -- findEvent -- =========== -- invariants: (i <= j), (u <= p j), ((i == 0) || (p i < u)) -- (the last one means 'i' does not increase unless it bounds 'p' below 'u') -- variant: either i increases or j decreases. -- upon termination: ∀ k. if (k < j) then (p k < u) else (u <= p k) -- (that is, the chosen event 'x j' is the first one whose -- associated cumulative probability 'p j' is greater than -- or equal to 'u') findEvent i j | j <= i = x j | u <= p m = findEvent i m | otherwise = findEvent (max m (i+1)) j where -- midpoint rounding down -- (i < j) ==> (m < j) m = (i + j) `div` 2 return $! if u <= 0 then x 0 else findEvent 0 (n-1) where n = V.length ds instance Functor (Categorical p) where fmap f (Categorical ds) = Categorical (V.map (second f) ds) instance Foldable (Categorical p) where foldMap f (Categorical ds) = foldMap (f . snd) (V.toList ds) instance Traversable (Categorical p) where traverse f (Categorical ds) = Categorical . V.fromList <$> traverse (\(p,e) -> (\e' -> (p,e')) <$> f e) (V.toList ds) sequenceA (Categorical ds) = Categorical . V.fromList <$> traverse (\(p,e) -> (\e' -> (p,e')) <$> e) (V.toList ds) instance Fractional p => Monad (Categorical p) where return x = Categorical (V.singleton (1, x)) -- I'm not entirely sure whether this is a valid form of failure; see next -- set of comments. fail _ = Categorical V.empty -- Should the normalize step be included here, or should normalization -- be assumed? It seems like there is (at least) 1 valid situation where -- non-normal results would arise: the distribution being modeled is -- "conditional" and some event arose that contradicted the assumed -- condition and thus was eliminated ('f' returned an empty or -- zero-probability consequent, possibly by 'fail'ing). -- -- It seems reasonable to continue in such circumstances, but should there -- be any renormalization? If so, does it make a difference when that -- renormalization is done? I'm pretty sure it does, actually. So, the -- normalization will be omitted here for now, as it's easier for the -- user (who really better know what they mean if they're returning -- non-normalized probability anyway) to normalize explicitly than to -- undo any normalization that was done automatically. xs >>= f = {- normalizeCategoricalPs . -} fromList $ do (p, x) <- toList xs (q, y) <- toList (f x) return (p * q, y) instance Fractional p => Applicative (Categorical p) where pure = return (<*>) = ap -- |Like 'fmap', but for the probabilities of a categorical distribution. mapCategoricalPs :: (Num p, Num q) => (p -> q) -> Categorical p e -> Categorical q e mapCategoricalPs f = fromList . map (first f) . toList -- |Adjust all the weights of a categorical distribution so that they -- sum to unity and remove all events whose probability is zero. normalizeCategoricalPs :: (Fractional p, Eq p) => Categorical p e -> Categorical p e normalizeCategoricalPs orig@(Categorical ds) | ps == 0 = Categorical V.empty | otherwise = runST $ do lastP <- newSTRef 0 nDups <- newSTRef 0 normalized <- V.thaw ds let n = V.length ds skip = modifySTRef' nDups (1+) save i p x = do d <- readSTRef nDups MV.write normalized (i-d) (p, x) sequence_ [ do let (p,x) = ds V.! i p0 <- readSTRef lastP if p == p0 then skip else do save i (p * scale) x writeSTRef lastP $! p | i <- [0..n-1] ] -- force last element to 1 d <- readSTRef nDups let n' = n-d (_,lastX) <- MV.read normalized (n'-1) MV.write normalized (n'-1) (1,lastX) Categorical <$> V.unsafeFreeze (MV.unsafeSlice 0 n' normalized) where ps = totalWeight orig scale = recip ps #if __GLASGOW_HASKELL__ < 706 -- |strict 'modifySTRef' modifySTRef' :: STRef s a -> (a -> a) -> ST s () modifySTRef' x f = do v <- readSTRef x let fv = f v fv `seq` writeSTRef x fv #endif -- |Simplify a categorical distribution by combining equivalent events (the new -- event will have a probability equal to the sum of all the originals). collectEvents :: (Ord e, Num p, Ord p) => Categorical p e -> Categorical p e collectEvents = collectEventsBy compare ((sum *** head) . unzip) -- |Simplify a categorical distribution by combining equivalent events (the new -- event will have a weight equal to the sum of all the originals). -- The comparator function is used to identify events to combine. Once chosen, -- the events and their weights are combined by the provided probability and -- event aggregation function. collectEventsBy :: Num p => (e -> e -> Ordering) -> ([(p,e)] -> (p,e))-> Categorical p e -> Categorical p e collectEventsBy compareE combine = fromList . map combine . groupEvents . sortEvents . toList where groupEvents = groupBy (\x y -> snd x `compareE` snd y == EQ) sortEvents = sortBy (compareE `on` snd) random-fu-0.2.7.0/src/Data/Random/Distribution/ChiSquare.hs0000644000000000000000000000167012724777671021543 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} module Data.Random.Distribution.ChiSquare where import Data.Random.RVar import Data.Random.Distribution import Data.Random.Distribution.Gamma import Numeric.SpecFunctions chiSquare :: Distribution ChiSquare t => Integer -> RVar t chiSquare = rvar . ChiSquare chiSquareT :: Distribution ChiSquare t => Integer -> RVarT m t chiSquareT = rvarT . ChiSquare newtype ChiSquare b = ChiSquare Integer instance (Fractional t, Distribution Gamma t) => Distribution ChiSquare t where rvarT (ChiSquare 0) = return 0 rvarT (ChiSquare n) | n > 0 = gammaT (0.5 * fromInteger n) 2 | otherwise = fail "chi-square distribution: degrees of freedom must be positive" instance (Real t, Distribution ChiSquare t) => CDF ChiSquare t where cdf (ChiSquare n) x = incompleteGamma (0.5 * fromInteger n) (0.5 * realToFrac x) random-fu-0.2.7.0/src/Data/Random/Distribution/Dirichlet.hs0000644000000000000000000000170312724777671021563 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs #-} module Data.Random.Distribution.Dirichlet where import Data.Random.RVar import Data.Random.Distribution import Data.Random.Distribution.Gamma import Data.List fractionalDirichlet :: (Fractional a, Distribution Gamma a) => [a] -> RVarT m [a] fractionalDirichlet [] = return [] fractionalDirichlet [_] = return [1] fractionalDirichlet as = do xs <- sequence [gammaT a 1 | a <- as] let total = foldl1' (+) xs return (map (* recip total) xs) dirichlet :: Distribution Dirichlet [a] => [a] -> RVar [a] dirichlet as = rvar (Dirichlet as) dirichletT :: Distribution Dirichlet [a] => [a] -> RVarT m [a] dirichletT as = rvarT (Dirichlet as) newtype Dirichlet a = Dirichlet a deriving (Eq, Show) instance (Fractional a, Distribution Gamma a) => Distribution Dirichlet [a] where rvarT (Dirichlet as) = fractionalDirichlet as random-fu-0.2.7.0/src/Data/Random/Distribution/Exponential.hs0000644000000000000000000000206712724777671022146 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} module Data.Random.Distribution.Exponential where import Data.Random.RVar import Data.Random.Distribution import Data.Random.Distribution.Uniform newtype Exponential a = Exp a floatingExponential :: (Floating a, Distribution StdUniform a) => a -> RVarT m a floatingExponential lambdaRecip = do x <- stdUniformT return (negate (log x) * lambdaRecip) floatingExponentialCDF :: Real a => a -> a -> Double floatingExponentialCDF lambdaRecip x = 1 - exp (negate (realToFrac x) / realToFrac lambdaRecip) exponential :: Distribution Exponential a => a -> RVar a exponential = rvar . Exp exponentialT :: Distribution Exponential a => a -> RVarT m a exponentialT = rvarT . Exp instance (Floating a, Distribution StdUniform a) => Distribution Exponential a where rvarT (Exp lambdaRecip) = floatingExponential lambdaRecip instance (Real a, Distribution Exponential a) => CDF Exponential a where cdf (Exp lambdaRecip) = floatingExponentialCDF lambdaReciprandom-fu-0.2.7.0/src/Data/Random/Distribution/Gamma.hs0000644000000000000000000000545212724777671020703 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, BangPatterns #-} module Data.Random.Distribution.Gamma ( Gamma(..) , gamma, gammaT , Erlang(..) , erlang, erlangT , mtGamma ) where import Data.Random.RVar import Data.Random.Distribution import Data.Random.Distribution.Uniform import Data.Random.Distribution.Normal import Data.Ratio import Numeric.SpecFunctions -- |derived from Marsaglia & Tang, "A Simple Method for generating gamma -- variables", ACM Transactions on Mathematical Software, Vol 26, No 3 (2000), p363-372. {-# SPECIALIZE mtGamma :: Double -> Double -> RVarT m Double #-} {-# SPECIALIZE mtGamma :: Float -> Float -> RVarT m Float #-} mtGamma :: (Floating a, Ord a, Distribution StdUniform a, Distribution Normal a) => a -> a -> RVarT m a mtGamma a b | a < 1 = do u <- stdUniformT mtGamma (1+a) $! (b * u ** recip a) | otherwise = go where !d = a - fromRational (1%3) !c = recip (sqrt (9*d)) go = do x <- stdNormalT let !v = 1 + c*x if v <= 0 then go else do u <- stdUniformT let !x_2 = x*x; !x_4 = x_2*x_2 v3 = v*v*v dv = d * v3 if u < 1 - 0.0331*x_4 || log u < 0.5 * x_2 + d - dv + d*log v3 then return (b*dv) else go {-# SPECIALIZE gamma :: Float -> Float -> RVar Float #-} {-# SPECIALIZE gamma :: Double -> Double -> RVar Double #-} gamma :: (Distribution Gamma a) => a -> a -> RVar a gamma a b = rvar (Gamma a b) gammaT :: (Distribution Gamma a) => a -> a -> RVarT m a gammaT a b = rvarT (Gamma a b) erlang :: (Distribution (Erlang a) b) => a -> RVar b erlang a = rvar (Erlang a) erlangT :: (Distribution (Erlang a) b) => a -> RVarT m b erlangT a = rvarT (Erlang a) data Gamma a = Gamma a a newtype Erlang a b = Erlang a instance (Floating a, Ord a, Distribution Normal a, Distribution StdUniform a) => Distribution Gamma a where {-# SPECIALIZE instance Distribution Gamma Double #-} {-# SPECIALIZE instance Distribution Gamma Float #-} rvarT (Gamma a b) = mtGamma a b instance (Real a, Distribution Gamma a) => CDF Gamma a where cdf (Gamma a b) x = incompleteGamma (realToFrac a) (realToFrac x / realToFrac b) instance (Integral a, Floating b, Ord b, Distribution Normal b, Distribution StdUniform b) => Distribution (Erlang a) b where rvarT (Erlang a) = mtGamma (fromIntegral a) 1 instance (Integral a, Real b, Distribution (Erlang a) b) => CDF (Erlang a) b where cdf (Erlang a) x = incompleteGamma (fromIntegral a) (realToFrac x) random-fu-0.2.7.0/src/Data/Random/Distribution/Multinomial.hs0000644000000000000000000000300612724777671022144 0ustar0000000000000000{-# LANGUAGE GADTs, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} module Data.Random.Distribution.Multinomial where import Data.Random.RVar import Data.Random.Distribution import Data.Random.Distribution.Binomial multinomial :: Distribution (Multinomial p) [a] => [p] -> a -> RVar [a] multinomial ps n = rvar (Multinomial ps n) multinomialT :: Distribution (Multinomial p) [a] => [p] -> a -> RVarT m [a] multinomialT ps n = rvarT (Multinomial ps n) data Multinomial p a where Multinomial :: [p] -> a -> Multinomial p [a] instance (Num a, Eq a, Fractional p, Distribution (Binomial p) a) => Distribution (Multinomial p) [a] where -- TODO: implement faster version based on Categorical for small n, large (length ps) rvarT (Multinomial ps0 t) = go t ps0 (tailSums ps0) id where go _ [] _ f = return (f []) go n [_] _ f = return (f [n]) go 0 (_:ps) (_ :psums) f = go 0 ps psums (f . (0:)) go n (p:ps) (psum:psums) f = do x <- binomialT n (p / psum) go (n-x) ps psums (f . (x:)) go _ _ _ _ = error "rvar/Multinomial: programming error! this case should be impossible!" -- less wasteful version of (map sum . tails) tailSums [] = [0] tailSums (x:xs) = case tailSums xs of (s:rest) -> (x+s):s:rest _ -> error "rvar/Multinomial/tailSums: programming error! this case should be impossible!" random-fu-0.2.7.0/src/Data/Random/Distribution/Normal.hs0000644000000000000000000002143212724777671021105 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, ForeignFunctionInterface, BangPatterns, RankNTypes #-} module Data.Random.Distribution.Normal ( Normal(..) , normal, normalT , stdNormal, stdNormalT , doubleStdNormal , floatStdNormal , realFloatStdNormal , normalTail , normalPair , boxMullerNormalPair , knuthPolarNormalPair ) where import Data.Random.Internal.Words import Data.Bits import Data.Random.Source import Data.Random.Distribution import Data.Random.Distribution.Uniform import Data.Random.Distribution.Ziggurat import Data.Random.RVar import Data.Vector.Generic (Vector) import qualified Data.Vector as V import qualified Data.Vector.Unboxed as UV import Data.Number.Erf -- |A random variable that produces a pair of independent -- normally-distributed values. normalPair :: (Floating a, Distribution StdUniform a) => RVar (a,a) normalPair = boxMullerNormalPair -- |A random variable that produces a pair of independent -- normally-distributed values, computed using the Box-Muller method. -- This algorithm is slightly slower than Knuth's method but using a -- constant amount of entropy (Knuth's method is a rejection method). -- It is also slightly more general (Knuth's method require an 'Ord' -- instance). {-# INLINE boxMullerNormalPair #-} boxMullerNormalPair :: (Floating a, Distribution StdUniform a) => RVar (a,a) boxMullerNormalPair = do u <- stdUniform t <- stdUniform let r = sqrt (-2 * log u) theta = (2 * pi) * t x = r * cos theta y = r * sin theta return (x,y) -- |A random variable that produces a pair of independent -- normally-distributed values, computed using Knuth's polar method. -- Slightly faster than 'boxMullerNormalPair' when it accepts on the -- first try, but does not always do so. {-# INLINE knuthPolarNormalPair #-} knuthPolarNormalPair :: (Floating a, Ord a, Distribution Uniform a) => RVar (a,a) knuthPolarNormalPair = do v1 <- uniform (-1) 1 v2 <- uniform (-1) 1 let s = v1*v1 + v2*v2 if s >= 1 then knuthPolarNormalPair else return $ if s == 0 then (0,0) else let scale = sqrt (-2 * log s / s) in (v1 * scale, v2 * scale) -- |Draw from the tail of a normal distribution (the region beyond the provided value) {-# INLINE normalTail #-} normalTail :: (Distribution StdUniform a, Floating a, Ord a) => a -> RVarT m a normalTail r = go where go = do !u <- stdUniformT let !x = log u / r !v <- stdUniformT let !y = log v if x*x + y+y > 0 then go else return (r - x) -- |Construct a 'Ziggurat' for sampling a normal distribution, given -- @logBase 2 c@ and the 'zGetIU' implementation. normalZ :: (RealFloat a, Erf a, Vector v a, Distribution Uniform a, Integral b) => b -> (forall m. RVarT m (Int, a)) -> Ziggurat v a normalZ p = mkZigguratRec True normalF normalFInv normalFInt normalFVol (2^p) -- | Ziggurat target function (upper half of a non-normalized gaussian PDF) normalF :: (Floating a, Ord a) => a -> a normalF x | x <= 0 = 1 | otherwise = exp ((-0.5) * x*x) -- | inverse of 'normalF' normalFInv :: Floating a => a -> a normalFInv y = sqrt ((-2) * log y) -- | integral of 'normalF' normalFInt :: (Floating a, Erf a, Ord a) => a -> a normalFInt x | x <= 0 = 0 | otherwise = normalFVol * erf (x * sqrt 0.5) -- | volume of 'normalF' normalFVol :: Floating a => a normalFVol = sqrt (0.5 * pi) -- |A random variable sampling from the standard normal distribution -- over any 'RealFloat' type (subject to the rest of the constraints - -- it builds and uses a 'Ziggurat' internally, which requires the 'Erf' -- class). -- -- Because it computes a 'Ziggurat', it is very expensive to use for -- just one evaluation, or even for multiple evaluations if not used and -- reused monomorphically (to enable the ziggurat table to be let-floated -- out). If you don't know whether your use case fits this description -- then you're probably better off using a different algorithm, such as -- 'boxMullerNormalPair' or 'knuthPolarNormalPair'. And of course if -- you don't need the full generality of this definition then you're much -- better off using 'doubleStdNormal' or 'floatStdNormal'. -- -- As far as I know, this should be safe to use in any monomorphic -- @Distribution Normal@ instance declaration. realFloatStdNormal :: (RealFloat a, Erf a, Distribution Uniform a) => RVarT m a realFloatStdNormal = runZiggurat (normalZ p getIU `asTypeOf` (undefined :: Ziggurat V.Vector a)) where p :: Int p = 6 getIU :: (Num a, Distribution Uniform a) => RVarT m (Int, a) getIU = do i <- getRandomWord8 u <- uniformT (-1) 1 return (fromIntegral i .&. (2^p-1), u) -- |A random variable sampling from the standard normal distribution -- over the 'Double' type. doubleStdNormal :: RVarT m Double doubleStdNormal = runZiggurat doubleStdNormalZ -- doubleStdNormalC must not be over 2^12 if using wordToDoubleWithExcess doubleStdNormalC :: Int doubleStdNormalC = 512 doubleStdNormalR, doubleStdNormalV :: Double doubleStdNormalR = 3.852046150368388 doubleStdNormalV = 2.4567663515413507e-3 {-# NOINLINE doubleStdNormalZ #-} doubleStdNormalZ :: Ziggurat UV.Vector Double doubleStdNormalZ = mkZiggurat_ True normalF normalFInv doubleStdNormalC doubleStdNormalR doubleStdNormalV getIU (normalTail doubleStdNormalR) where getIU :: RVarT m (Int, Double) getIU = do !w <- getRandomWord64 let (u,i) = wordToDoubleWithExcess w return $! (fromIntegral i .&. (doubleStdNormalC-1), u+u-1) -- |A random variable sampling from the standard normal distribution -- over the 'Float' type. floatStdNormal :: RVarT m Float floatStdNormal = runZiggurat floatStdNormalZ -- floatStdNormalC must not be over 2^9 if using word32ToFloatWithExcess floatStdNormalC :: Int floatStdNormalC = 512 floatStdNormalR, floatStdNormalV :: Float floatStdNormalR = 3.852046150368388 floatStdNormalV = 2.4567663515413507e-3 {-# NOINLINE floatStdNormalZ #-} floatStdNormalZ :: Ziggurat UV.Vector Float floatStdNormalZ = mkZiggurat_ True normalF normalFInv floatStdNormalC floatStdNormalR floatStdNormalV getIU (normalTail floatStdNormalR) where getIU :: RVarT m (Int, Float) getIU = do !w <- getRandomWord32 let (u,i) = word32ToFloatWithExcess w return (fromIntegral i .&. (floatStdNormalC-1), u+u-1) normalCdf :: (Real a) => a -> a -> a -> Double normalCdf m s x = normcdf ((realToFrac x - realToFrac m) / realToFrac s) normalPdf :: (Real a, Floating b) => a -> a -> a -> b normalPdf mu sigma x = (recip (sqrt (2 * pi * sigma2))) * (exp ((-((realToFrac x) - (realToFrac mu))^2) / (2 * sigma2))) where sigma2 = realToFrac sigma^2 normalLogPdf :: (Real a, Floating b) => a -> a -> a -> b normalLogPdf mu sigma x = log (recip (sqrt (2 * pi * sigma2))) + ((-((realToFrac x) - (realToFrac mu))^2) / (2 * sigma2)) where sigma2 = realToFrac sigma^2 -- |A specification of a normal distribution over the type 'a'. data Normal a -- |The \"standard\" normal distribution - mean 0, stddev 1 = StdNormal -- |@Normal m s@ is a normal distribution with mean @m@ and stddev @sd@. | Normal a a -- mean, sd instance Distribution Normal Double where rvarT StdNormal = doubleStdNormal rvarT (Normal m s) = do x <- doubleStdNormal return (x * s + m) instance Distribution Normal Float where rvarT StdNormal = floatStdNormal rvarT (Normal m s) = do x <- floatStdNormal return (x * s + m) instance (Real a, Distribution Normal a) => CDF Normal a where cdf StdNormal = normalCdf 0 1 cdf (Normal m s) = normalCdf m s instance (Real a, Floating a, Distribution Normal a) => PDF Normal a where pdf StdNormal = normalPdf 0 1 pdf (Normal m s) = normalPdf m s logPdf StdNormal = normalLogPdf 0 1 logPdf (Normal m s) = normalLogPdf m s {-# SPECIALIZE stdNormal :: RVar Double #-} {-# SPECIALIZE stdNormal :: RVar Float #-} -- |'stdNormal' is a normal variable with distribution 'StdNormal'. stdNormal :: Distribution Normal a => RVar a stdNormal = rvar StdNormal -- |'stdNormalT' is a normal process with distribution 'StdNormal'. stdNormalT :: Distribution Normal a => RVarT m a stdNormalT = rvarT StdNormal -- |@normal m s@ is a random variable with distribution @'Normal' m s@. normal :: Distribution Normal a => a -> a -> RVar a normal m s = rvar (Normal m s) -- |@normalT m s@ is a random process with distribution @'Normal' m s@. normalT :: Distribution Normal a => a -> a -> RVarT m a normalT m s = rvarT (Normal m s) random-fu-0.2.7.0/src/Data/Random/Distribution/Pareto.hs0000644000000000000000000000142312724777671021105 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} module Data.Random.Distribution.Pareto where import Data.Random pareto :: Distribution Pareto a => a -> a -> RVar a pareto xM a = rvar (Pareto xM a) paretoT :: Distribution Pareto a => a -> a -> RVarT m a paretoT xM a = rvarT (Pareto xM a) data Pareto a = Pareto !a !a instance (Floating a, Distribution StdUniform a) => Distribution Pareto a where rvarT (Pareto xM a) = do u <- stdUniformT return (xM / (1 - u) ** recip a) instance (Real a, Distribution Pareto a) => CDF Pareto a where cdf (Pareto xM a) x | x >= xM = 1 - (realToFrac xM / realToFrac x) ** realToFrac a | otherwise = 0random-fu-0.2.7.0/src/Data/Random/Distribution/Poisson.hs0000644000000000000000000000574012724777671021313 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, TemplateHaskell #-} module Data.Random.Distribution.Poisson where import Data.Random.Internal.TH import Data.Random.RVar import Data.Random.Distribution import Data.Random.Distribution.Uniform import Data.Random.Distribution.Gamma import Data.Random.Distribution.Binomial import Control.Monad -- from Knuth, with interpretation help from gsl sources integralPoisson :: (Integral a, RealFloat b, Distribution StdUniform b, Distribution (Erlang a) b, Distribution (Binomial b) a) => b -> RVarT m a integralPoisson = psn 0 where psn :: (Integral a, RealFloat b, Distribution StdUniform b, Distribution (Erlang a) b, Distribution (Binomial b) a) => a -> b -> RVarT m a psn j mu | mu > 10 = do let m = floor (mu * (7/8)) x <- erlangT m if x >= mu then do b <- binomialT (m - 1) (mu / x) return (j + b) else psn (j + m) (mu - x) | otherwise = prod 1 j where emu = exp (-mu) prod p k = do u <- stdUniformT if p * u > emu then prod (p * u) (k + 1) else return k integralPoissonCDF :: (Integral a, Real b) => b -> a -> Double integralPoissonCDF mu k = exp (negate lambda) * sum [ exp (fromIntegral i * log lambda - i_fac_ln) | (i, i_fac_ln) <- zip [0..k] (scanl (+) 0 (map log [1..])) ] where lambda = realToFrac mu fractionalPoisson :: (Num a, Distribution (Poisson b) Integer) => b -> RVarT m a fractionalPoisson mu = liftM fromInteger (poissonT mu) fractionalPoissonCDF :: (CDF (Poisson b) Integer, RealFrac a) => b -> a -> Double fractionalPoissonCDF mu k = cdf (Poisson mu) (floor k :: Integer) poisson :: (Distribution (Poisson b) a) => b -> RVar a poisson mu = rvar (Poisson mu) poissonT :: (Distribution (Poisson b) a) => b -> RVarT m a poissonT mu = rvarT (Poisson mu) newtype Poisson b a = Poisson b $( replicateInstances ''Int integralTypes [d| instance ( RealFloat b , Distribution StdUniform b , Distribution (Erlang Int) b , Distribution (Binomial b) Int ) => Distribution (Poisson b) Int where rvarT (Poisson mu) = integralPoisson mu instance (Real b, Distribution (Poisson b) Int) => CDF (Poisson b) Int where cdf (Poisson mu) = integralPoissonCDF mu |] ) $( replicateInstances ''Float realFloatTypes [d| instance (Distribution (Poisson b) Integer) => Distribution (Poisson b) Float where rvarT (Poisson mu) = fractionalPoisson mu instance (CDF (Poisson b) Integer) => CDF (Poisson b) Float where cdf (Poisson mu) = fractionalPoissonCDF mu |]) random-fu-0.2.7.0/src/Data/Random/Distribution/Rayleigh.hs0000644000000000000000000000233212724777671021417 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} module Data.Random.Distribution.Rayleigh where import Data.Random.RVar import Data.Random.Distribution import Data.Random.Distribution.Uniform floatingRayleigh :: (Floating a, Eq a, Distribution StdUniform a) => a -> RVarT m a floatingRayleigh s = do u <- stdUniformPosT return (s * sqrt (-2 * log u)) -- |The rayleigh distribution with a specified mode (\"sigma\") parameter. -- Its mean will be @sigma*sqrt(pi/2)@ and its variance will be @sigma^2*(4-pi)/2@ -- -- (therefore if you want one with a particular mean @m@, @sigma@ should be @m*sqrt(2/pi)@) newtype Rayleigh a = Rayleigh a rayleigh :: Distribution Rayleigh a => a -> RVar a rayleigh = rvar . Rayleigh rayleighT :: Distribution Rayleigh a => a -> RVarT m a rayleighT = rvarT . Rayleigh rayleighCDF :: Real a => a -> a -> Double rayleighCDF s x = 1 - exp ((-0.5)* realToFrac (x*x) / realToFrac (s*s)) instance (RealFloat a, Distribution StdUniform a) => Distribution Rayleigh a where rvarT (Rayleigh s) = floatingRayleigh s instance (Real a, Distribution Rayleigh a) => CDF Rayleigh a where cdf (Rayleigh s) x = rayleighCDF s x random-fu-0.2.7.0/src/Data/Random/Distribution/Simplex.hs0000644000000000000000000000345412724777671021302 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, GADTs #-} module Data.Random.Distribution.Simplex ( StdSimplex(..) , stdSimplex , stdSimplexT , fractionalStdSimplex ) where import Control.Applicative import Control.Monad import Data.List import Data.Random.RVar import Data.Random.Distribution import Data.Random.Distribution.Uniform -- |Uniform distribution over a standard simplex. newtype StdSimplex as = -- | @StdSimplex k@ constructs a standard simplex of dimension @k@ -- (standard /k/-simplex). -- An element of the simplex represents a vector variable @as = (a_0, -- a_1, ..., a_k)@. The elements of @as@ are more than or equal to @0@ -- and @sum as@ is always equal to @1@. StdSimplex Int deriving (Eq, Show) instance (Ord a, Fractional a, Distribution StdUniform a) => Distribution StdSimplex [a] where rvar (StdSimplex k) = fractionalStdSimplex k -- |@stdSimplex k@ returns a random variable being uniformly distributed over -- a standard simplex of dimension @k@. stdSimplex :: Distribution StdSimplex [a] => Int -> RVar [a] stdSimplex k = rvar (StdSimplex k) stdSimplexT :: Distribution StdSimplex [a] => Int -> RVarT m [a] stdSimplexT k = rvarT (StdSimplex k) -- |An algorithm proposed by Rubinstein & Melamed (1998). -- See, /e.g./, S. Onn, I. Weissman. -- Generating uniform random vectors over a simplex with implications to -- the volume of a certain polytope and to multivariate extremes. -- /Ann Oper Res/ (2011) __189__:331-342. fractionalStdSimplex :: (Ord a, Fractional a, Distribution StdUniform a) => Int -> RVar [a] fractionalStdSimplex k = do us <- replicateM k stdUniform let us' = sort us ++ [1] return $ zipWith (-) us' (0 : us') random-fu-0.2.7.0/src/Data/Random/Distribution/StretchedExponential.hs0000644000000000000000000000264212724777671024013 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} module Data.Random.Distribution.StretchedExponential where import Data.Random.RVar import Data.Random.Distribution import Data.Random.Distribution.Uniform newtype StretchedExponential a = StretchedExp (a,a) floatingStretchedExponential :: (Floating a, Distribution StdUniform a) => a -> a -> RVarT m a floatingStretchedExponential beta lambdaRecip = do x <- stdUniformT return (negate (log (1-x))**(1/beta) * lambdaRecip) floatingStretchedExponentialCDF :: Real a => a -> a -> a -> Double floatingStretchedExponentialCDF beta lambdaRecip x = 1 - exp (negate (realToFrac x / realToFrac lambdaRecip)**(realToFrac beta)) stretchedExponential :: Distribution StretchedExponential a => a -> a -> RVar a stretchedExponential beta lambdaRecip = rvar $ StretchedExp (beta, lambdaRecip) stretchedExponentialT :: Distribution StretchedExponential a => a -> a -> RVarT m a stretchedExponentialT beta lambdaRecip = rvarT $ StretchedExp (beta, lambdaRecip) instance (Floating a, Distribution StdUniform a) => Distribution StretchedExponential a where rvarT (StretchedExp (beta,lambdaRecip)) = floatingStretchedExponential beta lambdaRecip instance (Real a, Distribution StretchedExponential a) => CDF StretchedExponential a where cdf (StretchedExp (beta,lambdaRecip)) = floatingStretchedExponentialCDF beta lambdaReciprandom-fu-0.2.7.0/src/Data/Random/Distribution/T.hs0000644000000000000000000000261012724777671020055 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Random.Distribution.T where import Data.RVar import Data.Random.Distribution import Data.Random.Distribution.ChiSquare import Data.Random.Distribution.Normal import Numeric.SpecFunctions t :: Distribution T a => Integer -> RVar a t = rvar . T tT :: Distribution T a => Integer -> RVarT m a tT = rvarT . T newtype T a = T Integer deriving (Eq, Ord, Show) instance (Floating a, Distribution Normal a, Distribution ChiSquare a) => Distribution T a where rvarT (T n) | n > 0 = do x <- stdNormalT y <- chiSquareT n return (x * sqrt (fromInteger n / y)) | otherwise = fail "Student's t-distribution: degrees of freedom must be positive" instance (Real a, Distribution T a) => CDF T a where cdf (T n) t = incompleteBeta v2 v2 x where v = fromIntegral n v2 = 0.5 * v tD = realToFrac t u = sqrt (tD*tD + v) x = (tD + u) / (u + u) random-fu-0.2.7.0/src/Data/Random/Distribution/Triangular.hs0000644000000000000000000000445612724777671021774 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} module Data.Random.Distribution.Triangular where import Data.Random.RVar import Data.Random.Distribution import Data.Random.Distribution.Uniform -- |A description of a triangular distribution - a distribution whose PDF -- is a triangle ramping up from a lower bound to a specified midpoint -- and back down to the upper bound. This is a very simple distribution -- that does not generally occur naturally but is used sometimes as an -- estimate of a true distribution when only the range of the values and -- an approximate mode of the true distribution are known. data Triangular a = Triangular { -- |The lower bound of the triangle in the PDF (the smallest number the distribution can generate) triLower :: a, -- |The midpoint of the triangle (also the mode of the distribution) triMid :: a, -- |The upper bound of the triangle (and the largest number the distribution can generate) triUpper :: a} deriving (Eq, Show) -- |Compute a triangular distribution for a 'Floating' type. floatingTriangular :: (Floating a, Ord a, Distribution StdUniform a) => a -> a -> a -> RVarT m a floatingTriangular a b c | a > b = floatingTriangular b a c | b > c = floatingTriangular a c b | otherwise = do let p = (c-b)/(c-a) u <- stdUniformT let d | u >= p = a | otherwise = c x | u >= p = (u - p) / (1 - p) | otherwise = u / p -- may prefer this: reusing u costs resolution, especially if p or 1-p is small and c-a is large. -- x <- stdUniform return (b - ((1 - sqrt x) * (b-d))) -- |@triangularCDF a b c@ is the CDF of @realFloatTriangular a b c@. triangularCDF :: RealFrac a => a -> a -> a -> a -> Double triangularCDF a b c x | x < a = 0 | x <= b = realToFrac ((x - a)^(2 :: Int) / ((c - a) * (b - a))) | x <= c = realToFrac (1 - (c - x)^(2 :: Int) / ((c - a) * (c - b))) | otherwise = 1 instance (RealFloat a, Ord a, Distribution StdUniform a) => Distribution Triangular a where rvarT (Triangular a b c) = floatingTriangular a b c instance (RealFrac a, Distribution Triangular a) => CDF Triangular a where cdf (Triangular a b c) = triangularCDF a b crandom-fu-0.2.7.0/src/Data/Random/Distribution/Uniform.hs0000644000000000000000000003544112724777671021301 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances, UndecidableInstances, EmptyDataDecls, TemplateHaskell, BangPatterns #-} module Data.Random.Distribution.Uniform ( Uniform(..) , uniform , uniformT , StdUniform(..) , stdUniform , stdUniformT , stdUniformPos , stdUniformPosT , integralUniform , realFloatUniform , floatUniform , doubleUniform , fixedUniform , enumUniform , boundedStdUniform , boundedEnumStdUniform , realFloatStdUniform , fixedStdUniform , floatStdUniform , doubleStdUniform , boundedStdUniformCDF , realStdUniformCDF , realUniformCDF , enumUniformCDF ) where import Data.Random.Internal.TH import Data.Random.Internal.Words import Data.Random.Internal.Fixed import Data.Random.Source import Data.Random.Distribution import Data.Random.RVar import Data.Fixed import Data.Word import Data.Int import Control.Monad.Loops -- |Compute a random 'Integral' value between the 2 values provided (inclusive). {-# INLINE integralUniform #-} integralUniform :: (Integral a) => a -> a -> RVarT m a integralUniform !x !y = if x < y then integralUniform' x y else integralUniform' y x {-# SPECIALIZE integralUniform' :: Int -> Int -> RVarT m Int #-} {-# SPECIALIZE integralUniform' :: Int8 -> Int8 -> RVarT m Int8 #-} {-# SPECIALIZE integralUniform' :: Int16 -> Int16 -> RVarT m Int16 #-} {-# SPECIALIZE integralUniform' :: Int32 -> Int32 -> RVarT m Int32 #-} {-# SPECIALIZE integralUniform' :: Int64 -> Int64 -> RVarT m Int64 #-} {-# SPECIALIZE integralUniform' :: Word -> Word -> RVarT m Word #-} {-# SPECIALIZE integralUniform' :: Word8 -> Word8 -> RVarT m Word8 #-} {-# SPECIALIZE integralUniform' :: Word16 -> Word16 -> RVarT m Word16 #-} {-# SPECIALIZE integralUniform' :: Word32 -> Word32 -> RVarT m Word32 #-} {-# SPECIALIZE integralUniform' :: Word64 -> Word64 -> RVarT m Word64 #-} {-# SPECIALIZE integralUniform' :: Integer -> Integer -> RVarT m Integer #-} integralUniform' :: (Integral a) => a -> a -> RVarT m a integralUniform' !l !u | nReject == 0 = fmap shift prim | otherwise = fmap shift loop where m = 1 + toInteger u - toInteger l (bytes, nPossible) = bytesNeeded m nReject = nPossible `mod` m !prim = getRandomNByteInteger bytes !shift = \(!z) -> l + (fromInteger $! (z `mod` m)) loop = do z <- prim if z < nReject then loop else return z integralUniformCDF :: (Integral a, Fractional b) => a -> a -> a -> b integralUniformCDF a b x | b < a = integralUniformCDF b a x | x < a = 0 | x > b = 1 | otherwise = (fromIntegral x - fromIntegral a) / (fromIntegral b - fromIntegral a) -- TODO: come up with a decent, fast heuristic to decide whether to return an extra -- byte. May involve moving calculation of nReject into this function, and then -- accepting first if 4*nReject < nPossible or something similar. bytesNeeded :: Integer -> (Int, Integer) bytesNeeded x = head (dropWhile ((<= x).snd) powersOf256) powersOf256 :: [(Int, Integer)] powersOf256 = zip [0..] (iterate (256 *) 1) -- |Compute a random value for a 'Bounded' type, between 'minBound' and 'maxBound' -- (inclusive for 'Integral' or 'Enum' types, in ['minBound', 'maxBound') for Fractional types.) boundedStdUniform :: (Distribution Uniform a, Bounded a) => RVar a boundedStdUniform = uniform minBound maxBound boundedStdUniformCDF :: (CDF Uniform a, Bounded a) => a -> Double boundedStdUniformCDF = cdf (Uniform minBound maxBound) -- |Compute a random value for a 'Bounded' 'Enum' type, between 'minBound' and -- 'maxBound' (inclusive) boundedEnumStdUniform :: (Enum a, Bounded a) => RVarT m a boundedEnumStdUniform = enumUniform minBound maxBound boundedEnumStdUniformCDF :: (Enum a, Bounded a, Ord a) => a -> Double boundedEnumStdUniformCDF = enumUniformCDF minBound maxBound -- |Compute a uniform random 'Float' value in the range [0,1) floatStdUniform :: RVarT m Float floatStdUniform = do x <- getRandomWord32 return (word32ToFloat x) -- |Compute a uniform random 'Double' value in the range [0,1) {-# INLINE doubleStdUniform #-} doubleStdUniform :: RVarT m Double doubleStdUniform = getRandomDouble -- |Compute a uniform random value in the range [0,1) for any 'RealFloat' type realFloatStdUniform :: RealFloat a => RVarT m a realFloatStdUniform = do let (b, e) = decodeFloat one x <- uniformT 0 (b-1) if x == 0 then return (0 `asTypeOf` one) else return (encodeFloat x e) where one = 1 -- |Compute a uniform random 'Fixed' value in the range [0,1), with any -- desired precision. fixedStdUniform :: HasResolution r => RVarT m (Fixed r) fixedStdUniform = x where res = resolutionOf2 x x = do u <- uniformT 0 (res) return (mkFixed u) -- |The CDF of the random variable 'realFloatStdUniform'. realStdUniformCDF :: Real a => a -> Double realStdUniformCDF x | x <= 0 = 0 | x >= 1 = 1 | otherwise = realToFrac x -- |The PDF of the random variable 'realFloatStdUniform'. realStdUniformPDF :: Real a => a -> Double realStdUniformPDF x | x <= 0 = 0 | x >= 1 = 0 | otherwise = 1 -- |(internal) basic linear interpolation; @lerp x y@ is a linear function whose -- value is @x@ at 0 and @y@ at 1 lerp :: Num a => a -> a -> a -> a lerp x y a = (1-a)*x + a*y -- |@floatUniform a b@ computes a uniform random 'Float' value in the range [a,b) floatUniform :: Float -> Float -> RVarT m Float floatUniform 0 1 = floatStdUniform floatUniform a b = do x <- floatStdUniform return (lerp a b x) -- |@doubleUniform a b@ computes a uniform random 'Double' value in the range [a,b) {-# INLINE doubleUniform #-} doubleUniform :: Double -> Double -> RVarT m Double doubleUniform 0 1 = doubleStdUniform doubleUniform a b = do x <- doubleStdUniform return (lerp a b x) -- |@realFloatUniform a b@ computes a uniform random value in the range [a,b) for -- any 'RealFloat' type realFloatUniform :: RealFloat a => a -> a -> RVarT m a realFloatUniform 0 1 = realFloatStdUniform realFloatUniform a b = do x <- realFloatStdUniform return (lerp a b x) -- |@fixedUniform a b@ computes a uniform random 'Fixed' value in the range -- [a,b), with any desired precision. fixedUniform :: HasResolution r => Fixed r -> Fixed r -> RVarT m (Fixed r) fixedUniform a b = do u <- integralUniform (unMkFixed a) (unMkFixed b) return (mkFixed u) -- |@realUniformCDF a b@ is the CDF of the random variable @realFloatUniform a b@. realUniformCDF :: RealFrac a => a -> a -> a -> Double realUniformCDF a b x | b < a = realUniformCDF b a x | x <= a = 0 | x >= b = 1 | otherwise = realToFrac ((x-a) / (b-a)) -- |@realFloatUniform a b@ computes a uniform random value in the range [a,b) for -- any 'Enum' type enumUniform :: Enum a => a -> a -> RVarT m a enumUniform a b = do x <- integralUniform (fromEnum a) (fromEnum b) return (toEnum x) enumUniformCDF :: (Enum a, Ord a) => a -> a -> a -> Double enumUniformCDF a b x | b < a = enumUniformCDF b a x | x <= a = 0 | x >= b = 1 | otherwise = (e2f x - e2f a) / (e2f b - e2f a) where e2f = fromIntegral . fromEnum -- @uniform a b@ is a uniformly distributed random variable in the range -- [a,b] for 'Integral' or 'Enum' types and in the range [a,b) for 'Fractional' -- types. Requires a @Distribution Uniform@ instance for the type. uniform :: Distribution Uniform a => a -> a -> RVar a uniform a b = rvar (Uniform a b) -- @uniformT a b@ is a uniformly distributed random process in the range -- [a,b] for 'Integral' or 'Enum' types and in the range [a,b) for 'Fractional' -- types. Requires a @Distribution Uniform@ instance for the type. uniformT :: Distribution Uniform a => a -> a -> RVarT m a uniformT a b = rvarT (Uniform a b) -- |Get a \"standard\" uniformly distributed variable. -- For integral types, this means uniformly distributed over the full range -- of the type (there is no support for 'Integer'). For fractional -- types, this means uniformly distributed on the interval [0,1). {-# SPECIALIZE stdUniform :: RVar Double #-} {-# SPECIALIZE stdUniform :: RVar Float #-} stdUniform :: (Distribution StdUniform a) => RVar a stdUniform = rvar StdUniform -- |Get a \"standard\" uniformly distributed process. -- For integral types, this means uniformly distributed over the full range -- of the type (there is no support for 'Integer'). For fractional -- types, this means uniformly distributed on the interval [0,1). {-# SPECIALIZE stdUniformT :: RVarT m Double #-} {-# SPECIALIZE stdUniformT :: RVarT m Float #-} stdUniformT :: (Distribution StdUniform a) => RVarT m a stdUniformT = rvarT StdUniform -- |Like 'stdUniform', but returns only positive or zero values. Not -- exported because it is not truly uniform: nonzero values are twice -- as likely as zero on signed types. stdUniformNonneg :: (Distribution StdUniform a, Num a, Eq a) => RVarT m a stdUniformNonneg = fmap abs stdUniformT -- |Like 'stdUniform' but only returns positive values. stdUniformPos :: (Distribution StdUniform a, Num a, Eq a) => RVar a stdUniformPos = stdUniformPosT -- |Like 'stdUniform' but only returns positive values. stdUniformPosT :: (Distribution StdUniform a, Num a, Eq a) => RVarT m a stdUniformPosT = iterateUntil (/= 0) stdUniformNonneg -- |A definition of a uniform distribution over the type @t@. See also 'uniform'. data Uniform t = -- |A uniform distribution defined by a lower and upper range bound. -- For 'Integral' and 'Enum' types, the range is inclusive. For 'Fractional' -- types the range includes the lower bound but not the upper. Uniform !t !t -- |A name for the \"standard\" uniform distribution over the type @t@, -- if one exists. See also 'stdUniform'. -- -- For 'Integral' and 'Enum' types that are also 'Bounded', this is -- the uniform distribution over the full range of the type. -- For un-'Bounded' 'Integral' types this is not defined. -- For 'Fractional' types this is a random variable in the range [0,1) -- (that is, 0 to 1 including 0 but not including 1). data StdUniform t = StdUniform $( replicateInstances ''Int integralTypes [d| instance Distribution Uniform Int where rvarT (Uniform a b) = integralUniform a b instance CDF Uniform Int where cdf (Uniform a b) = integralUniformCDF a b |]) instance Distribution StdUniform Word8 where rvarT _ = getRandomWord8 instance Distribution StdUniform Word16 where rvarT _ = getRandomWord16 instance Distribution StdUniform Word32 where rvarT _ = getRandomWord32 instance Distribution StdUniform Word64 where rvarT _ = getRandomWord64 instance Distribution StdUniform Int8 where rvarT _ = fromIntegral `fmap` getRandomWord8 instance Distribution StdUniform Int16 where rvarT _ = fromIntegral `fmap` getRandomWord16 instance Distribution StdUniform Int32 where rvarT _ = fromIntegral `fmap` getRandomWord32 instance Distribution StdUniform Int64 where rvarT _ = fromIntegral `fmap` getRandomWord64 instance Distribution StdUniform Int where rvar _ = $(if toInteger (maxBound :: Int) > toInteger (maxBound :: Int32) then [|fromIntegral `fmap` getRandomWord64 :: RVar Int|] else [|fromIntegral `fmap` getRandomWord32 :: RVar Int|]) instance Distribution StdUniform Word where rvar _ = $(if toInteger (maxBound :: Word) > toInteger (maxBound :: Word32) then [|fromIntegral `fmap` getRandomWord64 :: RVar Word|] else [|fromIntegral `fmap` getRandomWord32 :: RVar Word|]) -- Integer has no StdUniform... instance CDF StdUniform Word8 where cdf _ = integralUniformCDF minBound maxBound instance CDF StdUniform Word16 where cdf _ = integralUniformCDF minBound maxBound instance CDF StdUniform Word32 where cdf _ = integralUniformCDF minBound maxBound instance CDF StdUniform Word64 where cdf _ = integralUniformCDF minBound maxBound instance CDF StdUniform Word where cdf _ = integralUniformCDF minBound maxBound instance CDF StdUniform Int8 where cdf _ = integralUniformCDF minBound maxBound instance CDF StdUniform Int16 where cdf _ = integralUniformCDF minBound maxBound instance CDF StdUniform Int32 where cdf _ = integralUniformCDF minBound maxBound instance CDF StdUniform Int64 where cdf _ = integralUniformCDF minBound maxBound instance CDF StdUniform Int where cdf _ = integralUniformCDF minBound maxBound instance Distribution Uniform Float where rvarT (Uniform a b) = floatUniform a b instance Distribution Uniform Double where rvarT (Uniform a b) = doubleUniform a b instance CDF Uniform Float where cdf (Uniform a b) = realUniformCDF a b instance CDF Uniform Double where cdf (Uniform a b) = realUniformCDF a b instance Distribution StdUniform Float where rvarT _ = floatStdUniform instance Distribution StdUniform Double where rvarT _ = getRandomDouble instance CDF StdUniform Float where cdf _ = realStdUniformCDF instance CDF StdUniform Double where cdf _ = realStdUniformCDF instance PDF StdUniform Float where pdf _ = realStdUniformPDF instance PDF StdUniform Double where pdf _ = realStdUniformPDF instance HasResolution r => Distribution Uniform (Fixed r) where rvarT (Uniform a b) = fixedUniform a b instance HasResolution r => CDF Uniform (Fixed r) where cdf (Uniform a b) = realUniformCDF a b instance HasResolution r => Distribution StdUniform (Fixed r) where rvarT ~StdUniform = fixedStdUniform instance HasResolution r => CDF StdUniform (Fixed r) where cdf ~StdUniform = realStdUniformCDF instance Distribution Uniform () where rvarT (Uniform _ _) = return () instance CDF Uniform () where cdf (Uniform _ _) = return 1 $( replicateInstances ''Char [''Char, ''Bool, ''Ordering] [d| instance Distribution Uniform Char where rvarT (Uniform a b) = enumUniform a b instance CDF Uniform Char where cdf (Uniform a b) = enumUniformCDF a b |]) instance Distribution StdUniform () where rvarT ~StdUniform = return () instance CDF StdUniform () where cdf ~StdUniform = return 1 instance Distribution StdUniform Bool where rvarT ~StdUniform = fmap even (getRandomWord8) instance CDF StdUniform Bool where cdf ~StdUniform = boundedEnumStdUniformCDF instance Distribution StdUniform Char where rvarT ~StdUniform = boundedEnumStdUniform instance CDF StdUniform Char where cdf ~StdUniform = boundedEnumStdUniformCDF instance Distribution StdUniform Ordering where rvarT ~StdUniform = boundedEnumStdUniform instance CDF StdUniform Ordering where cdf ~StdUniform = boundedEnumStdUniformCDF random-fu-0.2.7.0/src/Data/Random/Distribution/Weibull.hs0000644000000000000000000000121712724777671021257 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} module Data.Random.Distribution.Weibull where import Data.Random.Distribution import Data.Random.Distribution.Uniform data Weibull a = Weibull { weibullLambda :: !a, weibullK :: !a } deriving (Eq, Show) instance (Floating a, Distribution StdUniform a) => Distribution Weibull a where rvarT (Weibull lambda k) = do u <- rvarT StdUniform return (lambda * (negate (log u)) ** recip k) instance (Real a, Distribution Weibull a) => CDF Weibull a where cdf (Weibull lambda k) x = 1 - exp (negate ((realToFrac x / realToFrac lambda) ** realToFrac k))random-fu-0.2.7.0/src/Data/Random/Distribution/Ziggurat.hs0000644000000000000000000003212312724777671021450 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, RankNTypes, FlexibleInstances, FlexibleContexts, RecordWildCards, BangPatterns #-} -- |A generic \"ziggurat algorithm\" implementation. Fairly rough right -- now. -- -- There is a lot of room for improvement in 'findBin0' especially. -- It needs a fair amount of cleanup and elimination of redundant -- calculation, as well as either a justification for using the simple -- 'findMinFrom' or a proper root-finding algorithm. -- -- It would also be nice to add (preferably by pulling in an -- external package) support for numerical integration and -- differentiation, so that tables can be derived from only a -- PDF (if the end user is willing to take the performance and -- accuracy hit for the convenience). module Data.Random.Distribution.Ziggurat ( Ziggurat(..) , mkZigguratRec , mkZiggurat , mkZiggurat_ , findBin0 , runZiggurat ) where import Data.Random.Internal.Find import Data.Random.Distribution.Uniform import Data.Random.Distribution import Data.Random.RVar import Data.Vector.Generic as Vec import qualified Data.Vector as V import qualified Data.Vector.Unboxed as UV -- |A data structure containing all the data that is needed -- to implement Marsaglia & Tang's \"ziggurat\" algorithm for -- sampling certain kinds of random distributions. -- -- The documentation here is probably not sufficient to tell a user exactly -- how to build one of these from scratch, but it is not really intended to -- be. There are several helper functions that will build 'Ziggurat's. -- The pathologically curious may wish to read the 'runZiggurat' source. -- That is the ultimate specification of the semantics of all these fields. data Ziggurat v t = Ziggurat { -- |The X locations of each bin in the distribution. Bin 0 is the -- 'infinite' one. -- -- In the case of bin 0, the value given is sort of magical - x[0] is -- defined to be V/f(R). It's not actually the location of any bin, -- but a value computed to make the algorithm more concise and slightly -- faster by not needing to specially-handle bin 0 quite as often. -- If you really need to know why it works, see the 'runZiggurat' -- source or \"the literature\" - it's a fairly standard setup. zTable_xs :: !(v t), -- |The ratio of each bin's Y value to the next bin's Y value zTable_y_ratios :: !(v t), -- |The Y value (zFunc x) of each bin zTable_ys :: !(v t), -- |An RVar providing a random tuple consisting of: -- -- * a bin index, uniform over [0,c) :: Int (where @c@ is the -- number of bins in the tables) -- -- * a uniformly distributed fractional value, from -1 to 1 -- if not mirrored, from 0 to 1 otherwise. -- -- This is provided as a single 'RVar' because it can be implemented -- more efficiently than naively sampling 2 separate values - a -- single random word (64 bits) can be efficiently converted to -- a double (using 52 bits) and a bin number (using up to 12 bits), -- for example. zGetIU :: !(forall m. RVarT m (Int, t)), -- |The distribution for the final \"virtual\" bin -- (the ziggurat algorithm does not handle distributions -- that wander off to infinity, so another distribution is needed -- to handle the last \"bin\" that stretches to infinity) zTailDist :: (forall m. RVarT m t), -- |A copy of the uniform RVar generator for the base type, -- so that @Distribution Uniform t@ is not needed when sampling -- from a Ziggurat (makes it a bit more self-contained). zUniform :: !(forall m. t -> t -> RVarT m t), -- |The (one-sided antitone) PDF, not necessarily normalized zFunc :: !(t -> t), -- |A flag indicating whether the distribution should be -- mirrored about the origin (the ziggurat algorithm in -- its native form only samples from one-sided distributions. -- By mirroring, we can extend it to symmetric distributions -- such as the normal distribution) zMirror :: !Bool } -- |Sample from the distribution encoded in a 'Ziggurat' data structure. {-# INLINE runZiggurat #-} {-# SPECIALIZE runZiggurat :: Ziggurat UV.Vector Float -> RVarT m Float #-} {-# SPECIALIZE runZiggurat :: Ziggurat UV.Vector Double -> RVarT m Double #-} {-# SPECIALIZE runZiggurat :: Ziggurat V.Vector Float -> RVarT m Float #-} {-# SPECIALIZE runZiggurat :: Ziggurat V.Vector Double -> RVarT m Double #-} runZiggurat :: (Num a, Ord a, Vector v a) => Ziggurat v a -> RVarT m a runZiggurat !Ziggurat{..} = go where {-# NOINLINE go #-} go = do -- Select a bin (I) and a uniform value (U) from -1 to 1 -- (or 0 to 1 if not mirroring the distribution). -- Let X be U scaled to the size of the selected bin. (!i,!u) <- zGetIU -- if the uniform value U falls in the area "clearly inside" the -- bin, accept X immediately. -- Otherwise, depending on the bin selected, use either the -- tail distribution or an accept/reject test. if abs u < zTable_y_ratios ! i then return $! (u * zTable_xs ! i) else if i == 0 then sampleTail u else sampleGreyArea i $! (u * zTable_xs ! i) -- when the sample falls in the "grey area" (the area between -- the Y values of the selected bin and the bin after that one), -- use an accept/reject method based on the target PDF. {-# INLINE sampleGreyArea #-} sampleGreyArea i x = do !v <- zUniform (zTable_ys ! (i+1)) (zTable_ys ! i) if v < zFunc (abs x) then return $! x else go -- if the selected bin is the "infinite" one, call it quits and -- defer to the tail distribution (mirroring if needed to ensure -- the result has the sign already selected by zGetIU) {-# INLINE sampleTail #-} sampleTail x | zMirror && x < 0 = fmap negate zTailDist | otherwise = zTailDist -- |Build the tables to implement the \"ziggurat algorithm\" devised by -- Marsaglia & Tang, attempting to automatically compute the R and V -- values. -- -- Arguments: -- -- * flag indicating whether to mirror the distribution -- -- * the (one-sided antitone) PDF, not necessarily normalized -- -- * the inverse of the PDF -- -- * the number of bins -- -- * R, the x value of the first bin -- -- * V, the volume of each bin -- -- * an RVar providing the 'zGetIU' random tuple -- -- * an RVar sampling from the tail (the region where x > R) -- {-# INLINE mkZiggurat_ #-} {-# SPECIALIZE mkZiggurat_ :: Bool -> (Float -> Float) -> (Float -> Float) -> Int -> Float -> Float -> (forall m. RVarT m (Int, Float)) -> (forall m. RVarT m Float ) -> Ziggurat UV.Vector Float #-} {-# SPECIALIZE mkZiggurat_ :: Bool -> (Double -> Double) -> (Double -> Double) -> Int -> Double -> Double -> (forall m. RVarT m (Int, Double)) -> (forall m. RVarT m Double) -> Ziggurat UV.Vector Double #-} {-# SPECIALIZE mkZiggurat_ :: Bool -> (Float -> Float) -> (Float -> Float) -> Int -> Float -> Float -> (forall m. RVarT m (Int, Float)) -> (forall m. RVarT m Float ) -> Ziggurat V.Vector Float #-} {-# SPECIALIZE mkZiggurat_ :: Bool -> (Double -> Double) -> (Double -> Double) -> Int -> Double -> Double -> (forall m. RVarT m (Int, Double)) -> (forall m. RVarT m Double) -> Ziggurat V.Vector Double #-} mkZiggurat_ :: (RealFloat t, Vector v t, Distribution Uniform t) => Bool -> (t -> t) -> (t -> t) -> Int -> t -> t -> (forall m. RVarT m (Int, t)) -> (forall m. RVarT m t) -> Ziggurat v t mkZiggurat_ m f fInv c r v getIU tailDist = Ziggurat { zTable_xs = xs , zTable_y_ratios = precomputeRatios xs , zTable_ys = Vec.map f xs , zGetIU = getIU , zUniform = uniformT , zFunc = f , zTailDist = tailDist , zMirror = m } where xs = zigguratTable f fInv c r v -- |Build the tables to implement the \"ziggurat algorithm\" devised by -- Marsaglia & Tang, attempting to automatically compute the R and V -- values. -- -- Arguments are the same as for 'mkZigguratRec', with an additional -- argument for the tail distribution as a function of the selected -- R value. mkZiggurat :: (RealFloat t, Vector v t, Distribution Uniform t) => Bool -> (t -> t) -> (t -> t) -> (t -> t) -> t -> Int -> (forall m. RVarT m (Int, t)) -> (forall m. t -> RVarT m t) -> Ziggurat v t mkZiggurat m f fInv fInt fVol c getIU tailDist = mkZiggurat_ m f fInv c r v getIU (tailDist r) where (r,v) = findBin0 c f fInv fInt fVol -- |Build a lazy recursive ziggurat. Uses a lazily-constructed ziggurat -- as its tail distribution (with another as its tail, ad nauseam). -- -- Arguments: -- -- * flag indicating whether to mirror the distribution -- -- * the (one-sided antitone) PDF, not necessarily normalized -- -- * the inverse of the PDF -- -- * the integral of the PDF (definite, from 0) -- -- * the estimated volume under the PDF (from 0 to +infinity) -- -- * the chunk size (number of bins in each layer). 64 seems to -- perform well in practice. -- -- * an RVar providing the 'zGetIU' random tuple -- mkZigguratRec :: (RealFloat t, Vector v t, Distribution Uniform t) => Bool -> (t -> t) -> (t -> t) -> (t -> t) -> t -> Int -> (forall m. RVarT m (Int, t)) -> Ziggurat v t mkZigguratRec m f fInv fInt fVol c getIU = z where fix :: ((forall m. a -> RVarT m a) -> (forall m. a -> RVarT m a)) -> (forall m. a -> RVarT m a) fix g = g (fix g) z = mkZiggurat m f fInv fInt fVol c getIU (fix (mkTail m f fInv fInt fVol c getIU z)) mkTail :: (RealFloat a, Vector v a, Distribution Uniform a) => Bool -> (a -> a) -> (a -> a) -> (a -> a) -> a -> Int -> (forall m. RVarT m (Int, a)) -> Ziggurat v a -> (forall m. a -> RVarT m a) -> (forall m. a -> RVarT m a) mkTail m f fInv fInt fVol c getIU typeRep nextTail r = do x <- rvarT (mkZiggurat m f' fInv' fInt' fVol' c getIU nextTail `asTypeOf` typeRep) return (x + r * signum x) where fIntR = fInt r f' x | x < 0 = f r | otherwise = f (x+r) fInv' = subtract r . fInv fInt' x | x < 0 = 0 | otherwise = fInt (x+r) - fIntR fVol' = fVol - fIntR zigguratTable :: (Fractional a, Vector v a, Ord a) => (a -> a) -> (a -> a) -> Int -> a -> a -> v a zigguratTable f fInv c r v = case zigguratXs f fInv c r v of (xs, _excess) -> fromList xs zigguratExcess :: (Fractional a, Ord a) => (a -> a) -> (a -> a) -> Int -> a -> a -> a zigguratExcess f fInv c r v = snd (zigguratXs f fInv c r v) zigguratXs :: (Fractional a, Ord a) => (a -> a) -> (a -> a) -> Int -> a -> a -> ([a], a) zigguratXs f fInv c r v = (xs, excess) where xs = Prelude.map x [0..c] -- sample c x ys = Prelude.map f xs x 0 = v / f r x 1 = r x i | i == c = 0 x i | i > 1 = next (i-1) x _ = error "zigguratXs: programming error! this case should be impossible!" next i = let x_i = xs!!i in if x_i <= 0 then -1 else fInv (ys!!i + (v / x_i)) excess = xs!!(c-1) * (f 0 - ys !! (c-1)) - v precomputeRatios :: (Vector v a, Fractional a) => v a -> v a precomputeRatios zTable_xs = generate (c-1) $ \i -> zTable_xs!(i+1) / zTable_xs!i where c = Vec.length zTable_xs -- |I suspect this isn't completely right, but it works well so far. -- Search the distribution for an appropriate R and V. -- -- Arguments: -- -- * Number of bins -- -- * target function (one-sided antitone PDF, not necessarily normalized) -- -- * function inverse -- -- * function definite integral (from 0 to _) -- -- * estimate of total volume under function (integral from 0 to infinity) -- -- Result: (R,V) findBin0 :: (RealFloat b) => Int -> (b -> b) -> (b -> b) -> (b -> b) -> b -> (b, b) findBin0 cInt f fInv fInt fVol = (rMin,v rMin) where c = fromIntegral cInt v r = r * f r + fVol - fInt r -- initial R guess: r0 = findMin (\r -> v r <= fVol / c) -- find a better R: rMin = findMinFrom r0 1 $ \r -> let e = exc r in e >= 0 && not (isNaN e) exc x = zigguratExcess f fInv cInt x (v x) instance (Num t, Ord t, Vector v t) => Distribution (Ziggurat v) t where rvar = runZiggurat random-fu-0.2.7.0/src/Data/Random/Internal/0000755000000000000000000000000012724777671016414 5ustar0000000000000000random-fu-0.2.7.0/src/Data/Random/Internal/Find.hs0000644000000000000000000000425112724777671017632 0ustar0000000000000000{- - ``Data/Random/Internal/Find'' - Utilities for searching fractional domains. Needs cleanup, testing, - and such. Used for constructing generic ziggurats. -} module Data.Random.Internal.Find where findMax :: (Fractional a, Ord a) => (a -> Bool) -> a findMax p = negate (findMin (p.negate)) -- |Given an upward-closed predicate on an ordered Fractional type, -- find the smallest value satisfying the predicate. findMin :: (Fractional a, Ord a) => (a -> Bool) -> a findMin = findMinFrom 0 1 -- |Given an upward-closed predicate on an ordered Fractional type, -- find the smallest value satisfying the predicate. Starts at the -- specified point with the specified stepsize, performs an exponential -- search out from there until it finds an interval bracketing the -- change-point of the predicate, and then performs a bisection search -- to isolate the change point. Note that infinitely-divisible domains -- such as 'Rational' cannot be searched by this function because it does -- not terminate until it reaches a point where further subdivision of the -- interval has no effect. findMinFrom :: (Fractional a, Ord a) => a -> a -> (a -> Bool) -> a findMinFrom z0 0 p = findMinFrom z0 1 p findMinFrom z0 step1 p | p z0 = descend (z0-step1) z0 | otherwise = fixZero (ascend z0 (z0+step1)) where -- eliminate negative zero, which, in many domains, is technically -- a feasible answer fixZero 0 = 0 fixZero z = z -- preconditions: -- not (p l) -- 0 <= l < x ascend l x | p x = bisect l x | otherwise = ascend x $! 2*x-z0 -- preconditions: -- p h -- x < h <= 0 descend x h | p x = (descend $! 2*x-z0) x | otherwise = bisect x h -- preconditions: -- not (p l) -- p h -- l <= h bisect l h | l /< h = h | l /< mid || mid /< h = if p mid then mid else h | p mid = bisect l mid | otherwise = bisect mid h where a /< b = not (a < b) mid = (l+h)*0.5 random-fu-0.2.7.0/src/Data/Random/Internal/Fixed.hs0000644000000000000000000000227112724777671020011 0ustar0000000000000000{-# LANGUAGE CPP #-} module Data.Random.Internal.Fixed where import Data.Fixed import Unsafe.Coerce #ifdef old_Fixed -- So much for backward compatibility through base (>=5) ... resolutionOf :: HasResolution r => f r -> Integer resolutionOf x = resolution (res x) where res :: HasResolution r => f r -> r res = undefined resolutionOf2 :: HasResolution r => f (g r) -> Integer resolutionOf2 x = resolution (res x) where res :: HasResolution r => f (g r) -> r res = undefined #else resolutionOf :: HasResolution r => f r -> Integer resolutionOf = resolution resolutionOf2 :: HasResolution r => f (g r) -> Integer resolutionOf2 x = resolution (res x) where res :: HasResolution r => f (g r) -> g r res = undefined #endif -- |The 'Fixed' type doesn't expose its constructors, but I need a way to -- convert them to and from their raw representation in order to sample -- them. As long as 'Fixed' is a newtype wrapping 'Integer', 'mkFixed' and -- 'unMkFixed' as defined here will work. Both are implemented using -- 'unsafeCoerce'. mkFixed :: Integer -> Fixed r mkFixed = unsafeCoerce unMkFixed :: Fixed r -> Integer unMkFixed = unsafeCoercerandom-fu-0.2.7.0/src/Data/Random/Internal/TH.hs0000644000000000000000000000524712724777671017273 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- |Template Haskell utility code to replicate instance declarations -- to cover large numbers of types. I'm doing that rather than using -- class contexts because most Distribution instances need to cover -- multiple classes (such as Enum, Integral and Fractional) and that -- can't be done easily because of overlap. -- -- I experimented a bit with a convoluted type-level classification -- scheme, but I think this is simpler and easier to understand. It -- makes the haddock docs more cluttered because of the combinatorial -- explosion of instances, but overall I think it's just more sane than -- anything else I've come up with yet. module Data.Random.Internal.TH ( replicateInstances , integralTypes, realFloatTypes ) where import Data.Generics import Language.Haskell.TH import Data.Word import Data.Int import Control.Monad -- |Names of standard 'Integral' types integralTypes :: [Name] integralTypes = [ ''Integer , ''Int, ''Int8, ''Int16, ''Int32, ''Int64 , ''Word, ''Word8, ''Word16, ''Word32, ''Word64 ] -- |Names of standard 'RealFloat' types realFloatTypes :: [Name] realFloatTypes = [ ''Float, ''Double ] -- @replaceName x y@ is a function that will -- replace @x@ with @y@ whenever it sees it. That is: -- -- > replaceName x y x ==> y -- > replaceName x y z ==> z -- (@z /= x@) replaceName :: Name -> Name -> Name -> Name replaceName x y z | x == z = y | otherwise = z -- | @replicateInstances standin types decls@ will take the template-haskell -- 'Dec's in @decls@ and substitute every instance of the 'Name' @standin@ with -- each 'Name' in @types@, producing one copy of the 'Dec's in @decls@ for every -- 'Name' in @types@. -- -- For example, 'Data.Random.Distribution.Uniform' has the following bit of TH code: -- -- @ $( replicateInstances ''Int integralTypes [d| @ -- -- @ instance Distribution Uniform Int where rvar (Uniform a b) = integralUniform a b @ -- -- @ instance CDF Uniform Int where cdf (Uniform a b) = integralUniformCDF a b @ -- -- @ |]) @ -- -- This code takes those 2 instance declarations and creates identical ones for -- every type named in 'integralTypes'. replicateInstances :: (Monad m, Data t) => Name -> [Name] -> m [t] -> m [t] replicateInstances standin types getDecls = liftM concat $ sequence [ do decls <- getDecls sequence [ everywhereM (mkM (return . replaceName standin t)) dec | dec <- decls ] | t <- types ]