mwc-random-0.14.0.0/0000755000000000000000000000000013321427423012165 5ustar0000000000000000mwc-random-0.14.0.0/changelog.md0000644000000000000000000000324713321427423014444 0ustar0000000000000000## Changes in 0.14.0.0 * Low level functions for acquiring random data for initialization of PRGN state is moved to `System.Random.MWC.SeedSource` module * Ensure that carry is always correct when restoring PRNG state from seed. Only affects users who create 258 element seed manually. (#63, #65) ## Changes in 0.13.6.0 * `tablePoisson` now can handle λ>1923, see #59 for details. That required intoduction of dependency on math-functions. ## Changes in 0.13.5.0 * `logCategorical` added ## Changes in 0.13.4.0 * `withSystemRandom` uses RtlGenRandom for seeding generator on windows ## Changes in 0.13.3.1 * primitive-0.6 compatibility ## Changes in 0.13.3.0 * Monadic variant of vector shuffle added: `uniformShuffleM` * Context on `uniformShuffle` loosened ## Changes in 0.13.2.2 * Fixed crash during gen. initialization on Windows when stderr is not available (#36). ## Changes in 0.13.2.0 * Generators for beta, Bernoully, Dirichlet and categorical distributions added. * Functions for generating random shuffles added. ## Changes in 0.13.1.2 * GHC 7.9 support ## Changes in 0.13.1.1 * Long standing performance problem in normal distribution fixed (#16) ## Changes in 0.13.1.0 * `createSystemRandom` added ## Changes in 0.13.0.0 * Workaround for GHC bug 8072 (bug 25). GHC 7.6 on 32-bit platrofms is affected. * Generators for truncated exponential and geometric distributions added. ## Changes in 0.12.0.0 * Fucntion `asGenIO` and `asGenST` added. * Generation of discrete random variates using condensed tables methed. Tables for Poisson and binomial distributions are provided. mwc-random-0.14.0.0/Setup.lhs0000644000000000000000000000011413321427423013771 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain mwc-random-0.14.0.0/README.markdown0000644000000000000000000000174413321427423014674 0ustar0000000000000000# Efficient, general purpose pseudo-random number generation [![Build Status](https://travis-ci.org/Shimuuar/mwc-random.png?branch=master)](https://travis-ci.org/Shimuuar/mwc-random) [![Build status](https://ci.appveyor.com/api/projects/status/4228vkxje4as3nhw/branch/master)](https://ci.appveyor.com/project/Shimuuar/mwc-random) This package provides the System.Random.MWC module, a Haskell library for generating high-quality pseudo-random numbers in a space- and time-efficient way. # Get involved! Please report bugs via the [github issue tracker](http://github.com/bos/mwc-random). Master git [git repository](http://github.com/bos/mwc-random): * `git clone git://github.com/bos/mwc-random.git` There's also a [Mercurial mirror](http://bitbucket.org/bos/mwc-random): * `hg clone http://bitbucket.org/bos/mwc-random` (You can create and contribute changes using either Mercurial or git.) # Authors This library is written and maintained by Bryan O'Sullivan, . mwc-random-0.14.0.0/mwc-random.cabal0000644000000000000000000000342213321427423015216 0ustar0000000000000000name: mwc-random version: 0.14.0.0 synopsis: Fast, high quality pseudo random number generation description: This package contains code for generating high quality random numbers that follow either a uniform or normal distribution. The generated numbers are suitable for use in statistical applications. . The uniform PRNG uses Marsaglia's MWC256 (also known as MWC8222) multiply-with-carry generator, which has a period of 2^8222 and fares well in tests of randomness. It is also extremely fast, between 2 and 3 times faster than the Mersenne Twister. . Compared to the mersenne-random package, this package has a more convenient API, is faster, and supports more statistical distributions. license: BSD3 license-file: LICENSE homepage: https://github.com/bos/mwc-random bug-reports: https://github.com/bos/mwc-random/issues author: Bryan O'Sullivan maintainer: Bryan O'Sullivan copyright: 2009, 2010, 2011 Bryan O'Sullivan category: Math, Statistics build-type: Simple cabal-version: >= 1.8.0.4 extra-source-files: changelog.md README.markdown library exposed-modules: System.Random.MWC System.Random.MWC.Distributions System.Random.MWC.CondensedTable System.Random.MWC.SeedSource build-depends: base >= 4.5 && < 5 , primitive >= 0.6 , time , vector >= 0.7 , math-functions >= 0.2.1.0 ghc-options: -Wall -funbox-strict-fields -fwarn-tabs source-repository head type: git location: git://github.com/bos/mwc-random source-repository head type: mercurial location: https://bitbucket.org/bos/mwc-random mwc-random-0.14.0.0/LICENSE0000644000000000000000000000245413321427423013177 0ustar0000000000000000Copyright (c) 2009, Bryan O'Sullivan All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. mwc-random-0.14.0.0/System/0000755000000000000000000000000013321427423013451 5ustar0000000000000000mwc-random-0.14.0.0/System/Random/0000755000000000000000000000000013321427423014671 5ustar0000000000000000mwc-random-0.14.0.0/System/Random/MWC.hs0000644000000000000000000006260413321427423015663 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, FlexibleContexts, MagicHash, Rank2Types, ScopedTypeVariables, TypeFamilies, UnboxedTuples #-} -- | -- Module : System.Random.MWC -- Copyright : (c) 2009-2012 Bryan O'Sullivan -- License : BSD3 -- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- -- Pseudo-random number generation. This module contains code for -- generating high quality random numbers that follow a uniform -- distribution. -- -- For non-uniform distributions, see the -- 'System.Random.MWC.Distributions' module. -- -- The uniform PRNG uses Marsaglia's MWC256 (also known as MWC8222) -- multiply-with-carry generator, which has a period of 2^8222 and -- fares well in tests of randomness. It is also extremely fast, -- between 2 and 3 times faster than the Mersenne Twister. -- -- The generator state is stored in the 'Gen' data type. It can be -- created in several ways: -- -- 1. Using the 'withSystemRandom' call, which creates a random state. -- -- 2. Supply your own seed to 'initialize' function. -- -- 3. Finally, 'create' makes a generator from a fixed seed. -- Generators created in this way aren't really random. -- -- For repeatability, the state of the generator can be snapshotted -- and replayed using the 'save' and 'restore' functions. -- -- The simplest use is to generate a vector of uniformly distributed values: -- -- @ -- vs \<- 'withSystemRandom' . 'asGenST' $ \\gen -> 'uniformVector' gen 100 -- @ -- -- These values can be of any type which is an instance of the class -- 'Variate'. -- -- To generate random values on demand, first 'create' a random number -- generator. -- -- @ -- gen <- 'create' -- @ -- -- Hold onto this generator and use it wherever random values are -- required (creating a new generator is expensive compared to -- generating a random number, so you don't want to throw them -- away). Get a random value using 'uniform' or 'uniformR': -- -- @ -- v <- 'uniform' gen -- @ -- -- @ -- v <- 'uniformR' (1, 52) gen -- @ module System.Random.MWC ( -- * Gen: Pseudo-Random Number Generators Gen , create , initialize , withSystemRandom , createSystemRandom -- ** Type helpers -- $typehelp , GenIO , GenST , asGenIO , asGenST -- * Variates: uniformly distributed values , Variate(..) , uniformVector -- * Seed: state management , Seed , fromSeed , toSeed , save , restore -- * References -- $references ) where #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) #include "MachDeps.h" #endif import Control.Monad (ap, liftM, unless) import Control.Monad.Primitive (PrimMonad, PrimBase, PrimState, unsafePrimToIO) import Control.Monad.ST (ST) import Data.Bits ((.&.), (.|.), shiftL, shiftR, xor) import Data.Int (Int8, Int16, Int32, Int64) import Data.IORef (atomicModifyIORef, newIORef) import Data.Typeable (Typeable) import Data.Vector.Generic (Vector) import Data.Word import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as I import qualified Data.Vector.Unboxed.Mutable as M import System.IO (hPutStrLn, stderr) import System.IO.Unsafe (unsafePerformIO) import qualified Control.Exception as E #if defined(mingw32_HOST_OS) import Foreign.Ptr import Foreign.C.Types #endif import System.Random.MWC.SeedSource -- | The class of types for which we can generate uniformly -- distributed random variates. -- -- The uniform PRNG uses Marsaglia's MWC256 (also known as MWC8222) -- multiply-with-carry generator, which has a period of 2^8222 and -- fares well in tests of randomness. It is also extremely fast, -- between 2 and 3 times faster than the Mersenne Twister. -- -- /Note/: Marsaglia's PRNG is not known to be cryptographically -- secure, so you should not use it for cryptographic operations. class Variate a where -- | Generate a single uniformly distributed random variate. The -- range of values produced varies by type: -- -- * For fixed-width integral types, the type's entire range is -- used. -- -- * For floating point numbers, the range (0,1] is used. Zero is -- explicitly excluded, to allow variates to be used in -- statistical calculations that require non-zero values -- (e.g. uses of the 'log' function). -- -- To generate a 'Float' variate with a range of [0,1), subtract -- 2**(-33). To do the same with 'Double' variates, subtract -- 2**(-53). uniform :: (PrimMonad m) => Gen (PrimState m) -> m a -- | Generate single uniformly distributed random variable in a -- given range. -- -- * For integral types inclusive range is used. -- -- * For floating point numbers range (a,b] is used if one ignores -- rounding errors. uniformR :: (PrimMonad m) => (a,a) -> Gen (PrimState m) -> m a instance Variate Int8 where uniform = uniform1 fromIntegral uniformR a b = uniformRange a b {-# INLINE uniform #-} {-# INLINE uniformR #-} instance Variate Int16 where uniform = uniform1 fromIntegral uniformR a b = uniformRange a b {-# INLINE uniform #-} {-# INLINE uniformR #-} instance Variate Int32 where uniform = uniform1 fromIntegral uniformR a b = uniformRange a b {-# INLINE uniform #-} {-# INLINE uniformR #-} instance Variate Int64 where uniform = uniform2 wordsTo64Bit uniformR a b = uniformRange a b {-# INLINE uniform #-} {-# INLINE uniformR #-} instance Variate Word8 where uniform = uniform1 fromIntegral uniformR a b = uniformRange a b {-# INLINE uniform #-} {-# INLINE uniformR #-} instance Variate Word16 where uniform = uniform1 fromIntegral uniformR a b = uniformRange a b {-# INLINE uniform #-} {-# INLINE uniformR #-} instance Variate Word32 where uniform = uniform1 id uniformR a b = uniformRange a b {-# INLINE uniform #-} {-# INLINE uniformR #-} instance Variate Word64 where uniform = uniform2 wordsTo64Bit uniformR a b = uniformRange a b {-# INLINE uniform #-} {-# INLINE uniformR #-} instance Variate Bool where uniform = uniform1 wordToBool uniformR (False,True) g = uniform g uniformR (False,False) _ = return False uniformR (True,True) _ = return True uniformR (True,False) g = uniform g {-# INLINE uniform #-} {-# INLINE uniformR #-} instance Variate Float where uniform = uniform1 wordToFloat uniformR (x1,x2) = uniform1 (\w -> x1 + (x2-x1) * wordToFloat w) {-# INLINE uniform #-} {-# INLINE uniformR #-} instance Variate Double where uniform = uniform2 wordsToDouble uniformR (x1,x2) = uniform2 (\w1 w2 -> x1 + (x2-x1) * wordsToDouble w1 w2) {-# INLINE uniform #-} {-# INLINE uniformR #-} instance Variate Int where #if WORD_SIZE_IN_BITS < 64 uniform = uniform1 fromIntegral #else uniform = uniform2 wordsTo64Bit #endif uniformR a b = uniformRange a b {-# INLINE uniform #-} {-# INLINE uniformR #-} instance Variate Word where #if WORD_SIZE_IN_BITS < 64 uniform = uniform1 fromIntegral #else uniform = uniform2 wordsTo64Bit #endif uniformR a b = uniformRange a b {-# INLINE uniform #-} {-# INLINE uniformR #-} {- instance Variate Integer where uniform g = do u <- uniform g return $! fromIntegral (u :: Int) {-# INLINE uniform #-} -} instance (Variate a, Variate b) => Variate (a,b) where uniform g = (,) `liftM` uniform g `ap` uniform g uniformR ((x1,y1),(x2,y2)) g = (,) `liftM` uniformR (x1,x2) g `ap` uniformR (y1,y2) g {-# INLINE uniform #-} {-# INLINE uniformR #-} instance (Variate a, Variate b, Variate c) => Variate (a,b,c) where uniform g = (,,) `liftM` uniform g `ap` uniform g `ap` uniform g uniformR ((x1,y1,z1),(x2,y2,z2)) g = (,,) `liftM` uniformR (x1,x2) g `ap` uniformR (y1,y2) g `ap` uniformR (z1,z2) g {-# INLINE uniform #-} {-# INLINE uniformR #-} instance (Variate a, Variate b, Variate c, Variate d) => Variate (a,b,c,d) where uniform g = (,,,) `liftM` uniform g `ap` uniform g `ap` uniform g `ap` uniform g uniformR ((x1,y1,z1,t1),(x2,y2,z2,t2)) g = (,,,) `liftM` uniformR (x1,x2) g `ap` uniformR (y1,y2) g `ap` uniformR (z1,z2) g `ap` uniformR (t1,t2) g {-# INLINE uniform #-} {-# INLINE uniformR #-} wordsTo64Bit :: (Integral a) => Word32 -> Word32 -> a wordsTo64Bit x y = fromIntegral ((fromIntegral x `shiftL` 32) .|. fromIntegral y :: Word64) {-# INLINE wordsTo64Bit #-} wordToBool :: Word32 -> Bool wordToBool i = (i .&. 1) /= 0 {-# INLINE wordToBool #-} wordToFloat :: Word32 -> Float wordToFloat x = (fromIntegral i * m_inv_32) + 0.5 + m_inv_33 where m_inv_33 = 1.16415321826934814453125e-10 m_inv_32 = 2.3283064365386962890625e-10 i = fromIntegral x :: Int32 {-# INLINE wordToFloat #-} wordsToDouble :: Word32 -> Word32 -> Double wordsToDouble x y = (fromIntegral u * m_inv_32 + (0.5 + m_inv_53) + fromIntegral (v .&. 0xFFFFF) * m_inv_52) where m_inv_52 = 2.220446049250313080847263336181640625e-16 m_inv_53 = 1.1102230246251565404236316680908203125e-16 m_inv_32 = 2.3283064365386962890625e-10 u = fromIntegral x :: Int32 v = fromIntegral y :: Int32 {-# INLINE wordsToDouble #-} -- | State of the pseudo-random number generator. It uses mutable -- state so same generator shouldn't be used from the different -- threads simultaneously. newtype Gen s = Gen (M.MVector s Word32) -- | A shorter name for PRNG state in the 'IO' monad. type GenIO = Gen (PrimState IO) -- | A shorter name for PRNG state in the 'ST' monad. type GenST s = Gen (PrimState (ST s)) -- | Constrain the type of an action to run in the 'IO' monad. asGenIO :: (GenIO -> IO a) -> (GenIO -> IO a) asGenIO = id -- | Constrain the type of an action to run in the 'ST' monad. asGenST :: (GenST s -> ST s a) -> (GenST s -> ST s a) asGenST = id ioff, coff :: Int ioff = 256 coff = 257 -- | Create a generator for variates using a fixed seed. create :: PrimMonad m => m (Gen (PrimState m)) create = initialize defaultSeed {-# INLINE create #-} -- | Create a generator for variates using the given seed, of which up -- to 256 elements will be used. For arrays of less than 256 -- elements, part of the default seed will be used to finish -- initializing the generator's state. -- -- Examples: -- -- > initialize (singleton 42) -- -- > initialize (fromList [4, 8, 15, 16, 23, 42]) -- -- If a seed contains fewer than 256 elements, it is first used -- verbatim, then its elements are 'xor'ed against elements of the -- default seed until 256 elements are reached. -- -- If a seed contains exactly 258 elements, then the last two elements -- are used to set the generator's initial state. This allows for -- complete generator reproducibility, so that e.g. @gen' == gen@ in -- the following example: -- -- @gen' <- 'initialize' . 'fromSeed' =<< 'save'@ -- -- In the MWC algorithm, the /carry/ value must be strictly smaller than the -- multiplicator (see https://en.wikipedia.org/wiki/Multiply-with-carry). -- Hence, if a seed contains exactly 258 elements, the /carry/ value, which is -- the last of the 258 values, is moduloed by the multiplicator. -- -- Note that if the /first/ carry value is strictly smaller than the multiplicator, -- all subsequent carry values are also strictly smaller than the multiplicator -- (a proof of this is in the comments of the code of 'uniformWord32'), hence -- when restoring a saved state, we have the guarantee that moduloing the saved -- carry won't modify its value. initialize :: (PrimMonad m, Vector v Word32) => v Word32 -> m (Gen (PrimState m)) initialize seed = do q <- M.unsafeNew 258 fill q if fini == 258 then do M.unsafeWrite q ioff $ G.unsafeIndex seed ioff .&. 255 M.unsafeWrite q coff $ G.unsafeIndex seed coff `mod` fromIntegral aa else do M.unsafeWrite q ioff 255 M.unsafeWrite q coff 362436 return (Gen q) where fill q = go 0 where go i | i == 256 = return () | otherwise = M.unsafeWrite q i s >> go (i+1) where s | i >= fini = if fini == 0 then G.unsafeIndex defaultSeed i else G.unsafeIndex defaultSeed i `xor` G.unsafeIndex seed (i `mod` fini) | otherwise = G.unsafeIndex seed i fini = G.length seed {-# INLINE initialize #-} -- | An immutable snapshot of the state of a 'Gen'. newtype Seed = Seed { -- | Convert seed into vector. fromSeed :: I.Vector Word32 } deriving (Eq, Show, Typeable) -- | Convert vector to 'Seed'. It acts similarily to 'initialize' and -- will accept any vector. If you want to pass seed immediately to -- restore you better call initialize directly since following law holds: -- -- > restore (toSeed v) = initialize v toSeed :: (Vector v Word32) => v Word32 -> Seed toSeed v = Seed $ I.create $ do { Gen q <- initialize v; return q } -- | Save the state of a 'Gen', for later use by 'restore'. save :: PrimMonad m => Gen (PrimState m) -> m Seed save (Gen q) = Seed `liftM` G.freeze q {-# INLINE save #-} -- | Create a new 'Gen' that mirrors the state of a saved 'Seed'. restore :: PrimMonad m => Seed -> m (Gen (PrimState m)) restore (Seed s) = Gen `liftM` G.thaw s {-# INLINE restore #-} -- | Seed a PRNG with data from the system's fast source of -- pseudo-random numbers (\"@\/dev\/urandom@\" on Unix-like systems or -- @RtlGenRandom@ on Windows), then run the given action. -- -- This is a somewhat expensive function, and is intended to be called -- only occasionally (e.g. once per thread). You should use the `Gen` -- it creates to generate many random numbers. withSystemRandom :: PrimBase m => (Gen (PrimState m) -> m a) -> IO a withSystemRandom act = do seed <- acquireSeedSystem 256 `E.catch` \(_::E.IOException) -> do seen <- atomicModifyIORef warned ((,) True) unless seen $ E.handle (\(_::E.IOException) -> return ()) $ do hPutStrLn stderr $ "Warning: Couldn't use randomness source " ++ randomSourceName hPutStrLn stderr ("Warning: using system clock for seed instead " ++ "(quality will be lower)") acquireSeedTime unsafePrimToIO $ initialize (I.fromList seed) >>= act where warned = unsafePerformIO $ newIORef False {-# NOINLINE warned #-} -- | Seed a PRNG with data from the system's fast source of pseudo-random -- numbers. All the caveats of 'withSystemRandom' apply here as well. createSystemRandom :: IO GenIO createSystemRandom = withSystemRandom (return :: GenIO -> IO GenIO) -- | Compute the next index into the state pool. This is simply -- addition modulo 256. nextIndex :: Integral a => a -> Int nextIndex i = fromIntegral j where j = fromIntegral (i+1) :: Word8 {-# INLINE nextIndex #-} -- The multiplicator : 0x5BCF5AB2 -- -- Eventhough it is a 'Word64', it is important for the correctness of the proof -- on carry value that it is /not/ greater than maxBound 'Word32'. aa :: Word64 aa = 1540315826 {-# INLINE aa #-} uniformWord32 :: PrimMonad m => Gen (PrimState m) -> m Word32 uniformWord32 (Gen q) = do i <- nextIndex `liftM` M.unsafeRead q ioff c <- fromIntegral `liftM` M.unsafeRead q coff qi <- fromIntegral `liftM` M.unsafeRead q i let t = aa * qi + c -- The comments in this function are a proof that: -- "if the carry value is strictly smaller than the multiplicator, -- the next carry value is also strictly smaller than the multiplicator." -- Eventhough the proof is written in terms of the actual value of the multiplicator, -- it holds for any multiplicator value /not/ greater than maxBound 'Word32' -- -- (In the code, the multiplicator is aa, the carry value is c, -- the next carry value is c''.) -- -- So we'll assume that c < aa, and show that c'' < aa : -- -- by definition, aa = 0x5BCF5AB2, qi <= 0xFFFFFFFF (because it is a 'Word32') -- hence aa*qi <= 0x5BCF5AB200000000 - 0x5BCF5AB2. -- -- hence t < 0x5BCF5AB200000000 (because t = aa * qi + c and c < 0x5BCF5AB2) -- hence t <= 0x5BCF5AB1FFFFFFFF c' = fromIntegral (t `shiftR` 32) -- c' < 0x5BCF5AB1 x = fromIntegral t + c' (# x', c'' #) | x < c' = (# x + 1, c' + 1 #) | otherwise = (# x, c' #) -- hence c'' < 0x5BCF5AB2, -- hence c'' < aa, which is what we wanted to prove. M.unsafeWrite q i x' M.unsafeWrite q ioff (fromIntegral i) M.unsafeWrite q coff (fromIntegral c'') return x' {-# INLINE uniformWord32 #-} uniform1 :: PrimMonad m => (Word32 -> a) -> Gen (PrimState m) -> m a uniform1 f gen = do i <- uniformWord32 gen return $! f i {-# INLINE uniform1 #-} uniform2 :: PrimMonad m => (Word32 -> Word32 -> a) -> Gen (PrimState m) -> m a uniform2 f (Gen q) = do i <- nextIndex `liftM` M.unsafeRead q ioff let j = nextIndex i c <- fromIntegral `liftM` M.unsafeRead q coff qi <- fromIntegral `liftM` M.unsafeRead q i qj <- fromIntegral `liftM` M.unsafeRead q j let t = aa * qi + c c' = fromIntegral (t `shiftR` 32) x = fromIntegral t + c' (# x', c'' #) | x < c' = (# x + 1, c' + 1 #) | otherwise = (# x, c' #) u = aa * qj + fromIntegral c'' d' = fromIntegral (u `shiftR` 32) y = fromIntegral u + d' (# y', d'' #) | y < d' = (# y + 1, d' + 1 #) | otherwise = (# y, d' #) M.unsafeWrite q i x' M.unsafeWrite q j y' M.unsafeWrite q ioff (fromIntegral j) M.unsafeWrite q coff (fromIntegral d'') return $! f x' y' {-# INLINE uniform2 #-} -- Type family for fixed size integrals. For signed data types it's -- its unsigned couterpart with same size and for unsigned data types -- it's same type type family Unsigned a :: * type instance Unsigned Int8 = Word8 type instance Unsigned Int16 = Word16 type instance Unsigned Int32 = Word32 type instance Unsigned Int64 = Word64 type instance Unsigned Word8 = Word8 type instance Unsigned Word16 = Word16 type instance Unsigned Word32 = Word32 type instance Unsigned Word64 = Word64 -- This is workaround for bug #25. -- -- GHC-7.6 has a bug (#8072) which results in calculation of wrong -- number of buckets in function `uniformRange'. Consequently uniformR -- generates values in wrong range. -- -- Bug only affects 32-bit systems and Int/Word data types. Word32 -- works just fine. So we set Word32 as unsigned counterpart for Int -- and Word on 32-bit systems. It's done only for GHC-7.6 because -- other versions are unaffected by the bug and we expect that GHC may -- optimise code which uses Word better. #if (WORD_SIZE_IN_BITS < 64) && (__GLASGOW_HASKELL__ == 706) type instance Unsigned Int = Word32 type instance Unsigned Word = Word32 #else type instance Unsigned Int = Word type instance Unsigned Word = Word #endif -- Subtract two numbers under assumption that x>=y and store result in -- unsigned data type of same size sub :: (Integral a, Integral (Unsigned a)) => a -> a -> Unsigned a sub x y = fromIntegral x - fromIntegral y {-# INLINE sub #-} add :: (Integral a, Integral (Unsigned a)) => a -> Unsigned a -> a add m x = m + fromIntegral x {-# INLINE add #-} -- Generate uniformly distributed value in inclusive range. -- -- NOTE: This function must be fully applied. Otherwise it won't be -- inlined, which will cause a severe performance loss. -- -- > uniformR = uniformRange -- won't be inlined -- > uniformR a b = uniformRange a b -- will be inlined uniformRange :: ( PrimMonad m , Integral a, Bounded a, Variate a , Integral (Unsigned a), Bounded (Unsigned a), Variate (Unsigned a)) => (a,a) -> Gen (PrimState m) -> m a uniformRange (x1,x2) g | n == 0 = uniform g -- Abuse overflow in unsigned types | otherwise = loop where -- Allow ranges where x2 Gen (PrimState m) -> Int -> m (v a) uniformVector gen n = G.replicateM n (uniform gen) {-# INLINE uniformVector #-} defaultSeed :: I.Vector Word32 defaultSeed = I.fromList [ 0x7042e8b3, 0x06f7f4c5, 0x789ea382, 0x6fb15ad8, 0x54f7a879, 0x0474b184, 0xb3f8f692, 0x4114ea35, 0xb6af0230, 0xebb457d2, 0x47693630, 0x15bc0433, 0x2e1e5b18, 0xbe91129c, 0xcc0815a0, 0xb1260436, 0xd6f605b1, 0xeaadd777, 0x8f59f791, 0xe7149ed9, 0x72d49dd5, 0xd68d9ded, 0xe2a13153, 0x67648eab, 0x48d6a1a1, 0xa69ab6d7, 0x236f34ec, 0x4e717a21, 0x9d07553d, 0x6683a701, 0x19004315, 0x7b6429c5, 0x84964f99, 0x982eb292, 0x3a8be83e, 0xc1df1845, 0x3cf7b527, 0xb66a7d3f, 0xf93f6838, 0x736b1c85, 0x5f0825c1, 0x37e9904b, 0x724cd7b3, 0xfdcb7a46, 0xfdd39f52, 0x715506d5, 0xbd1b6637, 0xadabc0c0, 0x219037fc, 0x9d71b317, 0x3bec717b, 0xd4501d20, 0xd95ea1c9, 0xbe717202, 0xa254bd61, 0xd78a6c5b, 0x043a5b16, 0x0f447a25, 0xf4862a00, 0x48a48b75, 0x1e580143, 0xd5b6a11b, 0x6fb5b0a4, 0x5aaf27f9, 0x668bcd0e, 0x3fdf18fd, 0x8fdcec4a, 0x5255ce87, 0xa1b24dbf, 0x3ee4c2e1, 0x9087eea2, 0xa4131b26, 0x694531a5, 0xa143d867, 0xd9f77c03, 0xf0085918, 0x1e85071c, 0x164d1aba, 0xe61abab5, 0xb8b0c124, 0x84899697, 0xea022359, 0x0cc7fa0c, 0xd6499adf, 0x746da638, 0xd9e5d200, 0xefb3360b, 0x9426716a, 0xabddf8c2, 0xdd1ed9e4, 0x17e1d567, 0xa9a65000, 0x2f37dbc5, 0x9a4b8fd5, 0xaeb22492, 0x0ebe8845, 0xd89dd090, 0xcfbb88c6, 0xb1325561, 0x6d811d90, 0x03aa86f4, 0xbddba397, 0x0986b9ed, 0x6f4cfc69, 0xc02b43bc, 0xee916274, 0xde7d9659, 0x7d3afd93, 0xf52a7095, 0xf21a009c, 0xfd3f795e, 0x98cef25b, 0x6cb3af61, 0x6fa0e310, 0x0196d036, 0xbc198bca, 0x15b0412d, 0xde454349, 0x5719472b, 0x8244ebce, 0xee61afc6, 0xa60c9cb5, 0x1f4d1fd0, 0xe4fb3059, 0xab9ec0f9, 0x8d8b0255, 0x4e7430bf, 0x3a22aa6b, 0x27de22d3, 0x60c4b6e6, 0x0cf61eb3, 0x469a87df, 0xa4da1388, 0xf650f6aa, 0x3db87d68, 0xcdb6964c, 0xb2649b6c, 0x6a880fa9, 0x1b0c845b, 0xe0af2f28, 0xfc1d5da9, 0xf64878a6, 0x667ca525, 0x2114b1ce, 0x2d119ae3, 0x8d29d3bf, 0x1a1b4922, 0x3132980e, 0xd59e4385, 0x4dbd49b8, 0x2de0bb05, 0xd6c96598, 0xb4c527c3, 0xb5562afc, 0x61eeb602, 0x05aa192a, 0x7d127e77, 0xc719222d, 0xde7cf8db, 0x2de439b8, 0x250b5f1a, 0xd7b21053, 0xef6c14a1, 0x2041f80f, 0xc287332e, 0xbb1dbfd3, 0x783bb979, 0x9a2e6327, 0x6eb03027, 0x0225fa2f, 0xa319bc89, 0x864112d4, 0xfe990445, 0xe5e2e07c, 0xf7c6acb8, 0x1bc92142, 0x12e9b40e, 0x2979282d, 0x05278e70, 0xe160ba4c, 0xc1de0909, 0x458b9bf4, 0xbfce9c94, 0xa276f72a, 0x8441597d, 0x67adc2da, 0x6162b854, 0x7f9b2f4a, 0x0d995b6b, 0x193b643d, 0x399362b3, 0x8b653a4b, 0x1028d2db, 0x2b3df842, 0x6eecafaf, 0x261667e9, 0x9c7e8cda, 0x46063eab, 0x7ce7a3a1, 0xadc899c9, 0x017291c4, 0x528d1a93, 0x9a1ee498, 0xbb7d4d43, 0x7837f0ed, 0x34a230cc, 0x614a628d, 0xb03f93b8, 0xd72e3b08, 0x604c98db, 0x3cfacb79, 0x8b81646a, 0xc0f082fa, 0xd1f92388, 0xe5a91e39, 0xf95c756d, 0x1177742f, 0xf8819323, 0x5c060b80, 0x96c1cd8f, 0x47d7b440, 0xbbb84197, 0x35f749cc, 0x95b0e132, 0x8d90ad54, 0x5c3f9423, 0x4994005b, 0xb58f53b9, 0x32df7348, 0x60f61c29, 0x9eae2f32, 0x85a3d398, 0x3b995dd4, 0x94c5e460, 0x8e54b9f3, 0x87bc6e2a, 0x90bbf1ea, 0x55d44719, 0x2cbbfe6e, 0x439d82f0, 0x4eb3782d, 0xc3f1e669, 0x61ff8d9e, 0x0909238d, 0xef406165, 0x09c1d762, 0x705d184f, 0x188f2cc4, 0x9c5aa12a, 0xc7a5d70e, 0xbc78cb1b, 0x1d26ae62, 0x23f96ae3, 0xd456bf32, 0xe4654f55, 0x31462bd8 ] {-# NOINLINE defaultSeed #-} -- $references -- -- * Marsaglia, G. (2003) Seeds for random number generators. -- /Communications of the ACM/ 46(5):90–93. -- -- -- * Doornik, J.A. (2007) Conversion of high-period random numbers to -- floating point. -- /ACM Transactions on Modeling and Computer Simulation/ 17(1). -- -- $typehelp -- -- The functions in this package are deliberately written for -- flexibility, and will run in both the 'IO' and 'ST' monads. -- -- This can defeat the compiler's ability to infer a principal type in -- simple (and common) cases. For instance, we would like the -- following to work cleanly: -- -- > import System.Random.MWC -- > import Data.Vector.Unboxed -- > -- > main = do -- > v <- withSystemRandom $ \gen -> uniformVector gen 20 -- > print (v :: Vector Int) -- -- Unfortunately, the compiler cannot tell what monad 'uniformVector' -- should execute in. The \"fix\" of adding explicit type annotations -- is not pretty: -- -- > {-# LANGUAGE ScopedTypeVariables #-} -- > -- > import Control.Monad.ST -- > -- > main = do -- > vs <- withSystemRandom $ -- > \(gen::GenST s) -> uniformVector gen 20 :: ST s (Vector Int) -- > print vs -- -- As a more readable alternative, this library provides 'asGenST' and -- 'asGenIO' to constrain the types appropriately. We can get rid of -- the explicit type annotations as follows: -- -- > main = do -- > vs <- withSystemRandom . asGenST $ \gen -> uniformVector gen 20 -- > print (vs :: Vector Int) -- -- This is almost as compact as the original code that the compiler -- rejected. mwc-random-0.14.0.0/System/Random/MWC/0000755000000000000000000000000013321427423015317 5ustar0000000000000000mwc-random-0.14.0.0/System/Random/MWC/SeedSource.hs0000644000000000000000000000662713321427423017727 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Low level source of random values for seeds. It should work on both -- unices and windows module System.Random.MWC.SeedSource ( acquireSeedSystem , acquireSeedTime , randomSourceName ) where import Control.Monad (liftM) import Data.Word (Word32,Word64) import Data.Bits (shiftR) import Data.Ratio ((%), numerator) import Data.Time.Clock.POSIX (getPOSIXTime) import Foreign.Storable import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Marshal.Array (peekArray) #if defined(mingw32_HOST_OS) import Foreign.Ptr import Foreign.C.Types #endif import System.CPUTime (cpuTimePrecision, getCPUTime) import System.IO (IOMode(..), hGetBuf, withBinaryFile) -- Acquire seed from current time. This is horrible fallback for -- Windows system. acquireSeedTime :: IO [Word32] acquireSeedTime = do c <- (numerator . (%cpuTimePrecision)) `liftM` getCPUTime t <- toRational `liftM` getPOSIXTime let n = fromIntegral (numerator t) :: Word64 return [fromIntegral c, fromIntegral n, fromIntegral (n `shiftR` 32)] -- | Acquire seed from the system entropy source. On Unix machines, -- this will attempt to use @/dev/urandom@. On Windows, it will internally -- use @RtlGenRandom@. acquireSeedSystem :: forall a. Storable a => Int -> IO [a] acquireSeedSystem nElts = do let eltSize = sizeOf (undefined :: a) nbytes = nElts * eltSize #if !defined(mingw32_HOST_OS) allocaBytes nbytes $ \buf -> do nread <- withBinaryFile "/dev/urandom" ReadMode $ \h -> hGetBuf h buf nbytes peekArray (nread `div` eltSize) buf #else -- Generate 256 random Word32s from RtlGenRandom allocaBytes nbytes $ \buf -> do ok <- c_RtlGenRandom buf (fromIntegral nbytes) if ok then return () else fail "Couldn't use RtlGenRandom" peekArray nElts buf -- Note: on 64-bit Windows, the 'stdcall' calling convention -- isn't supported, so we use 'ccall' instead. #if defined(i386_HOST_ARCH) # define WINDOWS_CCONV stdcall #elif defined(x86_64_HOST_ARCH) # define WINDOWS_CCONV ccall #else # error Unknown mingw32 architecture! #endif -- Note: On Windows, the typical convention would be to use -- the CryptoGenRandom API in order to generate random data. -- However, here we use 'SystemFunction036', AKA RtlGenRandom. -- -- This is a commonly used API for this purpose; one bonus is -- that it avoids having to bring in the CryptoAPI library, -- and completely sidesteps the initialization cost of CryptoAPI. -- -- While this function is technically "subject to change" that is -- extremely unlikely in practice: rand_s in the Microsoft CRT uses -- this, and they can't change it easily without also breaking -- backwards compatibility with e.g. statically linked applications. -- -- The name 'SystemFunction036' is the actual link-time name; the -- display name is just for giggles, I guess. -- -- See also: -- - http://blogs.msdn.com/b/michael_howard/archive/2005/01/14/353379.aspx -- - https://bugzilla.mozilla.org/show_bug.cgi?id=504270 -- foreign import WINDOWS_CCONV unsafe "SystemFunction036" c_RtlGenRandom :: Ptr a -> CULong -> IO Bool #endif -- | Name of source of randomness. It should be used in error messages randomSourceName :: String #if !defined(mingw32_HOST_OS) randomSourceName = "/dev/urandom" #else randomSourceName = "RtlGenRandom" #endif mwc-random-0.14.0.0/System/Random/MWC/Distributions.hs0000644000000000000000000002762613321427423020532 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP, GADTs, FlexibleContexts, ScopedTypeVariables #-} -- | -- Module : System.Random.MWC.Distributions -- Copyright : (c) 2012 Bryan O'Sullivan -- License : BSD3 -- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- -- Pseudo-random number generation for non-uniform distributions. module System.Random.MWC.Distributions ( -- * Variates: non-uniformly distributed values -- ** Continuous distributions normal , standard , exponential , truncatedExp , gamma , chiSquare , beta -- ** Discrete distribution , categorical , logCategorical , geometric0 , geometric1 , bernoulli -- ** Multivariate , dirichlet -- * Permutations , uniformPermutation , uniformShuffle , uniformShuffleM -- * References -- $references ) where import Prelude hiding (mapM) import Control.Monad (liftM) import Control.Monad.Primitive (PrimMonad, PrimState) import Data.Bits ((.&.)) import Data.Foldable (foldl') #if !MIN_VERSION_base(4,8,0) import Data.Traversable (Traversable) #endif import Data.Traversable (mapM) import Data.Word (Word32) import System.Random.MWC (Gen, uniform, uniformR) import qualified Data.Vector.Unboxed as I import qualified Data.Vector.Generic as G import qualified Data.Vector.Generic.Mutable as M -- Unboxed 2-tuple data T = T {-# UNPACK #-} !Double {-# UNPACK #-} !Double -- | Generate a normally distributed random variate with given mean -- and standard deviation. normal :: PrimMonad m => Double -- ^ Mean -> Double -- ^ Standard deviation -> Gen (PrimState m) -> m Double {-# INLINE normal #-} normal m s gen = do x <- standard gen return $! m + s * x -- | Generate a normally distributed random variate with zero mean and -- unit variance. -- -- The implementation uses Doornik's modified ziggurat algorithm. -- Compared to the ziggurat algorithm usually used, this is slower, -- but generates more independent variates that pass stringent tests -- of randomness. standard :: PrimMonad m => Gen (PrimState m) -> m Double {-# INLINE standard #-} standard gen = loop where loop = do u <- (subtract 1 . (*2)) `liftM` uniform gen ri <- uniform gen let i = fromIntegral ((ri :: Word32) .&. 127) bi = I.unsafeIndex blocks i bj = I.unsafeIndex blocks (i+1) case () of _| abs u < I.unsafeIndex ratios i -> return $! u * bi | i == 0 -> normalTail (u < 0) | otherwise -> do let x = u * bi xx = x * x d = exp (-0.5 * (bi * bi - xx)) e = exp (-0.5 * (bj * bj - xx)) c <- uniform gen if e + c * (d - e) < 1 then return x else loop normalTail neg = tailing where tailing = do x <- ((/rNorm) . log) `liftM` uniform gen y <- log `liftM` uniform gen if y * (-2) < x * x then tailing else return $! if neg then x - rNorm else rNorm - x -- Constants used by standard/normal. They are floated to the top -- level to avoid performance regression (Bug #16) when blocks/ratios -- are recalculated on each call to standard/normal. It's also -- somewhat difficult to trigger reliably. blocks :: I.Vector Double blocks = (`I.snoc` 0) . I.cons (v/f) . I.cons rNorm . I.unfoldrN 126 go $! T rNorm f where go (T b g) = let !u = T h (exp (-0.5 * h * h)) h = sqrt (-2 * log (v / b + g)) in Just (h, u) v = 9.91256303526217e-3 f = exp (-0.5 * rNorm * rNorm) {-# NOINLINE blocks #-} rNorm :: Double rNorm = 3.442619855899 ratios :: I.Vector Double ratios = I.zipWith (/) (I.tail blocks) blocks {-# NOINLINE ratios #-} -- | Generate an exponentially distributed random variate. exponential :: PrimMonad m => Double -- ^ Scale parameter -> Gen (PrimState m) -- ^ Generator -> m Double {-# INLINE exponential #-} exponential b gen = do x <- uniform gen return $! - log x / b -- | Generate truncated exponentially distributed random variate. truncatedExp :: PrimMonad m => Double -- ^ Scale parameter -> (Double,Double) -- ^ Range to which distribution is -- truncated. Values may be negative. -> Gen (PrimState m) -- ^ Generator. -> m Double {-# INLINE truncatedExp #-} truncatedExp scale (a,b) gen = do -- We shift a to 0 and then generate distribution truncated to [0,b-a] -- It's easier let delta = b - a p <- uniform gen return $! a - log ( (1 - p) + p*exp(-scale*delta)) / scale -- | Random variate generator for gamma distribution. gamma :: PrimMonad m => Double -- ^ Shape parameter -> Double -- ^ Scale parameter -> Gen (PrimState m) -- ^ Generator -> m Double {-# INLINE gamma #-} gamma a b gen | a <= 0 = pkgError "gamma" "negative alpha parameter" | otherwise = mainloop where mainloop = do T x v <- innerloop u <- uniform gen let cont = u > 1 - 0.331 * sqr (sqr x) && log u > 0.5 * sqr x + a1 * (1 - v + log v) -- Rarely evaluated case () of _| cont -> mainloop | a >= 1 -> return $! a1 * v * b | otherwise -> do y <- uniform gen return $! y ** (1 / a) * a1 * v * b -- inner loop innerloop = do x <- standard gen case 1 + a2*x of v | v <= 0 -> innerloop | otherwise -> return $! T x (v*v*v) -- constants a' = if a < 1 then a + 1 else a a1 = a' - 1/3 a2 = 1 / sqrt(9 * a1) -- | Random variate generator for the chi square distribution. chiSquare :: PrimMonad m => Int -- ^ Number of degrees of freedom -> Gen (PrimState m) -- ^ Generator -> m Double {-# INLINE chiSquare #-} chiSquare n gen | n <= 0 = pkgError "chiSquare" "number of degrees of freedom must be positive" | otherwise = do x <- gamma (0.5 * fromIntegral n) 1 gen return $! 2 * x -- | Random variate generator for the geometric distribution, -- computing the number of failures before success. Distribution's -- support is [0..]. geometric0 :: PrimMonad m => Double -- ^ /p/ success probability lies in (0,1] -> Gen (PrimState m) -- ^ Generator -> m Int {-# INLINE geometric0 #-} geometric0 p gen | p == 1 = return 0 | p > 0 && p < 1 = do q <- uniform gen -- FIXME: We want to use log1p here but it will -- introduce dependency on math-functions. return $! floor $ log q / log (1 - p) | otherwise = pkgError "geometric0" "probability out of [0,1] range" -- | Random variate generator for geometric distribution for number of -- trials. Distribution's support is [1..] (i.e. just 'geometric0' -- shifted by 1). geometric1 :: PrimMonad m => Double -- ^ /p/ success probability lies in (0,1] -> Gen (PrimState m) -- ^ Generator -> m Int {-# INLINE geometric1 #-} geometric1 p gen = do n <- geometric0 p gen return $! n + 1 -- | Random variate generator for Beta distribution beta :: PrimMonad m => Double -- ^ alpha (>0) -> Double -- ^ beta (>0) -> Gen (PrimState m) -- ^ Generator -> m Double {-# INLINE beta #-} beta a b gen = do x <- gamma a 1 gen y <- gamma b 1 gen return $! x / (x+y) -- | Random variate generator for Dirichlet distribution dirichlet :: (PrimMonad m, Traversable t) => t Double -- ^ container of parameters -> Gen (PrimState m) -- ^ Generator -> m (t Double) {-# INLINE dirichlet #-} dirichlet t gen = do t' <- mapM (\x -> gamma x 1 gen) t let total = foldl' (+) 0 t' return $ fmap (/total) t' -- | Random variate generator for Bernoulli distribution bernoulli :: PrimMonad m => Double -- ^ Probability of success (returning True) -> Gen (PrimState m) -- ^ Generator -> m Bool {-# INLINE bernoulli #-} bernoulli p gen = ( v Double -- ^ List of weights [>0] -> Gen (PrimState m) -- ^ Generator -> m Int {-# INLINE categorical #-} categorical v gen | G.null v = pkgError "categorical" "empty weights!" | otherwise = do let cv = G.scanl1' (+) v p <- (G.last cv *) `liftM` uniform gen return $! case G.findIndex (>=p) cv of Just i -> i Nothing -> pkgError "categorical" "bad weights!" -- | Random variate generator for categorical distribution where the -- weights are in the log domain. It's implemented in terms of -- 'categorical'. logCategorical :: (PrimMonad m, G.Vector v Double) => v Double -- ^ List of logarithms of weights -> Gen (PrimState m) -- ^ Generator -> m Int {-# INLINE logCategorical #-} logCategorical v gen | G.null v = pkgError "logCategorical" "empty weights!" | otherwise = categorical (G.map (exp . subtract m) v) gen where m = G.maximum v -- | Random variate generator for uniformly distributed permutations. -- It returns random permutation of vector /[0 .. n-1]/. -- -- This is the Fisher-Yates shuffle uniformPermutation :: forall m v. (PrimMonad m, G.Vector v Int) => Int -> Gen (PrimState m) -> m (v Int) {-# INLINE uniformPermutation #-} uniformPermutation n gen | n < 0 = pkgError "uniformPermutation" "size must be >=0" | otherwise = uniformShuffle (G.generate n id :: v Int) gen -- | Random variate generator for a uniformly distributed shuffle (all -- shuffles are equiprobable) of a vector. It uses Fisher-Yates -- shuffle algorithm. uniformShuffle :: (PrimMonad m, G.Vector v a) => v a -> Gen (PrimState m) -> m (v a) {-# INLINE uniformShuffle #-} uniformShuffle vec gen | G.length vec <= 1 = return vec | otherwise = do mvec <- G.thaw vec uniformShuffleM mvec gen G.unsafeFreeze mvec -- | In-place uniformly distributed shuffle (all shuffles are -- equiprobable)of a vector. uniformShuffleM :: (PrimMonad m, M.MVector v a) => v (PrimState m) a -> Gen (PrimState m) -> m () {-# INLINE uniformShuffleM #-} uniformShuffleM vec gen | M.length vec <= 1 = return () | otherwise = loop 0 where n = M.length vec lst = n-1 loop i | i == lst = return () | otherwise = do j <- uniformR (i,lst) gen M.unsafeSwap vec i j loop (i+1) sqr :: Double -> Double sqr x = x * x {-# INLINE sqr #-} pkgError :: String -> String -> a pkgError func msg = error $ "System.Random.MWC.Distributions." ++ func ++ ": " ++ msg -- $references -- -- * Doornik, J.A. (2005) An improved ziggurat method to generate -- normal random samples. Mimeo, Nuffield College, University of -- Oxford. -- -- * Thomas, D.B.; Leong, P.G.W.; Luk, W.; Villasenor, J.D. -- (2007). Gaussian random number generators. -- /ACM Computing Surveys/ 39(4). -- mwc-random-0.14.0.0/System/Random/MWC/CondensedTable.hs0000644000000000000000000002467713321427423020545 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : System.Random.MWC.CondensedTable -- Copyright : (c) 2012 Aleksey Khudyakov -- License : BSD3 -- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : portable -- -- Table-driven generation of random variates. This approach can -- generate random variates in /O(1)/ time for the supported -- distributions, at a modest cost in initialization time. module System.Random.MWC.CondensedTable ( -- * Condensed tables CondensedTable , CondensedTableV , CondensedTableU , genFromTable -- * Constructors for tables , tableFromProbabilities , tableFromWeights , tableFromIntWeights -- ** Disrete distributions , tablePoisson , tableBinomial -- * References -- $references ) where import Control.Arrow (second,(***)) import Control.Monad.Primitive (PrimMonad(..)) import Data.Word import Data.Int import Data.Bits import qualified Data.Vector.Generic as G import Data.Vector.Generic ((++)) import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector.Unboxed as U import qualified Data.Vector as V import Data.Vector.Generic (Vector) import Numeric.SpecFunctions (logFactorial) import Prelude hiding ((++)) import System.Random.MWC -- | A lookup table for arbitrary discrete distributions. It allows -- the generation of random variates in /O(1)/. Note that probability -- is quantized in units of @1/2^32@, and all distributions with -- infinite support (e.g. Poisson) should be truncated. data CondensedTable v a = CondensedTable {-# UNPACK #-} !Word64 !(v a) -- Lookup limit and first table {-# UNPACK #-} !Word64 !(v a) -- Second table {-# UNPACK #-} !Word64 !(v a) -- Third table !(v a) -- Last table -- Implementation note. We have to store lookup limit in Word64 since -- we need to accomodate two cases. First is when we have no values in -- lookup table, second is when all elements are there -- -- Both are pretty easy to realize. For first one probability of every -- outcome should be less then 1/256, latter arise when probabilities -- of two outcomes are [0.5,0.5] -- | A 'CondensedTable' that uses unboxed vectors. type CondensedTableU = CondensedTable U.Vector -- | A 'CondensedTable' that uses boxed vectors, and is able to hold -- any type of element. type CondensedTableV = CondensedTable V.Vector -- | Generate a random value using a condensed table. genFromTable :: (PrimMonad m, Vector v a) => CondensedTable v a -> Gen (PrimState m) -> m a {-# INLINE genFromTable #-} genFromTable table gen = do w <- uniform gen return $ lookupTable table $ fromIntegral (w :: Word32) lookupTable :: Vector v a => CondensedTable v a -> Word64 -> a {-# INLINE lookupTable #-} lookupTable (CondensedTable na aa nb bb nc cc dd) i | i < na = aa `at` ( i `shiftR` 24) | i < nb = bb `at` ((i - na) `shiftR` 16) | i < nc = cc `at` ((i - nb) `shiftR` 8 ) | otherwise = dd `at` ( i - nc) where at arr j = G.unsafeIndex arr (fromIntegral j) ---------------------------------------------------------------- -- Table generation ---------------------------------------------------------------- -- | Generate a condensed lookup table from a list of outcomes with -- given probabilities. The vector should be non-empty and the -- probabilites should be non-negative and sum to 1. If this is not -- the case, this algorithm will construct a table for some -- distribution that may bear no resemblance to what you intended. tableFromProbabilities :: (Vector v (a,Word32), Vector v (a,Double), Vector v a, Vector v Word32) => v (a, Double) -> CondensedTable v a {-# INLINE tableFromProbabilities #-} tableFromProbabilities v | G.null tbl = pkgError "tableFromProbabilities" "empty vector of outcomes" | otherwise = tableFromIntWeights $ G.map (second $ toWeight . (* mlt)) tbl where -- 2^32. N.B. This number is exatly representable. mlt = 4.294967296e9 -- Drop non-positive probabilities tbl = G.filter ((> 0) . snd) v -- Convert Double weight to Word32 and avoid overflow at the same -- time. It's especially dangerous if one probability is -- approximately 1 and others are 0. toWeight w | w > mlt - 1 = 2^(32::Int) - 1 | otherwise = round w -- | Same as 'tableFromProbabilities' but treats number as weights not -- probilities. Non-positive weights are discarded, and those -- remaining are normalized to 1. tableFromWeights :: (Vector v (a,Word32), Vector v (a,Double), Vector v a, Vector v Word32) => v (a, Double) -> CondensedTable v a {-# INLINE tableFromWeights #-} tableFromWeights = tableFromProbabilities . normalize . G.filter ((> 0) . snd) where normalize v | G.null v = pkgError "tableFromWeights" "no positive weights" | otherwise = G.map (second (/ s)) v where -- Explicit fold is to avoid 'Vector v Double' constraint s = G.foldl' (flip $ (+) . snd) 0 v -- | Generate a condensed lookup table from integer weights. Weights -- should sum to @2^32@ at least approximately. This function will -- correct small deviations from @2^32@ such as arising from rounding -- errors. But for large deviations it's likely to product incorrect -- result with terrible performance. tableFromIntWeights :: (Vector v (a,Word32), Vector v a, Vector v Word32) => v (a, Word32) -> CondensedTable v a {-# INLINE tableFromIntWeights #-} tableFromIntWeights v | n == 0 = pkgError "tableFromIntWeights" "empty table" -- Single element tables should be treated sepately. Otherwise -- they will confuse correctWeights | n == 1 = let m = 2^(32::Int) - 1 -- Works for both Word32 & Word64 in CondensedTable m (G.replicate 256 $ fst $ G.head tbl) m G.empty m G.empty G.empty | otherwise = CondensedTable na aa nb bb nc cc dd where -- We must filter out zero-probability outcomes because they may -- confuse weight correction algorithm tbl = G.filter ((/=0) . snd) v n = G.length tbl -- Corrected table table = uncurry G.zip $ id *** correctWeights $ G.unzip tbl -- Make condensed table mkTable d = G.concatMap (\(x,w) -> G.replicate (fromIntegral $ digit d w) x) table len = fromIntegral . G.length -- Tables aa = mkTable 0 bb = mkTable 1 cc = mkTable 2 dd = mkTable 3 -- Offsets na = len aa `shiftL` 24 nb = na + (len bb `shiftL` 16) nc = nb + (len cc `shiftL` 8) -- Calculate N'th digit base 256 digit :: Int -> Word32 -> Word32 digit 0 x = x `shiftR` 24 digit 1 x = (x `shiftR` 16) .&. 0xff digit 2 x = (x `shiftR` 8 ) .&. 0xff digit 3 x = x .&. 0xff digit _ _ = pkgError "digit" "the impossible happened!?" {-# INLINE digit #-} -- Correct integer weights so they sum up to 2^32. Array of weight -- should contain at least 2 elements. correctWeights :: G.Vector v Word32 => v Word32 -> v Word32 {-# INLINE correctWeights #-} correctWeights v = G.create $ do let -- Sum of weights s = G.foldl' (flip $ (+) . fromIntegral) 0 v :: Int64 -- Array size n = G.length v arr <- G.thaw v -- On first pass over array adjust only entries which are larger -- than `lim'. On second and subsequent passes `lim' is set to 1. -- -- It's possibly to make this algorithm loop endlessly if all -- weights are 1 or 0. let loop lim i delta | delta == 0 = return () | i >= n = loop 1 0 delta | otherwise = do w <- M.read arr i case () of _| w < lim -> loop lim (i+1) delta | delta < 0 -> M.write arr i (w + 1) >> loop lim (i+1) (delta + 1) | otherwise -> M.write arr i (w - 1) >> loop lim (i+1) (delta - 1) loop 255 0 (s - 2^(32::Int)) return arr -- | Create a lookup table for the Poisson distibution. Note that -- table construction may have significant cost. For λ < 100 it -- takes as much time to build table as generation of 1000-30000 -- variates. tablePoisson :: Double -> CondensedTableU Int tablePoisson = tableFromProbabilities . make where make lam | lam < 0 = pkgError "tablePoisson" "negative lambda" | lam < 22.8 = U.unfoldr unfoldForward (exp (-lam), 0) | otherwise = U.unfoldr unfoldForward (pMax, nMax) ++ U.tail (U.unfoldr unfoldBackward (pMax, nMax)) where -- Number with highest probability and its probability -- -- FIXME: this is not ideal precision-wise. Check if code -- from statistics gives better precision. nMax = floor lam :: Int pMax = exp $ fromIntegral nMax * log lam - lam - logFactorial nMax -- Build probability list unfoldForward (p,i) | p < minP = Nothing | otherwise = Just ( (i,p) , (p * lam / fromIntegral (i+1), i+1) ) -- Go down unfoldBackward (p,i) | p < minP = Nothing | otherwise = Just ( (i,p) , (p / lam * fromIntegral i, i-1) ) -- Minimal representable probability for condensed tables minP = 1.1641532182693481e-10 -- 2**(-33) -- | Create a lookup table for the binomial distribution. tableBinomial :: Int -- ^ Number of tries -> Double -- ^ Probability of success -> CondensedTableU Int tableBinomial n p = tableFromProbabilities makeBinom where makeBinom | n <= 0 = pkgError "tableBinomial" "non-positive number of tries" | p == 0 = U.singleton (0,1) | p == 1 = U.singleton (n,1) | p > 0 && p < 1 = U.unfoldrN (n + 1) unfolder ((1-p)^n, 0) | otherwise = pkgError "tableBinomial" "probability is out of range" where h = p / (1 - p) unfolder (t,i) = Just ( (i,t) , (t * (fromIntegral $ n + 1 - i1) * h / fromIntegral i1, i1) ) where i1 = i + 1 pkgError :: String -> String -> a pkgError func err = error . concat $ ["System.Random.MWC.CondensedTable.", func, ": ", err] -- $references -- -- * Wang, J.; Tsang, W. W.; G. Marsaglia (2004), Fast Generation of -- Discrete Random Variables, /Journal of Statistical Software, -- American Statistical Association/, vol. 11(i03). --