diff --git a/.darcs-boring b/.darcs-boring deleted file mode 100644 --- a/.darcs-boring +++ /dev/null @@ -1,5 +0,0 @@ -^dist(/|$) -^setup(/|$) -^GNUmakefile$ -^Makefile.local$ -^.depend(.bak)?$ diff --git a/.gitignore b/.gitignore deleted file mode 100644 --- a/.gitignore +++ /dev/null @@ -1,12 +0,0 @@ -*~ - -Thumbs.db -.DS_Store - -GNUmakefile -dist-install/ -ghc.mk - -dist -.cabal-sandbox -cabal.sandbox.config diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,5 +0,0 @@ -language: haskell -ghc: - - 7.4 - - 7.6 - - 7.8 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,84 @@ +# 1.2.0 + +1. Breaking change which mostly maintains backwards compatibility, see + "Breaking Changes" below. +2. Support for monadic generators e.g. [mwc-random](https://hackage.haskell.org/package/mwc-random). +3. Monadic adapters for pure generators (providing a uniform monadic + interface to pure and monadic generators). +4. Faster in all cases except one by more than x18 (N.B. x18 not 18%) and + some cases (depending on the type) faster by more than x1000 - see + below for benchmarks. +5. Passes a large number of random number test suites: + * [dieharder](http://webhome.phy.duke.edu/~rgb/General/dieharder.php "venerable") + * [TestU01 (SmallCrush, Crush, BigCrush)](http://simul.iro.umontreal.ca/testu01/tu01.html "venerable") + * [PractRand](http://pracrand.sourceforge.net/ "active") + * [gjrand](http://gjrand.sourceforge.net/ "active") + * See [random-quality](https://github.com/tweag/random-quality) + for details on how to do this yourself. +6. Better quality split as judged by these + [tests](https://www.cambridge.org/core/journals/journal-of-functional-programming/article/evaluation-of-splittable-pseudorandom-generators/3EBAA9F14939C5BB5560E32D1A132637). Again + see [random-quality](https://github.com/tweag/random-quality) for + details on how to do this yourself. +7. Unbiased generation of ranges. +8. Updated tests and benchmarks. +9. [Continuous integration](https://travis-ci.org/github/haskell/random). + +### Breaking Changes + +Version 1.2.0 introduces these breaking changes: + +* requires `base >= 4.8` (GHC-7.10) +* `StdGen` is no longer an instance of `Read` +* `randomIO` and `randomRIO` were extracted from the `Random` class into + separate functions + +In addition, there may be import clashes with new functions, e.g. `uniform` and +`uniformR`. + +### Deprecations + +Version 1.2.0 introduces `genWord64`, `genWord32` and similar methods to the +`RandomGen` class. The significantly slower method `next` and its companion +`genRange` are now deprecated. + +### Issues Addressed + + Issue Number | Description | Comment +--------------|-------------|-------- + [25](https://github.com/haskell/random/issues/25) | The seeds generated by split are not independent | Fixed: changed algorithm to SplitMix, which provides a robust split operation + [26](https://github.com/haskell/random/issues/26) | Add Random instances for tuples | Addressed: added `Uniform` instances for up to 6-tuples + [44](https://github.com/haskell/random/issues/44) | Add Random instance for Natural | Addressed: added UniformRange instance for Natural + [51](https://github.com/haskell/random/issues/51) | Very low throughput | Fixed: see benchmarks below + [53](https://github.com/haskell/random/issues/53) | incorrect distribution of randomR for floating-point numbers | (\*) + [55](https://github.com/haskell/random/issues/55) | System/Random.hs:43:1: warning: [-Wtabs] | Fixed: No more tabs + [58](https://github.com/haskell/random/issues/58) | Why does random for Float and Double produce exactly 24 or 53 bits? | (\*) + [59](https://github.com/haskell/random/issues/59) | read :: StdGen fails for strings longer than 6 | Addressed: StdGen is no longer an instance of Read + +#### Comments + +(\*) 1.2 samples more bits but does not sample every `Float` or +`Double`. There are methods to do this but they have some downsides; +see [here](https://github.com/idontgetoutmuch/random/issues/105) for a +fuller discussion. + +## Benchmarks + +Here are some benchmarks run on a 3.1 GHz Intel Core i7. The full +benchmarks can be run using e.g. `stack bench`. The benchmarks are +measured in milliseconds per 100,000 generations. In some cases, the +performance is over x1000 times better; the minimum performance +increase for the types listed below is more than x36. + + Name | 1.1 Mean | 1.2 Mean +------------|----------|---------- + Float | 27.819 | 0.305 + Double | 50.644 | 0.328 + Integer | 42.332 | 0.332 + Word | 40.739 | 0.027 + Int | 43.847 | 0.028 + Char | 17.009 | 0.462 + Bool | 17.542 | 0.027 + # 1.1 * breaking change to `randomIValInteger` to improve RNG quality and performance see https://github.com/haskell/random/pull/4 and @@ -23,4 +104,3 @@ # 1.0.0.4 bumped version for float/double range bugfix - diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,18 +1,33 @@ -The Haskell Standard Library -- Random Number Generation -======================================================== -[![Build Status](https://secure.travis-ci.org/haskell/random.svg?branch=master)](http://travis-ci.org/haskell/random) +# The Haskell Standard Library -This library provides a basic interface for (splittable) random number generators. +## Random Number Generation +### Status + +| Language | Travis | Coveralls | +|:--------:|:------:|:---------:| +| ![GitHub top language](https://img.shields.io/github/languages/top/haskell/random.svg) | [![Build Status](https://secure.travis-ci.org/haskell/random.svg?master)](http://travis-ci.org/haskell/random) | [![Coverage Status](https://coveralls.io/repos/github/haskell/random/badge.svg?branch=master)](https://coveralls.io/github/haskell/random?branch=master) + +| Package | Hackage | Nightly | LTS | +|:-------------------|:-------:|:-------:|:---:| +| [`random`](https://github.com/haskell/random)| [![Hackage](https://img.shields.io/hackage/v/random.svg)](https://hackage.haskell.org/package/random)| [![Nightly](https://www.stackage.org/package/random/badge/nightly)](https://www.stackage.org/nightly/package/random)| [![Nightly](https://www.stackage.org/package/random/badge/lts)](https://www.stackage.org/lts/package/random) + +### Description + +This library provides a basic interface for (splittable) pseudo-random number +generators. + The API documentation can be found here: - http://hackage.haskell.org/package/random/docs/System-Random.html +> http://hackage.haskell.org/package/random/docs/System-Random.html -A module supplying this interface is required for Haskell 98 (but not Haskell -2010). An older [version] -(http://www.haskell.org/ghc/docs/latest/html/libraries/haskell98/Random.html) -of this library is included with GHC in the haskell98 package. This newer -version, with compatible api, is included in the [Haskell Platform] -(http://www.haskell.org/platform/contents.html). +An [older version][haskell98-version] of this library is included with GHC in +the `haskell98` package. This newer version is included in the [Haskell +Platform][haskell-platform]. -Please report bugs in the Github [issue tracker] (https://github.com/haskell/random/issues) (no longer in the GHC trac). +Please report bugs in the [GitHub issue tracker][issue-tracker] (no longer in +the GHC trac). + +[haskell-platform]: http://www.haskell.org/platform/contents.html +[haskell98-version]: https://downloads.haskell.org/~ghc/7.6.3/docs/html/libraries/haskell98/Random.html +[issue-tracker]: https://github.com/haskell/random/issues diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,5 +1,3 @@ -module Main (main) where - import Distribution.Simple main :: IO () diff --git a/System/Random.hs b/System/Random.hs deleted file mode 100644 --- a/System/Random.hs +++ /dev/null @@ -1,609 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : System.Random --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE in the 'random' repository) --- --- Maintainer : libraries@haskell.org --- Stability : stable --- Portability : portable --- --- This library deals with the common task of pseudo-random number --- generation. The library makes it possible to generate repeatable --- results, by starting with a specified initial random number generator, --- or to get different results on each run by using the system-initialised --- generator or by supplying a seed from some other source. --- --- The library is split into two layers: --- --- * A core /random number generator/ provides a supply of bits. --- The class 'RandomGen' provides a common interface to such generators. --- The library provides one instance of 'RandomGen', the abstract --- data type 'StdGen'. Programmers may, of course, supply their own --- instances of 'RandomGen'. --- --- * The class 'Random' provides a way to extract values of a particular --- type from a random number generator. For example, the 'Float' --- instance of 'Random' allows one to generate random values of type --- 'Float'. --- --- This implementation uses the Portable Combined Generator of L'Ecuyer --- ["System.Random\#LEcuyer"] for 32-bit computers, transliterated by --- Lennart Augustsson. It has a period of roughly 2.30584e18. --- ------------------------------------------------------------------------------ - -#include "MachDeps.h" - -module System.Random - ( - - -- $intro - - -- * Random number generators - -#ifdef ENABLE_SPLITTABLEGEN - RandomGen(next, genRange) - , SplittableGen(split) -#else - RandomGen(next, genRange, split) -#endif - -- ** Standard random number generators - , StdGen - , mkStdGen - - -- ** The global random number generator - - -- $globalrng - - , getStdRandom - , getStdGen - , setStdGen - , newStdGen - - -- * Random values of various types - , Random ( random, randomR, - randoms, randomRs, - randomIO, randomRIO ) - - -- * References - -- $references - - ) where - -import Prelude - -import Data.Bits -import Data.Int -import Data.Word -import Foreign.C.Types - -#ifdef __NHC__ -import CPUTime ( getCPUTime ) -import Foreign.Ptr ( Ptr, nullPtr ) -import Foreign.C ( CTime, CUInt ) -#else -import System.CPUTime ( getCPUTime ) -import Data.Time ( getCurrentTime, UTCTime(..) ) -import Data.Ratio ( numerator, denominator ) -#endif -import Data.Char ( isSpace, chr, ord ) -import System.IO.Unsafe ( unsafePerformIO ) -import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) -#if MIN_VERSION_base (4,6,0) -import Data.IORef ( atomicModifyIORef' ) -#else -import Data.IORef ( atomicModifyIORef ) -#endif -import Numeric ( readDec ) - -#ifdef __GLASGOW_HASKELL__ -import GHC.Exts ( build ) -#else --- | A dummy variant of build without fusion. -{-# INLINE build #-} -build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] -build g = g (:) [] -#endif - -#if !MIN_VERSION_base (4,6,0) -atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b -atomicModifyIORef' ref f = do - b <- atomicModifyIORef ref - (\x -> let (a, b) = f x - in (a, a `seq` b)) - b `seq` return b -#endif - --- The standard nhc98 implementation of Time.ClockTime does not match --- the extended one expected in this module, so we lash-up a quick --- replacement here. -#ifdef __NHC__ -foreign import ccall "time.h time" readtime :: Ptr CTime -> IO CTime -getTime :: IO (Integer, Integer) -getTime = do CTime t <- readtime nullPtr; return (toInteger t, 0) -#else -getTime :: IO (Integer, Integer) -getTime = do - utc <- getCurrentTime - let daytime = toRational $ utctDayTime utc - return $ quotRem (numerator daytime) (denominator daytime) -#endif - --- | The class 'RandomGen' provides a common interface to random number --- generators. --- -#ifdef ENABLE_SPLITTABLEGEN --- Minimal complete definition: 'next'. -#else --- Minimal complete definition: 'next' and 'split'. -#endif - -class RandomGen g where - - -- |The 'next' operation returns an 'Int' that is uniformly distributed - -- in the range returned by 'genRange' (including both end points), - -- and a new generator. - next :: g -> (Int, g) - - -- |The 'genRange' operation yields the range of values returned by - -- the generator. - -- - -- It is required that: - -- - -- * If @(a,b) = 'genRange' g@, then @a < b@. - -- - -- * 'genRange' always returns a pair of defined 'Int's. - -- - -- The second condition ensures that 'genRange' cannot examine its - -- argument, and hence the value it returns can be determined only by the - -- instance of 'RandomGen'. That in turn allows an implementation to make - -- a single call to 'genRange' to establish a generator's range, without - -- being concerned that the generator returned by (say) 'next' might have - -- a different range to the generator passed to 'next'. - -- - -- The default definition spans the full range of 'Int'. - genRange :: g -> (Int,Int) - - -- default method - genRange _ = (minBound, maxBound) - -#ifdef ENABLE_SPLITTABLEGEN --- | The class 'SplittableGen' proivides a way to specify a random number --- generator that can be split into two new generators. -class SplittableGen g where -#endif - -- |The 'split' operation allows one to obtain two distinct random number - -- generators. This is very useful in functional programs (for example, when - -- passing a random number generator down to recursive calls), but very - -- little work has been done on statistically robust implementations of - -- 'split' (["System.Random\#Burton", "System.Random\#Hellekalek"] - -- are the only examples we know of). - split :: g -> (g, g) - -{- | -The 'StdGen' instance of 'RandomGen' has a 'genRange' of at least 30 bits. - -The result of repeatedly using 'next' should be at least as statistically -robust as the /Minimal Standard Random Number Generator/ described by -["System.Random\#Park", "System.Random\#Carta"]. -Until more is known about implementations of 'split', all we require is -that 'split' deliver generators that are (a) not identical and -(b) independently robust in the sense just given. - -The 'Show' and 'Read' instances of 'StdGen' provide a primitive way to save the -state of a random number generator. -It is required that @'read' ('show' g) == g@. - -In addition, 'reads' may be used to map an arbitrary string (not necessarily one -produced by 'show') onto a value of type 'StdGen'. In general, the 'Read' -instance of 'StdGen' has the following properties: - -* It guarantees to succeed on any string. - -* It guarantees to consume only a finite portion of the string. - -* Different argument strings are likely to result in different results. - --} - -data StdGen - = StdGen !Int32 !Int32 - -instance RandomGen StdGen where - next = stdNext - genRange _ = stdRange - -#ifdef ENABLE_SPLITTABLEGEN -instance SplittableGen StdGen where -#endif - split = stdSplit - -instance Show StdGen where - showsPrec p (StdGen s1 s2) = - showsPrec p s1 . - showChar ' ' . - showsPrec p s2 - -instance Read StdGen where - readsPrec _p = \ r -> - case try_read r of - r'@[_] -> r' - _ -> [stdFromString r] -- because it shouldn't ever fail. - where - try_read r = do - (s1, r1) <- readDec (dropWhile isSpace r) - (s2, r2) <- readDec (dropWhile isSpace r1) - return (StdGen s1 s2, r2) - -{- - If we cannot unravel the StdGen from a string, create - one based on the string given. --} -stdFromString :: String -> (StdGen, String) -stdFromString s = (mkStdGen num, rest) - where (cs, rest) = splitAt 6 s - num = foldl (\a x -> x + 3 * a) 1 (map ord cs) - - -{- | -The function 'mkStdGen' provides an alternative way of producing an initial -generator, by mapping an 'Int' into a generator. Again, distinct arguments -should be likely to produce distinct generators. --} -mkStdGen :: Int -> StdGen -- why not Integer ? -mkStdGen s = mkStdGen32 $ fromIntegral s - -{- -From ["System.Random\#LEcuyer"]: "The integer variables s1 and s2 ... must be -initialized to values in the range [1, 2147483562] and [1, 2147483398] -respectively." --} -mkStdGen32 :: Int32 -> StdGen -mkStdGen32 sMaybeNegative = StdGen (s1+1) (s2+1) - where - -- We want a non-negative number, but we can't just take the abs - -- of sMaybeNegative as -minBound == minBound. - s = sMaybeNegative .&. maxBound - (q, s1) = s `divMod` 2147483562 - s2 = q `mod` 2147483398 - -createStdGen :: Integer -> StdGen -createStdGen s = mkStdGen32 $ fromIntegral s - -{- | -With a source of random number supply in hand, the 'Random' class allows the -programmer to extract random values of a variety of types. - -Minimal complete definition: 'randomR' and 'random'. - --} - -class Random a where - -- | Takes a range /(lo,hi)/ and a random number generator - -- /g/, and returns a random value uniformly distributed in the closed - -- interval /[lo,hi]/, together with a new generator. It is unspecified - -- what happens if /lo>hi/. For continuous types there is no requirement - -- that the values /lo/ and /hi/ are ever produced, but they may be, - -- depending on the implementation and the interval. - randomR :: RandomGen g => (a,a) -> g -> (a,g) - - -- | The same as 'randomR', but using a default range determined by the type: - -- - -- * For bounded types (instances of 'Bounded', such as 'Char'), - -- the range is normally the whole type. - -- - -- * For fractional types, the range is normally the semi-closed interval - -- @[0,1)@. - -- - -- * For 'Integer', the range is (arbitrarily) the range of 'Int'. - random :: RandomGen g => g -> (a, g) - - -- | Plural variant of 'randomR', producing an infinite list of - -- random values instead of returning a new generator. - {-# INLINE randomRs #-} - randomRs :: RandomGen g => (a,a) -> g -> [a] - randomRs ival g = build (\cons _nil -> buildRandoms cons (randomR ival) g) - - -- | Plural variant of 'random', producing an infinite list of - -- random values instead of returning a new generator. - {-# INLINE randoms #-} - randoms :: RandomGen g => g -> [a] - randoms g = build (\cons _nil -> buildRandoms cons random g) - - -- | A variant of 'randomR' that uses the global random number generator - -- (see "System.Random#globalrng"). - randomRIO :: (a,a) -> IO a - randomRIO range = getStdRandom (randomR range) - - -- | A variant of 'random' that uses the global random number generator - -- (see "System.Random#globalrng"). - randomIO :: IO a - randomIO = getStdRandom random - --- | Produce an infinite list-equivalent of random values. -{-# INLINE buildRandoms #-} -buildRandoms :: RandomGen g - => (a -> as -> as) -- ^ E.g. '(:)' but subject to fusion - -> (g -> (a,g)) -- ^ E.g. 'random' - -> g -- ^ A 'RandomGen' instance - -> as -buildRandoms cons rand = go - where - -- The seq fixes part of #4218 and also makes fused Core simpler. - go g = x `seq` (x `cons` go g') where (x,g') = rand g - - -instance Random Integer where - randomR ival g = randomIvalInteger ival g - random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g - -instance Random Int where randomR = randomIvalIntegral; random = randomBounded -instance Random Int8 where randomR = randomIvalIntegral; random = randomBounded -instance Random Int16 where randomR = randomIvalIntegral; random = randomBounded -instance Random Int32 where randomR = randomIvalIntegral; random = randomBounded -instance Random Int64 where randomR = randomIvalIntegral; random = randomBounded - -#ifndef __NHC__ --- Word is a type synonym in nhc98. -instance Random Word where randomR = randomIvalIntegral; random = randomBounded -#endif -instance Random Word8 where randomR = randomIvalIntegral; random = randomBounded -instance Random Word16 where randomR = randomIvalIntegral; random = randomBounded -instance Random Word32 where randomR = randomIvalIntegral; random = randomBounded -instance Random Word64 where randomR = randomIvalIntegral; random = randomBounded - -instance Random CChar where randomR = randomIvalIntegral; random = randomBounded -instance Random CSChar where randomR = randomIvalIntegral; random = randomBounded -instance Random CUChar where randomR = randomIvalIntegral; random = randomBounded -instance Random CShort where randomR = randomIvalIntegral; random = randomBounded -instance Random CUShort where randomR = randomIvalIntegral; random = randomBounded -instance Random CInt where randomR = randomIvalIntegral; random = randomBounded -instance Random CUInt where randomR = randomIvalIntegral; random = randomBounded -instance Random CLong where randomR = randomIvalIntegral; random = randomBounded -instance Random CULong where randomR = randomIvalIntegral; random = randomBounded -instance Random CPtrdiff where randomR = randomIvalIntegral; random = randomBounded -instance Random CSize where randomR = randomIvalIntegral; random = randomBounded -instance Random CWchar where randomR = randomIvalIntegral; random = randomBounded -instance Random CSigAtomic where randomR = randomIvalIntegral; random = randomBounded -instance Random CLLong where randomR = randomIvalIntegral; random = randomBounded -instance Random CULLong where randomR = randomIvalIntegral; random = randomBounded -instance Random CIntPtr where randomR = randomIvalIntegral; random = randomBounded -instance Random CUIntPtr where randomR = randomIvalIntegral; random = randomBounded -instance Random CIntMax where randomR = randomIvalIntegral; random = randomBounded -instance Random CUIntMax where randomR = randomIvalIntegral; random = randomBounded - -instance Random Char where - randomR (a,b) g = - case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of - (x,g') -> (chr x, g') - random g = randomR (minBound,maxBound) g - -instance Random Bool where - randomR (a,b) g = - case (randomIvalInteger (bool2Int a, bool2Int b) g) of - (x, g') -> (int2Bool x, g') - where - bool2Int :: Bool -> Integer - bool2Int False = 0 - bool2Int True = 1 - - int2Bool :: Int -> Bool - int2Bool 0 = False - int2Bool _ = True - - random g = randomR (minBound,maxBound) g - -{-# INLINE randomRFloating #-} -randomRFloating :: (Fractional a, Num a, Ord a, Random a, RandomGen g) => (a, a) -> g -> (a, g) -randomRFloating (l,h) g - | l>h = randomRFloating (h,l) g - | otherwise = let (coef,g') = random g in - (2.0 * (0.5*l + coef * (0.5*h - 0.5*l)), g') -- avoid overflow - -instance Random Double where - randomR = randomRFloating - random rng = - case random rng of - (x,rng') -> - -- We use 53 bits of randomness corresponding to the 53 bit significand: - ((fromIntegral (mask53 .&. (x::Int64)) :: Double) - / fromIntegral twoto53, rng') - where - twoto53 = (2::Int64) ^ (53::Int64) - mask53 = twoto53 - 1 - -instance Random Float where - randomR = randomRFloating - random rng = - -- TODO: Faster to just use 'next' IF it generates enough bits of randomness. - case random rng of - (x,rng') -> - -- We use 24 bits of randomness corresponding to the 24 bit significand: - ((fromIntegral (mask24 .&. (x::Int32)) :: Float) - / fromIntegral twoto24, rng') - -- Note, encodeFloat is another option, but I'm not seeing slightly - -- worse performance with the following [2011.06.25]: --- (encodeFloat rand (-24), rng') - where - mask24 = twoto24 - 1 - twoto24 = (2::Int32) ^ (24::Int32) - --- CFloat/CDouble are basically the same as a Float/Double: -instance Random CFloat where - randomR = randomRFloating - random rng = case random rng of - (x,rng') -> (realToFrac (x::Float), rng') - -instance Random CDouble where - randomR = randomRFloating - -- A MYSTERY: - -- Presently, this is showing better performance than the Double instance: - -- (And yet, if the Double instance uses randomFrac then its performance is much worse!) - random = randomFrac - -- random rng = case random rng of - -- (x,rng') -> (realToFrac (x::Double), rng') - -mkStdRNG :: Integer -> IO StdGen -mkStdRNG o = do - ct <- getCPUTime - (sec, psec) <- getTime - return (createStdGen (sec * 12345 + psec + ct + o)) - -randomBounded :: (RandomGen g, Random a, Bounded a) => g -> (a, g) -randomBounded = randomR (minBound, maxBound) - --- The two integer functions below take an [inclusive,inclusive] range. -randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g) -randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h) - -{-# SPECIALIZE randomIvalInteger :: (Num a) => - (Integer, Integer) -> StdGen -> (a, StdGen) #-} - -randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) -randomIvalInteger (l,h) rng - | l > h = randomIvalInteger (h,l) rng - | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng') - where - (genlo, genhi) = genRange rng - b = fromIntegral genhi - fromIntegral genlo + 1 - - -- Probabilities of the most likely and least likely result - -- will differ at most by a factor of (1 +- 1/q). Assuming the RandomGen - -- is uniform, of course - - -- On average, log q / log b more random values will be generated - -- than the minimum - q = 1000 - k = h - l + 1 - magtgt = k * q - - -- generate random values until we exceed the target magnitude - f mag v g | mag >= magtgt = (v, g) - | otherwise = v' `seq`f (mag*b) v' g' where - (x,g') = next g - v' = (v * b + (fromIntegral x - fromIntegral genlo)) - - --- The continuous functions on the other hand take an [inclusive,exclusive) range. -randomFrac :: (RandomGen g, Fractional a) => g -> (a, g) -randomFrac = randomIvalDouble (0::Double,1) realToFrac - -randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g) -randomIvalDouble (l,h) fromDouble rng - | l > h = randomIvalDouble (h,l) fromDouble rng - | otherwise = - case (randomIvalInteger (toInteger (minBound::Int32), toInteger (maxBound::Int32)) rng) of - (x, rng') -> - let - scaled_x = - fromDouble (0.5*l + 0.5*h) + -- previously (l+h)/2, overflowed - fromDouble ((0.5*h - 0.5*l) / (0.5 * realToFrac int32Count)) * -- avoid overflow - fromIntegral (x::Int32) - in - (scaled_x, rng') - -int32Count :: Integer -int32Count = toInteger (maxBound::Int32) - toInteger (minBound::Int32) + 1 -- GHC ticket #3982 - -stdRange :: (Int,Int) -stdRange = (1, 2147483562) - -stdNext :: StdGen -> (Int, StdGen) --- Returns values in the range stdRange -stdNext (StdGen s1 s2) = (fromIntegral z', StdGen s1'' s2'') - where z' = if z < 1 then z + 2147483562 else z - z = s1'' - s2'' - - k = s1 `quot` 53668 - s1' = 40014 * (s1 - k * 53668) - k * 12211 - s1'' = if s1' < 0 then s1' + 2147483563 else s1' - - k' = s2 `quot` 52774 - s2' = 40692 * (s2 - k' * 52774) - k' * 3791 - s2'' = if s2' < 0 then s2' + 2147483399 else s2' - -stdSplit :: StdGen -> (StdGen, StdGen) -stdSplit std@(StdGen s1 s2) - = (left, right) - where - -- no statistical foundation for this! - left = StdGen new_s1 t2 - right = StdGen t1 new_s2 - - new_s1 | s1 == 2147483562 = 1 - | otherwise = s1 + 1 - - new_s2 | s2 == 1 = 2147483398 - | otherwise = s2 - 1 - - StdGen t1 t2 = snd (next std) - --- The global random number generator - -{- $globalrng #globalrng# - -There is a single, implicit, global random number generator of type -'StdGen', held in some global variable maintained by the 'IO' monad. It is -initialised automatically in some system-dependent fashion, for example, by -using the time of day, or Linux's kernel random number generator. To get -deterministic behaviour, use 'setStdGen'. --} - --- |Sets the global random number generator. -setStdGen :: StdGen -> IO () -setStdGen sgen = writeIORef theStdGen sgen - --- |Gets the global random number generator. -getStdGen :: IO StdGen -getStdGen = readIORef theStdGen - -theStdGen :: IORef StdGen -theStdGen = unsafePerformIO $ do - rng <- mkStdRNG 0 - newIORef rng - --- |Applies 'split' to the current global random generator, --- updates it with one of the results, and returns the other. -newStdGen :: IO StdGen -newStdGen = atomicModifyIORef' theStdGen split - -{- |Uses the supplied function to get a value from the current global -random generator, and updates the global generator with the new generator -returned by the function. For example, @rollDice@ gets a random integer -between 1 and 6: - -> rollDice :: IO Int -> rollDice = getStdRandom (randomR (1,6)) - --} - -getStdRandom :: (StdGen -> (a,StdGen)) -> IO a -getStdRandom f = atomicModifyIORef' theStdGen (swap . f) - where swap (v,g) = (g,v) - -{- $references - -1. FW #Burton# Burton and RL Page, /Distributed random number generation/, -Journal of Functional Programming, 2(2):203-212, April 1992. - -2. SK #Park# Park, and KW Miller, /Random number generators - -good ones are hard to find/, Comm ACM 31(10), Oct 1988, pp1192-1201. - -3. DG #Carta# Carta, /Two fast implementations of the minimal standard -random number generator/, Comm ACM, 33(1), Jan 1990, pp87-88. - -4. P #Hellekalek# Hellekalek, /Don\'t trust parallel Monte Carlo/, -Department of Mathematics, University of Salzburg, -, 1998. - -5. Pierre #LEcuyer# L'Ecuyer, /Efficient and portable combined random -number generators/, Comm ACM, 31(6), Jun 1988, pp742-749. - -The Web site is a great source of information. - --} diff --git a/bench-legacy/BinSearch.hs b/bench-legacy/BinSearch.hs new file mode 100644 --- /dev/null +++ b/bench-legacy/BinSearch.hs @@ -0,0 +1,149 @@ + +{- + Binary search over benchmark input sizes. + + There are many good ways to measure the time it takes to perform a + certain computation on a certain input. However, frequently, it's + challenging to pick the right input size for all platforms and all + compilataion modes. + + Sometimes for linear-complexity benchmarks it is better to measure + /throughput/, i.e. elements processed per second. That is, fixing + the time of execution and measuring the amount of work done (rather + than the reverse). This library provides a simple way to search for + an appropriate input size that results in the desired execution time. + + An alternative approach is to kill the computation after a certain + amount of time and observe how much work it has completed. + -} +module BinSearch + ( + binSearch + ) +where + +import Control.Monad +import Data.Time.Clock -- Not in 6.10 +import Data.List +import System.IO +import Prelude hiding (min,max,log) + + + +-- | Binary search for the number of inputs to a computation that +-- results in a specified amount of execution time in seconds. For example: +-- +-- > binSearch verbose N (min,max) kernel +-- +-- ... will find the right input size that results in a time +-- between min and max, then it will then run for N trials and +-- return the median (input,time-in-seconds) pair. +binSearch :: Bool -> Integer -> (Double,Double) -> (Integer -> IO ()) -> IO (Integer, Double) +binSearch verbose trials (min, max) kernel = do + when verbose $ + putStrLn $ + "[binsearch] Binary search for input size resulting in time in range " ++ + show (min, max) + let desired_exec_length = 1.0 + good_trial t = + (toRational t <= toRational max) && (toRational t >= toRational min) + -- At some point we must give up... + loop n + | n > ((2 :: Integer) ^ (100 :: Integer)) = + error + "ERROR binSearch: This function doesn't seem to scale in proportion to its last argument." + -- Not allowed to have "0" size input, bump it back to one: + loop 0 = loop 1 + loop n = do + when verbose $ putStr $ "[binsearch:" ++ show n ++ "] " + time <- timeit $ kernel n + when verbose $ putStrLn $ "Time consumed: " ++ show time + let rate = fromIntegral n / time + -- [2010.06.09] Introducing a small fudge factor to help our guess get over the line: + let initial_fudge_factor = 1.10 + fudge_factor = 1.01 -- Even in the steady state we fudge a little + guess = desired_exec_length * rate + -- TODO: We should keep more history here so that we don't re-explore input space we + -- have already explored. This is a balancing act because of randomness in + -- execution time. + if good_trial time + then do + when verbose $ + putStrLn + "[binsearch] Time in range. LOCKING input size and performing remaining trials." + print_trial 1 n time + lockin (trials - 1) n [time] + else if time < 0.100 + then loop (2 * n) + else do + when verbose $ + putStrLn $ + "[binsearch] Estimated rate to be " ++ + show (round rate :: Integer) ++ + " per second. Trying to scale up..." + -- Here we've exited the doubling phase, but we're making our + -- first guess as to how big a real execution should be: + if time > 0.100 && time < 0.33 * desired_exec_length + then do + when verbose $ + putStrLn + "[binsearch] (Fudging first guess a little bit extra)" + loop (round $ guess * initial_fudge_factor) + else loop (round $ guess * fudge_factor) + -- Termination condition: Done with all trials. + lockin 0 n log = do + when verbose $ + putStrLn $ + "[binsearch] Time-per-unit for all trials: " ++ + concat + (intersperse " " (map (show . (/ toDouble n) . toDouble) $ sort log)) + return (n, log !! (length log `quot` 2)) -- Take the median + lockin trials_left n log = do + when verbose $ + putStrLn + "[binsearch]------------------------------------------------------------" + time <- timeit $ kernel n + -- hFlush stdout + print_trial (trials - trials_left + 1) n time + -- whenverbose$ hFlush stdout + lockin (trials_left - 1) n (time : log) + print_trial :: Integer -> Integer -> NominalDiffTime -> IO () + print_trial trialnum n time = + let rate = fromIntegral n / time + timeperunit = time / fromIntegral n + in when verbose $ + putStrLn $ + "[binsearch] TRIAL: " ++ + show trialnum ++ + " secPerUnit: " ++ + showTime timeperunit ++ + " ratePerSec: " ++ show rate ++ " seconds: " ++ showTime time + (n, t) <- loop 1 + return (n, fromRational $ toRational t) + + +showTime :: NominalDiffTime -> String +showTime t = show ((fromRational $ toRational t) :: Double) + +toDouble :: Real a => a -> Double +toDouble = fromRational . toRational + + +-- Could use cycle counters here.... but the point of this is to time +-- things on the order of a second. +timeit :: IO () -> IO NominalDiffTime +timeit io = do + strt <- getCurrentTime + io + end <- getCurrentTime + return (diffUTCTime end strt) +{- +test :: IO (Integer,Double) +test = + binSearch True 3 (1.0, 1.05) + (\n -> + do v <- newIORef 0 + forM_ [1..n] $ \i -> do + old <- readIORef v + writeIORef v (old+i)) +-} diff --git a/bench-legacy/SimpleRNGBench.hs b/bench-legacy/SimpleRNGBench.hs new file mode 100644 --- /dev/null +++ b/bench-legacy/SimpleRNGBench.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables, ForeignFunctionInterface #-} +{-# OPTIONS_GHC -fwarn-unused-imports #-} + +-- | A simple script to do some very basic timing of the RNGs. + +module Main where + +import System.Exit (exitSuccess, exitFailure) +import System.Environment +import System.Random +import System.CPUTime (getCPUTime) +import System.CPUTime.Rdtsc +import System.Console.GetOpt + +import GHC.Conc +import Control.Concurrent +import Control.Monad +import Control.Exception + +import Data.IORef +import Data.Word +import Data.List hiding (last,sum) +import Data.Int +import Data.List.Split hiding (split) +import Text.Printf + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.ForeignPtr +import Foreign.Storable (peek,poke) + +import Prelude hiding (last,sum) +import BinSearch + +---------------------------------------------------------------------------------------------------- +-- Miscellaneous helpers: + +-- Readable large integer printing: +commaint :: Show a => a -> String +commaint n = reverse $ concat $ intersperse "," $ chunk 3 $ reverse (show n) + +padleft :: Int -> String -> String +padleft n str | length str >= n = str +padleft n str | otherwise = take (n - length str) (repeat ' ') ++ str + +padright :: Int -> String -> String +padright n str | length str >= n = str +padright n str | otherwise = str ++ take (n - length str) (repeat ' ') + +fmt_num :: (RealFrac a, PrintfArg a) => a -> String +fmt_num n = + if n < 100 + then printf "%.2f" n + else commaint (round n :: Integer) + + +-- Measure clock frequency, spinning rather than sleeping to try to +-- stay on the same core. +measureFreq :: IO Int64 +measureFreq = do + let second = 1000 * 1000 * 1000 * 1000 -- picoseconds are annoying + t1 <- rdtsc + start <- getCPUTime + let loop !n !last = do + t2 <- rdtsc + when (t2 < last) $ putStrLn $ "COUNTERS WRAPPED " ++ show (last, t2) + cput <- getCPUTime + if cput - start < second + then loop (n + 1) t2 + else return (n, t2) + (n, t2) <- loop 0 t1 + putStrLn $ " Approx getCPUTime calls per second: " ++ commaint (n :: Int64) + when (t2 < t1) $ + putStrLn $ + "WARNING: rdtsc not monotonically increasing, first " ++ + show t1 ++ " then " ++ show t2 ++ " on the same OS thread" + return $ fromIntegral (t2 - t1) + +---------------------------------------------------------------------------------------------------- + +-- Test overheads without actually generating any random numbers: +data NoopRNG = NoopRNG +instance RandomGen NoopRNG where + next g = (0, g) + genRange _ = (0, 0) + split g = (g, g) + +-- An RNG generating only 0 or 1: +data BinRNG = BinRNG StdGen +instance RandomGen BinRNG where + next (BinRNG g) = (x `mod` 2, BinRNG g') + where + (x, g') = next g + genRange _ = (0, 1) + split (BinRNG g) = (BinRNG g1, BinRNG g2) + where + (g1, g2) = split g + + +---------------------------------------------------------------------------------------------------- +-- Drivers to get random numbers repeatedly. + +type Kern = Int -> Ptr Int -> IO () + +-- [2011.01.28] Changing this to take "count" and "accumulator ptr" as arguments: +-- foreign import ccall "cbits/c_test.c" blast_rands :: Kern +-- foreign import ccall "cbits/c_test.c" store_loop :: Kern +-- foreign import ccall unsafe "stdlib.hs" rand :: IO Int + +{-# INLINE timeit #-} +timeit :: (Random a, RandomGen g) => Int -> Int64 -> String -> g -> (g -> (a,g)) -> IO () +timeit numthreads freq msg gen nxt = do + counters <- forM [1 .. numthreads] (const $ newIORef (1 :: Int64)) + tids <- forM counters $ \counter -> forkIO $ infloop counter (nxt gen) + threadDelay (1000 * 1000) -- One second + mapM_ killThread tids + finals <- mapM readIORef counters + let mean :: Double = + fromIntegral (foldl1 (+) finals) / fromIntegral numthreads + cycles_per :: Double = fromIntegral freq / mean + printResult (round mean :: Int64) msg cycles_per + where + infloop !counter (!_, !g) = do + incr counter + infloop counter (nxt g) + incr !counter + -- modifyIORef counter (+1) -- Not strict enough! + = do + c <- readIORef counter + let c' = c + 1 + _ <- evaluate c' + writeIORef counter c' + + +-- This function times an IO function on one or more threads. Rather +-- than running a fixed number of iterations, it uses a binary search +-- to find out how many iterations can be completed in a second. +timeit_foreign :: Int -> Int64 -> String -> (Int -> Ptr Int -> IO ()) -> IO Int64 +timeit_foreign numthreads freq msg ffn = do + ptr :: ForeignPtr Int <- mallocForeignPtr + let kern = + if numthreads == 1 + then ffn + else replicate_kernel numthreads ffn + wrapped n = withForeignPtr ptr (kern $ fromIntegral n) + (n, t) <- binSearch False 1 (1.0, 1.05) wrapped + let total_per_second = round $ fromIntegral n * (1 / t) + cycles_per = fromIntegral freq * t / fromIntegral n + printResult total_per_second msg cycles_per + return total_per_second + -- This lifts a C kernel to operate simultaneously on N threads. + where + replicate_kernel :: Int -> Kern -> Kern + replicate_kernel nthreads kern n ptr = do + ptrs <- forM [1 .. nthreads] (const mallocForeignPtr) + tmpchan <- newChan + -- let childwork = ceiling$ fromIntegral n / fromIntegral nthreads + let childwork = n -- Keep it the same.. interested in per-thread throughput. + -- Fork/join pattern: + forM_ ptrs $ \pt -> + forkIO $ + withForeignPtr pt $ \p -> do + kern (fromIntegral childwork) p + result <- peek p + writeChan tmpchan result + results <- forM [1 .. nthreads] $ \_ -> readChan tmpchan + -- Meaningless semantics here... sum the child ptrs and write to the input one: + poke ptr (foldl1 (+) results) + + +printResult :: Int64 -> String -> Double -> IO () +printResult total msg cycles_per = + putStrLn $ + " " ++ + padleft 11 (commaint total) ++ + " randoms generated " ++ + padright 27 ("[" ++ msg ++ "]") ++ + " ~ " ++ fmt_num cycles_per ++ " cycles/int" + +---------------------------------------------------------------------------------------------------- +-- Main Script + +data Flag = NoC | Help + deriving (Show, Eq) + +options :: [OptDescr Flag] +options = + [ Option ['h'] ["help"] (NoArg Help) "print program help" + , Option [] ["noC"] (NoArg NoC) "omit C benchmarks, haskell only" + ] + +main :: IO () +main = do + argv <- getArgs + let (opts,_,other) = getOpt Permute options argv + + unless (null other) $ do + putStrLn "ERROR: Unrecognized options: " + mapM_ putStr other + exitFailure + + when (Help `elem` opts) $ do + putStr $ usageInfo "Benchmark random number generation" options + exitSuccess + + putStrLn "\nHow many random numbers can we generate in a second on one thread?" + + t1 <- rdtsc + t2 <- rdtsc + putStrLn (" Cost of rdtsc (ffi call): " ++ show (t2 - t1)) + + freq <- measureFreq + putStrLn $ " Approx clock frequency: " ++ commaint freq + + let randInt = random :: RandomGen g => g -> (Int,g) + randWord16 = random :: RandomGen g => g -> (Word16,g) + randFloat = random :: RandomGen g => g -> (Float,g) + randCFloat = random :: RandomGen g => g -> (CFloat,g) + randDouble = random :: RandomGen g => g -> (Double,g) + randCDouble = random :: RandomGen g => g -> (CDouble,g) + randInteger = random :: RandomGen g => g -> (Integer,g) + randBool = random :: RandomGen g => g -> (Bool,g) + randChar = random :: RandomGen g => g -> (Char,g) + + gen = mkStdGen 23852358661234 + gamut th = do + putStrLn " First, timing System.Random.next:" + timeit th freq "constant zero gen" NoopRNG next + timeit th freq "System.Random stdGen/next" gen next + + putStrLn "\n Second, timing System.Random.random at different types:" + timeit th freq "System.Random Ints" gen randInt + timeit th freq "System.Random Word16" gen randWord16 + timeit th freq "System.Random Floats" gen randFloat + timeit th freq "System.Random CFloats" gen randCFloat + timeit th freq "System.Random Doubles" gen randDouble + timeit th freq "System.Random CDoubles" gen randCDouble + timeit th freq "System.Random Integers" gen randInteger + timeit th freq "System.Random Bools" gen randBool + timeit th freq "System.Random Chars" gen randChar + + putStrLn "\n Next timing range-restricted System.Random.randomR:" + timeit th freq "System.Random Ints" gen (randomR (-100, 100::Int)) + timeit th freq "System.Random Word16s" gen (randomR ( 100, 300::Word16)) + timeit th freq "System.Random Floats" gen (randomR (-100, 100::Float)) + timeit th freq "System.Random CFloats" gen (randomR (-100, 100::CFloat)) + timeit th freq "System.Random Doubles" gen (randomR (-100, 100::Double)) + timeit th freq "System.Random CDoubles" gen (randomR (-100, 100::CDouble)) + timeit th freq "System.Random Integers" gen (randomR (-100, 100::Integer)) + timeit th freq "System.Random Bools" gen (randomR (False, True::Bool)) + timeit th freq "System.Random Chars" gen (randomR ('a', 'z')) + timeit th freq "System.Random BIG Integers" gen (randomR (0, (2::Integer) ^ (5000::Int))) + + -- when (not$ NoC `elem` opts) $ do + -- putStrLn$ " Comparison to C's rand():" + -- timeit_foreign th freq "ptr store in C loop" store_loop + -- timeit_foreign th freq "rand/store in C loop" blast_rands + -- timeit_foreign th freq "rand in Haskell loop" (\n ptr -> forM_ [1..n]$ \_ -> rand ) + -- timeit_foreign th freq "rand/store in Haskell loop" (\n ptr -> forM_ [1..n]$ \_ -> do n <- rand; poke ptr n ) + -- return () + + -- Test with 1 thread and numCapabilities threads: + gamut 1 + when (numCapabilities > 1) $ do + putStrLn $ "\nNow "++ show numCapabilities ++" threads, reporting mean randoms-per-second-per-thread:" + void $ gamut numCapabilities + + putStrLn "Finished." + diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main (main) where + +import Control.Monad +import Control.Monad.State.Strict +import Data.Int +import Data.Proxy +import Data.Typeable +import Data.Word +import Foreign.C.Types +import Gauge.Main +import Numeric.Natural (Natural) +import System.Random.SplitMix as SM + +import System.Random.Stateful + +main :: IO () +main = do + let !sz = 100000 + genLengths = + -- create 5000 small lengths that are needed for ShortByteString generation + runStateGen (mkStdGen 2020) $ \g -> replicateM 5000 (uniformRM (16 + 1, 16 + 7) g) + defaultMain + [ bgroup "baseline" + [ let !smGen = SM.mkSMGen 1337 in bench "nextWord32" $ nf (genMany SM.nextWord32 smGen) sz + , let !smGen = SM.mkSMGen 1337 in bench "nextWord64" $ nf (genMany SM.nextWord64 smGen) sz + , let !smGen = SM.mkSMGen 1337 in bench "nextInt" $ nf (genMany SM.nextInt smGen) sz + , let !smGen = SM.mkSMGen 1337 in bench "split" $ nf (genMany SM.splitSMGen smGen) sz + ] + , bgroup "pure" + [ bgroup "random" + [ pureRandomBench (Proxy :: Proxy Float) sz + , pureRandomBench (Proxy :: Proxy Double) sz + , pureRandomBench (Proxy :: Proxy Integer) sz + ] + , bgroup "uniform" + [ pureUniformBench (Proxy :: Proxy Word8) sz + , pureUniformBench (Proxy :: Proxy Word16) sz + , pureUniformBench (Proxy :: Proxy Word32) sz + , pureUniformBench (Proxy :: Proxy Word64) sz + , pureUniformBench (Proxy :: Proxy Word) sz + , pureUniformBench (Proxy :: Proxy Int8) sz + , pureUniformBench (Proxy :: Proxy Int16) sz + , pureUniformBench (Proxy :: Proxy Int32) sz + , pureUniformBench (Proxy :: Proxy Int64) sz + , pureUniformBench (Proxy :: Proxy Int) sz + , pureUniformBench (Proxy :: Proxy Char) sz + , pureUniformBench (Proxy :: Proxy Bool) sz + , pureUniformBench (Proxy :: Proxy CChar) sz + , pureUniformBench (Proxy :: Proxy CSChar) sz + , pureUniformBench (Proxy :: Proxy CUChar) sz + , pureUniformBench (Proxy :: Proxy CShort) sz + , pureUniformBench (Proxy :: Proxy CUShort) sz + , pureUniformBench (Proxy :: Proxy CInt) sz + , pureUniformBench (Proxy :: Proxy CUInt) sz + , pureUniformBench (Proxy :: Proxy CLong) sz + , pureUniformBench (Proxy :: Proxy CULong) sz + , pureUniformBench (Proxy :: Proxy CPtrdiff) sz + , pureUniformBench (Proxy :: Proxy CSize) sz + , pureUniformBench (Proxy :: Proxy CWchar) sz + , pureUniformBench (Proxy :: Proxy CSigAtomic) sz + , pureUniformBench (Proxy :: Proxy CLLong) sz + , pureUniformBench (Proxy :: Proxy CULLong) sz + , pureUniformBench (Proxy :: Proxy CIntPtr) sz + , pureUniformBench (Proxy :: Proxy CUIntPtr) sz + , pureUniformBench (Proxy :: Proxy CIntMax) sz + , pureUniformBench (Proxy :: Proxy CUIntMax) sz + ] + , bgroup "uniformR" + [ bgroup "full" + [ pureUniformRFullBench (Proxy :: Proxy Word8) sz + , pureUniformRFullBench (Proxy :: Proxy Word16) sz + , pureUniformRFullBench (Proxy :: Proxy Word32) sz + , pureUniformRFullBench (Proxy :: Proxy Word64) sz + , pureUniformRFullBench (Proxy :: Proxy Word) sz + , pureUniformRFullBench (Proxy :: Proxy Int8) sz + , pureUniformRFullBench (Proxy :: Proxy Int16) sz + , pureUniformRFullBench (Proxy :: Proxy Int32) sz + , pureUniformRFullBench (Proxy :: Proxy Int64) sz + , pureUniformRFullBench (Proxy :: Proxy Int) sz + , pureUniformRFullBench (Proxy :: Proxy Char) sz + , pureUniformRFullBench (Proxy :: Proxy Bool) sz + , pureUniformRFullBench (Proxy :: Proxy CChar) sz + , pureUniformRFullBench (Proxy :: Proxy CSChar) sz + , pureUniformRFullBench (Proxy :: Proxy CUChar) sz + , pureUniformRFullBench (Proxy :: Proxy CShort) sz + , pureUniformRFullBench (Proxy :: Proxy CUShort) sz + , pureUniformRFullBench (Proxy :: Proxy CInt) sz + , pureUniformRFullBench (Proxy :: Proxy CUInt) sz + , pureUniformRFullBench (Proxy :: Proxy CLong) sz + , pureUniformRFullBench (Proxy :: Proxy CULong) sz + , pureUniformRFullBench (Proxy :: Proxy CPtrdiff) sz + , pureUniformRFullBench (Proxy :: Proxy CSize) sz + , pureUniformRFullBench (Proxy :: Proxy CWchar) sz + , pureUniformRFullBench (Proxy :: Proxy CSigAtomic) sz + , pureUniformRFullBench (Proxy :: Proxy CLLong) sz + , pureUniformRFullBench (Proxy :: Proxy CULLong) sz + , pureUniformRFullBench (Proxy :: Proxy CIntPtr) sz + , pureUniformRFullBench (Proxy :: Proxy CUIntPtr) sz + , pureUniformRFullBench (Proxy :: Proxy CIntMax) sz + , pureUniformRFullBench (Proxy :: Proxy CUIntMax) sz + ] + , bgroup "excludeMax" + [ pureUniformRExcludeMaxBench (Proxy :: Proxy Word8) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy Word16) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy Word32) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy Word64) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy Word) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy Int8) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy Int16) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy Int32) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy Int64) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy Int) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy Char) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy Bool) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CChar) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CSChar) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CUChar) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CShort) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CUShort) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CInt) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CUInt) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CLong) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CULong) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CPtrdiff) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CSize) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CWchar) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CSigAtomic) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CLLong) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CULLong) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CIntPtr) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CUIntPtr) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CIntMax) sz + , pureUniformRExcludeMaxBench (Proxy :: Proxy CUIntMax) sz + ] + , bgroup "includeHalf" + [ pureUniformRIncludeHalfBench (Proxy :: Proxy Word8) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy Word16) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy Word32) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy Word64) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy Word) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy Int8) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy Int16) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy Int32) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy Int64) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy Int) sz + , pureUniformRIncludeHalfEnumBench (Proxy :: Proxy Char) sz + , pureUniformRIncludeHalfEnumBench (Proxy :: Proxy Bool) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CChar) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CSChar) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CUChar) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CShort) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CUShort) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CInt) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CUInt) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CLong) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CULong) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CPtrdiff) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CSize) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CWchar) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CSigAtomic) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CLLong) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CULLong) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CIntPtr) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CUIntPtr) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CIntMax) sz + , pureUniformRIncludeHalfBench (Proxy :: Proxy CUIntMax) sz + ] + , bgroup "unbounded" + [ pureUniformRBench (Proxy :: Proxy Float) (1.23e-4, 5.67e8) sz + , pureUniformRBench (Proxy :: Proxy Double) (1.23e-4, 5.67e8) sz + , let !i = (10 :: Integer) ^ (100 :: Integer) + !range = (-i - 1, i + 1) + in pureUniformRBench (Proxy :: Proxy Integer) range sz + , let !n = (10 :: Natural) ^ (100 :: Natural) + !range = (1, n - 1) + in pureUniformRBench (Proxy :: Proxy Natural) range sz + ] + , bgroup "floating" + [ bgroup "IO" + [ bench "uniformFloat01M" $ nfIO $ runStateGenT_ (mkStdGen 1337) $ \g -> + replicateM_ sz $ do !_ <- uniformFloat01M g + return () + , bench "uniformFloatPositive01M" $ nfIO $ runStateGenT_ (mkStdGen 1337) $ \g -> + replicateM_ sz $ do !_ <- uniformFloatPositive01M g + return () + , bench "uniformDouble01M" $ nfIO $ runStateGenT_ (mkStdGen 1337) $ \g -> + replicateM_ sz $ do !_ <- uniformDouble01M g + return () + , bench "uniformDoublePositive01M" $ nfIO $ runStateGenT_ (mkStdGen 1337) $ \g -> + replicateM_ sz $ do !_ <- uniformDoublePositive01M g + return () + ] + -- + , bgroup "St" + [ bench "uniformFloat01M" $ nf + (\n -> runStateGen_ (mkStdGen 1337) $ \g -> replicateM_ n $ do !_ <- uniformFloat01M g + return () + ) sz + , bench "uniformFloatPositive01M" $ nf + (\n -> runStateGen_ (mkStdGen 1337) $ \g -> replicateM_ n $ do !_ <- uniformFloatPositive01M g + return () + ) sz + , bench "uniformDouble01M" $ nf + (\n -> runStateGen_ (mkStdGen 1337) $ \g -> replicateM_ n $ do !_ <- uniformDouble01M g + return () + ) sz + , bench "uniformDoublePositive01M" $ nf + (\n -> runStateGen_ (mkStdGen 1337) $ \g -> replicateM_ n $ do !_ <- uniformDoublePositive01M g + return () + ) sz + ] + , bgroup "pure" + [ let !stdGen = mkStdGen 1337 + in bench "uniformFloat01M" $ nf + (genMany (runState $ uniformFloat01M (StateGenM :: StateGenM StdGen)) stdGen) + sz + , let !stdGen = mkStdGen 1337 + in bench "uniformFloatPositive01M" $ nf + (genMany (runState $ uniformFloatPositive01M (StateGenM :: StateGenM StdGen)) stdGen) + sz + , let !stdGen = mkStdGen 1337 + in bench "uniformDouble01M" $ nf + (genMany (runState $ uniformDouble01M (StateGenM :: StateGenM StdGen)) stdGen) + sz + , let !stdGen = mkStdGen 1337 + in bench "uniformDoublePositive01M" $ nf + (genMany (runState $ uniformDoublePositive01M (StateGenM :: StateGenM StdGen)) stdGen) + sz + ] + ] + , bgroup "ShortByteString" + [ env (pure genLengths) $ \ ~(ns, gen) -> + bench "genShortByteString" $ + nfIO $ runStateGenT_ gen $ \g -> mapM (`uniformShortByteString` g) ns + ] + ] + ] + ] + +pureRandomBench :: forall a. (Typeable a, Random a) => Proxy a -> Int -> Benchmark +pureRandomBench px = + let !stdGen = mkStdGen 1337 + in pureBench px (genMany (random :: StdGen -> (a, StdGen)) stdGen) + +pureUniformBench :: forall a. (Typeable a, Uniform a) => Proxy a -> Int -> Benchmark +pureUniformBench px = + let !stdGen = mkStdGen 1337 + in pureBench px (genMany (uniform :: StdGen -> (a, StdGen)) stdGen) + +pureUniformRFullBench :: + forall a. (Typeable a, UniformRange a, Bounded a) + => Proxy a + -> Int + -> Benchmark +pureUniformRFullBench px = + let range = (minBound :: a, maxBound :: a) + in pureUniformRBench px range + +pureUniformRExcludeMaxBench :: + forall a. (Typeable a, UniformRange a, Bounded a, Enum a) + => Proxy a + -> Int + -> Benchmark +pureUniformRExcludeMaxBench px = + let range = (minBound :: a, pred (maxBound :: a)) + in pureUniformRBench px range + +pureUniformRIncludeHalfBench :: + forall a. (Typeable a, UniformRange a, Bounded a, Integral a) + => Proxy a + -> Int + -> Benchmark +pureUniformRIncludeHalfBench px = + let range = ((minBound :: a) + 1, ((maxBound :: a) `div` 2) + 1) + in pureUniformRBench px range + +pureUniformRIncludeHalfEnumBench :: + forall a. (Typeable a, UniformRange a, Bounded a, Enum a) + => Proxy a + -> Int + -> Benchmark +pureUniformRIncludeHalfEnumBench px = + let range = (succ (minBound :: a), toEnum ((fromEnum (maxBound :: a) `div` 2) + 1)) + in pureUniformRBench px range + +pureUniformRBench :: + forall a. (Typeable a, UniformRange a) + => Proxy a + -> (a, a) + -> Int + -> Benchmark +pureUniformRBench px range@(!_, !_) = + let !stdGen = mkStdGen 1337 + in pureBench px (genMany (uniformR range) stdGen) + +pureBench :: forall a. (Typeable a) => Proxy a -> (Int -> ()) -> Int -> Benchmark +pureBench px f sz = bench (showsTypeRep (typeRep px) "") $ nf f sz + +genMany :: (g -> (a, g)) -> g -> Int -> () +genMany f g0 n = go g0 0 + where + go g i + | i < n = + case f g of + (x, g') -> x `seq` go g' (i + 1) + | otherwise = g `seq` () diff --git a/random.cabal b/random.cabal --- a/random.cabal +++ b/random.cabal @@ -1,70 +1,193 @@ -name: random -version: 1.1 - - - - -license: BSD3 -license-file: LICENSE -maintainer: core-libraries-committee@haskell.org -bug-reports: https://github.com/haskell/random/issues -synopsis: random number library -category: System +cabal-version: >=1.10 +name: random +version: 1.2.0 +license: BSD3 +license-file: LICENSE +maintainer: core-libraries-committee@haskell.org +bug-reports: https://github.com/haskell/random/issues +synopsis: Pseudo-random number generation description: - This package provides a basic random number generation - library, including the ability to split random number - generators. + This package provides basic pseudo-random number generation, including the + ability to split random number generators. + . + == "System.Random": pure pseudo-random number interface + . + In pure code, use 'System.Random.uniform' and 'System.Random.uniformR' from + "System.Random" to generate pseudo-random numbers with a pure pseudo-random + number generator like 'System.Random.StdGen'. + . + As an example, here is how you can simulate rolls of a six-sided die using + 'System.Random.uniformR': + . + >>> let roll = uniformR (1, 6) :: RandomGen g => g -> (Word, g) + >>> let rolls = unfoldr (Just . roll) :: RandomGen g => g -> [Word] + >>> let pureGen = mkStdGen 42 + >>> take 10 (rolls pureGen) :: [Word] + [1,1,3,2,4,5,3,4,6,2] + . + See "System.Random" for more details. + . + == "System.Random.Stateful": monadic pseudo-random number interface + . + In monadic code, use 'System.Random.Stateful.uniformM' and + 'System.Random.Stateful.uniformRM' from "System.Random.Stateful" to generate + pseudo-random numbers with a monadic pseudo-random number generator, or + using a monadic adapter. + . + As an example, here is how you can simulate rolls of a six-sided die using + 'System.Random.Stateful.uniformRM': + . + >>> let rollM = uniformRM (1, 6) :: StatefulGen g m => g -> m Word + >>> let pureGen = mkStdGen 42 + >>> runStateGen_ pureGen (replicateM 10 . rollM) :: [Word] + [1,1,3,2,4,5,3,4,6,2] + . + The monadic adapter 'System.Random.Stateful.runGenState_' is used here to lift + the pure pseudo-random number generator @pureGen@ into the + 'System.Random.Stateful.StatefulGen' context. + . + The monadic interface can also be used with existing monadic pseudo-random + number generators. In this example, we use the one provided in the + package: + . + >>> import System.Random.MWC as MWC + >>> let rollM = uniformRM (1, 6) :: StatefulGen g m => g -> m Word + >>> monadicGen <- MWC.create + >>> replicateM 10 (rollM monadicGen) :: IO [Word] + [2,3,6,6,4,4,3,1,5,4] + . + See "System.Random.Stateful" for more details. +category: System +build-type: Simple extra-source-files: - .travis.yml - README.md - CHANGELOG.md - .gitignore - .darcs-boring + README.md + CHANGELOG.md +tested-with: GHC == 7.10.2 + , GHC == 7.10.3 + , GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.3 + , GHC == 8.4.4 + , GHC == 8.6.3 + , GHC == 8.6.4 + , GHC == 8.6.5 + , GHC == 8.8.1 + , GHC == 8.8.2 + , GHC == 8.10.1 +source-repository head + type: git + location: https://github.com/haskell/random.git -build-type: Simple --- cabal-version 1.8 needed because "the field 'build-depends: random' refers --- to a library which is defined within the same package" -cabal-version: >= 1.8 +library + exposed-modules: + System.Random + System.Random.Internal + System.Random.Stateful + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: + -Wall + if impl(ghc >= 8.0) + ghc-options: + -Wincomplete-record-updates -Wincomplete-uni-patterns + build-depends: + base >=4.8 && <5, + bytestring >=0.10.4 && <0.11, + deepseq >=1.1 && <2, + mtl >=2.2 && <2.3, + splitmix >=0.1 && <0.2 + if impl(ghc < 8.0) + build-depends: + transformers -Library - exposed-modules: - System.Random - extensions: CPP - GHC-Options: -O2 - build-depends: base >= 3 && < 5, time +test-suite legacy-test + type: exitcode-stdio-1.0 + main-is: Legacy.hs + hs-source-dirs: test-legacy + other-modules: + T7936 + TestRandomIOs + TestRandomRs + Random1283 + RangeTest -source-repository head - type: git - location: http://git.haskell.org/packages/random.git + default-language: Haskell2010 + ghc-options: -with-rtsopts=-M4M + if impl(ghc >= 8.0) + ghc-options: + -Wno-deprecations + build-depends: + base -any, + containers >=0.5 && <0.7, + random -any --- To run the Test-Suite: --- $ cabal configure --enable-tests --- $ cabal test --show-details=always --test-options="+RTS -M1M -RTS" +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + hs-source-dirs: test + default-language: Haskell2010 + build-depends: + base -any, + doctest >=0.15 && <0.18, + mwc-random >=0.13 && <0.15, + primitive >=0.6 && <0.8, + random -any, + unliftio >=0.2 && <0.3, + vector >= 0.10 && <0.14 -Test-Suite T7936 - type: exitcode-stdio-1.0 - main-is: T7936.hs - hs-source-dirs: tests - build-depends: base >= 3 && < 5, random - ghc-options: -rtsopts -O2 +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: + Spec.Range + Spec.Run -Test-Suite TestRandomRs - type: exitcode-stdio-1.0 - main-is: TestRandomRs.hs - hs-source-dirs: tests - build-depends: base >= 3 && < 5, random - ghc-options: -rtsopts -O2 - -- TODO. Why does the following not work? - --test-options: +RTS -M1M -RTS + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base -any, + bytestring -any, + random -any, + smallcheck >=1.2 && <1.3, + tasty >=1.0 && <1.4, + tasty-smallcheck >=0.8 && <0.9, + tasty-expected-failure >=0.11 && <0.12, + tasty-hunit >=0.10 && <0.11 -Test-Suite TestRandomIOs - type: exitcode-stdio-1.0 - main-is: TestRandomIOs.hs - hs-source-dirs: tests - build-depends: base >= 3 && < 5, random - ghc-options: -rtsopts -O2 +benchmark legacy-bench + type: exitcode-stdio-1.0 + main-is: SimpleRNGBench.hs + hs-source-dirs: bench-legacy + other-modules: BinSearch + default-language: Haskell2010 + ghc-options: + -Wall -O2 -threaded -rtsopts -with-rtsopts=-N + if impl(ghc >= 8.0) + ghc-options: + -Wno-deprecations + + build-depends: + base -any, + random -any, + rdtsc -any, + split >=0.2 && <0.3, + time >=1.4 && <1.11 + +benchmark bench + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench + default-language: Haskell2010 + ghc-options: -Wall -O2 + build-depends: + base -any, + gauge >=0.2.3 && <0.3, + mtl, + random -any, + splitmix >=0.1 && <0.2 diff --git a/src/System/Random.hs b/src/System/Random.hs new file mode 100644 --- /dev/null +++ b/src/System/Random.hs @@ -0,0 +1,500 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : System.Random +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE in the 'random' repository) +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- +-- This library deals with the common task of pseudo-random number generation. +module System.Random + ( + -- * Introduction + -- $introduction + + -- * Usage + -- $usagepure + + -- * Pure number generator interface + -- $interfaces + RandomGen(..) + , uniform + , uniformR + , genByteString + , Random(..) + , Uniform + , UniformRange + -- ** Standard pseudo-random number generator + , StdGen + , mkStdGen + + -- ** Global standard pseudo-random number generator + -- $globalstdgen + , getStdRandom + , getStdGen + , setStdGen + , newStdGen + , randomIO + , randomRIO + + -- * Compatibility and reproducibility + -- ** Backwards compatibility and deprecations + -- $deprecations + + -- ** Reproducibility + -- $reproducibility + + -- * Notes for pseudo-random number generator implementors + -- ** How to implement 'RandomGen' + -- $implementrandomgen + + -- * References + -- $references + ) where + +import Control.Arrow +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Data.Int +import Data.IORef +import Data.Word +import Foreign.C.Types +import GHC.Exts +import System.IO.Unsafe (unsafePerformIO) +import System.Random.Internal +import qualified System.Random.SplitMix as SM + +-- $introduction +-- +-- This module provides type classes and instances for the following concepts: +-- +-- [Pure pseudo-random number generators] 'RandomGen' is an interface to pure +-- pseudo-random number generators. +-- +-- 'StdGen', the standard pseudo-random number generator provided in this +-- library, is an instance of 'RandomGen'. It uses the SplitMix +-- implementation provided by the +-- package. +-- Programmers may, of course, supply their own instances of 'RandomGen'. +-- +-- $usagepure +-- +-- In pure code, use 'uniform' and 'uniformR' to generate pseudo-random values +-- with a pure pseudo-random number generator like 'StdGen'. +-- +-- >>> :{ +-- let rolls :: RandomGen g => Int -> g -> [Word] +-- rolls n = take n . unfoldr (Just . uniformR (1, 6)) +-- pureGen = mkStdGen 137 +-- in +-- rolls 10 pureGen :: [Word] +-- :} +-- [4,2,6,1,6,6,5,1,1,5] +-- +-- To run use a /monadic/ pseudo-random computation in pure code with a pure +-- pseudo-random number generator, use 'runGenState' and its variants. +-- +-- >>> :{ +-- let rollsM :: StatefulGen g m => Int -> g -> m [Word] +-- rollsM n = replicateM n . uniformRM (1, 6) +-- pureGen = mkStdGen 137 +-- in +-- runStateGen_ pureGen (rollsM 10) :: [Word] +-- :} +-- [4,2,6,1,6,6,5,1,1,5] + +------------------------------------------------------------------------------- +-- Pseudo-random number generator interfaces +------------------------------------------------------------------------------- + +-- $interfaces +-- +-- Pseudo-random number generators come in two flavours: /pure/ and /monadic/. +-- +-- ['RandomGen': pure pseudo-random number generators] These generators produce +-- a new pseudo-random value together with a new instance of the +-- pseudo-random number generator. +-- +-- Pure pseudo-random number generators should implement 'split' if they +-- are /splittable/, that is, if there is an efficient method to turn one +-- generator into two. The pseudo-random numbers produced by the two +-- resulting generators should not be correlated. See [1] for some +-- background on splittable pseudo-random generators. +-- +-- ['System.Random.Stateful.StatefulGen': monadic pseudo-random number generators] +-- See "System.Random.Stateful" module +-- + +-- | Generates a value uniformly distributed over all possible values of that +-- type. +-- +-- This is a pure version of 'System.Random.Stateful.uniformM'. +-- +-- ====__Examples__ +-- +-- >>> import System.Random +-- >>> let pureGen = mkStdGen 137 +-- >>> uniform pureGen :: (Bool, StdGen) +-- (True,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627}) +-- +-- @since 1.2.0 +uniform :: (RandomGen g, Uniform a) => g -> (a, g) +uniform g = runStateGen g uniformM + +-- | Generates a value uniformly distributed over the provided range, which +-- is interpreted as inclusive in the lower and upper bound. +-- +-- * @uniformR (1 :: Int, 4 :: Int)@ generates values uniformly from the set +-- \(\{1,2,3,4\}\) +-- +-- * @uniformR (1 :: Float, 4 :: Float)@ generates values uniformly from the +-- set \(\{x\;|\;1 \le x \le 4\}\) +-- +-- The following law should hold to make the function always defined: +-- +-- > uniformR (a, b) = uniformR (b, a) +-- +-- This is a pure version of 'System.Random.Stateful.uniformRM'. +-- +-- ====__Examples__ +-- +-- >>> import System.Random +-- >>> let pureGen = mkStdGen 137 +-- >>> uniformR (1 :: Int, 4 :: Int) pureGen +-- (4,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627}) +-- +-- @since 1.2.0 +uniformR :: (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g) +uniformR r g = runStateGen g (uniformRM r) + +-- | Generates a 'ByteString' of the specified size using a pure pseudo-random +-- number generator. See 'uniformByteString' for the monadic version. +-- +-- ====__Examples__ +-- +-- >>> import System.Random +-- >>> import Data.ByteString +-- >>> let pureGen = mkStdGen 137 +-- >>> unpack . fst . genByteString 10 $ pureGen +-- [51,123,251,37,49,167,90,109,1,4] +-- +-- @since 1.2.0 +genByteString :: RandomGen g => Int -> g -> (ByteString, g) +genByteString n g = runStateGenST g (uniformByteStringM n) +{-# INLINE genByteString #-} + +-- | The class of types for which uniformly distributed values can be +-- generated. +-- +-- 'Random' exists primarily for backwards compatibility with version 1.1 of +-- this library. In new code, use the better specified 'Uniform' and +-- 'UniformRange' instead. +class Random a where + + -- | Takes a range /(lo,hi)/ and a pseudo-random number generator + -- /g/, and returns a pseudo-random value uniformly distributed over the + -- closed interval /[lo,hi]/, together with a new generator. It is unspecified + -- what happens if /lo>hi/. For continuous types there is no requirement + -- that the values /lo/ and /hi/ are ever produced, but they may be, + -- depending on the implementation and the interval. + {-# INLINE randomR #-} + randomR :: RandomGen g => (a, a) -> g -> (a, g) + default randomR :: (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g) + randomR r g = runStateGen g (uniformRM r) + + -- | The same as 'randomR', but using a default range determined by the type: + -- + -- * For bounded types (instances of 'Bounded', such as 'Char'), + -- the range is normally the whole type. + -- + -- * For fractional types, the range is normally the semi-closed interval + -- @[0,1)@. + -- + -- * For 'Integer', the range is (arbitrarily) the range of 'Int'. + {-# INLINE random #-} + random :: RandomGen g => g -> (a, g) + default random :: (RandomGen g, Uniform a) => g -> (a, g) + random g = runStateGen g uniformM + + -- | Plural variant of 'randomR', producing an infinite list of + -- pseudo-random values instead of returning a new generator. + {-# INLINE randomRs #-} + randomRs :: RandomGen g => (a,a) -> g -> [a] + randomRs ival g = build (\cons _nil -> buildRandoms cons (randomR ival) g) + + -- | Plural variant of 'random', producing an infinite list of + -- pseudo-random values instead of returning a new generator. + {-# INLINE randoms #-} + randoms :: RandomGen g => g -> [a] + randoms g = build (\cons _nil -> buildRandoms cons random g) + + +-- | Produce an infinite list-equivalent of pseudo-random values. +-- +-- ====__Examples__ +-- +-- >>> import System.Random +-- >>> let pureGen = mkStdGen 137 +-- >>> (take 4 . buildRandoms (:) random $ pureGen) :: [Int] +-- [7879794327570578227,6883935014316540929,-1519291874655152001,2353271688382626589] +-- +{-# INLINE buildRandoms #-} +buildRandoms :: RandomGen g + => (a -> as -> as) -- ^ E.g. '(:)' but subject to fusion + -> (g -> (a,g)) -- ^ E.g. 'random' + -> g -- ^ A 'RandomGen' instance + -> as +buildRandoms cons rand = go + where + -- The seq fixes part of #4218 and also makes fused Core simpler. + go g = x `seq` (x `cons` go g') where (x,g') = rand g + +-- Generate values in the Int range +instance Random Integer where + random = first (toInteger :: Int -> Integer) . random +instance Random Int8 +instance Random Int16 +instance Random Int32 +instance Random Int64 +instance Random Int +instance Random Word +instance Random Word8 +instance Random Word16 +instance Random Word32 +instance Random Word64 +#if __GLASGOW_HASKELL >= 802 +instance Random CBool +#endif +instance Random CChar +instance Random CSChar +instance Random CUChar +instance Random CShort +instance Random CUShort +instance Random CInt +instance Random CUInt +instance Random CLong +instance Random CULong +instance Random CPtrdiff +instance Random CSize +instance Random CWchar +instance Random CSigAtomic +instance Random CLLong +instance Random CULLong +instance Random CIntPtr +instance Random CUIntPtr +instance Random CIntMax +instance Random CUIntMax +instance Random CFloat where + randomR (CFloat l, CFloat h) = first CFloat . randomR (l, h) + random = first CFloat . random +instance Random CDouble where + randomR (CDouble l, CDouble h) = first CDouble . randomR (l, h) + random = first CDouble . random + +instance Random Char +instance Random Bool +instance Random Double where + randomR r g = runStateGen g (uniformRM r) + random g = runStateGen g (uniformRM (0, 1)) +instance Random Float where + randomR r g = runStateGen g (uniformRM r) + random g = runStateGen g (uniformRM (0, 1)) + +------------------------------------------------------------------------------- +-- Global pseudo-random number generator +------------------------------------------------------------------------------- + +-- $globalstdgen +-- +-- There is a single, implicit, global pseudo-random number generator of type +-- 'StdGen', held in a global variable maintained by the 'IO' monad. It is +-- initialised automatically in some system-dependent fashion. To get +-- deterministic behaviour, use 'setStdGen'. +-- +-- Note that 'mkStdGen' also gives deterministic behaviour without requiring an +-- 'IO' context. + +-- |Sets the global pseudo-random number generator. +setStdGen :: MonadIO m => StdGen -> m () +setStdGen = liftIO . writeIORef theStdGen + +-- |Gets the global pseudo-random number generator. +getStdGen :: MonadIO m => m StdGen +getStdGen = liftIO $ readIORef theStdGen + +theStdGen :: IORef StdGen +theStdGen = unsafePerformIO $ SM.initSMGen >>= newIORef . StdGen +{-# NOINLINE theStdGen #-} + +-- |Applies 'split' to the current global pseudo-random generator, +-- updates it with one of the results, and returns the other. +newStdGen :: MonadIO m => m StdGen +newStdGen = liftIO $ atomicModifyIORef' theStdGen split + +{- |Uses the supplied function to get a value from the current global +random generator, and updates the global generator with the new generator +returned by the function. For example, @rollDice@ gets a pseudo-random integer +between 1 and 6: + +> rollDice :: IO Int +> rollDice = getStdRandom (randomR (1,6)) + +-} +getStdRandom :: MonadIO m => (StdGen -> (a, StdGen)) -> m a +getStdRandom f = liftIO $ atomicModifyIORef' theStdGen (swap . f) + where swap (v, g) = (g, v) + + +-- | A variant of 'randomR' that uses the global pseudo-random number +-- generator. +randomRIO :: (Random a, MonadIO m) => (a, a) -> m a +randomRIO range = liftIO $ getStdRandom (randomR range) + +-- | A variant of 'random' that uses the global pseudo-random number +-- generator. +randomIO :: (Random a, MonadIO m) => m a +randomIO = liftIO $ getStdRandom random + +------------------------------------------------------------------------------- +-- Notes +------------------------------------------------------------------------------- + +-- $implementrandomgen +-- +-- Consider these points when writing a 'RandomGen' instance for a given pure +-- pseudo-random number generator: +-- +-- * If the pseudo-random number generator has a power-of-2 modulus, that is, +-- it natively outputs @2^n@ bits of randomness for some @n@, implement +-- 'genWord8', 'genWord16', 'genWord32' and 'genWord64'. See below for more +-- details. +-- +-- * If the pseudo-random number generator does not have a power-of-2 +-- modulus, implement 'next' and 'genRange'. See below for more details. +-- +-- * If the pseudo-random number generator is splittable, implement 'split'. +-- If there is no suitable implementation, 'split' should fail with a +-- helpful error message. +-- +-- === How to implement 'RandomGen' for a pseudo-random number generator with power-of-2 modulus +-- +-- Suppose you want to implement a [permuted congruential +-- generator](https://en.wikipedia.org/wiki/Permuted_congruential_generator). +-- +-- >>> data PCGen = PCGen !Word64 !Word64 +-- +-- It produces a full 'Word32' of randomness per iteration. +-- +-- >>> import Data.Bits +-- >>> :{ +-- let stepGen :: PCGen -> (Word32, PCGen) +-- stepGen (PCGen state inc) = let +-- newState = state * 6364136223846793005 + (inc .|. 1) +-- xorShifted = fromIntegral (((state `shiftR` 18) `xor` state) `shiftR` 27) :: Word32 +-- rot = fromIntegral (state `shiftR` 59) :: Word32 +-- out = (xorShifted `shiftR` (fromIntegral rot)) .|. (xorShifted `shiftL` fromIntegral ((-rot) .&. 31)) +-- in (out, PCGen newState inc) +-- :} +-- +-- >>> fst $ stepGen $ snd $ stepGen (PCGen 17 29) +-- 3288430965 +-- +-- You can make it an instance of 'RandomGen' as follows: +-- +-- >>> :{ +-- instance RandomGen PCGen where +-- genWord32 = stepGen +-- split _ = error "PCG is not splittable" +-- :} +-- +-- +-- === How to implement 'RandomGen' for a pseudo-random number generator without a power-of-2 modulus +-- +-- __We do not recommend you implement any new pseudo-random number generators without a power-of-2 modulus.__ +-- +-- Pseudo-random number generators without a power-of-2 modulus perform +-- /significantly worse/ than pseudo-random number generators with a power-of-2 +-- modulus with this library. This is because most functionality in this +-- library is based on generating and transforming uniformly pseudo-random +-- machine words, and generating uniformly pseudo-random machine words using a +-- pseudo-random number generator without a power-of-2 modulus is expensive. +-- +-- The pseudo-random number generator from +-- natively +-- generates an integer value in the range @[1, 2147483562]@. This is the +-- generator used by this library before it was replaced by SplitMix in version +-- 1.2. +-- +-- >>> data LegacyGen = LegacyGen !Int32 !Int32 +-- >>> :{ +-- let legacyNext :: LegacyGen -> (Int, LegacyGen) +-- legacyNext (LegacyGen s1 s2) = (fromIntegral z', LegacyGen s1'' s2'') where +-- z' = if z < 1 then z + 2147483562 else z +-- z = s1'' - s2'' +-- k = s1 `quot` 53668 +-- s1' = 40014 * (s1 - k * 53668) - k * 12211 +-- s1'' = if s1' < 0 then s1' + 2147483563 else s1' +-- k' = s2 `quot` 52774 +-- s2' = 40692 * (s2 - k' * 52774) - k' * 3791 +-- s2'' = if s2' < 0 then s2' + 2147483399 else s2' +-- :} +-- +-- You can make it an instance of 'RandomGen' as follows: +-- +-- >>> :{ +-- instance RandomGen LegacyGen where +-- next = legacyNext +-- genRange _ = (1, 2147483562) +-- split _ = error "Not implemented" +-- :} +-- +-- $deprecations +-- +-- Version 1.2 mostly maintains backwards compatibility with version 1.1. This +-- has a few consequences users should be aware of: +-- +-- * The type class 'Random' is only provided for backwards compatibility. +-- New code should use 'Uniform' and 'UniformRange' instead. +-- +-- * The methods 'next' and 'genRange' in 'RandomGen' are deprecated and only +-- provided for backwards compatibility. New instances of 'RandomGen' should +-- implement word-based methods instead. See below for more information +-- about how to write a 'RandomGen' instance. +-- +-- * This library provides instances for 'Random' for some unbounded types +-- for backwards compatibility. For an unbounded type, there is no way +-- to generate a value with uniform probability out of its entire domain, so +-- the 'random' implementation for unbounded types actually generates a +-- value based on some fixed range. +-- +-- For 'Integer', 'random' generates a value in the 'Int' range. For 'Float' +-- and 'Double', 'random' generates a floating point value in the range @[0, +-- 1)@. +-- +-- This library does not provide 'Uniform' instances for any unbounded +-- types. +-- +-- $reproducibility +-- +-- If you have two builds of a particular piece of code against this library, +-- any deterministic function call should give the same result in the two +-- builds if the builds are +-- +-- * compiled against the same major version of this library +-- * on the same architecture (32-bit or 64-bit) +-- +-- $references +-- +-- 1. Guy L. Steele, Jr., Doug Lea, and Christine H. Flood. 2014. Fast +-- splittable pseudorandom number generators. In Proceedings of the 2014 ACM +-- International Conference on Object Oriented Programming Systems Languages & +-- Applications (OOPSLA '14). ACM, New York, NY, USA, 453-472. DOI: +-- + +-- $setup +-- +-- >>> import Control.Monad (replicateM) +-- >>> import Data.List (unfoldr) diff --git a/src/System/Random/Internal.hs b/src/System/Random/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/Random/Internal.hs @@ -0,0 +1,1111 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UnliftedFFITypes #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TypeFamilyDependencies #-} +#else +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +#endif +{-# OPTIONS_HADDOCK hide, not-home #-} + +-- | +-- Module : System.Random.Internal +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE in the 'random' repository) +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- +-- This library deals with the common task of pseudo-random number generation. +module System.Random.Internal + (-- * Pure and monadic pseudo-random number generator interfaces + RandomGen(..) + , StatefulGen(..) + , FrozenGen(..) + + -- ** Standard pseudo-random number generator + , StdGen(..) + , mkStdGen + + -- * Monadic adapters for pure pseudo-random number generators + -- ** Pure adapter + , StateGen(..) + , StateGenM(..) + , splitGen + , runStateGen + , runStateGen_ + , runStateGenT + , runStateGenT_ + , runStateGenST + + -- * Pseudo-random values of various types + , Uniform(..) + , UniformRange(..) + , uniformByteStringM + , uniformDouble01M + , uniformDoublePositive01M + , uniformFloat01M + , uniformFloatPositive01M + + -- * Generators for sequences of pseudo-random bytes + , genShortByteStringIO + , genShortByteStringST + ) where + +import Control.Arrow +import Control.DeepSeq (NFData) +import Control.Monad.IO.Class +import Control.Monad.ST +import Control.Monad.ST.Unsafe +import Control.Monad.State.Strict +import Data.Bits +import Data.ByteString.Builder.Prim (word64LE) +import Data.ByteString.Builder.Prim.Internal (runF) +import Data.ByteString.Short.Internal (ShortByteString(SBS), fromShort) +import Data.Int +import Data.Word +import Foreign.C.Types +import Foreign.Ptr (plusPtr) +import Foreign.Storable (Storable(pokeByteOff)) +import GHC.Exts +import GHC.IO (IO(..)) +import GHC.Word +import Numeric.Natural (Natural) +import System.IO.Unsafe (unsafePerformIO) +import qualified System.Random.SplitMix as SM +import qualified System.Random.SplitMix32 as SM32 +#if __GLASGOW_HASKELL__ >= 800 +import Data.Kind +#endif +#if __GLASGOW_HASKELL__ >= 802 +import Data.ByteString.Internal (ByteString(PS)) +import GHC.ForeignPtr +#else +import Data.ByteString (ByteString) +#endif + +-- | 'RandomGen' is an interface to pure pseudo-random number generators. +-- +-- 'StdGen' is the standard 'RandomGen' instance provided by this library. +{-# DEPRECATED next "No longer used" #-} +{-# DEPRECATED genRange "No longer used" #-} +class RandomGen g where + {-# MINIMAL split,(genWord32|genWord64|(next,genRange)) #-} + -- | Returns an 'Int' that is uniformly distributed over the range returned by + -- 'genRange' (including both end points), and a new generator. Using 'next' + -- is inefficient as all operations go via 'Integer'. See + -- [here](https://alexey.kuleshevi.ch/blog/2019/12/21/random-benchmarks) for + -- more details. It is thus deprecated. + next :: g -> (Int, g) + next g = runStateGen g (uniformRM (genRange g)) + + -- | Returns a 'Word8' that is uniformly distributed over the entire 'Word8' + -- range. + -- + -- @since 1.2.0 + genWord8 :: g -> (Word8, g) + genWord8 = first fromIntegral . genWord32 + + -- | Returns a 'Word16' that is uniformly distributed over the entire 'Word16' + -- range. + -- + -- @since 1.2.0 + genWord16 :: g -> (Word16, g) + genWord16 = first fromIntegral . genWord32 + + -- | Returns a 'Word32' that is uniformly distributed over the entire 'Word32' + -- range. + -- + -- @since 1.2.0 + genWord32 :: g -> (Word32, g) + genWord32 = randomIvalIntegral (minBound, maxBound) + -- Once `next` is removed, this implementation should be used instead: + -- first fromIntegral . genWord64 + + -- | Returns a 'Word64' that is uniformly distributed over the entire 'Word64' + -- range. + -- + -- @since 1.2.0 + genWord64 :: g -> (Word64, g) + genWord64 g = + case genWord32 g of + (l32, g') -> + case genWord32 g' of + (h32, g'') -> + ((fromIntegral h32 `shiftL` 32) .|. fromIntegral l32, g'') + + -- | @genWord32R upperBound g@ returns a 'Word32' that is uniformly + -- distributed over the range @[0, upperBound]@. + -- + -- @since 1.2.0 + genWord32R :: Word32 -> g -> (Word32, g) + genWord32R m g = runStateGen g (unbiasedWordMult32 m) + + -- | @genWord64R upperBound g@ returns a 'Word64' that is uniformly + -- distributed over the range @[0, upperBound]@. + -- + -- @since 1.2.0 + genWord64R :: Word64 -> g -> (Word64, g) + genWord64R m g = runStateGen g (unsignedBitmaskWithRejectionM uniformWord64 m) + + -- | @genShortByteString n g@ returns a 'ShortByteString' of length @n@ + -- filled with pseudo-random bytes. + -- + -- @since 1.2.0 + genShortByteString :: Int -> g -> (ShortByteString, g) + genShortByteString n g = + unsafePerformIO $ runStateGenT g (genShortByteStringIO n . uniformWord64) + {-# INLINE genShortByteString #-} + + -- | Yields the range of values returned by 'next'. + -- + -- It is required that: + -- + -- * If @(a, b) = 'genRange' g@, then @a < b@. + -- * 'genRange' must not examine its argument so the value it returns is + -- determined only by the instance of 'RandomGen'. + -- + -- The default definition spans the full range of 'Int'. + genRange :: g -> (Int, Int) + genRange _ = (minBound, maxBound) + + -- | Returns two distinct pseudo-random number generators. + -- + -- Implementations should take care to ensure that the resulting generators + -- are not correlated. Some pseudo-random number generators are not + -- splittable. In that case, the 'split' implementation should fail with a + -- descriptive 'error' message. + split :: g -> (g, g) + + +-- | 'StatefulGen' is an interface to monadic pseudo-random number generators. +class Monad m => StatefulGen g m where + {-# MINIMAL (uniformWord32|uniformWord64) #-} + -- | @uniformWord32R upperBound g@ generates a 'Word32' that is uniformly + -- distributed over the range @[0, upperBound]@. + -- + -- @since 1.2.0 + uniformWord32R :: Word32 -> g -> m Word32 + uniformWord32R = unsignedBitmaskWithRejectionM uniformWord32 + + -- | @uniformWord64R upperBound g@ generates a 'Word64' that is uniformly + -- distributed over the range @[0, upperBound]@. + -- + -- @since 1.2.0 + uniformWord64R :: Word64 -> g -> m Word64 + uniformWord64R = unsignedBitmaskWithRejectionM uniformWord64 + + -- | Generates a 'Word8' that is uniformly distributed over the entire 'Word8' + -- range. + -- + -- The default implementation extracts a 'Word8' from 'uniformWord32'. + -- + -- @since 1.2.0 + uniformWord8 :: g -> m Word8 + uniformWord8 = fmap fromIntegral . uniformWord32 + + -- | Generates a 'Word16' that is uniformly distributed over the entire + -- 'Word16' range. + -- + -- The default implementation extracts a 'Word16' from 'uniformWord32'. + -- + -- @since 1.2.0 + uniformWord16 :: g -> m Word16 + uniformWord16 = fmap fromIntegral . uniformWord32 + + -- | Generates a 'Word32' that is uniformly distributed over the entire + -- 'Word32' range. + -- + -- The default implementation extracts a 'Word32' from 'uniformWord64'. + -- + -- @since 1.2.0 + uniformWord32 :: g -> m Word32 + uniformWord32 = fmap fromIntegral . uniformWord64 + + -- | Generates a 'Word64' that is uniformly distributed over the entire + -- 'Word64' range. + -- + -- The default implementation combines two 'Word32' from 'uniformWord32' into + -- one 'Word64'. + -- + -- @since 1.2.0 + uniformWord64 :: g -> m Word64 + uniformWord64 g = do + l32 <- uniformWord32 g + h32 <- uniformWord32 g + pure (shiftL (fromIntegral h32) 32 .|. fromIntegral l32) + + -- | @uniformShortByteString n g@ generates a 'ShortByteString' of length @n@ + -- filled with pseudo-random bytes. + -- + -- @since 1.2.0 + uniformShortByteString :: Int -> g -> m ShortByteString + default uniformShortByteString :: MonadIO m => Int -> g -> m ShortByteString + uniformShortByteString n = genShortByteStringIO n . uniformWord64 + {-# INLINE uniformShortByteString #-} + + + +-- | This class is designed for stateful pseudo-random number generators that +-- can be saved as and restored from an immutable data type. +-- +-- @since 1.2.0 +class StatefulGen (MutableGen f m) m => FrozenGen f m where + -- | Represents the state of the pseudo-random number generator for use with + -- 'thawGen' and 'freezeGen'. + -- + -- @since 1.2.0 +#if __GLASGOW_HASKELL__ >= 800 + type MutableGen f m = (g :: Type) | g -> f +#else + type MutableGen f m :: * +#endif + -- | Saves the state of the pseudo-random number generator as a frozen seed. + -- + -- @since 1.2.0 + freezeGen :: MutableGen f m -> m f + -- | Restores the pseudo-random number generator from its frozen seed. + -- + -- @since 1.2.0 + thawGen :: f -> m (MutableGen f m) + + +data MBA s = MBA (MutableByteArray# s) + + +-- | Efficiently generates a sequence of pseudo-random bytes in a platform +-- independent manner. +-- +-- @since 1.2.0 +genShortByteStringIO :: + MonadIO m + => Int -- ^ Number of bytes to generate + -> m Word64 -- ^ IO action that can generate 8 random bytes at a time + -> m ShortByteString +genShortByteStringIO n0 gen64 = do + let !n@(I# n#) = max 0 n0 + !n64 = n `quot` 8 + !nrem64 = n `rem` 8 + MBA mba# <- + liftIO $ + IO $ \s# -> + case newPinnedByteArray# n# s# of + (# s'#, mba# #) -> (# s'#, MBA mba# #) + let go i ptr + | i < n64 = do + w64 <- gen64 + -- Writing 8 bytes at a time in a Little-endian order gives us + -- platform portability + liftIO $ runF word64LE w64 ptr + go (i + 1) (ptr `plusPtr` 8) + | otherwise = return ptr + ptr <- go 0 (Ptr (byteArrayContents# (unsafeCoerce# mba#))) + when (nrem64 > 0) $ do + w64 <- gen64 + -- In order to not mess up the byte order we write generated Word64 into a + -- temporary pointer and then copy only the missing bytes over to the array. + -- It is tempting to simply generate as many bytes as we still need using + -- smaller generators (eg. uniformWord8), but that would result in + -- inconsistent tail when total length is slightly varied. + liftIO $ do + let goRem64 z i = + when (i < nrem64) $ do + pokeByteOff ptr i (fromIntegral z :: Word8) + goRem64 (z `shiftR` 8) (i + 1) + goRem64 w64 0 + liftIO $ + IO $ \s# -> + case unsafeFreezeByteArray# mba# s# of + (# s'#, ba# #) -> (# s'#, SBS ba# #) +{-# INLINE genShortByteStringIO #-} + +-- | Same as 'genShortByteStringIO', but runs in 'ST'. +-- +-- @since 1.2.0 +genShortByteStringST :: Int -> ST s Word64 -> ST s ShortByteString +genShortByteStringST n action = + unsafeIOToST (genShortByteStringIO n (unsafeSTToIO action)) + + +-- | Generates a pseudo-random 'ByteString' of the specified size. +-- +-- @since 1.2.0 +{-# INLINE uniformByteStringM #-} +uniformByteStringM :: StatefulGen g m => Int -> g -> m ByteString +uniformByteStringM n g = do + ba <- uniformShortByteString n g + pure $ +#if __GLASGOW_HASKELL__ < 802 + fromShort ba +#else + let !(SBS ba#) = ba in + if isTrue# (isByteArrayPinned# ba#) + then pinnedByteArrayToByteString ba# + else fromShort ba + +pinnedByteArrayToByteString :: ByteArray# -> ByteString +pinnedByteArrayToByteString ba# = + PS (pinnedByteArrayToForeignPtr ba#) 0 (I# (sizeofByteArray# ba#)) +{-# INLINE pinnedByteArrayToByteString #-} + +pinnedByteArrayToForeignPtr :: ByteArray# -> ForeignPtr a +pinnedByteArrayToForeignPtr ba# = + ForeignPtr (byteArrayContents# ba#) (PlainPtr (unsafeCoerce# ba#)) +{-# INLINE pinnedByteArrayToForeignPtr #-} +#endif + + +-- | Opaque data type that carries the type of a pure pseudo-random number +-- generator. +-- +-- @since 1.2.0 +data StateGenM g = StateGenM + +-- | Wrapper for pure state gen, which acts as an immutable seed for the corresponding +-- stateful generator `StateGenM` +-- +-- @since 1.2.0 +newtype StateGen g = StateGen { unStateGen :: g } + deriving (Eq, Ord, Show, RandomGen, Storable, NFData) + +instance (RandomGen g, MonadState g m) => StatefulGen (StateGenM g) m where + uniformWord32R r _ = state (genWord32R r) + uniformWord64R r _ = state (genWord64R r) + uniformWord8 _ = state genWord8 + uniformWord16 _ = state genWord16 + uniformWord32 _ = state genWord32 + uniformWord64 _ = state genWord64 + uniformShortByteString n _ = state (genShortByteString n) + +instance (RandomGen g, MonadState g m) => FrozenGen (StateGen g) m where + type MutableGen (StateGen g) m = StateGenM g + freezeGen _ = fmap StateGen get + thawGen (StateGen g) = StateGenM <$ put g + +-- | Splits a pseudo-random number generator into two. Updates the state with +-- one of the resulting generators and returns the other. +-- +-- @since 1.2.0 +splitGen :: (MonadState g m, RandomGen g) => m g +splitGen = state split + +-- | Runs a monadic generating action in the `State` monad using a pure +-- pseudo-random number generator. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> let pureGen = mkStdGen 137 +-- >>> runStateGen pureGen randomM :: (Int, StdGen) +-- (7879794327570578227,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627}) +-- +-- @since 1.2.0 +runStateGen :: RandomGen g => g -> (StateGenM g -> State g a) -> (a, g) +runStateGen g f = runState (f StateGenM) g + +-- | Runs a monadic generating action in the `State` monad using a pure +-- pseudo-random number generator. Returns only the resulting pseudo-random +-- value. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> let pureGen = mkStdGen 137 +-- >>> runStateGen_ pureGen randomM :: Int +-- 7879794327570578227 +-- +-- @since 1.2.0 +runStateGen_ :: RandomGen g => g -> (StateGenM g -> State g a) -> a +runStateGen_ g = fst . runStateGen g + +-- | Runs a monadic generating action in the `StateT` monad using a pure +-- pseudo-random number generator. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> let pureGen = mkStdGen 137 +-- >>> runStateGenT pureGen randomM :: IO (Int, StdGen) +-- (7879794327570578227,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627}) +-- +-- @since 1.2.0 +runStateGenT :: RandomGen g => g -> (StateGenM g -> StateT g m a) -> m (a, g) +runStateGenT g f = runStateT (f StateGenM) g + +-- | Runs a monadic generating action in the `StateT` monad using a pure +-- pseudo-random number generator. Returns only the resulting pseudo-random +-- value. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> let pureGen = mkStdGen 137 +-- >>> runStateGenT_ pureGen randomM :: IO Int +-- 7879794327570578227 +-- +-- @since 1.2.0 +runStateGenT_ :: (RandomGen g, Functor f) => g -> (StateGenM g -> StateT g f a) -> f a +runStateGenT_ g = fmap fst . runStateGenT g + +-- | Runs a monadic generating action in the `ST` monad using a pure +-- pseudo-random number generator. +-- +-- @since 1.2.0 +runStateGenST :: RandomGen g => g -> (forall s . StateGenM g -> StateT g (ST s) a) -> (a, g) +runStateGenST g action = runST $ runStateGenT g action +{-# INLINE runStateGenST #-} + + +-- | The standard pseudo-random number generator. +newtype StdGen = StdGen { unStdGen :: SM.SMGen } + deriving (Show, RandomGen, NFData) + +instance Eq StdGen where + StdGen x1 == StdGen x2 = SM.unseedSMGen x1 == SM.unseedSMGen x2 + +instance RandomGen SM.SMGen where + next = SM.nextInt + genWord32 = SM.nextWord32 + genWord64 = SM.nextWord64 + split = SM.splitSMGen + +instance RandomGen SM32.SMGen where + next = SM32.nextInt + genWord32 = SM32.nextWord32 + genWord64 = SM32.nextWord64 + split = SM32.splitSMGen + +-- | Constructs a 'StdGen' deterministically. +mkStdGen :: Int -> StdGen +mkStdGen = StdGen . SM.mkSMGen . fromIntegral + +-- | The class of types for which a uniformly distributed value can be drawn +-- from all possible values of the type. +-- +-- @since 1.2.0 +class Uniform a where + -- | Generates a value uniformly distributed over all possible values of that + -- type. + -- + -- @since 1.2.0 + uniformM :: StatefulGen g m => g -> m a + +-- | The class of types for which a uniformly distributed value can be drawn +-- from a range. +-- +-- @since 1.2.0 +class UniformRange a where + -- | Generates a value uniformly distributed over the provided range, which + -- is interpreted as inclusive in the lower and upper bound. + -- + -- * @uniformRM (1 :: Int, 4 :: Int)@ generates values uniformly from the + -- set \(\{1,2,3,4\}\) + -- + -- * @uniformRM (1 :: Float, 4 :: Float)@ generates values uniformly from + -- the set \(\{x\;|\;1 \le x \le 4\}\) + -- + -- The following law should hold to make the function always defined: + -- + -- > uniformRM (a, b) = uniformRM (b, a) + -- + -- @since 1.2.0 + uniformRM :: StatefulGen g m => (a, a) -> g -> m a + +instance UniformRange Integer where + uniformRM = uniformIntegralM + +instance UniformRange Natural where + uniformRM = uniformIntegralM + +instance Uniform Int8 where + uniformM = fmap (fromIntegral :: Word8 -> Int8) . uniformWord8 +instance UniformRange Int8 where + uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int8 -> Word8) fromIntegral + +instance Uniform Int16 where + uniformM = fmap (fromIntegral :: Word16 -> Int16) . uniformWord16 +instance UniformRange Int16 where + uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int16 -> Word16) fromIntegral + {-# INLINE uniformRM #-} + +instance Uniform Int32 where + uniformM = fmap (fromIntegral :: Word32 -> Int32) . uniformWord32 +instance UniformRange Int32 where + uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int32 -> Word32) fromIntegral + {-# INLINE uniformRM #-} + +instance Uniform Int64 where + uniformM = fmap (fromIntegral :: Word64 -> Int64) . uniformWord64 +instance UniformRange Int64 where + uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int64 -> Word64) fromIntegral + {-# INLINE uniformRM #-} + +wordSizeInBits :: Int +wordSizeInBits = finiteBitSize (0 :: Word) + +instance Uniform Int where + uniformM + | wordSizeInBits == 64 = + fmap (fromIntegral :: Word64 -> Int) . uniformWord64 + | otherwise = + fmap (fromIntegral :: Word32 -> Int) . uniformWord32 + +instance UniformRange Int where + uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int -> Word) fromIntegral + {-# INLINE uniformRM #-} + +instance Uniform Word where + uniformM + | wordSizeInBits == 64 = + fmap (fromIntegral :: Word64 -> Word) . uniformWord64 + | otherwise = + fmap (fromIntegral :: Word32 -> Word) . uniformWord32 + +instance UniformRange Word where + {-# INLINE uniformRM #-} + uniformRM = unsignedBitmaskWithRejectionRM + +instance Uniform Word8 where + {-# INLINE uniformM #-} + uniformM = uniformWord8 +instance UniformRange Word8 where + {-# INLINE uniformRM #-} + uniformRM = unbiasedWordMult32RM + +instance Uniform Word16 where + {-# INLINE uniformM #-} + uniformM = uniformWord16 +instance UniformRange Word16 where + {-# INLINE uniformRM #-} + uniformRM = unbiasedWordMult32RM + +instance Uniform Word32 where + {-# INLINE uniformM #-} + uniformM = uniformWord32 +instance UniformRange Word32 where + {-# INLINE uniformRM #-} + uniformRM = unbiasedWordMult32RM + +instance Uniform Word64 where + {-# INLINE uniformM #-} + uniformM = uniformWord64 +instance UniformRange Word64 where + {-# INLINE uniformRM #-} + uniformRM = unsignedBitmaskWithRejectionRM + +#if __GLASGOW_HASKELL__ >= 802 +instance Uniform CBool where + uniformM = fmap CBool . uniformM +instance UniformRange CBool where + uniformRM (CBool b, CBool t) = fmap CBool . uniformRM (b, t) + {-# INLINE uniformRM #-} +#endif + +instance Uniform CChar where + uniformM = fmap CChar . uniformM +instance UniformRange CChar where + uniformRM (CChar b, CChar t) = fmap CChar . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CSChar where + uniformM = fmap CSChar . uniformM +instance UniformRange CSChar where + uniformRM (CSChar b, CSChar t) = fmap CSChar . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CUChar where + uniformM = fmap CUChar . uniformM +instance UniformRange CUChar where + uniformRM (CUChar b, CUChar t) = fmap CUChar . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CShort where + uniformM = fmap CShort . uniformM +instance UniformRange CShort where + uniformRM (CShort b, CShort t) = fmap CShort . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CUShort where + uniformM = fmap CUShort . uniformM +instance UniformRange CUShort where + uniformRM (CUShort b, CUShort t) = fmap CUShort . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CInt where + uniformM = fmap CInt . uniformM +instance UniformRange CInt where + uniformRM (CInt b, CInt t) = fmap CInt . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CUInt where + uniformM = fmap CUInt . uniformM +instance UniformRange CUInt where + uniformRM (CUInt b, CUInt t) = fmap CUInt . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CLong where + uniformM = fmap CLong . uniformM +instance UniformRange CLong where + uniformRM (CLong b, CLong t) = fmap CLong . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CULong where + uniformM = fmap CULong . uniformM +instance UniformRange CULong where + uniformRM (CULong b, CULong t) = fmap CULong . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CPtrdiff where + uniformM = fmap CPtrdiff . uniformM +instance UniformRange CPtrdiff where + uniformRM (CPtrdiff b, CPtrdiff t) = fmap CPtrdiff . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CSize where + uniformM = fmap CSize . uniformM +instance UniformRange CSize where + uniformRM (CSize b, CSize t) = fmap CSize . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CWchar where + uniformM = fmap CWchar . uniformM +instance UniformRange CWchar where + uniformRM (CWchar b, CWchar t) = fmap CWchar . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CSigAtomic where + uniformM = fmap CSigAtomic . uniformM +instance UniformRange CSigAtomic where + uniformRM (CSigAtomic b, CSigAtomic t) = fmap CSigAtomic . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CLLong where + uniformM = fmap CLLong . uniformM +instance UniformRange CLLong where + uniformRM (CLLong b, CLLong t) = fmap CLLong . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CULLong where + uniformM = fmap CULLong . uniformM +instance UniformRange CULLong where + uniformRM (CULLong b, CULLong t) = fmap CULLong . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CIntPtr where + uniformM = fmap CIntPtr . uniformM +instance UniformRange CIntPtr where + uniformRM (CIntPtr b, CIntPtr t) = fmap CIntPtr . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CUIntPtr where + uniformM = fmap CUIntPtr . uniformM +instance UniformRange CUIntPtr where + uniformRM (CUIntPtr b, CUIntPtr t) = fmap CUIntPtr . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CIntMax where + uniformM = fmap CIntMax . uniformM +instance UniformRange CIntMax where + uniformRM (CIntMax b, CIntMax t) = fmap CIntMax . uniformRM (b, t) + {-# INLINE uniformRM #-} + +instance Uniform CUIntMax where + uniformM = fmap CUIntMax . uniformM +instance UniformRange CUIntMax where + uniformRM (CUIntMax b, CUIntMax t) = fmap CUIntMax . uniformRM (b, t) + {-# INLINE uniformRM #-} + +-- | See [Floating point number caveats](System-Random-Stateful.html#fpcaveats). +instance UniformRange CFloat where + uniformRM (CFloat l, CFloat h) = fmap CFloat . uniformRM (l, h) + {-# INLINE uniformRM #-} + +-- | See [Floating point number caveats](System-Random-Stateful.html#fpcaveats). +instance UniformRange CDouble where + uniformRM (CDouble l, CDouble h) = fmap CDouble . uniformRM (l, h) + {-# INLINE uniformRM #-} + + +-- The `chr#` and `ord#` are the prim functions that will be called, regardless of which +-- way you gonna do the `Char` conversion, so it is better to call them directly and +-- bypass all the hoops. Also because `intToChar` and `charToInt` are internal functions +-- and are called on valid character ranges it is impossible to generate an invalid +-- `Char`, therefore it is totally fine to omit all the unnecessary checks involved in +-- other paths of conversion. +word32ToChar :: Word32 -> Char +word32ToChar (W32# w#) = C# (chr# (word2Int# w#)) +{-# INLINE word32ToChar #-} + +charToWord32 :: Char -> Word32 +charToWord32 (C# c#) = W32# (int2Word# (ord# c#)) +{-# INLINE charToWord32 #-} + +instance Uniform Char where + uniformM g = word32ToChar <$> unbiasedWordMult32 (charToWord32 maxBound) g + {-# INLINE uniformM #-} +instance UniformRange Char where + uniformRM (l, h) g = + word32ToChar <$> unbiasedWordMult32RM (charToWord32 l, charToWord32 h) g + {-# INLINE uniformRM #-} + +instance Uniform Bool where + uniformM = fmap wordToBool . uniformWord8 + where wordToBool w = (w .&. 1) /= 0 +instance UniformRange Bool where + uniformRM (False, False) _g = return False + uniformRM (True, True) _g = return True + uniformRM _ g = uniformM g + +-- | See [Floating point number caveats](System-Random-Stateful.html#fpcaveats). +instance UniformRange Double where + uniformRM (l, h) g + | l == h = return l + | otherwise = do + x <- uniformDouble01M g + return $ x * l + (1 -x) * h + +-- | Generates uniformly distributed 'Double' in the range \([0, 1]\). +-- Numbers are generated by generating uniform 'Word64' and dividing +-- it by \(2^{64}\). It's used to implement 'UniformR' instance for +-- 'Double'. +-- +-- @since 1.2.0 +uniformDouble01M :: StatefulGen g m => g -> m Double +uniformDouble01M g = do + w64 <- uniformWord64 g + return $ fromIntegral w64 / m + where + m = fromIntegral (maxBound :: Word64) :: Double + +-- | Generates uniformly distributed 'Double' in the range +-- \((0, 1]\). Number is generated as \(2^{-64}/2+\operatorname{uniformDouble01M}\). +-- Constant is 1\/2 of smallest nonzero value which could be generated +-- by 'uniformDouble01M'. +-- +-- @since 1.2.0 +uniformDoublePositive01M :: StatefulGen g m => g -> m Double +uniformDoublePositive01M g = (+ d) <$> uniformDouble01M g + where + -- We add small constant to shift generated value from zero. It's + -- selected as 1/2 of smallest possible nonzero value + d = 2.710505431213761e-20 -- 2**(-65) + +-- | See [Floating point number caveats](System-Random-Stateful.html#fpcaveats). +instance UniformRange Float where + uniformRM (l, h) g + | l == h = return l + | otherwise = do + x <- uniformFloat01M g + return $ x * l + (1 - x) * h + +-- | Generates uniformly distributed 'Float' in the range \([0, 1]\). +-- Numbers are generated by generating uniform 'Word32' and dividing +-- it by \(2^{32}\). It's used to implement 'UniformR' instance for 'Float' +-- +-- @since 1.2.0 +uniformFloat01M :: StatefulGen g m => g -> m Float +uniformFloat01M g = do + w32 <- uniformWord32 g + return $ fromIntegral w32 / m + where + m = fromIntegral (maxBound :: Word32) :: Float + +-- | Generates uniformly distributed 'Float' in the range +-- \((0, 1]\). Number is generated as \(2^{-32}/2+\operatorname{uniformFloat01M}\). +-- Constant is 1\/2 of smallest nonzero value which could be generated +-- by 'uniformFloat01M'. +-- +-- @since 1.2.0 +uniformFloatPositive01M :: StatefulGen g m => g -> m Float +uniformFloatPositive01M g = (+ d) <$> uniformFloat01M g + where + -- See uniformDoublePositive01M + d = 1.1641532182693481e-10 -- 2**(-33) + +-- The two integer functions below take an [inclusive,inclusive] range. +randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g) +randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h) + +{-# SPECIALIZE randomIvalInteger :: (Num a) => + (Integer, Integer) -> StdGen -> (a, StdGen) #-} + +randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) +randomIvalInteger (l,h) rng + | l > h = randomIvalInteger (h,l) rng + | otherwise = case f 1 0 rng of (v, rng') -> (fromInteger (l + v `mod` k), rng') + where + (genlo, genhi) = genRange rng + b = fromIntegral genhi - fromIntegral genlo + 1 :: Integer + + -- Probabilities of the most likely and least likely result + -- will differ at most by a factor of (1 +- 1/q). Assuming the RandomGen + -- is uniform, of course + + -- On average, log q / log b more pseudo-random values will be generated + -- than the minimum + q = 1000 :: Integer + k = h - l + 1 + magtgt = k * q + + -- generate pseudo-random values until we exceed the target magnitude + f mag v g | mag >= magtgt = (v, g) + | otherwise = v' `seq`f (mag*b) v' g' where + (x,g') = next g + v' = v * b + (fromIntegral x - fromIntegral genlo) + +-- | Generate an integral in the range @[l, h]@ if @l <= h@ and @[h, l]@ +-- otherwise. +uniformIntegralM :: (Bits a, Integral a, StatefulGen g m) => (a, a) -> g -> m a +uniformIntegralM (l, h) gen = case l `compare` h of + LT -> do + let limit = h - l + bounded <- case toIntegralSized limit :: Maybe Word64 of + Just limitAsWord64 -> + -- Optimisation: if 'limit' fits into 'Word64', generate a bounded + -- 'Word64' and then convert to 'Integer' + fromIntegral <$> unsignedBitmaskWithRejectionM uniformWord64 limitAsWord64 gen + Nothing -> boundedExclusiveIntegralM (limit + 1) gen + return $ l + bounded + GT -> uniformIntegralM (h, l) gen + EQ -> pure l +{-# INLINEABLE uniformIntegralM #-} + +-- | Generate an integral in the range @[0, s)@ using a variant of Lemire's +-- multiplication method. +-- +-- Daniel Lemire. 2019. Fast Random Integer Generation in an Interval. In ACM +-- Transactions on Modeling and Computer Simulation +-- https://doi.org/10.1145/3230636 +-- +-- PRECONDITION (unchecked): s > 0 +boundedExclusiveIntegralM :: forall a g m . (Bits a, Integral a, StatefulGen g m) => a -> g -> m a +boundedExclusiveIntegralM s gen = go + where + n = integralWordSize s + -- We renamed 'L' from the paper to 'k' here because 'L' is not a valid + -- variable name in Haskell and 'l' is already used in the algorithm. + k = wordSizeInBits * n + twoToK = (1 :: a) `shiftL` k + modTwoToKMask = twoToK - 1 + + t = (twoToK - s) `rem` s -- `rem`, instead of `mod` because `twoToK >= s` is guaranteed + go :: (Bits a, Integral a, StatefulGen g m) => m a + go = do + x <- uniformIntegralWords n gen + let m = x * s + -- m .&. modTwoToKMask == m `mod` twoToK + let l = m .&. modTwoToKMask + if l < t + then go + -- m `shiftR` k == m `quot` twoToK + else return $ m `shiftR` k +{-# INLINE boundedExclusiveIntegralM #-} + +-- | @integralWordSize i@ returns that least @w@ such that +-- @i <= WORD_SIZE_IN_BITS^w@. +integralWordSize :: (Bits a, Num a) => a -> Int +integralWordSize = go 0 + where + go !acc i + | i == 0 = acc + | otherwise = go (acc + 1) (i `shiftR` wordSizeInBits) +{-# INLINE integralWordSize #-} + +-- | @uniformIntegralWords n@ is a uniformly pseudo-random integral in the range +-- @[0, WORD_SIZE_IN_BITS^n)@. +uniformIntegralWords :: (Bits a, Integral a, StatefulGen g m) => Int -> g -> m a +uniformIntegralWords n gen = go 0 n + where + go !acc i + | i == 0 = return acc + | otherwise = do + (w :: Word) <- uniformM gen + go ((acc `shiftL` wordSizeInBits) .|. fromIntegral w) (i - 1) +{-# INLINE uniformIntegralWords #-} + +-- | Uniformly generate an 'Integral' in an inclusive-inclusive range. +-- +-- Only use for integrals size less than or equal to that of 'Word32'. +unbiasedWordMult32RM :: (StatefulGen g m, Integral a) => (a, a) -> g -> m a +unbiasedWordMult32RM (b, t) g + | b <= t = (+b) . fromIntegral <$> unbiasedWordMult32 (fromIntegral (t - b)) g + | otherwise = (+t) . fromIntegral <$> unbiasedWordMult32 (fromIntegral (b - t)) g +{-# SPECIALIZE unbiasedWordMult32RM :: StatefulGen g m => (Word8, Word8) -> g -> m Word8 #-} + +-- | Uniformly generate Word32 in @[0, s]@. +unbiasedWordMult32 :: StatefulGen g m => Word32 -> g -> m Word32 +unbiasedWordMult32 s g + | s == maxBound = uniformWord32 g + | otherwise = unbiasedWordMult32Exclusive (s+1) g +{-# INLINE unbiasedWordMult32 #-} + +-- | See [Lemire's paper](https://arxiv.org/pdf/1805.10941.pdf), +-- [O\'Neill's +-- blogpost](https://www.pcg-random.org/posts/bounded-rands.html) and +-- more directly [O\'Neill's github +-- repo](https://github.com/imneme/bounded-rands/blob/3d71f53c975b1e5b29f2f3b05a74e26dab9c3d84/bounded32.cpp#L234). +-- N.B. The range is [0,r) **not** [0,r]. +unbiasedWordMult32Exclusive :: forall g m . StatefulGen g m => Word32 -> g -> m Word32 +unbiasedWordMult32Exclusive r g = go + where + t :: Word32 + t = (-r) `mod` r -- Calculates 2^32 `mod` r!!! + go :: StatefulGen g m => m Word32 + go = do + x <- uniformWord32 g + let m :: Word64 + m = fromIntegral x * fromIntegral r + l :: Word32 + l = fromIntegral m + if l >= t then return (fromIntegral $ m `shiftR` 32) else go + +-- | This only works for unsigned integrals +unsignedBitmaskWithRejectionRM :: + (StatefulGen g m, FiniteBits a, Num a, Ord a, Uniform a) + => (a, a) + -> g + -> m a +unsignedBitmaskWithRejectionRM (bottom, top) gen + | bottom == top = pure top + | otherwise = (b +) <$> unsignedBitmaskWithRejectionM uniformM r gen + where + (b, r) = if bottom > top then (top, bottom - top) else (bottom, top - bottom) +{-# INLINE unsignedBitmaskWithRejectionRM #-} + +-- | This works for signed integrals by explicit conversion to unsigned and abusing +-- overflow. It uses `unsignedBitmaskWithRejectionM`, therefore it requires functions that +-- take the value to unsigned and back. +signedBitmaskWithRejectionRM :: + (Num a, Num b, Ord b, Ord a, FiniteBits a, StatefulGen g f, Uniform a) + => (b -> a) -- ^ Convert signed to unsigned. @a@ and @b@ must be of the same size. + -> (a -> b) -- ^ Convert unsigned to signed. @a@ and @b@ must be of the same size. + -> (b, b) -- ^ Range. + -> g -- ^ Generator. + -> f b +signedBitmaskWithRejectionRM toUnsigned fromUnsigned (bottom, top) gen + | bottom == top = pure top + | otherwise = + (b +) . fromUnsigned <$> unsignedBitmaskWithRejectionM uniformM r gen + -- This works in all cases, see Appendix 1 at the end of the file. + where + (b, r) = + if bottom > top + then (top, toUnsigned bottom - toUnsigned top) + else (bottom, toUnsigned top - toUnsigned bottom) +{-# INLINE signedBitmaskWithRejectionRM #-} + + +-- | Detailed explanation about the algorithm employed here can be found in this post: +-- http://web.archive.org/web/20200520071940/https://www.pcg-random.org/posts/bounded-rands.html +unsignedBitmaskWithRejectionM :: + forall a g m . (Ord a, FiniteBits a, Num a, StatefulGen g m) => (g -> m a) -> a -> g -> m a +unsignedBitmaskWithRejectionM genUniformM range gen = go + where + mask :: a + mask = complement zeroBits `shiftR` countLeadingZeros (range .|. 1) + go = do + x <- genUniformM gen + let x' = x .&. mask + if x' > range + then go + else pure x' +{-# INLINE unsignedBitmaskWithRejectionM #-} + +------------------------------------------------------------------------------- +-- 'Uniform' instances for tuples +------------------------------------------------------------------------------- + +instance (Uniform a, Uniform b) => Uniform (a, b) where + uniformM g = (,) <$> uniformM g <*> uniformM g + +instance (Uniform a, Uniform b, Uniform c) => Uniform (a, b, c) where + uniformM g = (,,) <$> uniformM g <*> uniformM g <*> uniformM g + +instance (Uniform a, Uniform b, Uniform c, Uniform d) => Uniform (a, b, c, d) where + uniformM g = (,,,) <$> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g + +instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e) => Uniform (a, b, c, d, e) where + uniformM g = (,,,,) <$> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g + +instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e, Uniform f) => Uniform (a, b, c, d, e, f) where + uniformM g = (,,,,,) <$> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g + +instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e, Uniform f, Uniform g) => Uniform (a, b, c, d, e, f, g) where + uniformM g = (,,,,,,) <$> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g + +-- Appendix 1. +-- +-- @top@ and @bottom@ are signed integers of bit width @n@. @toUnsigned@ +-- converts a signed integer to an unsigned number of the same bit width @n@. +-- +-- range = toUnsigned top - toUnsigned bottom +-- +-- This works out correctly thanks to modular arithmetic. Conceptually, +-- +-- toUnsigned x | x >= 0 = x +-- toUnsigned x | x < 0 = 2^n + x +-- +-- The following combinations are possible: +-- +-- 1. @bottom >= 0@ and @top >= 0@ +-- 2. @bottom < 0@ and @top >= 0@ +-- 3. @bottom < 0@ and @top < 0@ +-- +-- Note that @bottom >= 0@ and @top < 0@ is impossible because of the +-- invariant @bottom < top@. +-- +-- For any signed integer @i@ of width @n@, we have: +-- +-- -2^(n-1) <= i <= 2^(n-1) - 1 +-- +-- Considering each combination in turn, we have +-- +-- 1. @bottom >= 0@ and @top >= 0@ +-- +-- range = (toUnsigned top - toUnsigned bottom) `mod` 2^n +-- --^ top >= 0, so toUnsigned top == top +-- --^ bottom >= 0, so toUnsigned bottom == bottom +-- = (top - bottom) `mod` 2^n +-- --^ top <= 2^(n-1) - 1 and bottom >= 0 +-- --^ top - bottom <= 2^(n-1) - 1 +-- --^ 0 < top - bottom <= 2^(n-1) - 1 +-- = top - bottom +-- +-- 2. @bottom < 0@ and @top >= 0@ +-- +-- range = (toUnsigned top - toUnsigned bottom) `mod` 2^n +-- --^ top >= 0, so toUnsigned top == top +-- --^ bottom < 0, so toUnsigned bottom == 2^n + bottom +-- = (top - (2^n + bottom)) `mod` 2^n +-- --^ summand -2^n cancels out in calculation modulo 2^n +-- = (top - bottom) `mod` 2^n +-- --^ top <= 2^(n-1) - 1 and bottom >= -2^(n-1) +-- --^ top - bottom <= (2^(n-1) - 1) - (-2^(n-1)) = 2^n - 1 +-- --^ 0 < top - bottom <= 2^n - 1 +-- = top - bottom +-- +-- 3. @bottom < 0@ and @top < 0@ +-- +-- range = (toUnsigned top - toUnsigned bottom) `mod` 2^n +-- --^ top < 0, so toUnsigned top == 2^n + top +-- --^ bottom < 0, so toUnsigned bottom == 2^n + bottom +-- = ((2^n + top) - (2^n + bottom)) `mod` 2^n +-- --^ summand 2^n cancels out in calculation modulo 2^n +-- = (top - bottom) `mod` 2^n +-- --^ top <= -1 +-- --^ bottom >= -2^(n-1) +-- --^ top - bottom <= -1 - (-2^(n-1)) = 2^(n-1) - 1 +-- --^ 0 < top - bottom <= 2^(n-1) - 1 +-- = top - bottom diff --git a/src/System/Random/Stateful.hs b/src/System/Random/Stateful.hs new file mode 100644 --- /dev/null +++ b/src/System/Random/Stateful.hs @@ -0,0 +1,721 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : System.Random.Stateful +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE in the 'random' repository) +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- +-- This library deals with the common task of pseudo-random number generation. +module System.Random.Stateful + ( + -- * Pure Random Generator + module System.Random + -- * Monadic Random Generator + -- $introduction + + -- * Usage + -- $usagemonadic + + -- * Mutable pseudo-random number generator interfaces + -- $interfaces + , StatefulGen(..) + , FrozenGen(..) + , RandomGenM(..) + , withMutableGen + , withMutableGen_ + , randomM + , randomRM + , splitGenM + + -- * Monadic adapters for pure pseudo-random number generators #monadicadapters# + -- $monadicadapters + + -- ** Pure adapter + , StateGen(..) + , StateGenM(..) + , runStateGen + , runStateGen_ + , runStateGenT + , runStateGenT_ + , runStateGenST + -- ** Mutable adapter with atomic operations + , AtomicGen(..) + , AtomicGenM(..) + , newAtomicGenM + , applyAtomicGen + -- ** Mutable adapter in 'IO' + , IOGen(..) + , IOGenM(..) + , newIOGenM + , applyIOGen + -- ** Mutable adapter in 'ST' + , STGen(..) + , STGenM(..) + , newSTGenM + , applySTGen + , runSTGen + , runSTGen_ + + -- * Pseudo-random values of various types + -- $uniform + , Uniform(..) + , uniformListM + , UniformRange(..) + + -- * Generators for sequences of pseudo-random bytes + , genShortByteStringIO + , genShortByteStringST + , uniformByteStringM + , uniformDouble01M + , uniformDoublePositive01M + , uniformFloat01M + , uniformFloatPositive01M + + -- * Appendix + + -- ** How to implement 'StatefulGen' + -- $implementmonadrandom + + -- ** Floating point number caveats #fpcaveats# + -- $floating + + -- * References + -- $references + ) where + +import Control.DeepSeq +import Control.Monad.IO.Class +import Control.Monad.ST +import Control.Monad.State.Strict +import Data.IORef +import Data.STRef +import Foreign.Storable +import System.Random +import System.Random.Internal + +-- $introduction +-- +-- This module provides type classes and instances for the following concepts: +-- +-- [Monadic pseudo-random number generators] 'StatefulGen' is an interface to +-- monadic pseudo-random number generators. +-- +-- [Monadic adapters] 'StateGenM', 'AtomicGenM', 'IOGenM' and 'STGenM' turn a +-- 'RandomGen' instance into a 'StatefulGen' instance. +-- +-- [Drawing from a range] 'UniformRange' is used to generate a value of a +-- type uniformly within a range. +-- +-- This library provides instances of 'UniformRange' for many common +-- numeric types. +-- +-- [Drawing from the entire domain of a type] 'Uniform' is used to generate a +-- value of a type uniformly over all possible values of that type. +-- +-- This library provides instances of 'Uniform' for many common bounded +-- numeric types. +-- +-- $usagemonadic +-- +-- In monadic code, use the relevant 'Uniform' and 'UniformRange' instances to +-- generate pseudo-random values via 'uniformM' and 'uniformRM', respectively. +-- +-- As an example, @rollsM@ generates @n@ pseudo-random values of @Word@ in the +-- range @[1, 6]@ in a 'StatefulGen' context; given a /monadic/ pseudo-random +-- number generator, you can run this probabilistic computation as follows: +-- +-- >>> :{ +-- let rollsM :: StatefulGen g m => Int -> g -> m [Word] +-- rollsM n = replicateM n . uniformRM (1, 6) +-- in do +-- monadicGen <- MWC.create +-- rollsM 10 monadicGen :: IO [Word] +-- :} +-- [3,4,3,1,4,6,1,6,1,4] +-- +-- Given a /pure/ pseudo-random number generator, you can run the monadic +-- pseudo-random number computation @rollsM@ in an 'IO' or 'ST' context by +-- applying a monadic adapter like 'AtomicGenM', 'IOGenM' or 'STGenM' +-- (see [monadic-adapters](#monadicadapters)) to the pure pseudo-random number +-- generator. +-- +-- >>> :{ +-- let rollsM :: StatefulGen g m => Int -> g -> m [Word] +-- rollsM n = replicateM n . uniformRM (1, 6) +-- pureGen = mkStdGen 42 +-- in +-- newIOGenM pureGen >>= rollsM 10 :: IO [Word] +-- :} +-- [1,1,3,2,4,5,3,4,6,2] + +------------------------------------------------------------------------------- +-- Pseudo-random number generator interfaces +------------------------------------------------------------------------------- + +-- $interfaces +-- +-- Pseudo-random number generators come in two flavours: /pure/ and /monadic/. +-- +-- ['System.Random.RandomGen': pure pseudo-random number generators] +-- See "System.Random" module. +-- +-- ['StatefulGen': monadic pseudo-random number generators] These generators +-- mutate their own state as they produce pseudo-random values. They +-- generally live in 'ST' or 'IO' or some transformer that implements +-- @PrimMonad@. +-- + +------------------------------------------------------------------------------- +-- Monadic adapters +------------------------------------------------------------------------------- + +-- $monadicadapters +-- +-- Pure pseudo-random number generators can be used in monadic code via the +-- adapters 'StateGenM', 'AtomicGenM', 'IOGenM' and 'STGenM'. +-- +-- * 'StateGenM' can be used in any state monad. With strict 'StateT' there is +-- no performance overhead compared to using the 'RandomGen' instance +-- directly. 'StateGenM' is /not/ safe to use in the presence of exceptions +-- and concurrency. +-- +-- * 'AtomicGenM' is safe in the presence of exceptions and concurrency since +-- it performs all actions atomically. +-- +-- * 'IOGenM' is a wrapper around an 'IORef' that holds a pure generator. +-- 'IOGenM' is safe in the presence of exceptions, but not concurrency. +-- +-- * 'STGenM' is a wrapper around an 'STRef' that holds a pure generator. +-- 'STGenM' is safe in the presence of exceptions, but not concurrency. + +-- | Interface to operations on 'RandomGen' wrappers like 'IOGenM' and 'StateGenM'. +-- +-- @since 1.2.0 +class (RandomGen r, StatefulGen g m) => RandomGenM g r m | g -> r where + applyRandomGenM :: (r -> (a, r)) -> g -> m a + +-- | Splits a pseudo-random number generator into two. Overwrites the mutable +-- wrapper with one of the resulting generators and returns the other. +-- +-- @since 1.2.0 +splitGenM :: RandomGenM g r m => g -> m r +splitGenM = applyRandomGenM split + +instance (RandomGen r, MonadIO m) => RandomGenM (IOGenM r) r m where + applyRandomGenM = applyIOGen + +instance (RandomGen r, MonadIO m) => RandomGenM (AtomicGenM r) r m where + applyRandomGenM = applyAtomicGen + +instance (RandomGen r, MonadState r m) => RandomGenM (StateGenM r) r m where + applyRandomGenM f _ = state f + +instance RandomGen r => RandomGenM (STGenM r s) r (ST s) where + applyRandomGenM = applySTGen + + +-- | Runs a mutable pseudo-random number generator from its 'Frozen' state. +-- +-- ====__Examples__ +-- +-- >>> import Data.Int (Int8) +-- >>> withMutableGen (IOGen (mkStdGen 217)) (uniformListM 5) :: IO ([Int8], IOGen StdGen) +-- ([-74,37,-50,-2,3],IOGen {unIOGen = StdGen {unStdGen = SMGen 4273268533320920145 15251669095119325999}}) +-- +-- @since 1.2.0 +withMutableGen :: FrozenGen f m => f -> (MutableGen f m -> m a) -> m (a, f) +withMutableGen fg action = do + g <- thawGen fg + res <- action g + fg' <- freezeGen g + pure (res, fg') + +-- | Same as 'withMutableGen', but only returns the generated value. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> let pureGen = mkStdGen 137 +-- >>> withMutableGen_ (IOGen pureGen) (uniformRM (1 :: Int, 6 :: Int)) +-- 4 +-- +-- @since 1.2.0 +withMutableGen_ :: FrozenGen f m => f -> (MutableGen f m -> m a) -> m a +withMutableGen_ fg action = fst <$> withMutableGen fg action + + +-- | Generates a list of pseudo-random values. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> let pureGen = mkStdGen 137 +-- >>> g <- newIOGenM pureGen +-- >>> uniformListM 10 g :: IO [Bool] +-- [True,True,True,True,False,True,True,False,False,False] +-- +-- @since 1.2.0 +uniformListM :: (StatefulGen g m, Uniform a) => Int -> g -> m [a] +uniformListM n gen = replicateM n (uniformM gen) + +-- | Generates a pseudo-random value using monadic interface and `Random` instance. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> let pureGen = mkStdGen 137 +-- >>> g <- newIOGenM pureGen +-- >>> randomM g :: IO Double +-- 0.5728354935654512 +-- +-- @since 1.2.0 +randomM :: (RandomGenM g r m, Random a) => g -> m a +randomM = applyRandomGenM random + +-- | Generates a pseudo-random value using monadic interface and `Random` instance. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> let pureGen = mkStdGen 137 +-- >>> g <- newIOGenM pureGen +-- >>> randomRM (1, 100) g :: IO Int +-- 52 +-- +-- @since 1.2.0 +randomRM :: (RandomGenM g r m, Random a) => (a, a) -> g -> m a +randomRM r = applyRandomGenM (randomR r) + +-- | Wraps an 'IORef' that holds a pure pseudo-random number generator. All +-- operations are performed atomically. +-- +-- * 'AtomicGenM' is safe in the presence of exceptions and concurrency. +-- * 'AtomicGenM' is the slowest of the monadic adapters due to the overhead +-- of its atomic operations. +-- +-- @since 1.2.0 +newtype AtomicGenM g = AtomicGenM { unAtomicGenM :: IORef g} + + +-- | Frozen version of mutable `AtomicGenM` generator +-- +-- @since 1.2.0 +newtype AtomicGen g = AtomicGen { unAtomicGen :: g} + deriving (Eq, Ord, Show, RandomGen, Storable, NFData) + +-- | Creates a new 'AtomicGenM'. +-- +-- @since 1.2.0 +newAtomicGenM :: MonadIO m => g -> m (AtomicGenM g) +newAtomicGenM = fmap AtomicGenM . liftIO . newIORef + +instance (RandomGen g, MonadIO m) => StatefulGen (AtomicGenM g) m where + uniformWord32R r = applyAtomicGen (genWord32R r) + {-# INLINE uniformWord32R #-} + uniformWord64R r = applyAtomicGen (genWord64R r) + {-# INLINE uniformWord64R #-} + uniformWord8 = applyAtomicGen genWord8 + {-# INLINE uniformWord8 #-} + uniformWord16 = applyAtomicGen genWord16 + {-# INLINE uniformWord16 #-} + uniformWord32 = applyAtomicGen genWord32 + {-# INLINE uniformWord32 #-} + uniformWord64 = applyAtomicGen genWord64 + {-# INLINE uniformWord64 #-} + uniformShortByteString n = applyAtomicGen (genShortByteString n) + + +instance (RandomGen g, MonadIO m) => FrozenGen (AtomicGen g) m where + type MutableGen (AtomicGen g) m = AtomicGenM g + freezeGen = fmap AtomicGen . liftIO . readIORef . unAtomicGenM + thawGen (AtomicGen g) = newAtomicGenM g + +-- | Atomically applies a pure operation to the wrapped pseudo-random number +-- generator. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> let pureGen = mkStdGen 137 +-- >>> g <- newAtomicGenM pureGen +-- >>> applyAtomicGen random g :: IO Int +-- 7879794327570578227 +-- +-- @since 1.2.0 +applyAtomicGen :: MonadIO m => (g -> (a, g)) -> (AtomicGenM g) -> m a +applyAtomicGen op (AtomicGenM gVar) = + liftIO $ atomicModifyIORef' gVar $ \g -> + case op g of + (a, g') -> (g', a) +{-# INLINE applyAtomicGen #-} + +-- | Wraps an 'IORef' that holds a pure pseudo-random number generator. +-- +-- * 'IOGenM' is safe in the presence of exceptions, but not concurrency. +-- * 'IOGenM' is slower than 'StateGenM' due to the extra pointer indirection. +-- * 'IOGenM' is faster than 'AtomicGenM' since the 'IORef' operations used by +-- 'IOGenM' are not atomic. +-- +-- An example use case is writing pseudo-random bytes into a file: +-- +-- >>> import UnliftIO.Temporary (withSystemTempFile) +-- >>> import Data.ByteString (hPutStr) +-- >>> let ioGen g = withSystemTempFile "foo.bin" $ \_ h -> uniformRM (0, 100) g >>= flip uniformByteStringM g >>= hPutStr h +-- +-- and then run it: +-- +-- >>> newIOGenM (mkStdGen 1729) >>= ioGen +-- +-- @since 1.2.0 +newtype IOGenM g = IOGenM { unIOGenM :: IORef g } + +-- | Frozen version of mutable `IOGenM` generator +-- +-- @since 1.2.0 +newtype IOGen g = IOGen { unIOGen :: g } + deriving (Eq, Ord, Show, RandomGen, Storable, NFData) + + +-- | Creates a new 'IOGenM'. +-- +-- @since 1.2.0 +newIOGenM :: MonadIO m => g -> m (IOGenM g) +newIOGenM = fmap IOGenM . liftIO . newIORef + +instance (RandomGen g, MonadIO m) => StatefulGen (IOGenM g) m where + uniformWord32R r = applyIOGen (genWord32R r) + {-# INLINE uniformWord32R #-} + uniformWord64R r = applyIOGen (genWord64R r) + {-# INLINE uniformWord64R #-} + uniformWord8 = applyIOGen genWord8 + {-# INLINE uniformWord8 #-} + uniformWord16 = applyIOGen genWord16 + {-# INLINE uniformWord16 #-} + uniformWord32 = applyIOGen genWord32 + {-# INLINE uniformWord32 #-} + uniformWord64 = applyIOGen genWord64 + {-# INLINE uniformWord64 #-} + uniformShortByteString n = applyIOGen (genShortByteString n) + + +instance (RandomGen g, MonadIO m) => FrozenGen (IOGen g) m where + type MutableGen (IOGen g) m = IOGenM g + freezeGen = fmap IOGen . liftIO . readIORef . unIOGenM + thawGen (IOGen g) = newIOGenM g + + +-- | Applies a pure operation to the wrapped pseudo-random number generator. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> let pureGen = mkStdGen 137 +-- >>> g <- newIOGenM pureGen +-- >>> applyIOGen random g :: IO Int +-- 7879794327570578227 +-- +-- @since 1.2.0 +applyIOGen :: MonadIO m => (g -> (a, g)) -> IOGenM g -> m a +applyIOGen f (IOGenM ref) = liftIO $ do + g <- readIORef ref + case f g of + (!a, !g') -> a <$ writeIORef ref g' +{-# INLINE applyIOGen #-} + +-- | Wraps an 'STRef' that holds a pure pseudo-random number generator. +-- +-- * 'STGenM' is safe in the presence of exceptions, but not concurrency. +-- * 'STGenM' is slower than 'StateGenM' due to the extra pointer indirection. +-- +-- @since 1.2.0 +newtype STGenM g s = STGenM { unSTGenM :: STRef s g } + +-- | Frozen version of mutable `STGenM` generator +-- +-- @since 1.2.0 +newtype STGen g = STGen { unSTGen :: g } + deriving (Eq, Ord, Show, RandomGen, Storable, NFData) + +-- | Creates a new 'STGenM'. +-- +-- @since 1.2.0 +newSTGenM :: g -> ST s (STGenM g s) +newSTGenM = fmap STGenM . newSTRef + + +instance RandomGen g => StatefulGen (STGenM g s) (ST s) where + uniformWord32R r = applySTGen (genWord32R r) + {-# INLINE uniformWord32R #-} + uniformWord64R r = applySTGen (genWord64R r) + {-# INLINE uniformWord64R #-} + uniformWord8 = applySTGen genWord8 + {-# INLINE uniformWord8 #-} + uniformWord16 = applySTGen genWord16 + {-# INLINE uniformWord16 #-} + uniformWord32 = applySTGen genWord32 + {-# INLINE uniformWord32 #-} + uniformWord64 = applySTGen genWord64 + {-# INLINE uniformWord64 #-} + uniformShortByteString n = applySTGen (genShortByteString n) + +instance RandomGen g => FrozenGen (STGen g) (ST s) where + type MutableGen (STGen g) (ST s) = STGenM g s + freezeGen = fmap STGen . readSTRef . unSTGenM + thawGen (STGen g) = newSTGenM g + + +-- | Applies a pure operation to the wrapped pseudo-random number generator. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> let pureGen = mkStdGen 137 +-- >>> (runSTGen pureGen (\g -> applySTGen random g)) :: (Int, StdGen) +-- (7879794327570578227,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627}) +-- +-- @since 1.2.0 +applySTGen :: (g -> (a, g)) -> STGenM g s -> ST s a +applySTGen f (STGenM ref) = do + g <- readSTRef ref + case f g of + (!a, !g') -> a <$ writeSTRef ref g' +{-# INLINE applySTGen #-} + +-- | Runs a monadic generating action in the `ST` monad using a pure +-- pseudo-random number generator. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> let pureGen = mkStdGen 137 +-- >>> (runSTGen pureGen (\g -> applySTGen random g)) :: (Int, StdGen) +-- (7879794327570578227,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627}) +-- +-- @since 1.2.0 +runSTGen :: RandomGen g => g -> (forall s . STGenM g s -> ST s a) -> (a, g) +runSTGen g action = unSTGen <$> runST (withMutableGen (STGen g) action) + +-- | Runs a monadic generating action in the `ST` monad using a pure +-- pseudo-random number generator. Returns only the resulting pseudo-random +-- value. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> let pureGen = mkStdGen 137 +-- >>> (runSTGen_ pureGen (\g -> applySTGen random g)) :: Int +-- 7879794327570578227 +-- +-- @since 1.2.0 +runSTGen_ :: RandomGen g => g -> (forall s . STGenM g s -> ST s a) -> a +runSTGen_ g action = fst $ runSTGen g action + + +-- $uniform +-- +-- This library provides two type classes to generate pseudo-random values: +-- +-- * 'UniformRange' is used to generate a value of a type uniformly within a +-- range. +-- * 'Uniform' is used to generate a value of a type uniformly over all +-- possible values of that type. +-- +-- Types may have instances for both or just one of 'UniformRange' and +-- 'Uniform'. A few examples illustrate this: +-- +-- * 'Int', 'Word16' and 'Bool' are instances of both 'UniformRange' and +-- 'Uniform'. +-- * 'Integer', 'Float' and 'Double' each have an instance for 'UniformRange' +-- but no 'Uniform' instance. +-- * A hypothetical type @Radian@ representing angles by taking values in the +-- range @[0, 2π)@ has a trivial 'Uniform' instance, but no 'UniformRange' +-- instance: the problem is that two given @Radian@ values always span /two/ +-- ranges, one clockwise and one anti-clockwise. +-- * It is trivial to construct a @Uniform (a, b)@ instance given +-- @Uniform a@ and @Uniform b@ (and this library provides this tuple +-- instance). +-- * On the other hand, there is no correct way to construct a +-- @UniformRange (a, b)@ instance based on just @UniformRange a@ and +-- @UniformRange b@. + +------------------------------------------------------------------------------- +-- Notes +------------------------------------------------------------------------------- + +-- $floating +-- +-- The 'UniformRange' instances for 'Float' and 'Double' use the following +-- procedure to generate a random value in a range for @uniformRM (a, b) g@: +-- +-- If \(a = b\), return \(a\). Otherwise: +-- +-- 1. Generate \(x\) uniformly such that \(0 \leq x \leq 1\). +-- +-- The method by which \(x\) is sampled does not cover all representable +-- floating point numbers in the unit interval. The method never generates +-- denormal floating point numbers, for example. +-- +-- 2. Return \(x \cdot a + (1 - x) \cdot b\). +-- +-- Due to rounding errors, floating point operations are neither +-- associative nor distributive the way the corresponding operations on +-- real numbers are. Additionally, floating point numbers admit special +-- values @NaN@ as well as negative and positive infinity. +-- +-- For pathological values, step 2 can yield surprising results. +-- +-- * The result may be greater than @max a b@. +-- +-- >>> :{ +-- let (a, b, x) = (-2.13238e-29, -2.1323799e-29, 0.27736077) +-- result = x * a + (1 - x) * b :: Float +-- in (result, result > max a b) +-- :} +-- (-2.1323797e-29,True) +-- +-- * The result may be smaller than @min a b@. +-- +-- >>> :{ +-- let (a, b, x) = (-1.9087862, -1.908786, 0.4228573) +-- result = x * a + (1 - x) * b :: Float +-- in (result, result < min a b) +-- :} +-- (-1.9087863,True) +-- +-- What happens when @NaN@ or @Infinity@ are given to 'uniformRM'? We first +-- define them as constants: +-- +-- >>> nan = read "NaN" :: Float +-- >>> inf = read "Infinity" :: Float +-- +-- * If at least one of \(a\) or \(b\) is @NaN@, the result is @NaN@. +-- +-- >>> let (a, b, x) = (nan, 1, 0.5) in x * a + (1 - x) * b +-- NaN +-- >>> let (a, b, x) = (-1, nan, 0.5) in x * a + (1 - x) * b +-- NaN +-- +-- * If \(a\) is @-Infinity@ and \(b\) is @Infinity@, the result is @NaN@. +-- >>> let (a, b, x) = (-inf, inf, 0.5) in x * a + (1 - x) * b +-- NaN +-- +-- * Otherwise, if \(a\) is @Infinity@ or @-Infinity@, the result is \(a\). +-- +-- >>> let (a, b, x) = (inf, 1, 0.5) in x * a + (1 - x) * b +-- Infinity +-- >>> let (a, b, x) = (-inf, 1, 0.5) in x * a + (1 - x) * b +-- -Infinity +-- +-- * Otherwise, if \(b\) is @Infinity@ or @-Infinity@, the result is \(b\). +-- +-- >>> let (a, b, x) = (1, inf, 0.5) in x * a + (1 - x) * b +-- Infinity +-- >>> let (a, b, x) = (1, -inf, 0.5) in x * a + (1 - x) * b +-- -Infinity +-- +-- Note that the [GCC 10.1.0 C++ standard library](https://gcc.gnu.org/git/?p=gcc.git;a=blob;f=libstdc%2B%2B-v3/include/bits/random.h;h=19307fbc3ca401976ef6823e8fda893e4a263751;hb=63fa67847628e5f358e7e2e7edb8314f0ee31f30#l1859), +-- the [Java 10 standard library](https://docs.oracle.com/javase/10/docs/api/java/util/Random.html#doubles%28double,double%29) +-- and [CPython 3.8](https://github.com/python/cpython/blob/3.8/Lib/random.py#L417) +-- use the same procedure to generate floating point values in a range. +-- +-- $implementmonadrandom +-- +-- Typically, a monadic pseudo-random number generator has facilities to save +-- and restore its internal state in addition to generating pseudo-random numbers. +-- +-- Here is an example instance for the monadic pseudo-random number generator +-- from the @mwc-random@ package: +-- +-- > instance (s ~ PrimState m, PrimMonad m) => StatefulGen (MWC.Gen s) m where +-- > uniformWord8 = MWC.uniform +-- > uniformWord16 = MWC.uniform +-- > uniformWord32 = MWC.uniform +-- > uniformWord64 = MWC.uniform +-- > uniformShortByteString n g = unsafeSTToPrim (genShortByteStringST n (MWC.uniform g)) +-- +-- > instance PrimMonad m => FrozenGen MWC.Seed m where +-- > type MutableGen MWC.Seed m = MWC.Gen (PrimState m) +-- > thawGen = MWC.restore +-- > freezeGen = MWC.save +-- +-- === @FrozenGen@ +-- +-- `FrozenGen` gives us ability to use any stateful pseudo-random number generator in its +-- immutable form, if one exists that is. This concept is commonly known as a seed, which +-- allows us to save and restore the actual mutable state of a pseudo-random number +-- generator. The biggest benefit that can be drawn from a polymorphic access to a +-- stateful pseudo-random number generator in a frozen form is the ability to serialize, +-- deserialize and possibly even use the stateful generator in a pure setting without +-- knowing the actual type of a generator ahead of time. For example we can write a +-- function that accepts a frozen state of some pseudo-random number generator and +-- produces a short list with random even integers. +-- +-- >>> import Data.Int (Int8) +-- >>> :{ +-- myCustomRandomList :: FrozenGen f m => f -> m [Int8] +-- myCustomRandomList f = +-- withMutableGen_ f $ \gen -> do +-- len <- uniformRM (5, 10) gen +-- replicateM len $ do +-- x <- uniformM gen +-- pure $ if even x then x else x + 1 +-- :} +-- +-- and later we can apply it to a frozen version of a stateful generator, such as `STGen`: +-- +-- >>> print $ runST $ myCustomRandomList (STGen (mkStdGen 217)) +-- [-50,-2,4,-8,-58,-40,24,-32,-110,24] +-- +-- or a @Seed@ from @mwc-random@: +-- +-- >>> import Data.Vector.Primitive as P +-- >>> print $ runST $ myCustomRandomList (MWC.toSeed (P.fromList [1,2,3])) +-- [24,40,10,40,-8,48,-78,70,-12] +-- +-- Alternatively, instead of discarding the final state of the generator, as it happens +-- above, we could have used `withMutableGen`, which together with the result would give +-- us back its frozen form. This would allow us to store the end state of our generator +-- somewhere for the later reuse. +-- +-- +-- $references +-- +-- 1. Guy L. Steele, Jr., Doug Lea, and Christine H. Flood. 2014. Fast +-- splittable pseudorandom number generators. In Proceedings of the 2014 ACM +-- International Conference on Object Oriented Programming Systems Languages & +-- Applications (OOPSLA '14). ACM, New York, NY, USA, 453-472. DOI: +-- + +-- $setup +-- >>> import Control.Monad.Primitive +-- >>> import qualified System.Random.MWC as MWC +-- +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XMultiParamTypeClasses +-- >>> :set -XTypeFamilies +-- >>> :set -XUndecidableInstances +-- +-- >>> :{ +-- instance (s ~ PrimState m, PrimMonad m) => StatefulGen (MWC.Gen s) m where +-- uniformWord8 = MWC.uniform +-- uniformWord16 = MWC.uniform +-- uniformWord32 = MWC.uniform +-- uniformWord64 = MWC.uniform +-- uniformShortByteString n g = unsafeSTToPrim (genShortByteStringST n (MWC.uniform g)) +-- instance PrimMonad m => FrozenGen MWC.Seed m where +-- type MutableGen MWC.Seed m = MWC.Gen (PrimState m) +-- thawGen = MWC.restore +-- freezeGen = MWC.save +-- :} +-- diff --git a/test-legacy/Legacy.hs b/test-legacy/Legacy.hs new file mode 100644 --- /dev/null +++ b/test-legacy/Legacy.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import qualified Random1283 as Random1283 +import qualified RangeTest as RangeTest +import qualified T7936 as T7936 +import qualified TestRandomIOs as TestRandomIOs +import qualified TestRandomRs as TestRandomRs + +main :: IO () +main = do + Random1283.main + RangeTest.main + T7936.main + TestRandomIOs.main + TestRandomRs.main diff --git a/test-legacy/Random1283.hs b/test-legacy/Random1283.hs new file mode 100644 --- /dev/null +++ b/test-legacy/Random1283.hs @@ -0,0 +1,48 @@ +module Random1283 (main) where + +import Control.Concurrent +import Control.Monad +import Data.Sequence (Seq, ViewL(..), empty, fromList, viewl, (<|), (|>), (><)) +import System.Random + +-- This test + +threads, samples :: Int +threads = 4 +samples = 5000 + +main :: IO () +main = loopTest threads samples + +loopTest :: Int -> Int -> IO () +loopTest t s = do + isClean <- testRace t s + unless isClean $ putStrLn "race condition!" + +testRace :: Int -> Int -> IO Bool +testRace t s = do + ref <- liftM (take (t*s) . randoms) getStdGen + iss <- threadRandoms t s + return (isInterleavingOf (ref::[Int]) iss) + +threadRandoms :: Random a => Int -> Int -> IO [[a]] +threadRandoms t s = do + vs <- sequence $ replicate t $ do + v <- newEmptyMVar + _ <- forkIO (sequence (replicate s randomIO) >>= putMVar v) + return v + mapM takeMVar vs + +isInterleavingOf :: Eq a => [a] -> [[a]] -> Bool +isInterleavingOf xs' yss' = iio xs' (viewl $ fromList yss') EmptyL where + iio (x:xs) ((y:ys) :< yss) zss + | x /= y = iio (x:xs) (viewl yss) (viewl (fromViewL zss |> (y:ys))) + | x == y = iio xs (viewl ((ys <| yss) >< fromViewL zss)) EmptyL + iio xs ([] :< yss) zss = iio xs (viewl yss) zss + iio [] EmptyL EmptyL = True + iio _ _ _ = False + +fromViewL :: ViewL a -> Seq a +fromViewL EmptyL = empty +fromViewL (x :< xs) = x <| xs + diff --git a/test-legacy/RangeTest.hs b/test-legacy/RangeTest.hs new file mode 100644 --- /dev/null +++ b/test-legacy/RangeTest.hs @@ -0,0 +1,138 @@ +module RangeTest (main) where + +import Control.Monad +import System.Random +import Data.Int +import Data.Word +import Foreign.C.Types + +-- Take many measurements and record the max/min/average random values. +approxBounds :: + (RandomGen g, Random a, Ord a, Num a) => + (g -> (a,g)) -> Int -> a -> (a,a) -> g -> ((a,a,a),g) +-- Here we do a little hack to essentiall pass in the type in the last argument: +approxBounds nxt iters unused (explo,exphi) initrng = + if False + then ((unused,unused,unused),undefined) +-- else loop initrng iters 100 (-100) 0 -- Oops, can't use minBound/maxBound here. + else loop initrng iters exphi explo 0 + where + loop rng 0 mn mx sum' = ((mn,mx,sum'),rng) + loop rng n mn mx sum' = + case nxt rng of + (x, rng') -> loop rng' (n-1) (min x mn) (max x mx) (x+sum') + + +-- We check that: +-- (1) all generated numbers are in bounds +-- (2) we get "close" to the bounds +-- The with (2) is that we do enough trials to ensure that we can at +-- least hit the 90% mark. +checkBounds :: + (Real a, Show a, Ord a) => + String -> (Bool, a, a) -> ((a,a) -> StdGen -> ((a, a, t), StdGen)) -> IO () +checkBounds msg (exclusive,lo,hi) fun = do + -- (lo,hi) is [inclusive,exclusive) + putStr $ msg ++ ": " + (mn,mx,_) <- getStdRandom (fun (lo,hi)) + when (mn < lo) $ error $ "broke lower bound: " ++ show mn + when (mx > hi) $ error $ "broke upper bound: " ++ show mx + when (exclusive && mx >= hi)$ error$ "hit upper bound: " ++ show mx + + let epsilon = 0.1 * (toRational hi - toRational lo) + + when (toRational (hi - mx) > epsilon) $ error $ "didn't get close enough to upper bound: "++ show mx + when (toRational (mn - lo) > epsilon) $ error $ "didn't get close enough to lower bound: "++ show mn + putStrLn "Passed" + +boundedRange :: (Num a, Bounded a) => (Bool, a, a) +boundedRange = ( False, minBound, maxBound ) + +trials :: Int +trials = 5000 + +-- Keep in mind here that on some architectures (e.g. ARM) CChar, CWchar, and CSigAtomic +-- are unsigned +main :: IO () +main = + do + checkBounds "Int" boundedRange (approxBounds random trials (undefined::Int)) + checkBounds "Integer" (False, fromIntegral (minBound::Int), fromIntegral (maxBound::Int)) + (approxBounds random trials (undefined::Integer)) + checkBounds "Int8" boundedRange (approxBounds random trials (undefined::Int8)) + checkBounds "Int16" boundedRange (approxBounds random trials (undefined::Int16)) + checkBounds "Int32" boundedRange (approxBounds random trials (undefined::Int32)) + checkBounds "Int64" boundedRange (approxBounds random trials (undefined::Int64)) + checkBounds "Word" boundedRange (approxBounds random trials (undefined::Word)) + checkBounds "Word8" boundedRange (approxBounds random trials (undefined::Word8)) + checkBounds "Word16" boundedRange (approxBounds random trials (undefined::Word16)) + checkBounds "Word32" boundedRange (approxBounds random trials (undefined::Word32)) + checkBounds "Word64" boundedRange (approxBounds random trials (undefined::Word64)) + checkBounds "Double" (False,0.0,1.0) (approxBounds random trials (undefined::Double)) + checkBounds "Float" (False,0.0,1.0) (approxBounds random trials (undefined::Float)) + + checkBounds "CChar" boundedRange (approxBounds random trials (undefined:: CChar)) + checkBounds "CSChar" boundedRange (approxBounds random trials (undefined:: CSChar)) + checkBounds "CUChar" boundedRange (approxBounds random trials (undefined:: CUChar)) + checkBounds "CShort" boundedRange (approxBounds random trials (undefined:: CShort)) + checkBounds "CUShort" boundedRange (approxBounds random trials (undefined:: CUShort)) + checkBounds "CInt" boundedRange (approxBounds random trials (undefined:: CInt)) + checkBounds "CUInt" boundedRange (approxBounds random trials (undefined:: CUInt)) + checkBounds "CLong" boundedRange (approxBounds random trials (undefined:: CLong)) + checkBounds "CULong" boundedRange (approxBounds random trials (undefined:: CULong)) + checkBounds "CPtrdiff" boundedRange (approxBounds random trials (undefined:: CPtrdiff)) + checkBounds "CSize" boundedRange (approxBounds random trials (undefined:: CSize)) + checkBounds "CWchar" boundedRange (approxBounds random trials (undefined:: CWchar)) + checkBounds "CSigAtomic" boundedRange (approxBounds random trials (undefined:: CSigAtomic)) + checkBounds "CLLong" boundedRange (approxBounds random trials (undefined:: CLLong)) + checkBounds "CULLong" boundedRange (approxBounds random trials (undefined:: CULLong)) + checkBounds "CIntPtr" boundedRange (approxBounds random trials (undefined:: CIntPtr)) + checkBounds "CUIntPtr" boundedRange (approxBounds random trials (undefined:: CUIntPtr)) + checkBounds "CIntMax" boundedRange (approxBounds random trials (undefined:: CIntMax)) + checkBounds "CUIntMax" boundedRange (approxBounds random trials (undefined:: CUIntMax)) + + -- Then check all the range-restricted versions: + checkBounds "Int R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined::Int)) + checkBounds "Integer R" + (False,-100000000000000000000,100000000000000000000) + (approxBounds (randomR (-100000000000000000000,100000000000000000000)) trials (undefined::Integer)) + checkBounds "Int8 R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined::Int8)) + checkBounds "Int8 Rsmall" (False,-50,50) (approxBounds (randomR (-50,50)) trials (undefined::Int8)) + checkBounds "Int8 Rmini" (False,3,4) (approxBounds (randomR (3,4)) trials (undefined::Int8)) + checkBounds "Int8 Rtrivial" (False,3,3) (approxBounds (randomR (3,3)) trials (undefined::Int8)) + + checkBounds "Int16 R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined::Int16)) + checkBounds "Int32 R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined::Int32)) + checkBounds "Int64 R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined::Int64)) + checkBounds "Word R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined::Word)) + checkBounds "Word8 R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined::Word8)) + checkBounds "Word16 R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined::Word16)) + checkBounds "Word32 R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined::Word32)) + checkBounds "Word64 R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined::Word64)) + checkBounds "Double R" (False,10.0,77.0) (approxBounds (randomR (10,77)) trials (undefined::Double)) + checkBounds "Float R" (False,10.0,77.0) (approxBounds (randomR (10,77)) trials (undefined::Float)) + + checkBounds "CChar R" (False,0,100) (approxBounds (randomR (0,100)) trials (undefined:: CChar)) + checkBounds "CSChar R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CSChar)) + checkBounds "CUChar R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CUChar)) + checkBounds "CShort R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CShort)) + checkBounds "CUShort R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CUShort)) + checkBounds "CInt R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CInt)) + checkBounds "CUInt R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CUInt)) + checkBounds "CLong R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CLong)) + checkBounds "CULong R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CULong)) + checkBounds "CPtrdiff R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CPtrdiff)) + checkBounds "CSize R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CSize)) + checkBounds "CWchar R" (False,0,100) (approxBounds (randomR (0,100)) trials (undefined:: CWchar)) + checkBounds "CSigAtomic R" (False,0,100) (approxBounds (randomR (0,100)) trials (undefined:: CSigAtomic)) + checkBounds "CLLong R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CLLong)) + checkBounds "CULLong R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CULLong)) + checkBounds "CIntPtr R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CIntPtr)) + checkBounds "CUIntPtr R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CUIntPtr)) + checkBounds "CIntMax R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CIntMax)) + checkBounds "CUIntMax R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CUIntMax)) + +-- Untested: +-- instance Random Char where +-- instance Random Bool where +-- instance Random Integer where diff --git a/test-legacy/T7936.hs b/test-legacy/T7936.hs new file mode 100644 --- /dev/null +++ b/test-legacy/T7936.hs @@ -0,0 +1,15 @@ +-- Test for ticket #7936: +-- https://ghc.haskell.org/trac/ghc/ticket/7936 +-- +-- Used to fail with: +-- +-- $ cabal test T7936 --test-options="+RTS -M1M -RTS" +-- T7936: Heap exhausted; + +module T7936 where + +import System.Random (newStdGen) +import Control.Monad (replicateM_) + +main :: IO () +main = replicateM_ 100000 newStdGen diff --git a/test-legacy/TestRandomIOs.hs b/test-legacy/TestRandomIOs.hs new file mode 100644 --- /dev/null +++ b/test-legacy/TestRandomIOs.hs @@ -0,0 +1,21 @@ +-- Test for ticket #4218 (TestRandomIOs): +-- https://ghc.haskell.org/trac/ghc/ticket/4218 +-- +-- Used to fail with: +-- +-- $ cabal test TestRandomIOs --test-options="+RTS -M1M -RTS" +-- TestRandomIOs: Heap exhausted; + +module TestRandomIOs where + +import Control.Monad (replicateM) +import System.Random (randomIO) + +-- Build a list of 5000 random ints in memory (IO Monad is strict), and print +-- the last one. +-- Should use less than 1Mb of heap space, or we are generating a list of +-- unevaluated thunks. +main :: IO () +main = do + rs <- replicateM 5000 randomIO :: IO [Int] + print $ last rs diff --git a/test-legacy/TestRandomRs.hs b/test-legacy/TestRandomRs.hs new file mode 100644 --- /dev/null +++ b/test-legacy/TestRandomRs.hs @@ -0,0 +1,23 @@ +-- Test for ticket #4218 (TestRandomRs): +-- https://ghc.haskell.org/trac/ghc/ticket/4218 +-- +-- Fixed together with ticket #8704 +-- https://ghc.haskell.org/trac/ghc/ticket/8704 +-- Commit 4695ffa366f659940369f05e419a4f2249c3a776 +-- +-- Used to fail with: +-- +-- $ cabal test TestRandomRs --test-options="+RTS -M1M -RTS" +-- TestRandomRs: Heap exhausted; + +module TestRandomRs where + +import Control.Monad (liftM) +import System.Random (randomRs, getStdGen) + +-- Return the five-thousandth random number: +-- Should run in constant space (< 1Mb heap). +main :: IO () +main = do + n <- (last . take 5000 . randomRs (0, 1000000)) `liftM` getStdGen + print (n::Integer) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main (main) where + +import Data.ByteString.Short as SBS +import Data.Int +import Data.Typeable +import Data.Word +import Foreign.C.Types +import Numeric.Natural (Natural) +import System.Random +import Test.SmallCheck.Series as SC +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.SmallCheck as SC + +import qualified Spec.Range as Range +import qualified Spec.Run as Run + +main :: IO () +main = + defaultMain $ + testGroup + "Spec" + [ floatingSpec (Proxy :: Proxy Double) + , floatingSpec (Proxy :: Proxy Float) + , floatingSpec (Proxy :: Proxy CDouble) + , floatingSpec (Proxy :: Proxy CFloat) + , integralSpec (Proxy :: Proxy Word8) + , integralSpec (Proxy :: Proxy Word16) + , integralSpec (Proxy :: Proxy Word32) + , integralSpec (Proxy :: Proxy Word64) + , integralSpec (Proxy :: Proxy Word) + , integralSpec (Proxy :: Proxy Int8) + , integralSpec (Proxy :: Proxy Int16) + , integralSpec (Proxy :: Proxy Int32) + , integralSpec (Proxy :: Proxy Int64) + , integralSpec (Proxy :: Proxy Int) + , integralSpec (Proxy :: Proxy Char) + , integralSpec (Proxy :: Proxy Bool) +#if __GLASGOW_HASKELL >= 802 + , integralSpec (Proxy :: Proxy CBool) +#endif + , integralSpec (Proxy :: Proxy CChar) + , integralSpec (Proxy :: Proxy CSChar) + , integralSpec (Proxy :: Proxy CUChar) + , integralSpec (Proxy :: Proxy CShort) + , integralSpec (Proxy :: Proxy CUShort) + , integralSpec (Proxy :: Proxy CInt) + , integralSpec (Proxy :: Proxy CUInt) + , integralSpec (Proxy :: Proxy CLong) + , integralSpec (Proxy :: Proxy CULong) + , integralSpec (Proxy :: Proxy CPtrdiff) + , integralSpec (Proxy :: Proxy CSize) + , integralSpec (Proxy :: Proxy CWchar) + , integralSpec (Proxy :: Proxy CSigAtomic) + , integralSpec (Proxy :: Proxy CLLong) + , integralSpec (Proxy :: Proxy CULLong) + , integralSpec (Proxy :: Proxy CIntPtr) + , integralSpec (Proxy :: Proxy CUIntPtr) + , integralSpec (Proxy :: Proxy CIntMax) + , integralSpec (Proxy :: Proxy CUIntMax) + , integralSpec (Proxy :: Proxy Integer) + , integralSpec (Proxy :: Proxy Natural) + , runSpec + , floatTests + , byteStringSpec + , SC.testProperty "uniformRangeWithinExcludedF" $ seeded Range.uniformRangeWithinExcludedF + , SC.testProperty "uniformRangeWithinExcludedD" $ seeded Range.uniformRangeWithinExcludedD + ] + +floatTests :: TestTree +floatTests = testGroup "(Float)" + [ -- Check that https://github.com/haskell/random/issues/53 does not regress + + testCase "Subnormal generation not above upper bound" $ + [] @?= filter (>4.0e-45) (take 100000 $ randomRs (0, 4.0e-45::Float) $ mkStdGen 0) + + , testCase "Subnormal generation includes upper bound" $ + 1.0e-45 `elem` take 100 (randomRs (0, 1.0e-45::Float) $ mkStdGen 0) @? + "Does not contain 1.0e-45" + ] + +showsType :: forall t . Typeable t => Proxy t -> ShowS +showsType px = showsTypeRep (typeRep px) + +byteStringSpec :: TestTree +byteStringSpec = + testGroup + "ByteString" + [ SC.testProperty "genShortByteString" $ \(seed, n8) -> + let n = fromIntegral (n8 :: Word8) -- no need to generate huge collection of bytes + in SBS.length (fst (seeded (genShortByteString n) seed)) == n + , SC.testProperty "genByteString" $ \(seed, n8) -> + let n = fromIntegral (n8 :: Word8) + in SBS.toShort (fst (seeded (genByteString n) seed)) == + fst (seeded (genShortByteString n) seed) + ] + + +rangeSpec :: + forall a. + (SC.Serial IO a, Typeable a, Ord a, UniformRange a, Show a) + => Proxy a -> TestTree +rangeSpec px = + testGroup ("Range (" ++ showsType px ")") + [ SC.testProperty "uniformR" $ seeded $ Range.uniformRangeWithin px + ] + +integralSpec :: + forall a. + (SC.Serial IO a, Typeable a, Ord a, UniformRange a, Show a) + => Proxy a -> TestTree +integralSpec px = + testGroup ("(" ++ showsType px ")") + [ SC.testProperty "symmetric" $ seeded $ Range.symmetric px + , SC.testProperty "bounded" $ seeded $ Range.bounded px + , SC.testProperty "singleton" $ seeded $ Range.singleton px + , rangeSpec px + -- TODO: Add more tests + ] + +floatingSpec :: + forall a. + (SC.Serial IO a, Typeable a, Num a, Ord a, Random a, UniformRange a, Show a) + => Proxy a -> TestTree +floatingSpec px = + testGroup ("(" ++ showsType px ")") + [ SC.testProperty "uniformR" $ seeded $ Range.uniformRangeWithin px + -- TODO: Add more tests + ] + +runSpec :: TestTree +runSpec = testGroup "runGenState_ and runPrimGenIO_" + [ SC.testProperty "equal outputs" $ seeded $ \g -> monadic $ Run.runsEqual g ] + +-- | Create a StdGen instance from an Int and pass it to the given function. +seeded :: (StdGen -> a) -> Int -> a +seeded f = f . mkStdGen diff --git a/test/Spec/Range.hs b/test/Spec/Range.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Range.hs @@ -0,0 +1,42 @@ +module Spec.Range + ( symmetric + , bounded + , singleton + , uniformRangeWithin + , uniformRangeWithinExcludedF + , uniformRangeWithinExcludedD + ) where + +import System.Random.Internal +import System.Random.Stateful +import Data.Proxy + +symmetric :: (RandomGen g, UniformRange a, Eq a) => Proxy a -> g -> (a, a) -> Bool +symmetric _ g (l, r) = fst (uniformR (l, r) g) == fst (uniformR (r, l) g) + +bounded :: (RandomGen g, UniformRange a, Ord a) => Proxy a -> g -> (a, a) -> Bool +bounded _ g (l, r) = bottom <= result && result <= top + where + bottom = min l r + top = max l r + result = fst (uniformR (l, r) g) + +singleton :: (RandomGen g, UniformRange a, Eq a) => Proxy a -> g -> a -> Bool +singleton _ g x = result == x + where + result = fst (uniformR (x, x) g) + +uniformRangeWithin :: (RandomGen g, UniformRange a, Ord a) => Proxy a -> g -> (a, a) -> Bool +uniformRangeWithin _ gen (l, r) = + runStateGen_ gen $ \g -> + (\result -> min l r <= result && result <= max l r) <$> uniformRM (l, r) g + +uniformRangeWithinExcludedF :: RandomGen g => g -> Bool +uniformRangeWithinExcludedF gen = + runStateGen_ gen $ \g -> + (\result -> 0 < result && result <= 1) <$> uniformFloatPositive01M g + +uniformRangeWithinExcludedD :: RandomGen g => g -> Bool +uniformRangeWithinExcludedD gen = + runStateGen_ gen $ \g -> + (\result -> 0 < result && result <= 1) <$> uniformDoublePositive01M g diff --git a/test/Spec/Run.hs b/test/Spec/Run.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Run.hs @@ -0,0 +1,14 @@ +module Spec.Run (runsEqual) where + +import Data.Word (Word64) +import System.Random.Stateful + +runsEqual :: RandomGen g => g -> IO Bool +runsEqual g = do + let pureResult = runStateGen_ g uniformM :: Word64 + stResult = runSTGen_ g uniformM :: Word64 + ioGenM <- newIOGenM g + ioResult <- uniformM ioGenM + atomicGenM <- newAtomicGenM g + atomicResult <- uniformM atomicGenM + return $ all (pureResult ==) [stResult, ioResult, atomicResult] diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE CPP #-} +module Main where + +#if __GLASGOW_HASKELL__ >= 802 + +import Test.DocTest (doctest) + +main :: IO () +main = doctest ["src"] + +#else + +-- TODO: fix doctest support +main :: IO () +main = putStrLn "\nDoctests are not supported for older ghc version\n" + +#endif diff --git a/tests/T7936.hs b/tests/T7936.hs deleted file mode 100644 --- a/tests/T7936.hs +++ /dev/null @@ -1,14 +0,0 @@ --- Test for ticket #7936: --- https://ghc.haskell.org/trac/ghc/ticket/7936 --- --- Used to fail with: --- --- $ cabal test T7936 --test-options="+RTS -M1M -RTS" --- T7936: Heap exhausted; - -module Main where - -import System.Random (newStdGen) -import Control.Monad (replicateM_) - -main = replicateM_ 100000 newStdGen diff --git a/tests/TestRandomIOs.hs b/tests/TestRandomIOs.hs deleted file mode 100644 --- a/tests/TestRandomIOs.hs +++ /dev/null @@ -1,20 +0,0 @@ --- Test for ticket #4218 (TestRandomIOs): --- https://ghc.haskell.org/trac/ghc/ticket/4218 --- --- Used to fail with: --- --- $ cabal test TestRandomIOs --test-options="+RTS -M1M -RTS" --- TestRandomIOs: Heap exhausted; - -module Main where - -import Control.Monad (replicateM) -import System.Random (randomIO) - --- Build a list of 5000 random ints in memory (IO Monad is strict), and print --- the last one. --- Should use less than 1Mb of heap space, or we are generating a list of --- unevaluated thunks. -main = do - rs <- replicateM 5000 randomIO :: IO [Int] - print $ last rs diff --git a/tests/TestRandomRs.hs b/tests/TestRandomRs.hs deleted file mode 100644 --- a/tests/TestRandomRs.hs +++ /dev/null @@ -1,22 +0,0 @@ --- Test for ticket #4218 (TestRandomRs): --- https://ghc.haskell.org/trac/ghc/ticket/4218 --- --- Fixed together with ticket #8704 --- https://ghc.haskell.org/trac/ghc/ticket/8704 --- Commit 4695ffa366f659940369f05e419a4f2249c3a776 --- --- Used to fail with: --- --- $ cabal test TestRandomRs --test-options="+RTS -M1M -RTS" --- TestRandomRs: Heap exhausted; - -module Main where - -import Control.Monad (liftM, replicateM) -import System.Random (randomRs, getStdGen) - --- Return the five-thousandth random number: --- Should run in constant space (< 1Mb heap). -main = do - n <- (last . take 5000 . randomRs (0, 1000000)) `liftM` getStdGen - print (n::Integer)