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,156 @@ +# 1.3.1 + +* Add missing `SplitGen` instance for `StateGen`: [#183](https://github.com/haskell/random/pull/183) + +# 1.3.0 + +* Improve floating point value generation and avoid degenerate cases: [#172](https://github.com/haskell/random/pull/172) +* Add `Uniform` instance for `Maybe` and `Either`: [#167](https://github.com/haskell/random/pull/167) +* Add `Seed`, `SeedGen`, `seedSize`, `seedSizeProxy`, `mkSeed` and `unSeed`: + [#162](https://github.com/haskell/random/pull/162) +* Add `mkSeedFromByteString`, `unSeedToByteString`, `withSeed`, `withSeedM`, `withSeedFile`, + `seedGenTypeName`, `nonEmptyToSeed`, `nonEmptyFromSeed`, `withSeedM`, `withSeedMutableGen` and `withSeedMutableGen_` +* Add `SplitGen` and `splitGen`: [#160](https://github.com/haskell/random/pull/160) +* Add `unifromShuffleList` and `unifromShuffleListM`: [#140](https://github.com/haskell/random/pull/140) +* Add `uniformWordR`: [#140](https://github.com/haskell/random/pull/140) +* Add `mkStdGen64`: [#155](https://github.com/haskell/random/pull/155) +* Add `uniformListRM`, `uniformList`, `uniformListR`, `uniforms` and `uniformRs`: + [#154](https://github.com/haskell/random/pull/154) +* Add compatibility with recently added `ByteArray` to `base`: + [#153](https://github.com/haskell/random/pull/153) + * Switch to using `ByteArray` for type class implementation instead of + `ShortByteString` + * Add `unsafeUniformFillMutableByteArray` to `RandomGen` and a helper function + `defaultUnsafeUniformFillMutableByteArray` that makes implementation + for most instances easier. + * Add `uniformByteArray`, `uniformByteString` and `uniformFillMutableByteArray` + * Deprecate `genByteString` in favor of `uniformByteString` + * Add `uniformByteArrayM` to `StatefulGen` + * Add `uniformByteStringM` and `uniformShortByteStringM` + * Deprecate `System.Random.Stateful.uniformShortByteString` in favor of `uniformShortByteStringM` for + consistent naming and a future plan of removing it from `StatefulGen` + type class + * Add a pure `System.Random.uniformShortByteString` generating function. + * Deprecate `genShortByteString` in favor of `System.Random.uniformShortByteString` + * Expose a helper function `fillByteArrayST`, that can be used for + defining implementation for `uniformByteArrayM` + * Deprecate `genShortByteStringST` and `genShortByteStringIO` in favor of `fillByteArrayST` +* Improve `FrozenGen` interface: [#149](https://github.com/haskell/random/pull/149) + * Move `thawGen` from `FreezeGen` into the new `ThawGen` type class. Fixes an issue with + an unlawful instance of `StateGen` for `FreezeGen`. + * Add `modifyGen` and `overwriteGen` to the `FrozenGen` type class + * Switch `splitGenM` to use `SplitGen` and `FrozenGen` instead of deprecated `RandomGenM` + * Add `splitMutableGenM` + * Switch `randomM` and `randomRM` to use `FrozenGen` instead of `RandomGenM` + * Deprecate `RandomGenM` in favor of a more powerful `FrozenGen` +* Add `isInRangeOrd` and `isInRangeEnum` that can be used for implementing `isInRange`: + [#148](https://github.com/haskell/random/pull/148) +* Add `isInRange` to `UniformRange`: [#78](https://github.com/haskell/random/pull/78) +* Add default implementation for `uniformRM` using `Generics`: + [#92](https://github.com/haskell/random/pull/92) + +# 1.2.1 + +* Fix support for ghc-9.2 [#99](https://github.com/haskell/random/pull/99) +* Fix performance regression for ghc-9.0 [#101](https://github.com/haskell/random/pull/101) +* Add `uniformEnumM` and `uniformEnumRM` +* Add `initStdGen` [#103](https://github.com/haskell/random/pull/103) +* Add `globalStdGen` [#117](https://github.com/haskell/random/pull/117) +* Add `runStateGenST_` +* Ensure that default implementation of `ShortByteString` generation uses + unpinned memory. [#116](https://github.com/haskell/random/pull/116) +* Fix [#54](https://github.com/haskell/random/issues/54) with + [#68](https://github.com/haskell/random/pull/68) - if exactly one value in the + range of floating point is infinite, then `uniformRM`/`randomR` returns that + value. +* Add default implementation of `uniformM` that uses `Generic` + [#70](https://github.com/haskell/random/pull/70) +* `Random` instance for `CBool` [#77](https://github.com/haskell/random/pull/77) +* Addition of `TGen` and `TGenM` [#95](https://github.com/haskell/random/pull/95) +* Addition of tuple instances for `Random` up to 7-tuple + [#72](https://github.com/haskell/random/pull/72) + +# 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 +176,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 | Github Actions | Coveralls | +|:--------:|:--------------:|:---------:| +| ![GitHub top language](https://img.shields.io/github/languages/top/haskell/random.svg) | [![Build Status](https://github.com/haskell/random/actions/workflows/ci.yaml/badge.svg?branch=master)](https://github.com/haskell/random/actions/workflows/ci.yaml) | [![Coverage Status](https://coveralls.io/repos/github/haskell/random/badge.svg?branch=master)](https://coveralls.io/github/haskell/random?branch=master) + +| Github Repo | 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)| [![LTS](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,270 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# 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 238523586 + 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,399 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main (main) where + +import Control.Monad +import Control.Monad.State.Strict +import Data.Int +import Data.List (sortOn) +import Data.Proxy +import Data.Typeable +import Data.Word +import Foreign.C.Types +import Numeric.Natural (Natural) +import System.Random.SplitMix as SM +import Test.Tasty.Bench +#if MIN_VERSION_primitive(0,7,1) +import Control.Monad.Primitive +import Data.Primitive.Types +import Data.Primitive.PrimArray +#endif + +import System.Random.Stateful + +seed :: Int +seed = 1337 + +main :: IO () +main = do + let !sz = 100000 + !sz100MiB = 100 * 1024 * 1024 + genLengths :: ([Int], StdGen) + genLengths = + -- create 5000 small lengths that are needed for ShortByteString generation + runStateGen (mkStdGen 2020) $ \g -> replicateM 5000 (uniformRM (16 + 1, 16 + 7) g) + setStdGen $ mkStdGen seed + defaultMain + [ bgroup "baseline" + [ env (pure $ SM.mkSMGen $ fromIntegral seed) $ \smGen -> + bench "nextWord32" $ whnf (genMany SM.nextWord32 smGen) sz + , env (pure $ SM.mkSMGen $ fromIntegral seed) $ \smGen -> + bench "nextWord64" $ whnf (genMany SM.nextWord64 smGen) sz + , env (pure $ SM.mkSMGen $ fromIntegral seed) $ \smGen -> + bench "nextInt" $ whnf (genMany SM.nextInt smGen) sz + , env (pure $ SM.mkSMGen $ fromIntegral seed) $ \smGen -> + bench "split" $ whnf (genMany SM.splitSMGen smGen) sz + ] + , bgroup "pure" + [ bgroup "random" + [ pureBench random sz (Proxy :: Proxy Word8) + , pureBench random sz (Proxy :: Proxy Word16) + , pureBench random sz (Proxy :: Proxy Word32) + , pureBench random sz (Proxy :: Proxy Word64) + , pureBench random sz (Proxy :: Proxy Int8) + , pureBench random sz (Proxy :: Proxy Int16) + , pureBench random sz (Proxy :: Proxy Int32) + , pureBench random sz (Proxy :: Proxy Int64) + , pureBench random sz (Proxy :: Proxy Bool) + , pureBench random sz (Proxy :: Proxy Char) + , pureBench random sz (Proxy :: Proxy Float) + , pureBench random sz (Proxy :: Proxy Double) + , pureBench random sz (Proxy :: Proxy Integer) + ] + , bgroup "uniform" + [ pureBench uniform sz (Proxy :: Proxy Word8) + , pureBench uniform sz (Proxy :: Proxy Word16) + , pureBench uniform sz (Proxy :: Proxy Word32) + , pureBench uniform sz (Proxy :: Proxy Word64) + , pureBench uniform sz (Proxy :: Proxy Int8) + , pureBench uniform sz (Proxy :: Proxy Int16) + , pureBench uniform sz (Proxy :: Proxy Int32) + , pureBench uniform sz (Proxy :: Proxy Int64) + , pureBench uniform sz (Proxy :: Proxy Bool) + , pureBench uniform sz (Proxy :: Proxy Char) + , pureBench uniform sz (Proxy :: Proxy CChar) + , pureBench uniform sz (Proxy :: Proxy CSChar) + , pureBench uniform sz (Proxy :: Proxy CUChar) + , pureBench uniform sz (Proxy :: Proxy CShort) + , pureBench uniform sz (Proxy :: Proxy CUShort) + , pureBench uniform sz (Proxy :: Proxy CInt) + , pureBench uniform sz (Proxy :: Proxy CUInt) + , pureBench uniform sz (Proxy :: Proxy CLong) + , pureBench uniform sz (Proxy :: Proxy CULong) + , pureBench uniform sz (Proxy :: Proxy CPtrdiff) + , pureBench uniform sz (Proxy :: Proxy CSize) + , pureBench uniform sz (Proxy :: Proxy CWchar) + , pureBench uniform sz (Proxy :: Proxy CSigAtomic) + , pureBench uniform sz (Proxy :: Proxy CLLong) + , pureBench uniform sz (Proxy :: Proxy CULLong) + , pureBench uniform sz (Proxy :: Proxy CIntPtr) + , pureBench uniform sz (Proxy :: Proxy CUIntPtr) + , pureBench uniform sz (Proxy :: Proxy CIntMax) + , pureBench uniform sz (Proxy :: Proxy CUIntMax) + ] + , 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" + [ +#if MIN_VERSION_primitive(0,7,1) + bgroup "IO" + [ bgroup "Float" + [ env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> + bench "uniformRM" $ + nfIO (runStateGenT gen (fillMutablePrimArrayM (uniformRM (0 :: Float, 1.1)) ma)) + , env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> + bench "uniformFloat01M" $ + nfIO (runStateGenT gen (fillMutablePrimArrayM uniformFloat01M ma)) + , env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> + bench "uniformFloatPositive01M" $ + nfIO (runStateGenT gen (fillMutablePrimArrayM uniformFloatPositive01M ma)) + ] + , bgroup "Double" + [ env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> + bench "uniformRM" $ + nfIO (runStateGenT gen (fillMutablePrimArrayM (uniformRM (0 :: Double, 1.1)) ma)) + , env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> + bench "uniformDouble01M" $ + nfIO (runStateGenT gen (fillMutablePrimArrayM uniformDouble01M ma)) + , env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> + bench "uniformDoublePositive01M" $ + nfIO (runStateGenT gen (fillMutablePrimArrayM uniformDoublePositive01M ma)) + ] + ] + , +#endif + bgroup "State" + [ bgroup "Float" + [ env getStdGen $ + bench "uniformRM" . nf (`runStateGen` (replicateM_ sz . uniformRM (0.1 :: Float, 1.1))) + , env getStdGen $ + bench "uniformFloat01M" . nf (`runStateGen` (replicateM_ sz . uniformFloat01M)) + , env getStdGen $ + bench "uniformFloatPositive01M" . + nf (`runStateGen` (replicateM_ sz . uniformFloatPositive01M)) + ] + , bgroup "Double" + [ env getStdGen $ + bench "uniformRM" . nf (`runStateGen` (replicateM_ sz . uniformRM (0.1 :: Double, 1.1))) + , env getStdGen $ + bench "uniformDouble01M" . nf (`runStateGen` (replicateM_ sz . uniformDouble01M)) + , env getStdGen $ + bench "uniformDoublePositive01M" . + nf (`runStateGen` (replicateM_ sz . uniformDoublePositive01M)) + ] + ] + , bgroup "pure" + [ bgroup "Float" + [ env getStdGen $ \gen -> + bench "uniformRM" $ nf + (genMany (runState $ uniformRM (0.1 :: Float, 1.1) (StateGenM :: StateGenM StdGen)) gen) + sz + , env getStdGen $ \gen -> + bench "uniformFloat01M" $ nf + (genMany (runState $ uniformFloat01M (StateGenM :: StateGenM StdGen)) gen) + sz + , env getStdGen $ \gen -> + bench "uniformFloatPositive01M" $ nf + (genMany (runState $ uniformFloatPositive01M (StateGenM :: StateGenM StdGen)) gen) + sz + ] + , bgroup "Double" + [ env getStdGen $ \gen -> + bench "uniformRM" $ nf + (genMany (runState $ uniformRM (0.1 :: Double, 1.1) (StateGenM :: StateGenM StdGen)) gen) + sz + , env getStdGen $ \gen -> + bench "uniformDouble01M" $ nf + (genMany (runState $ uniformDouble01M (StateGenM :: StateGenM StdGen)) gen) + sz + , env getStdGen $ \gen -> + bench "uniformDoublePositive01M" $ nf + (genMany (runState $ uniformDoublePositive01M (StateGenM :: StateGenM StdGen)) gen) + sz + ] + ] + ] + ] + , bgroup "Bytes" + [ env (pure genLengths) $ \ ~(ns, gen) -> + bench "uniformShortByteStringM" $ + nfIO $ runStateGenT gen $ \g -> mapM (`uniformShortByteStringM` g) ns + , env getStdGen $ \gen -> + bench "uniformByteStringM 100MB" $ + nf (runStateGen gen . uniformByteStringM) sz100MiB + , env getStdGen $ \gen -> + bench "uniformByteArray 100MB" $ nf (\n -> uniformByteArray False n gen) sz100MiB + , env getStdGen $ \gen -> + bench "uniformByteString 100MB" $ nf (`uniformByteString` gen) sz100MiB + ] + ] + , env (pure [0 :: Integer .. 200000]) $ \xs -> + bgroup "shuffle" + [ env getStdGen $ bench "uniformShuffleList" . nf (uniformShuffleList xs) + , env getStdGen $ bench "uniformShuffleListM" . nf (`runStateGen` uniformShuffleListM xs) + , env getStdGen $ bench "naiveShuffleListM" . nf (`runStateGen` naiveShuffleListM xs) + ] + ] + +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 +{-# INLINE pureUniformRFullBench #-} + +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 +{-# INLINE pureUniformRExcludeMaxBench #-} + +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 +{-# INLINE pureUniformRIncludeHalfBench #-} + +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 +{-# INLINE pureUniformRIncludeHalfEnumBench #-} + +pureUniformRBench :: + forall a. (Typeable a, UniformRange a) + => Proxy a + -> (a, a) + -> Int + -> Benchmark +pureUniformRBench px range@(!_, !_) sz = pureBench (uniformR range) sz px +{-# INLINE pureUniformRBench #-} + +pureBench :: + forall a. Typeable a + => (StdGen -> (a, StdGen)) + -> Int + -> Proxy a + -> Benchmark +pureBench f sz px = + env getStdGen $ \gen -> + bench (showsTypeRep (typeRep px) "") $ whnf (genMany f gen) sz +{-# INLINE pureBench #-} + + +genMany :: (g -> (a, g)) -> g -> Int -> a +genMany f g0 n = go 0 $ f g0 + where + go i (!y, !g) + | i < n = go (i + 1) $ f g + | otherwise = y + +#if MIN_VERSION_primitive(0,7,1) +fillMutablePrimArrayM :: + (Prim a, PrimMonad m) + => (gen -> m a) + -> MutablePrimArray (PrimState m) a + -> gen + -> m (PrimArray a) +fillMutablePrimArrayM f ma g = do + n <- getSizeofMutablePrimArray ma + let go i + | i < n = f g >>= writePrimArray ma i >> go (i + 1) + | otherwise = pure () + go 0 + unsafeFreezePrimArray ma +#endif + + +naiveShuffleListM :: StatefulGen g m => [a] -> g -> m [a] +naiveShuffleListM xs gen = do + is <- uniformListM n gen + pure $ map snd $ sortOn fst $ zip (is :: [Int]) xs + where + !n = length xs +{-# INLINE naiveShuffleListM #-} diff --git a/random.cabal b/random.cabal --- a/random.cabal +++ b/random.cabal @@ -1,70 +1,200 @@ -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.3.1 +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.runStateGen_' 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 == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.6 + , GHC == 9.8.4 + , GHC == 9.10.1 + , GHC == 9.12.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 + other-modules: + System.Random.Array + System.Random.Seed + System.Random.GFinite + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: + -Wall + -Wincomplete-record-updates -Wincomplete-uni-patterns + build-depends: + base >=4.9 && <5, + bytestring >=0.10.4 && <0.13, + deepseq >=1.1 && <2, + mtl >=2.2 && <2.4, + transformers >=0.4 && <0.7, + splitmix >=0.1 && <0.2 + if impl(ghc < 9.4) + build-depends: data-array-byte -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=-M9M + -Wno-deprecations + build-depends: + base, + containers >=0.5 && <0.8, + random --- To run the Test-Suite: --- $ cabal configure --enable-tests --- $ cabal test --show-details=always --test-options="+RTS -M1M -RTS" +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: + Spec.Range + Spec.Run + Spec.Seed + Spec.Stateful -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 + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base, + bytestring, + random, + smallcheck >=1.2 && <1.3, + stm, + tasty >=1.0 && <1.6, + tasty-smallcheck >=0.8 && <0.9, + tasty-hunit >=0.10 && <0.11, + transformers -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 +-- Note. Fails when compiled with coverage: +-- https://github.com/haskell/random/issues/107 +test-suite spec-inspection + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test-inspection + default-language: Haskell2010 + ghc-options: -Wall + other-modules: + Spec.Inspection + build-depends: + base, + random, + tasty >=1.0 && <1.6, + tasty-inspection-testing + if impl(ghc >=9.10) + buildable: False -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 -Wno-deprecations + + build-depends: + base, + random, + rdtsc, + split >=0.2 && <0.3, + time >=1.4 && <1.13 + +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, + mtl, + primitive, + random, + splitmix >=0.1 && <0.2, + tasty-bench 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,917 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# 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 + ( split + , genWord8 + , genWord16 + , genWord32 + , genWord64 + , genWord32R + , genWord64R + , unsafeUniformFillMutableByteArray + ) + , SplitGen (splitGen) + , uniform + , uniformR + , Random(..) + , Uniform + , UniformRange + , Finite + -- ** Seed + , module System.Random.Seed + -- * Generators for sequences of pseudo-random bytes + -- ** Lists + , uniforms + , uniformRs + , uniformList + , uniformListR + , uniformShuffleList + -- ** Bytes + , uniformByteArray + , uniformByteString + , uniformShortByteString + , uniformFillMutableByteArray + -- *** Deprecated + , genByteString + , genShortByteString + + -- ** Standard pseudo-random number generator + , StdGen + , mkStdGen + , mkStdGen64 + , initStdGen + + -- ** Global standard pseudo-random number generator + -- $globalstdgen + , getStdRandom + , getStdGen + , setStdGen + , newStdGen + , randomIO + , randomRIO + + -- * Compatibility and reproducibility + -- ** Backwards compatibility and deprecations + , genRange + , next + -- $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 Control.Monad.State.Strict +import Control.Monad.ST (ST) +import Data.Array.Byte (ByteArray(..), MutableByteArray(..)) +import Data.ByteString (ByteString) +import Data.ByteString.Short.Internal (ShortByteString(..)) +import Data.Int +import Data.IORef +import Data.Word +import Foreign.C.Types +import GHC.Exts +import System.Random.Array (getSizeOfMutableByteArray, shortByteStringToByteString, shuffleListST) +import System.Random.GFinite (Finite) +import System.Random.Internal hiding (uniformShortByteString) +import System.Random.Seed +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 = fst . uniformListR n (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 'runStateGen' and its variants. +-- +-- >>> :{ +-- let rollsM :: StatefulGen g m => Int -> g -> m [Word] +-- rollsM n = uniformListRM n (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}) +-- +-- You can use type applications to disambiguate the type of the generated numbers: +-- +-- >>> :seti -XTypeApplications +-- >>> uniform @Bool pureGen +-- (True,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627}) +-- +-- @since 1.2.0 +uniform :: (Uniform a, RandomGen g) => g -> (a, g) +uniform g = runStateGen g uniformM +{-# INLINE uniform #-} + +-- | 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}) +-- +-- You can use type applications to disambiguate the type of the generated numbers: +-- +-- >>> :seti -XTypeApplications +-- >>> uniformR @Int (1, 4) pureGen +-- (4,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627}) +-- +-- @since 1.2.0 +uniformR :: (UniformRange a, RandomGen g) => (a, a) -> g -> (a, g) +uniformR r g = runStateGen g (uniformRM r) +{-# INLINE uniformR #-} + +-- | Produce an infinite list of pseudo-random values. Integrates nicely with list +-- fusion. Naturally, there is no way to recover the final generator, therefore either use +-- `split` before calling `uniforms` or use `uniformList` instead. +-- +-- Similar to `randoms`, except it relies on `Uniform` type class instead of `Random` +-- +-- ====__Examples__ +-- +-- >>> let gen = mkStdGen 2023 +-- >>> import Data.Word (Word16) +-- >>> take 5 $ uniforms gen :: [Word16] +-- [56342,15850,25292,14347,13919] +-- +-- @since 1.3.0 +uniforms :: (Uniform a, RandomGen g) => g -> [a] +uniforms g0 = + build $ \cons _nil -> + let go g = + case uniform g of + (x, g') -> x `seq` (x `cons` go g') + in go g0 +{-# INLINE uniforms #-} + +-- | Produce an infinite list of pseudo-random values in a specified range. Same as +-- `uniforms`, integrates nicely with list fusion. There is no way to recover the final +-- generator, therefore either use `split` before calling `uniformRs` or use +-- `uniformListR` instead. +-- +-- Similar to `randomRs`, except it relies on `UniformRange` type class instead of +-- `Random`. +-- +-- ====__Examples__ +-- +-- >>> let gen = mkStdGen 2023 +-- >>> take 5 $ uniformRs (10, 100) gen :: [Int] +-- [32,86,21,57,39] +-- +-- @since 1.3.0 +uniformRs :: (UniformRange a, RandomGen g) => (a, a) -> g -> [a] +uniformRs range g0 = + build $ \cons _nil -> + let go g = + case uniformR range g of + (x, g') -> x `seq` (x `cons` go g') + in go g0 +{-# INLINE uniformRs #-} + +-- | Produce a list of the supplied length with elements generated uniformly. +-- +-- See `uniformListM` for a stateful counterpart. +-- +-- ====__Examples__ +-- +-- >>> let gen = mkStdGen 2023 +-- >>> import Data.Word (Word16) +-- >>> uniformList 5 gen :: ([Word16], StdGen) +-- ([56342,15850,25292,14347,13919],StdGen {unStdGen = SMGen 6446154349414395371 1920468677557965761}) +-- +-- @since 1.3.0 +uniformList :: (Uniform a, RandomGen g) => Int -> g -> ([a], g) +uniformList n g = runStateGen g (uniformListM n) +{-# INLINE uniformList #-} + +-- | Produce a list of the supplied length with elements generated uniformly. +-- +-- See `uniformListM` for a stateful counterpart. +-- +-- ====__Examples__ +-- +-- >>> let gen = mkStdGen 2023 +-- >>> uniformListR 10 (20, 30) gen :: ([Int], StdGen) +-- ([26,30,27,24,30,25,27,21,27,27],StdGen {unStdGen = SMGen 12965503083958398648 1920468677557965761}) +-- +-- @since 1.3.0 +uniformListR :: (UniformRange a, RandomGen g) => Int -> (a, a) -> g -> ([a], g) +uniformListR n r g = runStateGen g (uniformListRM n r) +{-# INLINE uniformListR #-} + +-- | Shuffle elements of a list in a uniformly random order. +-- +-- ====__Examples__ +-- +-- >>> uniformShuffleList "ELVIS" $ mkStdGen 252 +-- ("LIVES",StdGen {unStdGen = SMGen 17676540583805057877 5302934877338729551}) +-- +-- @since 1.3.0 +uniformShuffleList :: RandomGen g => [a] -> g -> ([a], g) +uniformShuffleList xs g = + runStateGenST g $ \gen -> shuffleListST (`uniformWordR` gen) xs +{-# INLINE uniformShuffleList #-} + +-- | Generates a 'ByteString' of the specified size using a pure pseudo-random +-- number generator. See 'uniformByteStringM' for the monadic version. +-- +-- ====__Examples__ +-- +-- >>> import System.Random +-- >>> import Data.ByteString +-- >>> let pureGen = mkStdGen 137 +-- >>> :seti -Wno-deprecations +-- >>> 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 = uniformByteString +{-# INLINE genByteString #-} +{-# DEPRECATED genByteString "In favor of `uniformByteString`" #-} + +-- | Generates a 'ByteString' of the specified size using a pure pseudo-random +-- number generator. See 'uniformByteStringM' for the monadic version. +-- +-- ====__Examples__ +-- +-- >>> import System.Random +-- >>> import Data.ByteString (unpack) +-- >>> let pureGen = mkStdGen 137 +-- >>> unpack . fst $ uniformByteString 10 pureGen +-- [51,123,251,37,49,167,90,109,1,4] +-- +-- @since 1.3.0 +uniformByteString :: RandomGen g => Int -> g -> (ByteString, g) +uniformByteString n g = + case uniformByteArray True n g of + (byteArray, g') -> + (shortByteStringToByteString $ byteArrayToShortByteString byteArray, g') +{-# INLINE uniformByteString #-} + +-- | Same as @`uniformByteArray` `False`@, but for `ShortByteString`. +-- +-- Returns a 'ShortByteString' of length @n@ filled with pseudo-random bytes. +-- +-- ====__Examples__ +-- +-- >>> import System.Random +-- >>> import Data.ByteString.Short (unpack) +-- >>> let pureGen = mkStdGen 137 +-- >>> unpack . fst $ uniformShortByteString 10 pureGen +-- [51,123,251,37,49,167,90,109,1,4] +-- +-- @since 1.3.0 +uniformShortByteString :: RandomGen g => Int -> g -> (ShortByteString, g) +uniformShortByteString n g = + case uniformByteArray False n g of + (ByteArray ba#, g') -> (SBS ba#, g') +{-# INLINE uniformShortByteString #-} + +-- | Fill in a slice of a mutable byte array with randomly generated bytes. This function +-- does not fail, instead it clamps the offset and number of bytes to generate into a valid +-- range. +-- +-- @since 1.3.0 +uniformFillMutableByteArray :: + RandomGen g + => MutableByteArray s + -- ^ Mutable array to fill with random bytes + -> Int + -- ^ Offset into a mutable array from the beginning in number of bytes. Offset will be + -- clamped into the range between 0 and the total size of the mutable array + -> Int + -- ^ Number of randomly generated bytes to write into the array. This number will be + -- clamped between 0 and the total size of the array without the offset. + -> g + -> ST s g +uniformFillMutableByteArray mba i0 n g = do + !sz <- getSizeOfMutableByteArray mba + let !offset = max 0 (min sz i0) + !numBytes = min (sz - offset) (max 0 n) + unsafeUniformFillMutableByteArray mba offset numBytes g +{-# INLINE uniformFillMutableByteArray #-} + +-- | The class of types for which random values can be generated. Most +-- instances of `Random` will produce values that are uniformly distributed on the full +-- range, but for those types without a well-defined "full range" some sensible default +-- subrange will be selected. +-- +-- 'Random' exists primarily for backwards compatibility with version 1.1 of +-- this library. In new code, use the better specified 'Uniform' and +-- 'UniformRange' instead. +-- +-- @since 1.0.0 +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/, but usually the values will simply get swapped. + -- + -- >>> let gen = mkStdGen 26 + -- >>> fst $ randomR ('a', 'z') gen + -- 'z' + -- >>> fst $ randomR ('a', 'z') gen + -- 'z' + -- + -- 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. + -- + -- There is no requirement to follow the @Ord@ instance and the concept of range can be + -- defined on per type basis. For example product types will treat their values + -- independently: + -- + -- >>> fst $ randomR (('a', 5.0), ('z', 10.0)) $ mkStdGen 26 + -- ('z',5.22694980853051) + -- + -- In case when a lawful range is desired `uniformR` should be used + -- instead. + -- + -- @since 1.0.0 + {-# 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 floating point types, the range is normally the closed interval @[0,1]@. + -- + -- * For 'Integer', the range is (arbitrarily) the range of 'Int'. + -- + -- @since 1.0.0 + {-# 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. + -- + -- @since 1.0.0 + {-# 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. + -- + -- @since 1.0.0 + {-# 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: + -- https://gitlab.haskell.org/ghc/ghc/-/issues/4218 + go g = x `seq` (x `cons` go g') where (x,g') = rand g + +-- | /Note/ - `random` generates values in the `Int` range +instance Random Integer where + random = first (toInteger :: Int -> Integer) . random + {-# INLINE 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 +-- | /Note/ - `random` produces values in the closed range @[0,1]@. +instance Random CFloat where + randomR r = coerce . randomR (coerce r :: (Float, Float)) + {-# INLINE randomR #-} + random = first CFloat . random + {-# INLINE random #-} +-- | /Note/ - `random` produces values in the closed range @[0,1]@. +instance Random CDouble where + randomR r = coerce . randomR (coerce r :: (Double, Double)) + {-# INLINE randomR #-} + random = first CDouble . random + {-# INLINE random #-} + +instance Random Char +instance Random Bool +-- | /Note/ - `random` produces values in the closed range @[0,1]@. +instance Random Double where + randomR r g = runStateGen g (uniformRM r) + {-# INLINE randomR #-} + -- We return 1 - uniformDouble01M here for backwards compatibility with + -- v1.2.0. Just return the result of uniformDouble01M in the next major + -- version. + random g = runStateGen g (fmap (1 -) . uniformDouble01M) + {-# INLINE random #-} +-- | /Note/ - `random` produces values in the closed range @[0,1]@. +instance Random Float where + randomR r g = runStateGen g (uniformRM r) + {-# INLINE randomR #-} + -- We return 1 - uniformFloat01M here for backwards compatibility with + -- v1.2.0. Just return the result of uniformFloat01M in the next major + -- version. + random g = runStateGen g (fmap (1 -) . uniformFloat01M) + {-# INLINE random #-} + + + +-- | Initialize 'StdGen' using system entropy (i.e. @\/dev\/urandom@) when it is +-- available, while falling back on using system time as the seed. +-- +-- @since 1.2.1 +initStdGen :: MonadIO m => m StdGen +initStdGen = liftIO (StdGen <$> SM.initSMGen) + + +-- | /Note/ - `randomR` treats @a@ and @b@ types independently +instance (Random a, Random b) => Random (a, b) where + randomR ((al, bl), (ah, bh)) = runState $ + (,) <$> state (randomR (al, ah)) <*> state (randomR (bl, bh)) + {-# INLINE randomR #-} + random = runState $ (,) <$> state random <*> state random + {-# INLINE random #-} + +-- | /Note/ - `randomR` treats @a@, @b@ and @c@ types independently +instance (Random a, Random b, Random c) => Random (a, b, c) where + randomR ((al, bl, cl), (ah, bh, ch)) = runState $ + (,,) <$> state (randomR (al, ah)) + <*> state (randomR (bl, bh)) + <*> state (randomR (cl, ch)) + {-# INLINE randomR #-} + random = runState $ (,,) <$> state random <*> state random <*> state random + {-# INLINE random #-} + +-- | /Note/ - `randomR` treats @a@, @b@, @c@ and @d@ types independently +instance (Random a, Random b, Random c, Random d) => Random (a, b, c, d) where + randomR ((al, bl, cl, dl), (ah, bh, ch, dh)) = runState $ + (,,,) <$> state (randomR (al, ah)) + <*> state (randomR (bl, bh)) + <*> state (randomR (cl, ch)) + <*> state (randomR (dl, dh)) + {-# INLINE randomR #-} + random = runState $ + (,,,) <$> state random <*> state random <*> state random <*> state random + {-# INLINE random #-} + +-- | /Note/ - `randomR` treats @a@, @b@, @c@, @d@ and @e@ types independently +instance (Random a, Random b, Random c, Random d, Random e) => Random (a, b, c, d, e) where + randomR ((al, bl, cl, dl, el), (ah, bh, ch, dh, eh)) = runState $ + (,,,,) <$> state (randomR (al, ah)) + <*> state (randomR (bl, bh)) + <*> state (randomR (cl, ch)) + <*> state (randomR (dl, dh)) + <*> state (randomR (el, eh)) + {-# INLINE randomR #-} + random = runState $ + (,,,,) <$> state random <*> state random <*> state random <*> state random <*> state random + {-# INLINE random #-} + +-- | /Note/ - `randomR` treats @a@, @b@, @c@, @d@, @e@ and @f@ types independently +instance (Random a, Random b, Random c, Random d, Random e, Random f) => + Random (a, b, c, d, e, f) where + randomR ((al, bl, cl, dl, el, fl), (ah, bh, ch, dh, eh, fh)) = runState $ + (,,,,,) <$> state (randomR (al, ah)) + <*> state (randomR (bl, bh)) + <*> state (randomR (cl, ch)) + <*> state (randomR (dl, dh)) + <*> state (randomR (el, eh)) + <*> state (randomR (fl, fh)) + {-# INLINE randomR #-} + random = runState $ + (,,,,,) <$> state random + <*> state random + <*> state random + <*> state random + <*> state random + <*> state random + {-# INLINE random #-} + +-- | /Note/ - `randomR` treats @a@, @b@, @c@, @d@, @e@, @f@ and @g@ types independently +instance (Random a, Random b, Random c, Random d, Random e, Random f, Random g) => + Random (a, b, c, d, e, f, g) where + randomR ((al, bl, cl, dl, el, fl, gl), (ah, bh, ch, dh, eh, fh, gh)) = runState $ + (,,,,,,) <$> state (randomR (al, ah)) + <*> state (randomR (bl, bh)) + <*> state (randomR (cl, ch)) + <*> state (randomR (dl, dh)) + <*> state (randomR (el, eh)) + <*> state (randomR (fl, fh)) + <*> state (randomR (gl, gh)) + {-# INLINE randomR #-} + random = runState $ + (,,,,,,) <$> state random + <*> state random + <*> state random + <*> state random + <*> state random + <*> state random + <*> state random + {-# INLINE random #-} + +------------------------------------------------------------------------------- +-- Global pseudo-random number generator +------------------------------------------------------------------------------- + +-- $globalstdgen +-- +-- There is a single, implicit, global pseudo-random number generator of type +-- 'StdGen', held in a global mutable variable that can be manipulated from +-- within the 'IO' monad. It is also available as +-- 'System.Random.Stateful.globalStdGen', therefore it is recommended to use the +-- new "System.Random.Stateful" interface to explicitly operate on the global +-- pseudo-random number generator. +-- +-- It is initialised with 'initStdGen', although it is possible to override its +-- value with 'setStdGen'. All operations on the global pseudo-random number +-- generator are thread safe, however in presence of concurrency they are +-- naturally become non-deterministic. Moreover, relying on the global mutable +-- state makes it hard to know which of the dependent libraries are using it as +-- well, making it unpredictable in the local context. Precisely of this reason, +-- the global pseudo-random number generator is only suitable for uses in +-- applications, test suites, etc. and is advised against in development of +-- reusable libraries. +-- +-- It is also important to note that either using 'StdGen' with pure functions +-- from other sections of this module or by relying on +-- 'System.Random.Stateful.runStateGen' from stateful interface does not only +-- give us deterministic behaviour without requiring 'IO', but it is also more +-- efficient. + + +-- | Sets the global pseudo-random number generator. Overwrites the contents of +-- 'System.Random.Stateful.globalStdGen' +-- +-- @since 1.0.0 +setStdGen :: MonadIO m => StdGen -> m () +setStdGen = liftIO . writeIORef theStdGen + +-- | Gets the global pseudo-random number generator. Extracts the contents of +-- 'System.Random.Stateful.globalStdGen' +-- +-- @since 1.0.0 +getStdGen :: MonadIO m => m StdGen +getStdGen = liftIO $ readIORef theStdGen + +-- | Applies 'split' to the current global pseudo-random generator +-- 'System.Random.Stateful.globalStdGen', updates it with one of the results, +-- and returns the other. +-- +-- @since 1.0.0 +newStdGen :: MonadIO m => m StdGen +newStdGen = liftIO $ atomicModifyIORef' theStdGen splitGen + +-- | 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@ produces a pseudo-random integer +-- between 1 and 6: +-- +-- >>> rollDice = getStdRandom (randomR (1, 6)) +-- >>> replicateM 10 (rollDice :: IO Int) +-- [1,1,1,4,5,6,1,2,2,5] +-- +-- This is an outdated function and it is recommended to switch to its +-- equivalent 'System.Random.Stateful.applyAtomicGen' instead, possibly with the +-- 'System.Random.Stateful.globalStdGen' if relying on the global state is +-- acceptable. +-- +-- >>> import System.Random.Stateful +-- >>> rollDice = applyAtomicGen (uniformR (1, 6)) globalStdGen +-- >>> replicateM 10 (rollDice :: IO Int) +-- [2,1,1,5,4,3,6,6,3,2] +-- +-- @since 1.0.0 +getStdRandom :: MonadIO m => (StdGen -> (a, StdGen)) -> m a +getStdRandom f = liftIO $ atomicModifyIORef' theStdGen (swap . f) + where swap (v, g) = (g, v) + + +-- | A variant of 'System.Random.Stateful.randomRM' that uses the global +-- pseudo-random number generator 'System.Random.Stateful.globalStdGen' +-- +-- >>> randomRIO (2020, 2100) :: IO Int +-- 2028 +-- +-- Similar to 'randomIO', this function is equivalent to @'getStdRandom' +-- 'randomR'@ and is included in this interface for historical reasons and +-- backwards compatibility. It is recommended to use +-- 'System.Random.Stateful.uniformRM' instead, possibly with the +-- 'System.Random.Stateful.globalStdGen' if relying on the global state is +-- acceptable. +-- +-- >>> import System.Random.Stateful +-- >>> uniformRM (2020, 2100) globalStdGen :: IO Int +-- 2044 +-- +-- @since 1.0.0 +randomRIO :: (Random a, MonadIO m) => (a, a) -> m a +randomRIO range = getStdRandom (randomR range) + +-- | A variant of 'System.Random.Stateful.randomM' that uses the global +-- pseudo-random number generator 'System.Random.Stateful.globalStdGen'. +-- +-- >>> import Data.Int +-- >>> randomIO :: IO Int32 +-- 114794456 +-- +-- This function is equivalent to @'getStdRandom' 'random'@ and is included in +-- this interface for historical reasons and backwards compatibility. It is +-- recommended to use 'System.Random.Stateful.uniformM' instead, possibly with +-- the 'System.Random.Stateful.globalStdGen' if relying on the global state is +-- acceptable. +-- +-- >>> import System.Random.Stateful +-- >>> uniformM globalStdGen :: IO Int32 +-- -1768545016 +-- +-- @since 1.0.0 +randomIO :: (Random a, MonadIO m) => m a +randomIO = 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) +-- >>> setStdGen (mkStdGen 0) diff --git a/src/System/Random/Array.hs b/src/System/Random/Array.hs new file mode 100644 --- /dev/null +++ b/src/System/Random/Array.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UnboxedTuples #-} +-- | +-- Module : System.Random.Array +-- Copyright : (c) Alexey Kuleshevich 2024 +-- License : BSD-style (see the file LICENSE in the 'random' repository) +-- Maintainer : libraries@haskell.org +-- +module System.Random.Array + ( -- * Helper array functionality + ioToST + , wordSizeInBits + -- ** MutableByteArray + , newMutableByteArray + , newPinnedMutableByteArray + , freezeMutableByteArray + , writeWord8 + , writeWord64LE + , writeByteSliceWord64LE + , indexWord8 + , indexWord64LE + , indexByteSliceWord64LE + , sizeOfByteArray + , shortByteStringToByteArray + , byteArrayToShortByteString + , getSizeOfMutableByteArray + , shortByteStringToByteString + -- ** MutableArray + , Array (..) + , MutableArray (..) + , newMutableArray + , freezeMutableArray + , writeArray + , shuffleListM + , shuffleListST + ) where + +import Control.Monad.Trans (lift, MonadTrans) +import Control.Monad (when) +import Control.Monad.ST +import Data.Array.Byte (ByteArray(..), MutableByteArray(..)) +import Data.Bits +import Data.ByteString.Short.Internal (ShortByteString(SBS)) +import qualified Data.ByteString.Short.Internal as SBS (fromShort) +import Data.Word +import GHC.Exts +import GHC.IO (IO(..)) +import GHC.ST (ST(..)) +import GHC.Word +#if __GLASGOW_HASKELL__ >= 802 +import Data.ByteString.Internal (ByteString(PS)) +import GHC.ForeignPtr +#else +import Data.ByteString (ByteString) +#endif + +-- Needed for WORDS_BIGENDIAN +#include "MachDeps.h" + +wordSizeInBits :: Int +wordSizeInBits = finiteBitSize (0 :: Word) + +---------------- +-- Byte Array -- +---------------- + +-- Architecture independent helpers: + +sizeOfByteArray :: ByteArray -> Int +sizeOfByteArray (ByteArray ba#) = I# (sizeofByteArray# ba#) + +st_ :: (State# s -> State# s) -> ST s () +st_ m# = ST $ \s# -> (# m# s#, () #) +{-# INLINE st_ #-} + +ioToST :: IO a -> ST RealWorld a +ioToST (IO m#) = ST m# +{-# INLINE ioToST #-} + +newMutableByteArray :: Int -> ST s (MutableByteArray s) +newMutableByteArray (I# n#) = + ST $ \s# -> + case newByteArray# n# s# of + (# s'#, mba# #) -> (# s'#, MutableByteArray mba# #) +{-# INLINE newMutableByteArray #-} + +newPinnedMutableByteArray :: Int -> ST s (MutableByteArray s) +newPinnedMutableByteArray (I# n#) = + ST $ \s# -> + case newPinnedByteArray# n# s# of + (# s'#, mba# #) -> (# s'#, MutableByteArray mba# #) +{-# INLINE newPinnedMutableByteArray #-} + +freezeMutableByteArray :: MutableByteArray s -> ST s ByteArray +freezeMutableByteArray (MutableByteArray mba#) = + ST $ \s# -> + case unsafeFreezeByteArray# mba# s# of + (# s'#, ba# #) -> (# s'#, ByteArray ba# #) + +writeWord8 :: MutableByteArray s -> Int -> Word8 -> ST s () +writeWord8 (MutableByteArray mba#) (I# i#) (W8# w#) = st_ (writeWord8Array# mba# i# w#) +{-# INLINE writeWord8 #-} + +writeByteSliceWord64LE :: MutableByteArray s -> Int -> Int -> Word64 -> ST s () +writeByteSliceWord64LE mba fromByteIx toByteIx = go fromByteIx + where + go !i !z = + when (i < toByteIx) $ do + writeWord8 mba i (fromIntegral z :: Word8) + go (i + 1) (z `shiftR` 8) +{-# INLINE writeByteSliceWord64LE #-} + +indexWord8 :: + ByteArray + -> Int -- ^ Offset into immutable byte array in number of bytes + -> Word8 +indexWord8 (ByteArray ba#) (I# i#) = + W8# (indexWord8Array# ba# i#) +{-# INLINE indexWord8 #-} + +indexWord64LE :: + ByteArray + -> Int -- ^ Offset into immutable byte array in number of bytes + -> Word64 +#if defined WORDS_BIGENDIAN || !(__GLASGOW_HASKELL__ >= 806) +indexWord64LE ba i = indexByteSliceWord64LE ba i (i + 8) +#else +indexWord64LE (ByteArray ba#) (I# i#) + | wordSizeInBits == 64 = W64# (indexWord8ArrayAsWord64# ba# i#) + | otherwise = + let !w32l = W32# (indexWord8ArrayAsWord32# ba# i#) + !w32u = W32# (indexWord8ArrayAsWord32# ba# (i# +# 4#)) + in (fromIntegral w32u `shiftL` 32) .|. fromIntegral w32l +#endif +{-# INLINE indexWord64LE #-} + +indexByteSliceWord64LE :: + ByteArray + -> Int -- ^ Starting offset in number of bytes + -> Int -- ^ Ending offset in number of bytes + -> Word64 +indexByteSliceWord64LE ba fromByteIx toByteIx = goWord8 fromByteIx 0 + where + r = (toByteIx - fromByteIx) `rem` 8 + nPadBits = if r == 0 then 0 else 8 * (8 - r) + goWord8 i !w64 + | i < toByteIx = goWord8 (i + 1) (shiftL w64 8 .|. fromIntegral (indexWord8 ba i)) + | otherwise = byteSwap64 (shiftL w64 nPadBits) +{-# INLINE indexByteSliceWord64LE #-} + +-- On big endian machines we need to write one byte at a time for consistency with little +-- endian machines. Also for GHC versions prior to 8.6 we don't have primops that can +-- write with byte offset, eg. writeWord8ArrayAsWord64# and writeWord8ArrayAsWord32#, so we +-- also must fallback to writing one byte a time. Such fallback results in about 3 times +-- slow down, which is not the end of the world. +writeWord64LE :: + MutableByteArray s + -> Int -- ^ Offset into mutable byte array in number of bytes + -> Word64 -- ^ 8 bytes that will be written into the supplied array + -> ST s () +#if defined WORDS_BIGENDIAN || !(__GLASGOW_HASKELL__ >= 806) +writeWord64LE mba i w64 = + writeByteSliceWord64LE mba i (i + 8) w64 +#else +writeWord64LE (MutableByteArray mba#) (I# i#) w64@(W64# w64#) + | wordSizeInBits == 64 = st_ (writeWord8ArrayAsWord64# mba# i# w64#) + | otherwise = do + let !(W32# w32l#) = fromIntegral w64 + !(W32# w32u#) = fromIntegral (w64 `shiftR` 32) + st_ (writeWord8ArrayAsWord32# mba# i# w32l#) + st_ (writeWord8ArrayAsWord32# mba# (i# +# 4#) w32u#) +#endif +{-# INLINE writeWord64LE #-} + +getSizeOfMutableByteArray :: MutableByteArray s -> ST s Int +getSizeOfMutableByteArray (MutableByteArray mba#) = +#if __GLASGOW_HASKELL__ >=802 + ST $ \s -> + case getSizeofMutableByteArray# mba# s of + (# s', n# #) -> (# s', I# n# #) +#else + pure $! I# (sizeofMutableByteArray# mba#) +#endif +{-# INLINE getSizeOfMutableByteArray #-} + +shortByteStringToByteArray :: ShortByteString -> ByteArray +shortByteStringToByteArray (SBS ba#) = ByteArray ba# +{-# INLINE shortByteStringToByteArray #-} + +byteArrayToShortByteString :: ByteArray -> ShortByteString +byteArrayToShortByteString (ByteArray ba#) = SBS ba# +{-# INLINE byteArrayToShortByteString #-} + +-- | Convert a ShortByteString to ByteString by casting, whenever memory is pinned, +-- otherwise make a copy into a new pinned ByteString +shortByteStringToByteString :: ShortByteString -> ByteString +shortByteStringToByteString ba = +#if __GLASGOW_HASKELL__ < 802 + SBS.fromShort ba +#else + let !(SBS ba#) = ba in + if isTrue# (isByteArrayPinned# ba#) + then pinnedByteArrayToByteString ba# + else SBS.fromShort ba +{-# INLINE shortByteStringToByteString #-} + +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 + +----------------- +-- Boxed Array -- +----------------- + +data Array a = Array (Array# a) + +data MutableArray s a = MutableArray (MutableArray# s a) + +newMutableArray :: Int -> a -> ST s (MutableArray s a) +newMutableArray (I# n#) a = + ST $ \s# -> + case newArray# n# a s# of + (# s'#, ma# #) -> (# s'#, MutableArray ma# #) +{-# INLINE newMutableArray #-} + +freezeMutableArray :: MutableArray s a -> ST s (Array a) +freezeMutableArray (MutableArray ma#) = + ST $ \s# -> + case unsafeFreezeArray# ma# s# of + (# s'#, a# #) -> (# s'#, Array a# #) +{-# INLINE freezeMutableArray #-} + +sizeOfMutableArray :: MutableArray s a -> Int +sizeOfMutableArray (MutableArray ma#) = I# (sizeofMutableArray# ma#) +{-# INLINE sizeOfMutableArray #-} + +readArray :: MutableArray s a -> Int -> ST s a +readArray (MutableArray ma#) (I# i#) = ST (readArray# ma# i#) +{-# INLINE readArray #-} + +writeArray :: MutableArray s a -> Int -> a -> ST s () +writeArray (MutableArray ma#) (I# i#) a = st_ (writeArray# ma# i# a) +{-# INLINE writeArray #-} + +swapArray :: MutableArray s a -> Int -> Int -> ST s () +swapArray ma i j = do + x <- readArray ma i + y <- readArray ma j + writeArray ma j x + writeArray ma i y +{-# INLINE swapArray #-} + +-- | Write contents of the list into the mutable array. Make sure that array is big +-- enough or segfault will happen. +fillMutableArrayFromList :: MutableArray s a -> [a] -> ST s () +fillMutableArrayFromList ma = go 0 + where + go _ [] = pure () + go i (x:xs) = writeArray ma i x >> go (i + 1) xs +{-# INLINE fillMutableArrayFromList #-} + +readListFromMutableArray :: MutableArray s a -> ST s [a] +readListFromMutableArray ma = go (len - 1) [] + where + len = sizeOfMutableArray ma + go i !acc + | i >= 0 = do + x <- readArray ma i + go (i - 1) (x : acc) + | otherwise = pure acc +{-# INLINE readListFromMutableArray #-} + + +-- | Generate a list of indices that will be used for swapping elements in uniform shuffling: +-- +-- @ +-- [ (0, n - 1) +-- , (0, n - 2) +-- , (0, n - 3) +-- , ... +-- , (0, 3) +-- , (0, 2) +-- , (0, 1) +-- ] +-- @ +genSwapIndices + :: Monad m + => (Word -> m Word) + -- ^ Action that generates a Word in the supplied range. + -> Word + -- ^ Number of index swaps to generate. + -> m [Int] +genSwapIndices genWordR n = go 1 [] + where + go i !acc + | i >= n = pure acc + | otherwise = do + x <- genWordR i + let !xi = fromIntegral x + go (i + 1) (xi : acc) +{-# INLINE genSwapIndices #-} + + +-- | Implementation of mutable version of Fisher-Yates shuffle. Unfortunately, we cannot generally +-- interleave pseudo-random number generation and mutation of `ST` monad, therefore we have to +-- pre-generate all of the index swaps with `genSwapIndices` and store them in a list before we can +-- perform the actual swaps. +shuffleListM :: Monad m => (Word -> m Word) -> [a] -> m [a] +shuffleListM genWordR ls + | len <= 1 = pure ls + | otherwise = do + swapIxs <- genSwapIndices genWordR (fromIntegral len) + pure $ runST $ do + ma <- newMutableArray len $ error "Impossible: shuffleListM" + fillMutableArrayFromList ma ls + + -- Shuffle elements of the mutable array according to the uniformly generated index swap list + let goSwap _ [] = pure () + goSwap i (j:js) = swapArray ma i j >> goSwap (i - 1) js + goSwap (len - 1) swapIxs + + readListFromMutableArray ma + where + len = length ls +{-# INLINE shuffleListM #-} + +-- | This is a ~x2-x3 more efficient version of `shuffleListM`. It is more efficient because it does +-- not need to pregenerate a list of indices and instead generates them on demand. Because of this the +-- result that will be produced will differ for the same generator, since the order in which index +-- swaps are generated is reversed. +-- +-- Unfortunately, most stateful generator monads can't handle `MonadTrans`, so this version is only +-- used for implementing the pure shuffle. +shuffleListST :: (Monad (t (ST s)), MonadTrans t) => (Word -> t (ST s) Word) -> [a] -> t (ST s) [a] +shuffleListST genWordR ls + | len <= 1 = pure ls + | otherwise = do + ma <- lift $ newMutableArray len $ error "Impossible: shuffleListST" + lift $ fillMutableArrayFromList ma ls + + -- Shuffle elements of the mutable array according to the uniformly generated index swap + let goSwap i = + when (i > 0) $ do + j <- genWordR $ (fromIntegral :: Int -> Word) i + lift $ swapArray ma i ((fromIntegral :: Word -> Int) j) + goSwap (i - 1) + goSwap (len - 1) + + lift $ readListFromMutableArray ma + where + len = length ls +{-# INLINE shuffleListST #-} diff --git a/src/System/Random/GFinite.hs b/src/System/Random/GFinite.hs new file mode 100644 --- /dev/null +++ b/src/System/Random/GFinite.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : System.Random.GFinite +-- Copyright : (c) Andrew Lelechenko 2020 +-- License : BSD-style (see the file LICENSE in the 'random' repository) +-- Maintainer : libraries@haskell.org +-- +module System.Random.GFinite + ( Cardinality(..) + , Finite(..) + , GFinite(..) + ) where + +import Data.Bits +import Data.Int +import Data.Void +import Data.Word +import GHC.Exts (Proxy#, proxy#) +import GHC.Generics + +-- | Cardinality of a set. +data Cardinality + = Shift !Int -- ^ Shift n is equivalent to Card (bit n) + | Card !Integer + deriving (Eq, Ord, Show) + +-- | This is needed only as a superclass of 'Integral'. +instance Enum Cardinality where + toEnum = fromIntegral + fromEnum = fromIntegral + succ = (+ 1) + pred = subtract 1 + enumFrom x = map fromInteger (enumFrom (toInteger x)) + enumFromThen x y = map fromInteger (enumFromThen (toInteger x) (toInteger y)) + enumFromTo x y = map fromInteger (enumFromTo (toInteger x) (toInteger y)) + enumFromThenTo x y z = map fromInteger (enumFromThenTo (toInteger x) (toInteger y) (toInteger z)) + +instance Num Cardinality where + fromInteger 1 = Shift 0 -- () + fromInteger 2 = Shift 1 -- Bool + fromInteger n = Card n + {-# INLINE fromInteger #-} + + x + y = fromInteger (toInteger x + toInteger y) + {-# INLINE (+) #-} + + Shift x * Shift y = Shift (x + y) + Shift x * Card y = Card (y `shiftL` x) + Card x * Shift y = Card (x `shiftL` y) + Card x * Card y = Card (x * y) + {-# INLINE (*) #-} + + abs = Card . abs . toInteger + signum = Card . signum . toInteger + negate = Card . negate . toInteger + +-- | This is needed only as a superclass of 'Integral'. +instance Real Cardinality where + toRational = fromIntegral + +instance Integral Cardinality where + toInteger = \case + Shift n -> bit n + Card n -> n + {-# INLINE toInteger #-} + + quotRem x' = \case + Shift n -> (Card (x `shiftR` n), Card (x .&. (bit n - 1))) + Card n -> let (q, r) = x `quotRem` n in (Card q, Card r) + where + x = toInteger x' + {-# INLINE quotRem #-} + +-- | A type class for data with a finite number of inhabitants. This type class +-- is used in the default implementation of 'System.Random.Stateful.Uniform'. +-- +-- Users are not supposed to write instances of 'Finite' manually. +-- There is a default implementation in terms of 'Generic' instead. +-- +-- >>> :seti -XDeriveGeneric -XDeriveAnyClass +-- >>> import GHC.Generics (Generic) +-- >>> data MyBool = MyTrue | MyFalse deriving (Generic, Finite) +-- >>> data Action = Code MyBool | Eat (Maybe Bool) | Sleep deriving (Generic, Finite) +-- +class Finite a where + cardinality :: Proxy# a -> Cardinality + toFinite :: Integer -> a + fromFinite :: a -> Integer + + default cardinality :: (Generic a, GFinite (Rep a)) => Proxy# a -> Cardinality + cardinality _ = gcardinality (proxy# :: Proxy# (Rep a)) + {-# INLINE cardinality #-} + + default toFinite :: (Generic a, GFinite (Rep a)) => Integer -> a + toFinite = to . toGFinite + {-# INLINE toFinite #-} + + default fromFinite :: (Generic a, GFinite (Rep a)) => a -> Integer + fromFinite = fromGFinite . from + {-# INLINE fromFinite #-} + +class GFinite f where + gcardinality :: Proxy# f -> Cardinality + toGFinite :: Integer -> f a + fromGFinite :: f a -> Integer + +instance GFinite V1 where + gcardinality _ = 0 + {-# INLINE gcardinality #-} + toGFinite = const $ error "GFinite: V1 has no inhabitants" + {-# INLINE toGFinite #-} + fromGFinite = const $ error "GFinite: V1 has no inhabitants" + {-# INLINE fromGFinite #-} + +instance GFinite U1 where + gcardinality _ = 1 + {-# INLINE gcardinality #-} + toGFinite = const U1 + {-# INLINE toGFinite #-} + fromGFinite = const 0 + {-# INLINE fromGFinite #-} + +instance Finite a => GFinite (K1 _x a) where + gcardinality _ = cardinality (proxy# :: Proxy# a) + {-# INLINE gcardinality #-} + toGFinite = K1 . toFinite + {-# INLINE toGFinite #-} + fromGFinite = fromFinite . unK1 + {-# INLINE fromGFinite #-} + +instance GFinite a => GFinite (M1 _x _y a) where + gcardinality _ = gcardinality (proxy# :: Proxy# a) + {-# INLINE gcardinality #-} + toGFinite = M1 . toGFinite + {-# INLINE toGFinite #-} + fromGFinite = fromGFinite . unM1 + {-# INLINE fromGFinite #-} + +instance (GFinite a, GFinite b) => GFinite (a :+: b) where + gcardinality _ = + gcardinality (proxy# :: Proxy# a) + gcardinality (proxy# :: Proxy# b) + {-# INLINE gcardinality #-} + + toGFinite n + | n < cardA = L1 $ toGFinite n + | otherwise = R1 $ toGFinite (n - cardA) + where + cardA = toInteger (gcardinality (proxy# :: Proxy# a)) + {-# INLINE toGFinite #-} + + fromGFinite = \case + L1 x -> fromGFinite x + R1 x -> fromGFinite x + toInteger (gcardinality (proxy# :: Proxy# a)) + {-# INLINE fromGFinite #-} + +instance (GFinite a, GFinite b) => GFinite (a :*: b) where + gcardinality _ = + gcardinality (proxy# :: Proxy# a) * gcardinality (proxy# :: Proxy# b) + {-# INLINE gcardinality #-} + + toGFinite n = toGFinite (toInteger q) :*: toGFinite (toInteger r) + where + cardB = gcardinality (proxy# :: Proxy# b) + (q, r) = Card n `quotRem` cardB + {-# INLINE toGFinite #-} + + fromGFinite (q :*: r) = + toInteger (gcardinality (proxy# :: Proxy# b) * Card (fromGFinite q)) + fromGFinite r + {-# INLINE fromGFinite #-} + +instance Finite Void +instance Finite () +instance Finite Bool +instance Finite Ordering + +instance Finite Char where + cardinality _ = Card $ toInteger (fromEnum (maxBound :: Char)) + 1 + {-# INLINE cardinality #-} + toFinite = toEnum . fromInteger + {-# INLINE toFinite #-} + fromFinite = toInteger . fromEnum + {-# INLINE fromFinite #-} + +cardinalityDef :: forall a. (Num a, FiniteBits a) => Proxy# a -> Cardinality +cardinalityDef _ = Shift (finiteBitSize (0 :: a)) + +toFiniteDef :: forall a. (Num a, FiniteBits a) => Integer -> a +toFiniteDef n + | isSigned (0 :: a) = fromInteger (n - bit (finiteBitSize (0 :: a) - 1)) + | otherwise = fromInteger n + +fromFiniteDef :: (Integral a, FiniteBits a) => a -> Integer +fromFiniteDef x + | isSigned x = toInteger x + bit (finiteBitSize x - 1) + | otherwise = toInteger x + +instance Finite Word8 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Word16 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Word32 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Word64 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Word where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Int8 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Int16 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Int32 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Int64 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Int where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} + +instance Finite a => Finite (Maybe a) +instance (Finite a, Finite b) => Finite (Either a b) +instance (Finite a, Finite b) => Finite (a, b) +instance (Finite a, Finite b, Finite c) => Finite (a, b, c) +instance (Finite a, Finite b, Finite c, Finite d) => Finite (a, b, c, d) +instance (Finite a, Finite b, Finite c, Finite d, Finite e) => Finite (a, b, c, d, e) +instance (Finite a, Finite b, Finite c, Finite d, Finite e, Finite f) => Finite (a, b, c, d, e, f) +instance (Finite a, Finite b, Finite c, Finite d, Finite e, Finite f, Finite g) => Finite (a, b, c, d, e, f, g) 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,1815 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# 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(..) + , SplitGen(..) + , Seed(..) + -- * Stateful + , StatefulGen(..) + , FrozenGen(..) + , ThawedGen(..) + , splitGenM + , splitMutableGenM + + -- ** Standard pseudo-random number generator + , StdGen(..) + , mkStdGen + , mkStdGen64 + , theStdGen + + -- * Monadic adapters for pure pseudo-random number generators + -- ** Pure adapter + , StateGen(..) + , StateGenM(..) + , runStateGen + , runStateGen_ + , runStateGenT + , runStateGenT_ + , runStateGenST + , runStateGenST_ + + -- * Pseudo-random values of various types + , Uniform(..) + , uniformViaFiniteM + , UniformRange(..) + , uniformWordR + , uniformDouble01M + , uniformDoublePositive01M + , uniformFloat01M + , uniformFloatPositive01M + , uniformEnumM + , uniformEnumRM + , uniformListM + , uniformListRM + , isInRangeOrd + , isInRangeEnum + , scaleFloating + + -- * Generators for sequences of pseudo-random bytes + , uniformShortByteStringM + , uniformByteArray + , fillByteArrayST + , genShortByteStringIO + , genShortByteStringST + , defaultUnsafeFillMutableByteArrayT + , defaultUnsafeUniformFillMutableByteArray + -- ** Helpers for dealing with MutableByteArray + , newMutableByteArray + , newPinnedMutableByteArray + , freezeMutableByteArray + , writeWord8 + , writeWord64LE + , indexWord8 + , indexWord64LE + , indexByteSliceWord64LE + , sizeOfByteArray + , shortByteStringToByteArray + , byteArrayToShortByteString + ) where + +import Control.Arrow +import Control.DeepSeq (NFData) +import Control.Monad (replicateM, when, (>=>)) +import Control.Monad.Cont (ContT, runContT) +import Control.Monad.ST +import Control.Monad.State.Strict (MonadState(..), State, StateT(..), execStateT, runState) +import Control.Monad.Trans (lift, MonadTrans) +import Control.Monad.Trans.Identity (IdentityT (runIdentityT)) +import Data.Array.Byte (ByteArray(..), MutableByteArray(..)) +import Data.Bits +import Data.ByteString.Short.Internal (ShortByteString(SBS)) +import Data.IORef (IORef, newIORef) +import Data.Int +import Data.Word +import Foreign.C.Types +import Foreign.Storable (Storable) +import GHC.Exts +import GHC.Generics +import GHC.IO (IO(..)) +import GHC.ST (ST(..)) +import GHC.Word +import Numeric.Natural (Natural) +import System.IO.Unsafe (unsafePerformIO) +import System.Random.Array +import System.Random.GFinite (Cardinality(..), GFinite(..), Finite) +import qualified System.Random.SplitMix as SM +import qualified System.Random.SplitMix32 as SM32 +import Data.Kind + +-- | This is a binary form of pseudo-random number generator's state. It is designed to be +-- safe and easy to use for input/output operations like restoring from file, transmitting +-- over the network, etc. +-- +-- Constructor is not exported, becasue it is important for implementation to enforce the +-- invariant of the underlying byte array being of the exact same length as the generator has +-- specified in `System.Random.Seed.SeedSize`. Use `System.Random.Seed.mkSeed` and +-- `System.Random.Seed.unSeed` to get access to the raw bytes in a safe manner. +-- +-- @since 1.3.0 +newtype Seed g = Seed ByteArray + deriving (Eq, Ord, Show) + + +-- | 'RandomGen' is an interface to pure pseudo-random number generators. +-- +-- 'StdGen' is the standard 'RandomGen' instance provided by this library. +-- +-- @since 1.0.0 +{-# DEPRECATED next "No longer used" #-} +{-# DEPRECATED genRange "No longer used" #-} +class RandomGen g where + {-# MINIMAL (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. + -- + -- @since 1.0.0 + 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 + {-# INLINE genWord8 #-} + + -- | Returns a 'Word16' that is uniformly distributed over the entire 'Word16' + -- range. + -- + -- @since 1.2.0 + genWord16 :: g -> (Word16, g) + genWord16 = first fromIntegral . genWord32 + {-# INLINE genWord16 #-} + + -- | 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 + {-# INLINE genWord32 #-} + + -- | 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'') + {-# INLINE genWord64 #-} + + -- | @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) + {-# INLINE genWord32R #-} + + -- | @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) + {-# INLINE genWord64R #-} + + -- | Same as @`uniformByteArray` `False`@, but for `ShortByteString`. + -- + -- @genShortByteString n g@ returns a 'ShortByteString' of length @n@ filled with + -- pseudo-random bytes. + -- + -- /Note/ - This function will be removed from the type class in the next major release as + -- it is no longer needed because of `unsafeUniformFillMutableByteArray`. + -- + -- @since 1.2.0 + genShortByteString :: Int -> g -> (ShortByteString, g) + genShortByteString n g = + case uniformByteArray False n g of + (ByteArray ba#, g') -> (SBS ba#, g') + {-# INLINE genShortByteString #-} + + -- | Fill in the supplied `MutableByteArray` with uniformly generated random bytes. This function + -- is unsafe because it is not required to do any bounds checking. For a safe variant use + -- `System.Random.Sateful.uniformFillMutableByteArrayM` instead. + -- + -- Default type class implementation uses `defaultUnsafeUniformFillMutableByteArray`. + -- + -- @since 1.3.0 + unsafeUniformFillMutableByteArray :: + MutableByteArray s + -- ^ Mutable array to fill with random bytes + -> Int + -- ^ Offset into a mutable array from the beginning in number of bytes. Offset must + -- be non-negative, but this will not be checked + -> Int + -- ^ Number of randomly generated bytes to write into the array. Number of bytes + -- must be non-negative and less then the total size of the array, minus the + -- offset. This also will be checked. + -> g + -> ST s g + unsafeUniformFillMutableByteArray = defaultUnsafeUniformFillMutableByteArray + {-# INLINE unsafeUniformFillMutableByteArray #-} + + -- | 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'. + -- + -- @since 1.0.0 + 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. + -- + -- @since 1.0.0 + split :: g -> (g, g) + default split :: SplitGen g => g -> (g, g) + split = splitGen + +{-# DEPRECATED genShortByteString "In favor of `System.Random.uniformShortByteString`" #-} +{-# DEPRECATED split "In favor of `splitGen`" #-} + +-- | Pseudo-random generators that can be split into two separate and independent +-- psuedo-random generators should provide an instance for this type class. +-- +-- Historically this functionality was included in the `RandomGen` type class in the +-- `split` function, however, few pseudo-random generators possess this property of +-- splittability. This lead the old `split` function being usually implemented in terms of +-- `error`. +-- +-- @since 1.3.0 +class RandomGen g => SplitGen g where + + -- | Returns two distinct pseudo-random number generators. + -- + -- Implementations should take care to ensure that the resulting generators + -- are not correlated. + -- + -- @since 1.3.0 + splitGen :: g -> (g, g) + +-- | 'StatefulGen' is an interface to monadic pseudo-random number generators. +-- +-- @since 1.2.0 +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 + {-# INLINE uniformWord32R #-} + + -- | @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 + {-# INLINE uniformWord64R #-} + + -- | 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 + {-# INLINE uniformWord8 #-} + + -- | 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 + {-# INLINE uniformWord16 #-} + + -- | 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 + {-# INLINE uniformWord32 #-} + + -- | 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) + {-# INLINE uniformWord64 #-} + + -- | @uniformByteArrayM n g@ generates a 'ByteArray' of length @n@ + -- filled with pseudo-random bytes. + -- + -- @since 1.3.0 + uniformByteArrayM :: + Bool -- ^ Should `ByteArray` be allocated as pinned memory or not + -> Int -- ^ Size of the newly created `ByteArray` in number of bytes. + -> g -- ^ Generator to use for filling in the newly created `ByteArray` + -> m ByteArray + default uniformByteArrayM :: + (RandomGen f, FrozenGen f m, g ~ MutableGen f m) => Bool -> Int -> g -> m ByteArray + uniformByteArrayM isPinned n g = modifyGen g (uniformByteArray isPinned n) + {-# INLINE uniformByteArrayM #-} + + -- | @uniformShortByteString n g@ generates a 'ShortByteString' of length @n@ + -- filled with pseudo-random bytes. + -- + -- @since 1.2.0 + uniformShortByteString :: Int -> g -> m ShortByteString + uniformShortByteString = uniformShortByteStringM + {-# INLINE uniformShortByteString #-} +{-# DEPRECATED uniformShortByteString "In favor of `uniformShortByteStringM`" #-} + + +-- | This class is designed for mutable pseudo-random number generators that have a frozen +-- imutable counterpart that can be manipulated in pure code. +-- +-- It also works great with frozen generators that are based on pure generators that have +-- a `RandomGen` instance. +-- +-- Here are a few laws, which are important for this type class: +-- +-- * Roundtrip and complete destruction on overwrite: +-- +-- @ +-- overwriteGen mg fg >> freezeGen mg = pure fg +-- @ +-- +-- * Modification of a mutable generator: +-- +-- @ +-- overwriteGen mg fg = modifyGen mg (const ((), fg) +-- @ +-- +-- * Freezing of a mutable generator: +-- +-- @ +-- freezeGen mg = modifyGen mg (\fg -> (fg, fg)) +-- @ +-- +-- @since 1.2.0 +class StatefulGen (MutableGen f m) m => FrozenGen f m where + {-# MINIMAL (modifyGen|(freezeGen,overwriteGen)) #-} + -- | Represents the state of the pseudo-random number generator for use with + -- 'thawGen' and 'freezeGen'. + -- + -- @since 1.2.0 + type MutableGen f m = (g :: Type) | g -> f + + -- | Saves the state of the pseudo-random number generator as a frozen seed. + -- + -- @since 1.2.0 + freezeGen :: MutableGen f m -> m f + freezeGen mg = modifyGen mg (\fg -> (fg, fg)) + {-# INLINE freezeGen #-} + + -- | Apply a pure function to the frozen pseudo-random number generator. + -- + -- @since 1.3.0 + modifyGen :: MutableGen f m -> (f -> (a, f)) -> m a + modifyGen mg f = do + fg <- freezeGen mg + case f fg of + (a, !fg') -> a <$ overwriteGen mg fg' + {-# INLINE modifyGen #-} + + -- | Overwrite contents of the mutable pseudo-random number generator with the + -- supplied frozen one + -- + -- @since 1.3.0 + overwriteGen :: MutableGen f m -> f -> m () + overwriteGen mg fg = modifyGen mg (const ((), fg)) + {-# INLINE overwriteGen #-} + +-- | Functionality for thawing frozen generators is not part of the `FrozenGen` class, +-- becase not all mutable generators support functionality of creating new mutable +-- generators, which is what thawing is in its essence. For this reason `StateGen` does +-- not have an instance for this type class, but it has one for `FrozenGen`. +-- +-- Here is an important law that relates this type class to `FrozenGen` +-- +-- * Roundtrip and independence of mutable generators: +-- +-- @ +-- traverse thawGen fgs >>= traverse freezeGen = pure fgs +-- @ +-- +-- @since 1.3.0 +class FrozenGen f m => ThawedGen f m where + -- | Create a new mutable pseudo-random number generator from its frozen state. + -- + -- @since 1.2.0 + thawGen :: f -> m (MutableGen f m) + +-- | Splits a pseudo-random number generator into two. Overwrites the mutable +-- pseudo-random number generator with one of the immutable pseudo-random number +-- generators produced by a `split` function and returns the other. +-- +-- @since 1.3.0 +splitGenM :: (SplitGen f, FrozenGen f m) => MutableGen f m -> m f +splitGenM = flip modifyGen splitGen + +-- | Splits a pseudo-random number generator into two. Overwrites the mutable wrapper with +-- one of the resulting generators and returns the other as a new mutable generator. +-- +-- @since 1.3.0 +splitMutableGenM :: (SplitGen f, ThawedGen f m) => MutableGen f m -> m (MutableGen f m) +splitMutableGenM = splitGenM >=> thawGen + +-- | Efficiently generates a sequence of pseudo-random bytes in a platform +-- independent manner. +-- +-- @since 1.3.0 +uniformByteArray :: + RandomGen g + => Bool -- ^ Should byte array be allocated in pinned or unpinned memory. + -> Int -- ^ Number of bytes to generate + -> g -- ^ Pure pseudo-random numer generator + -> (ByteArray, g) +uniformByteArray isPinned n0 g = + runST $ do + let !n = max 0 n0 + mba <- + if isPinned + then newPinnedMutableByteArray n + else newMutableByteArray n + g' <- unsafeUniformFillMutableByteArray mba 0 n g + ba <- freezeMutableByteArray mba + pure (ba, g') +{-# INLINE uniformByteArray #-} + +-- | Using an `ST` action that generates 8 bytes at a time fill in a new `ByteArray` in +-- architecture agnostic manner. +-- +-- @since 1.3.0 +fillByteArrayST :: Bool -> Int -> ST s Word64 -> ST s ByteArray +fillByteArrayST isPinned n0 action = do + let !n = max 0 n0 + mba <- if isPinned + then newPinnedMutableByteArray n + else newMutableByteArray n + runIdentityT $ defaultUnsafeFillMutableByteArrayT mba 0 n (lift action) + freezeMutableByteArray mba +{-# INLINE fillByteArrayST #-} + +defaultUnsafeFillMutableByteArrayT :: + (Monad (t (ST s)), MonadTrans t) + => MutableByteArray s + -> Int + -> Int + -> t (ST s) Word64 + -> t (ST s) () +defaultUnsafeFillMutableByteArrayT mba offset n gen64 = do + let !n64 = n `quot` 8 + !endIx64 = offset + n64 * 8 + !nrem = n `rem` 8 + let go !i = + when (i < endIx64) $ do + w64 <- gen64 + -- Writing 8 bytes at a time in a Little-endian order gives us + -- platform portability + lift $ writeWord64LE mba i w64 + go (i + 8) + go offset + when (nrem > 0) $ do + let !endIx = offset + n + w64 <- gen64 + -- In order to not mess up the byte order we write 1 byte at a time in + -- Little endian order. 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. + lift $ writeByteSliceWord64LE mba (endIx - nrem) endIx w64 +{-# INLINEABLE defaultUnsafeFillMutableByteArrayT #-} +{-# SPECIALIZE defaultUnsafeFillMutableByteArrayT + :: MutableByteArray s + -> Int + -> Int + -> IdentityT (ST s) Word64 + -> IdentityT (ST s) () #-} +{-# SPECIALIZE defaultUnsafeFillMutableByteArrayT + :: MutableByteArray s + -> Int + -> Int + -> StateT g (ST s) Word64 + -> StateT g (ST s) () #-} + +-- | Efficiently generates a sequence of pseudo-random bytes in a platform +-- independent manner. +-- +-- @since 1.2.0 +defaultUnsafeUniformFillMutableByteArray :: + RandomGen g + => MutableByteArray s + -> Int -- ^ Starting offset + -> Int -- ^ Number of random bytes to write into the array + -> g -- ^ ST action that can generate 8 random bytes at a time + -> ST s g +defaultUnsafeUniformFillMutableByteArray mba i0 n g = + flip execStateT g + $ defaultUnsafeFillMutableByteArrayT mba i0 n (state genWord64) +{-# INLINE defaultUnsafeUniformFillMutableByteArray #-} + + +-- | Same as 'genShortByteStringIO', but runs in 'ST'. +-- +-- @since 1.2.0 +genShortByteStringST :: Int -> ST s Word64 -> ST s ShortByteString +genShortByteStringST n0 action = byteArrayToShortByteString <$> fillByteArrayST False n0 action +{-# INLINE genShortByteStringST #-} +{-# DEPRECATED genShortByteStringST "In favor of `fillByteArrayST`, since `uniformShortByteString`, which it was used for, was also deprecated" #-} + +-- | Efficiently fills in a new `ShortByteString` in a platform independent manner. +-- +-- @since 1.2.0 +genShortByteStringIO :: + Int -- ^ Number of bytes to generate + -> IO Word64 -- ^ IO action that can generate 8 random bytes at a time + -> IO ShortByteString +genShortByteStringIO n ioAction = stToIO $ genShortByteStringST n (ioToST ioAction) +{-# INLINE genShortByteStringIO #-} +{-# DEPRECATED genShortByteStringIO "In favor of `fillByteArrayST`" #-} + +-- | @uniformShortByteString n g@ generates a 'ShortByteString' of length @n@ +-- filled with pseudo-random bytes. +-- +-- @since 1.3.0 +uniformShortByteStringM :: StatefulGen g m => Int -> g -> m ShortByteString +uniformShortByteStringM n g = byteArrayToShortByteString <$> uniformByteArrayM False n g +{-# INLINE uniformShortByteStringM #-} + +-- | 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, SplitGen, Storable, NFData) + +instance (RandomGen g, MonadState g m) => StatefulGen (StateGenM g) m where + uniformWord32R r _ = state (genWord32R r) + {-# INLINE uniformWord32R #-} + uniformWord64R r _ = state (genWord64R r) + {-# INLINE uniformWord64R #-} + uniformWord8 _ = state genWord8 + {-# INLINE uniformWord8 #-} + uniformWord16 _ = state genWord16 + {-# INLINE uniformWord16 #-} + uniformWord32 _ = state genWord32 + {-# INLINE uniformWord32 #-} + uniformWord64 _ = state genWord64 + {-# INLINE uniformWord64 #-} + +instance (RandomGen g, MonadState g m) => FrozenGen (StateGen g) m where + type MutableGen (StateGen g) m = StateGenM g + freezeGen _ = fmap StateGen get + modifyGen _ f = state (coerce f) + {-# INLINE modifyGen #-} + overwriteGen _ f = put (coerce f) + {-# INLINE overwriteGen #-} + +-- | 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 +{-# INLINE runStateGen #-} + +-- | 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 +{-# INLINE runStateGen_ #-} + +-- | 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 +{-# INLINE runStateGenT #-} + +-- | 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.1 +runStateGenT_ :: (RandomGen g, Functor f) => g -> (StateGenM g -> StateT g f a) -> f a +runStateGenT_ g = fmap fst . runStateGenT g +{-# INLINE runStateGenT_ #-} + +-- | 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 #-} + +-- | Runs a monadic generating action in the `ST` monad using a pure +-- pseudo-random number generator. Same as `runStateGenST`, but discards the +-- resulting generator. +-- +-- @since 1.2.1 +runStateGenST_ :: RandomGen g => g -> (forall s . StateGenM g -> StateT g (ST s) a) -> a +runStateGenST_ g action = runST $ runStateGenT_ g action +{-# INLINE runStateGenST_ #-} + + +-- | 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) +{-# INLINE uniformListM #-} + + +-- | Generates a list of pseudo-random values in a specified range. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> let pureGen = mkStdGen 137 +-- >>> g <- newIOGenM pureGen +-- >>> uniformListRM 10 (20, 30) g :: IO [Int] +-- [23,21,28,25,28,28,26,25,29,27] +-- +-- @since 1.3.0 +uniformListRM :: (StatefulGen g m, UniformRange a) => Int -> (a, a) -> g -> m [a] +uniformListRM n range gen = replicateM n (uniformRM range gen) +{-# INLINE uniformListRM #-} + +-- | The standard pseudo-random number generator. +newtype StdGen = StdGen { unStdGen :: SM.SMGen } + deriving (Show, RandomGen, SplitGen, NFData) + +instance Eq StdGen where + StdGen x1 == StdGen x2 = SM.unseedSMGen x1 == SM.unseedSMGen x2 + +instance RandomGen SM.SMGen where + next = SM.nextInt + {-# INLINE next #-} + genWord32 = SM.nextWord32 + {-# INLINE genWord32 #-} + genWord64 = SM.nextWord64 + {-# INLINE genWord64 #-} + -- Despite that this is the same default implementation as in the type class definition, + -- for some mysterious reason without this overwrite, performance of ByteArray generation + -- slows down by a factor of x4: + unsafeUniformFillMutableByteArray = defaultUnsafeUniformFillMutableByteArray + {-# INLINE unsafeUniformFillMutableByteArray #-} + +instance SplitGen SM.SMGen where + splitGen = SM.splitSMGen + {-# INLINE splitGen #-} + +instance RandomGen SM32.SMGen where + next = SM32.nextInt + {-# INLINE next #-} + genWord32 = SM32.nextWord32 + {-# INLINE genWord32 #-} + genWord64 = SM32.nextWord64 + {-# INLINE genWord64 #-} + +instance SplitGen SM32.SMGen where + splitGen = SM32.splitSMGen + {-# INLINE splitGen #-} + +-- | Constructs a 'StdGen' deterministically from an `Int` seed. See `mkStdGen64` for a `Word64` +-- variant that is architecture agnostic. +mkStdGen :: Int -> StdGen +mkStdGen = mkStdGen64 . fromIntegral + +-- | Constructs a 'StdGen' deterministically from a `Word64` seed. +-- +-- The difference between `mkStdGen` is that `mkStdGen64` will work the same on 64-bit and +-- 32-bit architectures, while the former can only use 32-bit of information for +-- initializing the psuedo-random number generator on 32-bit operating systems +-- +-- @since 1.3.0 +mkStdGen64 :: Word64 -> StdGen +mkStdGen64 = StdGen . SM.mkSMGen + +-- | Global mutable veriable with `StdGen` +theStdGen :: IORef StdGen +theStdGen = unsafePerformIO $ SM.initSMGen >>= newIORef . StdGen +{-# NOINLINE theStdGen #-} + + +-- | 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. + -- + -- There is a default implementation via 'Generic': + -- + -- >>> :seti -XDeriveGeneric -XDeriveAnyClass + -- >>> import GHC.Generics (Generic) + -- >>> import System.Random.Stateful + -- >>> data MyBool = MyTrue | MyFalse deriving (Show, Generic, Finite, Uniform) + -- >>> data Action = Code MyBool | Eat (Maybe Bool) | Sleep deriving (Show, Generic, Finite, Uniform) + -- >>> gen <- newIOGenM (mkStdGen 42) + -- >>> uniformListM 10 gen :: IO [Action] + -- [Code MyTrue,Code MyTrue,Eat Nothing,Code MyFalse,Eat (Just False),Eat (Just True),Eat Nothing,Eat (Just False),Sleep,Code MyFalse] + -- + -- @since 1.2.0 + uniformM :: StatefulGen g m => g -> m a + + default uniformM :: (StatefulGen g m, Generic a, GUniform (Rep a)) => g -> m a + uniformM = fmap to . (`runContT` pure) . guniformM + {-# INLINE uniformM #-} + +-- | Default implementation of 'Uniform' type class for 'Generic' data. +-- It's important to use 'ContT', because without it 'fmap' and '>>=' remain +-- polymorphic too long and GHC fails to inline or specialize it, ending up +-- building full 'Rep' a structure in memory. 'ContT' +-- makes 'fmap' and '>>=' used in 'guniformM' monomorphic, so GHC is able to +-- specialize 'Generic' instance reasonably close to a handwritten one. +class GUniform f where + guniformM :: StatefulGen g m => g -> ContT r m (f a) + +instance GUniform f => GUniform (M1 i c f) where + guniformM = fmap M1 . guniformM + {-# INLINE guniformM #-} + +instance Uniform a => GUniform (K1 i a) where + guniformM = fmap K1 . lift . uniformM + {-# INLINE guniformM #-} + +instance GUniform U1 where + guniformM = const $ return U1 + {-# INLINE guniformM #-} + +instance (GUniform f, GUniform g) => GUniform (f :*: g) where + guniformM g = (:*:) <$> guniformM g <*> guniformM g + {-# INLINE guniformM #-} + +instance (GFinite f, GFinite g) => GUniform (f :+: g) where + guniformM = lift . finiteUniformM + {-# INLINE guniformM #-} + +finiteUniformM :: forall g m f a. (StatefulGen g m, GFinite f) => g -> m (f a) +finiteUniformM = fmap toGFinite . case gcardinality (proxy# :: Proxy# f) of + Shift n + | n <= 64 -> fmap toInteger . unsignedBitmaskWithRejectionM uniformWord64 (bit n - 1) + | otherwise -> boundedByPowerOf2ExclusiveIntegralM n + Card n + | n <= bit 64 -> fmap toInteger . unsignedBitmaskWithRejectionM uniformWord64 (fromInteger n - 1) + | otherwise -> boundedExclusiveIntegralM n +{-# INLINE finiteUniformM #-} + +-- | A definition of 'Uniform' for 'System.Random.Finite' types. +-- If your data has several fields of sub-'Word' cardinality, +-- this instance may be more efficient than one, derived via 'Generic' and 'GUniform'. +-- +-- >>> :seti -XDeriveGeneric -XDeriveAnyClass +-- >>> import GHC.Generics (Generic) +-- >>> import System.Random.Stateful +-- >>> data Triple = Triple Word8 Word8 Word8 deriving (Show, Generic, Finite) +-- >>> instance Uniform Triple where uniformM = uniformViaFiniteM +-- >>> gen <- newIOGenM (mkStdGen 42) +-- >>> uniformListM 5 gen :: IO [Triple] +-- [Triple 60 226 48,Triple 234 194 151,Triple 112 96 95,Triple 51 251 15,Triple 6 0 208] +-- +uniformViaFiniteM :: (StatefulGen g m, Generic a, GFinite (Rep a)) => g -> m a +uniformViaFiniteM = fmap to . finiteUniformM +{-# INLINE uniformViaFiniteM #-} + +-- | 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) + -- + -- The range is understood as defined by means of 'isInRange', so + -- + -- > isInRange (a, b) <$> uniformRM (a, b) gen == pure True + -- + -- but beware of + -- [floating point number caveats](System-Random-Stateful.html#fpcaveats). + -- + -- There is a default implementation via 'Generic': + -- + -- >>> :seti -XDeriveGeneric -XDeriveAnyClass + -- >>> import GHC.Generics (Generic) + -- >>> import Data.Word (Word8) + -- >>> import Control.Monad (replicateM) + -- >>> import System.Random.Stateful + -- >>> gen <- newIOGenM (mkStdGen 42) + -- >>> data Tuple = Tuple Bool Word8 deriving (Show, Generic, UniformRange) + -- >>> replicateM 10 (uniformRM (Tuple False 100, Tuple True 150) gen) + -- [Tuple False 102,Tuple True 118,Tuple False 115,Tuple True 113,Tuple True 126,Tuple False 127,Tuple True 130,Tuple False 113,Tuple False 150,Tuple False 125] + -- + -- @since 1.2.0 + uniformRM :: StatefulGen g m => (a, a) -> g -> m a + + -- | A notion of (inclusive) ranges prescribed to @a@. + -- + -- Ranges are symmetric: + -- + -- > isInRange (lo, hi) x == isInRange (hi, lo) x + -- + -- Ranges include their endpoints: + -- + -- > isInRange (lo, hi) lo == True + -- + -- When endpoints coincide, there is nothing else: + -- + -- > isInRange (x, x) y == x == y + -- + -- Endpoints are endpoints: + -- + -- > isInRange (lo, hi) x ==> + -- > isInRange (lo, x) hi == x == hi + -- + -- Ranges are transitive relations: + -- + -- > isInRange (lo, hi) lo' && isInRange (lo, hi) hi' && isInRange (lo', hi') x + -- > ==> isInRange (lo, hi) x + -- + -- There is a default implementation of 'isInRange' via 'Generic'. Other helper function + -- that can be used for implementing this function are `isInRangeOrd` and + -- `isInRangeEnum`. + -- + -- Note that the @isRange@ method from @Data.Ix@ is /not/ a suitable default + -- implementation of 'isInRange'. Unlike 'isInRange', @isRange@ is not + -- required to be symmetric, and many @isRange@ implementations are not + -- symmetric in practice. + -- + -- @since 1.3.0 + isInRange :: (a, a) -> a -> Bool + + default uniformRM :: (StatefulGen g m, Generic a, GUniformRange (Rep a)) => (a, a) -> g -> m a + uniformRM (a, b) = fmap to . (`runContT` pure) . guniformRM (from a, from b) + {-# INLINE uniformRM #-} + + default isInRange :: (Generic a, GUniformRange (Rep a)) => (a, a) -> a -> Bool + isInRange (a, b) x = gisInRange (from a, from b) (from x) + {-# INLINE isInRange #-} + +class GUniformRange f where + guniformRM :: StatefulGen g m => (f a, f a) -> g -> ContT r m (f a) + gisInRange :: (f a, f a) -> f a -> Bool + +instance GUniformRange f => GUniformRange (M1 i c f) where + guniformRM (M1 a, M1 b) = fmap M1 . guniformRM (a, b) + {-# INLINE guniformRM #-} + gisInRange (M1 a, M1 b) (M1 x) = gisInRange (a, b) x + +instance UniformRange a => GUniformRange (K1 i a) where + guniformRM (K1 a, K1 b) = fmap K1 . lift . uniformRM (a, b) + {-# INLINE guniformRM #-} + gisInRange (K1 a, K1 b) (K1 x) = isInRange (a, b) x + +instance GUniformRange U1 where + guniformRM = const $ const $ return U1 + {-# INLINE guniformRM #-} + gisInRange = const $ const True + +instance (GUniformRange f, GUniformRange g) => GUniformRange (f :*: g) where + guniformRM (x1 :*: y1, x2 :*: y2) g = + (:*:) <$> guniformRM (x1, x2) g <*> guniformRM (y1, y2) g + {-# INLINE guniformRM #-} + gisInRange (x1 :*: y1, x2 :*: y2) (x3 :*: y3) = + gisInRange (x1, x2) x3 && gisInRange (y1, y2) y3 + +-- | Utilize `Ord` instance to decide if a value is within the range. Designed to be used +-- for implementing `isInRange` +-- +-- @since 1.3.0 +isInRangeOrd :: Ord a => (a, a) -> a -> Bool +isInRangeOrd (a, b) x = min a b <= x && x <= max a b + +-- | Utilize `Enum` instance to decide if a value is within the range. Designed to be used +-- for implementing `isInRange` +-- +-- @since 1.3.0 +isInRangeEnum :: Enum a => (a, a) -> a -> Bool +isInRangeEnum (a, b) x = isInRangeOrd (fromEnum a, fromEnum b) (fromEnum x) + +instance UniformRange Integer where + uniformRM = uniformIntegralM + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance UniformRange Natural where + uniformRM = uniformIntegralM + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform Int8 where + uniformM = fmap (fromIntegral :: Word8 -> Int8) . uniformWord8 + {-# INLINE uniformM #-} +instance UniformRange Int8 where + uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int8 -> Word8) fromIntegral + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform Int16 where + uniformM = fmap (fromIntegral :: Word16 -> Int16) . uniformWord16 + {-# INLINE uniformM #-} +instance UniformRange Int16 where + uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int16 -> Word16) fromIntegral + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform Int32 where + uniformM = fmap (fromIntegral :: Word32 -> Int32) . uniformWord32 + {-# INLINE uniformM #-} +instance UniformRange Int32 where + uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int32 -> Word32) fromIntegral + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform Int64 where + uniformM = fmap (fromIntegral :: Word64 -> Int64) . uniformWord64 + {-# INLINE uniformM #-} +instance UniformRange Int64 where + uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int64 -> Word64) fromIntegral + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform Int where + uniformM + | wordSizeInBits == 64 = + fmap (fromIntegral :: Word64 -> Int) . uniformWord64 + | otherwise = + fmap (fromIntegral :: Word32 -> Int) . uniformWord32 + {-# INLINE uniformM #-} + +instance UniformRange Int where + uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int -> Word) fromIntegral + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform Word where + uniformM + | wordSizeInBits == 64 = + fmap (fromIntegral :: Word64 -> Word) . uniformWord64 + | otherwise = + fmap (fromIntegral :: Word32 -> Word) . uniformWord32 + {-# INLINE uniformM #-} + +instance UniformRange Word where + uniformRM = unsignedBitmaskWithRejectionRM + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +-- | Architecture specific `Word` generation in the specified lower range +-- +-- @since 1.3.0 +uniformWordR :: + StatefulGen g m + => Word + -- ^ Maximum value to generate + -> g + -- ^ Stateful generator + -> m Word +uniformWordR r + | wordSizeInBits == 64 = + fmap (fromIntegral :: Word64 -> Word) . uniformWord64R ((fromIntegral :: Word -> Word64) r) + | otherwise = + fmap (fromIntegral :: Word32 -> Word) . uniformWord32R ((fromIntegral :: Word -> Word32) r) +{-# INLINE uniformWordR #-} + +instance Uniform Word8 where + uniformM = uniformWord8 + {-# INLINE uniformM #-} +instance UniformRange Word8 where + uniformRM = unbiasedWordMult32RM + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform Word16 where + uniformM = uniformWord16 + {-# INLINE uniformM #-} +instance UniformRange Word16 where + uniformRM = unbiasedWordMult32RM + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform Word32 where + uniformM = uniformWord32 + {-# INLINE uniformM #-} +instance UniformRange Word32 where + uniformRM = unbiasedWordMult32RM + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform Word64 where + uniformM = uniformWord64 + {-# INLINE uniformM #-} +instance UniformRange Word64 where + uniformRM = unsignedBitmaskWithRejectionRM + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +#if __GLASGOW_HASKELL__ >= 802 +instance Uniform CBool where + uniformM = fmap CBool . uniformM + {-# INLINE uniformM #-} +instance UniformRange CBool where + uniformRM (CBool b, CBool t) = fmap CBool . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd +#endif + +instance Uniform CChar where + uniformM = fmap CChar . uniformM + {-# INLINE uniformM #-} +instance UniformRange CChar where + uniformRM (CChar b, CChar t) = fmap CChar . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CSChar where + uniformM = fmap CSChar . uniformM + {-# INLINE uniformM #-} +instance UniformRange CSChar where + uniformRM (CSChar b, CSChar t) = fmap CSChar . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CUChar where + uniformM = fmap CUChar . uniformM + {-# INLINE uniformM #-} +instance UniformRange CUChar where + uniformRM (CUChar b, CUChar t) = fmap CUChar . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CShort where + uniformM = fmap CShort . uniformM + {-# INLINE uniformM #-} +instance UniformRange CShort where + uniformRM (CShort b, CShort t) = fmap CShort . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CUShort where + uniformM = fmap CUShort . uniformM + {-# INLINE uniformM #-} +instance UniformRange CUShort where + uniformRM (CUShort b, CUShort t) = fmap CUShort . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CInt where + uniformM = fmap CInt . uniformM + {-# INLINE uniformM #-} +instance UniformRange CInt where + uniformRM (CInt b, CInt t) = fmap CInt . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CUInt where + uniformM = fmap CUInt . uniformM + {-# INLINE uniformM #-} +instance UniformRange CUInt where + uniformRM (CUInt b, CUInt t) = fmap CUInt . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CLong where + uniformM = fmap CLong . uniformM + {-# INLINE uniformM #-} +instance UniformRange CLong where + uniformRM (CLong b, CLong t) = fmap CLong . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CULong where + uniformM = fmap CULong . uniformM + {-# INLINE uniformM #-} +instance UniformRange CULong where + uniformRM (CULong b, CULong t) = fmap CULong . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CPtrdiff where + uniformM = fmap CPtrdiff . uniformM + {-# INLINE uniformM #-} +instance UniformRange CPtrdiff where + uniformRM (CPtrdiff b, CPtrdiff t) = fmap CPtrdiff . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CSize where + uniformM = fmap CSize . uniformM + {-# INLINE uniformM #-} +instance UniformRange CSize where + uniformRM (CSize b, CSize t) = fmap CSize . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CWchar where + uniformM = fmap CWchar . uniformM + {-# INLINE uniformM #-} +instance UniformRange CWchar where + uniformRM (CWchar b, CWchar t) = fmap CWchar . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CSigAtomic where + uniformM = fmap CSigAtomic . uniformM + {-# INLINE uniformM #-} +instance UniformRange CSigAtomic where + uniformRM (CSigAtomic b, CSigAtomic t) = fmap CSigAtomic . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CLLong where + uniformM = fmap CLLong . uniformM + {-# INLINE uniformM #-} +instance UniformRange CLLong where + uniformRM (CLLong b, CLLong t) = fmap CLLong . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CULLong where + uniformM = fmap CULLong . uniformM + {-# INLINE uniformM #-} +instance UniformRange CULLong where + uniformRM (CULLong b, CULLong t) = fmap CULLong . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CIntPtr where + uniformM = fmap CIntPtr . uniformM + {-# INLINE uniformM #-} +instance UniformRange CIntPtr where + uniformRM (CIntPtr b, CIntPtr t) = fmap CIntPtr . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CUIntPtr where + uniformM = fmap CUIntPtr . uniformM + {-# INLINE uniformM #-} +instance UniformRange CUIntPtr where + uniformRM (CUIntPtr b, CUIntPtr t) = fmap CUIntPtr . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CIntMax where + uniformM = fmap CIntMax . uniformM + {-# INLINE uniformM #-} +instance UniformRange CIntMax where + uniformRM (CIntMax b, CIntMax t) = fmap CIntMax . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance Uniform CUIntMax where + uniformM = fmap CUIntMax . uniformM + {-# INLINE uniformM #-} +instance UniformRange CUIntMax where + uniformRM (CUIntMax b, CUIntMax t) = fmap CUIntMax . uniformRM (b, t) + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +-- | 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 #-} + isInRange = isInRangeOrd + +-- | 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 #-} + isInRange = isInRangeOrd + +-- 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 +#if __GLASGOW_HASKELL__ < 902 +word32ToChar (W32# w#) = C# (chr# (word2Int# w#)) +#else +word32ToChar (W32# w#) = C# (chr# (word2Int# (word32ToWord# w#))) +#endif +{-# INLINE word32ToChar #-} + +charToWord32 :: Char -> Word32 +#if __GLASGOW_HASKELL__ < 902 +charToWord32 (C# c#) = W32# (int2Word# (ord# c#)) +#else +charToWord32 (C# c#) = W32# (wordToWord32# (int2Word# (ord# c#))) +#endif +{-# 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 #-} + isInRange = isInRangeOrd + +instance Uniform () where + uniformM = const $ pure () + {-# INLINE uniformM #-} +instance UniformRange () where + uniformRM = const $ const $ pure () + {-# INLINE uniformRM #-} + +instance Uniform Bool where + uniformM = fmap wordToBool . uniformWord8 + where wordToBool w = (w .&. 1) /= 0 + {-# INLINE wordToBool #-} + {-# INLINE uniformM #-} +instance UniformRange Bool where + uniformRM (False, False) _g = return False + uniformRM (True, True) _g = return True + uniformRM _ g = uniformM g + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +instance (Finite a, Uniform a) => Uniform (Maybe a) + +instance (Finite a, Uniform a, Finite b, Uniform b) => Uniform (Either a b) + +-- | See [Floating point number caveats](System-Random-Stateful.html#fpcaveats). +instance UniformRange Double where + uniformRM (l, h) g + | l == h = return l + | isInfinite l || isInfinite h = + -- Optimisation exploiting absorption: + -- (+Infinity) + (-Infinity) = NaN + -- (-Infinity) + (+Infinity) = NaN + -- (+Infinity) + _ = +Infinity + -- (-Infinity) + _ = -Infinity + -- _ + (+Infinity) = +Infinity + -- _ + (-Infinity) = -Infinity + return $! h + l + | otherwise = do + w64 <- uniformWord64 g + pure $! scaleFloating l h w64 + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +-- | 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 'UniformRange' instance for +-- 'Double'. +-- +-- @since 1.2.0 +uniformDouble01M :: forall g m. StatefulGen g m => g -> m Double +uniformDouble01M g = do + w64 <- uniformWord64 g + return $ fromIntegral w64 / m + where + m = fromIntegral (maxBound :: Word64) :: Double +{-# INLINE uniformDouble01M #-} + +-- | 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 :: forall g m. 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) +{-# INLINE uniformDoublePositive01M #-} + +-- | See [Floating point number caveats](System-Random-Stateful.html#fpcaveats). +instance UniformRange Float where + uniformRM (l, h) g + | l == h = return l + | isInfinite l || isInfinite h = + -- Optimisation exploiting absorption: + -- (+Infinity) + (-Infinity) = NaN + -- (-Infinity) + (+Infinity) = NaN + -- (+Infinity) + _ = +Infinity + -- (-Infinity) + _ = -Infinity + -- _ + (+Infinity) = +Infinity + -- _ + (-Infinity) = -Infinity + return $! h + l + | otherwise = do + w32 <- uniformWord32 g + pure $! scaleFloating l h w32 + {-# INLINE uniformRM #-} + isInRange = isInRangeOrd + +-- | This is the function that is used to scale a floating point value from random word range to +-- the custom @[low, high]@ range. +-- +-- @since 1.3.0 +scaleFloating :: + forall a w. (RealFloat a, Integral w, Bounded w, FiniteBits w) + => a + -- ^ Low + -> a + -- ^ High + -> w + -- ^ Uniformly distributed unsigned integral value that will be used for converting to a floating + -- point value and subsequent scaling to the specified range + -> a +scaleFloating l h w = + if isInfinite diff + then let !x = fromIntegral w / m + !y = x * l + (1 - x) * h + in max (min y (max l h)) (min l h) + else let !topMostBit = finiteBitSize w - 1 + !x = fromIntegral (clearBit w topMostBit) / m + in if testBit w topMostBit + then l + diff * x + else h + negate diff * x + where + !diff = h - l + !m = fromIntegral (maxBound :: w) :: a +{-# INLINE scaleFloating #-} + +-- | 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 'UniformRange' instance for 'Float'. +-- +-- @since 1.2.0 +uniformFloat01M :: forall g m. StatefulGen g m => g -> m Float +uniformFloat01M g = do + w32 <- uniformWord32 g + return $ fromIntegral w32 / m + where + m = fromIntegral (maxBound :: Word32) :: Float +{-# INLINE uniformFloat01M #-} + +-- | 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 :: forall g m. StatefulGen g m => g -> m Float +uniformFloatPositive01M g = (+ d) <$> uniformFloat01M g + where + -- See uniformDoublePositive01M + d = 1.1641532182693481e-10 -- 2**(-33) +{-# INLINE uniformFloatPositive01M #-} + +-- | Generates uniformly distributed 'Enum'. +-- One can use it to define a 'Uniform' instance: +-- +-- > data Colors = Red | Green | Blue deriving (Enum, Bounded) +-- > instance Uniform Colors where uniformM = uniformEnumM +-- +-- @since 1.3.0 +uniformEnumM :: forall a g m. (Enum a, Bounded a, StatefulGen g m) => g -> m a +uniformEnumM g = toEnum <$> uniformRM (fromEnum (minBound :: a), fromEnum (maxBound :: a)) g +{-# INLINE uniformEnumM #-} + +-- | Generates uniformly distributed 'Enum' in the given range. +-- One can use it to define a 'UniformRange' instance: +-- +-- > data Colors = Red | Green | Blue deriving (Enum) +-- > instance UniformRange Colors where +-- > uniformRM = uniformEnumRM +-- > inInRange (lo, hi) x = isInRange (fromEnum lo, fromEnum hi) (fromEnum x) +-- +-- @since 1.3.0 +uniformEnumRM :: forall a g m. (Enum a, StatefulGen g m) => (a, a) -> g -> m a +uniformEnumRM (l, h) g = toEnum <$> uniformRM (fromEnum l, fromEnum h) g +{-# INLINE uniformEnumRM #-} + +-- 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 :: forall a g m. (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 #-} +{-# SPECIALIZE uniformIntegralM :: StatefulGen g m => (Integer, Integer) -> g -> m Integer #-} +{-# SPECIALIZE uniformIntegralM :: StatefulGen g m => (Natural, Natural) -> g -> m Natural #-} + +-- | 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 #-} + +-- | boundedByPowerOf2ExclusiveIntegralM s ~ boundedExclusiveIntegralM (bit s) +boundedByPowerOf2ExclusiveIntegralM :: + forall a g m. (Bits a, Integral a, StatefulGen g m) => Int -> g -> m a +boundedByPowerOf2ExclusiveIntegralM s gen = do + let n = (s + wordSizeInBits - 1) `quot` wordSizeInBits + x <- uniformIntegralWords n gen + return $ x .&. (bit s - 1) +{-# INLINE boundedByPowerOf2ExclusiveIntegralM #-} + +-- | @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 :: forall a g m. (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 :: forall a g m. (Integral a, StatefulGen g m) => (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 +{-# INLINE unbiasedWordMult32RM #-} + +-- | Uniformly generate Word32 in @[0, s]@. +unbiasedWordMult32 :: forall g m. 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 +{-# INLINE unbiasedWordMult32Exclusive #-} + +-- | This only works for unsigned integrals +unsignedBitmaskWithRejectionRM :: + forall a g m . (FiniteBits a, Num a, Ord a, Uniform a, StatefulGen g m) + => (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 :: + forall a b g m. (Num a, Num b, Ord b, Ord a, FiniteBits a, StatefulGen g m, 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. + -> m 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 + {-# INLINE uniformM #-} + +instance (Uniform a, Uniform b, Uniform c) => Uniform (a, b, c) where + uniformM g = (,,) <$> uniformM g <*> uniformM g <*> uniformM g + {-# INLINE uniformM #-} + +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 + {-# INLINE uniformM #-} + +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 + {-# INLINE uniformM #-} + +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 + {-# INLINE uniformM #-} + +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 + {-# INLINE uniformM #-} + +instance (UniformRange a, UniformRange b) => UniformRange (a, b) +instance (UniformRange a, UniformRange b, UniformRange c) => UniformRange (a, b, c) +instance (UniformRange a, UniformRange b, UniformRange c, UniformRange d) => UniformRange (a, b, c, d) +instance (UniformRange a, UniformRange b, UniformRange c, UniformRange d, UniformRange e) => UniformRange (a, b, c, d, e) +instance (UniformRange a, UniformRange b, UniformRange c, UniformRange d, UniformRange e, UniformRange f) => UniformRange (a, b, c, d, e, f) +instance (UniformRange a, UniformRange b, UniformRange c, UniformRange d, UniformRange e, UniformRange f, UniformRange g) => UniformRange (a, b, c, d, e, f, 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/Seed.hs b/src/System/Random/Seed.hs new file mode 100644 --- /dev/null +++ b/src/System/Random/Seed.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- | +-- Module : System.Random.Seed +-- Copyright : (c) Alexey Kuleshevich 2024 +-- License : BSD-style (see the file LICENSE in the 'random' repository) +-- Maintainer : libraries@haskell.org +-- + +module System.Random.Seed + ( SeedGen(..) + , -- ** Seed + Seed + , seedSize + , seedSizeProxy + , mkSeed + , unSeed + , mkSeedFromByteString + , unSeedToByteString + , withSeed + , withSeedM + , withSeedFile + , seedGenTypeName + , nonEmptyToSeed + , nonEmptyFromSeed + ) where + +import Control.Monad (unless) +import qualified Control.Monad.Fail as F +import Control.Monad.IO.Class +import Control.Monad.ST +import Control.Monad.State.Strict (get, put, runStateT) +import Data.Array.Byte (ByteArray(..)) +import Data.Bits +import qualified Data.ByteString as BS +import qualified Data.ByteString.Short.Internal as SBS (fromShort, toShort) +import Data.Coerce +import Data.Functor.Identity (runIdentity) +import Data.List.NonEmpty as NE (NonEmpty(..), nonEmpty, toList) +import Data.Typeable +import Data.Word +import GHC.Exts (Proxy#, proxy#) +import GHC.TypeLits (Nat, KnownNat, natVal', type (<=)) +import System.Random.Internal +import qualified System.Random.SplitMix as SM +import qualified System.Random.SplitMix32 as SM32 + + +-- | Interface for converting a pure pseudo-random number generator to and from non-empty +-- sequence of bytes. Seeds are stored in Little-Endian order regardless of the platform +-- it is being used on, which provides cross-platform compatibility, while providing +-- optimal performance for the most common platform type. +-- +-- Conversion to and from a `Seed` serves as a building block for implementing +-- serialization for any pure or frozen pseudo-random number generator. +-- +-- It is not trivial to implement platform independence. For this reason this type class +-- has two alternative ways of creating an instance for this class. The easiest way for +-- constructing a platform indepent seed is by converting the inner state of a generator +-- to and from a list of 64 bit words using `toSeed64` and `fromSeed64` respectively. In +-- that case cross-platform support will be handled automaticaly. +-- +-- >>> :set -XDataKinds -XTypeFamilies +-- >>> import Data.Word (Word8, Word32) +-- >>> import Data.Bits ((.|.), shiftR, shiftL) +-- >>> import Data.List.NonEmpty (NonEmpty ((:|))) +-- >>> data FiveByteGen = FiveByteGen Word8 Word32 deriving Show +-- >>> :{ +-- instance SeedGen FiveByteGen where +-- type SeedSize FiveByteGen = 5 +-- fromSeed64 (w64 :| _) = +-- FiveByteGen (fromIntegral (w64 `shiftR` 32)) (fromIntegral w64) +-- toSeed64 (FiveByteGen x1 x4) = +-- let w64 = (fromIntegral x1 `shiftL` 32) .|. fromIntegral x4 +-- in (w64 :| []) +-- :} +-- +-- >>> FiveByteGen 0x80 0x01020304 +-- FiveByteGen 128 16909060 +-- >>> fromSeed (toSeed (FiveByteGen 0x80 0x01020304)) +-- FiveByteGen 128 16909060 +-- >>> toSeed (FiveByteGen 0x80 0x01020304) +-- Seed [0x04, 0x03, 0x02, 0x01, 0x80] +-- >>> toSeed64 (FiveByteGen 0x80 0x01020304) +-- 549772722948 :| [] +-- +-- However, when performance is of utmost importance or default handling of cross platform +-- independence is not sufficient, then an adventurous developer can try implementing +-- conversion into bytes directly with `toSeed` and `fromSeed`. +-- +-- Properties that must hold: +-- +-- @ +-- > fromSeed (toSeed gen) == gen +-- @ +-- +-- @ +-- > fromSeed64 (toSeed64 gen) == gen +-- @ +-- +-- Note, that there is no requirement for every `Seed` to roundtrip, eg. this proprty does +-- not even hold for `StdGen`: +-- +-- >>> let seed = nonEmptyToSeed (0xab :| [0xff00]) :: Seed StdGen +-- >>> seed == toSeed (fromSeed seed) +-- False +-- +-- @since 1.3.0 +class (KnownNat (SeedSize g), 1 <= SeedSize g, Typeable g) => SeedGen g where + -- | Number of bytes that is required for storing the full state of a pseudo-random + -- number generator. It should be big enough to satisfy the roundtrip property: + -- + -- @ + -- > fromSeed (toSeed gen) == gen + -- @ + -- + type SeedSize g :: Nat + {-# MINIMAL (fromSeed, toSeed)|(fromSeed64, toSeed64) #-} + + -- | Convert from a binary representation to a pseudo-random number generator + -- + -- @since 1.3.0 + fromSeed :: Seed g -> g + fromSeed = fromSeed64 . nonEmptyFromSeed + + -- | Convert to a binary representation of a pseudo-random number generator + -- + -- @since 1.3.0 + toSeed :: g -> Seed g + toSeed = nonEmptyToSeed . toSeed64 + + -- | Construct pseudo-random number generator from a list of words. Whenever list does + -- not have enough bytes to satisfy the `SeedSize` requirement, it will be padded with + -- zeros. On the other hand when it has more than necessary, extra bytes will be dropped. + -- + -- For example if `SeedSize` is set to 2, then only the lower 16 bits of the first + -- element in the list will be used. + -- + -- @since 1.3.0 + fromSeed64 :: NonEmpty Word64 -> g + fromSeed64 = fromSeed . nonEmptyToSeed + + -- | Convert pseudo-random number generator to a list of words + -- + -- In case when `SeedSize` is not a multiple of 8, then the upper bits of the last word + -- in the list will be set to zero. + -- + -- @since 1.3.0 + toSeed64 :: g -> NonEmpty Word64 + toSeed64 = nonEmptyFromSeed . toSeed + +instance SeedGen StdGen where + type SeedSize StdGen = SeedSize SM.SMGen + fromSeed = coerce (fromSeed :: Seed SM.SMGen -> SM.SMGen) + toSeed = coerce (toSeed :: SM.SMGen -> Seed SM.SMGen) + +instance SeedGen g => SeedGen (StateGen g) where + type SeedSize (StateGen g) = SeedSize g + fromSeed = coerce (fromSeed :: Seed g -> g) + toSeed = coerce (toSeed :: g -> Seed g) + +instance SeedGen SM.SMGen where + type SeedSize SM.SMGen = 16 + fromSeed (Seed ba) = + SM.seedSMGen (indexWord64LE ba 0) (indexWord64LE ba 8) + toSeed g = + case SM.unseedSMGen g of + (seed, gamma) -> Seed $ runST $ do + mba <- newMutableByteArray 16 + writeWord64LE mba 0 seed + writeWord64LE mba 8 gamma + freezeMutableByteArray mba + +instance SeedGen SM32.SMGen where + type SeedSize SM32.SMGen = 8 + fromSeed (Seed ba) = + let x = indexWord64LE ba 0 + seed, gamma :: Word32 + seed = fromIntegral (shiftR x 32) + gamma = fromIntegral x + in SM32.seedSMGen seed gamma + toSeed g = + let seed, gamma :: Word32 + (seed, gamma) = SM32.unseedSMGen g + in Seed $ runST $ do + mba <- newMutableByteArray 8 + let w64 :: Word64 + w64 = shiftL (fromIntegral seed) 32 .|. fromIntegral gamma + writeWord64LE mba 0 w64 + freezeMutableByteArray mba + +instance SeedGen g => Uniform (Seed g) where + uniformM = fmap Seed . uniformByteArrayM False (seedSize @g) + +-- | Get the expected size of the `Seed` in number bytes +-- +-- @since 1.3.0 +seedSize :: forall g. SeedGen g => Int +seedSize = fromInteger $ natVal' (proxy# :: Proxy# (SeedSize g)) + +-- | Just like `seedSize`, except it accepts a proxy as an argument. +-- +-- @since 1.3.0 +seedSizeProxy :: forall proxy g. SeedGen g => proxy g -> Int +seedSizeProxy _px = seedSize @g + +-- | Construct a `Seed` from a `ByteArray` of expected length. Whenever `ByteArray` does +-- not match the `SeedSize` specified by the pseudo-random generator, this function will +-- `F.fail`. +-- +-- @since 1.3.0 +mkSeed :: forall g m. (SeedGen g, F.MonadFail m) => ByteArray -> m (Seed g) +mkSeed ba = do + unless (sizeOfByteArray ba == seedSize @g) $ do + F.fail $ "Unexpected number of bytes: " + ++ show (sizeOfByteArray ba) + ++ ". Exactly " + ++ show (seedSize @g) + ++ " bytes is required by the " + ++ show (seedGenTypeName @g) + pure $ Seed ba + +-- | Helper function that allows for operating directly on the `Seed`, while supplying a +-- function that uses the pseudo-random number generator that is constructed from that +-- `Seed`. +-- +-- ====__Example__ +-- +-- >>> :set -XTypeApplications +-- >>> import System.Random +-- >>> withSeed (nonEmptyToSeed (pure 2024) :: Seed StdGen) (uniform @Int) +-- (1039666877624726199,Seed [0xe9, 0x07, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) +-- +-- @since 1.3.0 +withSeed :: SeedGen g => Seed g -> (g -> (a, g)) -> (a, Seed g) +withSeed seed f = runIdentity (withSeedM seed (pure . f)) + +-- | Same as `withSeed`, except it is useful with monadic computation and frozen generators. +-- +-- See `System.Random.Stateful.withSeedMutableGen` for a helper that also handles seeds +-- for mutable pseduo-random number generators. +-- +-- @since 1.3.0 +withSeedM :: (SeedGen g, Functor f) => Seed g -> (g -> f (a, g)) -> f (a, Seed g) +withSeedM seed f = fmap toSeed <$> f (fromSeed seed) + +-- | This is a function that shows the name of the generator type, which is useful for +-- error reporting. +-- +-- @since 1.3.0 +seedGenTypeName :: forall g. SeedGen g => String +seedGenTypeName = show (typeOf (Proxy @g)) + + +-- | Just like `mkSeed`, but uses `ByteString` as argument. Results in a memcopy of the seed. +-- +-- @since 1.3.0 +mkSeedFromByteString :: (SeedGen g, F.MonadFail m) => BS.ByteString -> m (Seed g) +mkSeedFromByteString = mkSeed . shortByteStringToByteArray . SBS.toShort + +-- | Unwrap the `Seed` and get the underlying `ByteArray` +-- +-- @since 1.3.0 +unSeed :: Seed g -> ByteArray +unSeed (Seed ba) = ba + +-- | Just like `unSeed`, but produced a `ByteString`. Results in a memcopy of the seed. +-- +-- @since 1.3.0 +unSeedToByteString :: Seed g -> BS.ByteString +unSeedToByteString = SBS.fromShort . byteArrayToShortByteString . unSeed + + +-- | Read the seed from a file and use it for constructing a pseudo-random number +-- generator. After supplied action has been applied to the constructed generator, the +-- resulting generator will be converted back to a seed and written to the same file. +-- +-- @since 1.3.0 +withSeedFile :: (SeedGen g, MonadIO m) => FilePath -> (Seed g -> m (a, Seed g)) -> m a +withSeedFile fileName action = do + bs <- liftIO $ BS.readFile fileName + seed <- liftIO $ mkSeedFromByteString bs + (res, seed') <- action seed + liftIO $ BS.writeFile fileName $ unSeedToByteString seed' + pure res + +-- | Construct a seed from a list of 64-bit words. At most `SeedSize` many bytes will be used. +-- +-- @since 1.3.0 +nonEmptyToSeed :: forall g. SeedGen g => NonEmpty Word64 -> Seed g +nonEmptyToSeed xs = Seed $ runST $ do + let n = seedSize @g + mba <- newMutableByteArray n + _ <- flip runStateT (NE.toList xs) $ do + defaultUnsafeFillMutableByteArrayT mba 0 n $ do + get >>= \case + [] -> pure 0 + w:ws -> w <$ put ws + freezeMutableByteArray mba + +-- | Convert a `Seed` to a list of 64bit words. +-- +-- @since 1.3.0 +nonEmptyFromSeed :: forall g. SeedGen g => Seed g -> NonEmpty Word64 +nonEmptyFromSeed (Seed ba) = + case nonEmpty $ reverse $ goWord64 0 [] of + Just ne -> ne + Nothing -> -- Seed is at least 1 byte in size, so it can't be empty + error $ "Impossible: Seed for " + ++ seedGenTypeName @g + ++ " must be at least: " + ++ show (seedSize @g) + ++ " bytes, but got " + ++ show n + where + n = sizeOfByteArray ba + n8 = 8 * (n `quot` 8) + goWord64 i !acc + | i < n8 = goWord64 (i + 8) (indexWord64LE ba i : acc) + | i == n = acc + | otherwise = indexByteSliceWord64LE ba i n : acc 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,1006 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# 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 + ( uniformWord32R + , uniformWord64R + , uniformWord8 + , uniformWord16 + , uniformWord32 + , uniformWord64 + , uniformShortByteString + ) + , FrozenGen(..) + , ThawedGen(..) + , withMutableGen + , withMutableGen_ + , withSeedMutableGen + , withSeedMutableGen_ + , randomM + , randomRM + , splitGenM + , splitMutableGenM + + -- ** Deprecated + , RandomGenM(..) + + -- * Monadic adapters for pure pseudo-random number generators #monadicadapters# + -- $monadicadapters + + -- ** Pure adapter in 'MonadState' + , StateGen(..) + , StateGenM(..) + , runStateGen + , runStateGen_ + , runStateGenT + , runStateGenT_ + , runStateGenST + , runStateGenST_ + -- ** Mutable thread-safe adapter in 'IO' + , AtomicGen(..) + , AtomicGenM(..) + , newAtomicGenM + , applyAtomicGen + , globalStdGen + -- ** Mutable adapter in 'IO' + , IOGen(..) + , IOGenM(..) + , newIOGenM + , applyIOGen + -- ** Mutable adapter in 'ST' + , STGen(..) + , STGenM(..) + , newSTGenM + , applySTGen + , runSTGen + , runSTGen_ + -- ** Mutable thread-safe adapter in 'STM' + , TGen(..) + , TGenM(..) + , newTGenM + , newTGenMIO + , applyTGen + + -- * Pseudo-random values of various types + -- $uniform + , Uniform(..) + , uniformViaFiniteM + , UniformRange(..) + , isInRangeOrd + , isInRangeEnum + + -- ** Lists + , uniformListM + , uniformListRM + , uniformShuffleListM + + -- ** Generators for sequences of pseudo-random bytes + , uniformByteArrayM + , uniformByteStringM + , uniformShortByteStringM + + -- * Helper functions for createing instances + -- ** Sequences of bytes + , fillByteArrayST + , genShortByteStringIO + , genShortByteStringST + , defaultUnsafeUniformFillMutableByteArray + -- ** Floating point numbers + , uniformDouble01M + , uniformDoublePositive01M + , uniformFloat01M + , uniformFloatPositive01M + -- ** Enum types + , uniformEnumM + , uniformEnumRM + -- ** Word + , uniformWordR + + -- * Appendix + + -- ** How to implement 'StatefulGen' + -- $implemenstatefulegen + + -- ** Floating point number caveats #fpcaveats# + , scaleFloating + -- $floating + + -- * References + -- $references + ) where + +import Control.DeepSeq +import Control.Monad.IO.Class +import Control.Monad.ST +import GHC.Conc.Sync (STM, TVar, newTVar, newTVarIO, readTVar, writeTVar) +import Control.Monad.State.Strict (MonadState, state) +import Data.ByteString (ByteString) +import Data.Coerce +import Data.IORef +import Data.STRef +import Foreign.Storable +import System.Random hiding (uniformShortByteString) +import System.Random.Array (shuffleListM, shortByteStringToByteString) +import System.Random.Internal +#if __GLASGOW_HASKELL__ >= 808 +import GHC.IORef (atomicModifyIORef2Lazy) +#endif + + +-- $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', 'STGenM` and 'TGenM' +-- 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 using +-- [@mwc-random@](https://hackage.haskell.org/package/mwc-random) as follows: +-- +-- >>> import Control.Monad (replicateM) +-- >>> :{ +-- let rollsM :: StatefulGen g m => Int -> g -> m [Word] +-- rollsM n = replicateM n . uniformRM (1, 6) +-- :} +-- +-- > import qualified System.Random.MWC as MWC +-- > >>> 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 'Control.Monad.State.Strict.StateT', 'IO', 'ST' or 'STM' +-- context by applying a monadic adapter like 'StateGenM', 'AtomicGenM', 'IOGenM', +-- 'STGenM' or 'TGenM' (see [monadic-adapters](#monadicadapters)) to the pure +-- pseudo-random number generator. +-- +-- >>> let pureGen = mkStdGen 42 +-- >>> 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 +-- 'Control.Monad.State.Strict.StateT', 'ST', 'IO' or 'STM' or some other transformer +-- on top of those monads. +-- + +------------------------------------------------------------------------------- +-- Monadic adapters +------------------------------------------------------------------------------- + +-- $monadicadapters +-- +-- Pure pseudo-random number generators can be used in monadic code via the +-- adapters 'StateGenM', 'AtomicGenM', 'IOGenM', 'STGenM' and 'TGenM' +-- +-- * 'StateGenM' can be used in any state monad. With strict +-- 'Control.Monad.State.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. +-- +-- * 'TGenM' is a wrapper around a 'TVar' that holds a pure generator. 'TGenM' +-- can be used in a software transactional memory monad 'STM`. It is not as +-- performant as 'AtomicGenM`, but it can provide stronger guarantees in a +-- concurrent setting. + +-- | 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 +{-# DEPRECATED applyRandomGenM "In favor of `modifyGen`" #-} +{-# DEPRECATED RandomGenM "In favor of `FrozenGen`" #-} + +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 + +instance RandomGen r => RandomGenM (TGenM r) r STM where + applyRandomGenM = applyTGen + + +-- | Shuffle elements of a list in a uniformly random order. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> runStateGen_ (mkStdGen 127) $ uniformShuffleListM "ELVIS" +-- "LIVES" +-- +-- @since 1.3.0 +uniformShuffleListM :: StatefulGen g m => [a] -> g -> m [a] +uniformShuffleListM xs gen = shuffleListM (`uniformWordR` gen) xs +{-# INLINE uniformShuffleListM #-} + +-- | Runs a mutable pseudo-random number generator from its 'FrozenGen' 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 :: ThawedGen 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_ :: ThawedGen f m => f -> (MutableGen f m -> m a) -> m a +withMutableGen_ fg action = thawGen fg >>= action + + +-- | Just like `withMutableGen`, except uses a `Seed` instead of a frozen generator. +-- +-- ====__Examples__ +-- +-- Here is good example of how `withSeedMutableGen` can be used with `withSeedFile`, which uses a locally stored seed. +-- +-- First we define a @reportSeed@ function that will print the contents of a seed file as a list of bytes: +-- +-- >>> import Data.ByteString as BS (readFile, writeFile, unpack) +-- >>> :seti -XOverloadedStrings +-- >>> let reportSeed fp = print . ("Seed: " <>) . show . BS.unpack =<< BS.readFile fp +-- +-- Given a file path, write an `StdGen` seed into the file: +-- +-- >>> :seti -XFlexibleContexts -XScopedTypeVariables +-- >>> let writeInitSeed fp = BS.writeFile fp (unSeedToByteString (toSeed (mkStdGen 2025))) +-- +-- Apply a `StatefulGen` monadic action that uses @`IOGen` `StdGen`@, restored from the seed in the given path: +-- +-- >>> let withMutableSeedFile fp action = withSeedFile fp (\(seed :: Seed (IOGen StdGen)) -> withSeedMutableGen seed action) +-- +-- Given a path and an action initialize the seed file and apply the action using that seed: +-- +-- >>> let withInitSeedFile fp action = writeInitSeed fp *> reportSeed fp *> withMutableSeedFile fp action <* reportSeed fp +-- +-- For the sake of example we will use a temporary directory for storing the seed. Here we +-- report the contents of the seed file before and after we shuffle a list: +-- +-- >>> import UnliftIO.Temporary (withSystemTempDirectory) +-- >>> withSystemTempDirectory "random" (\fp -> withInitSeedFile (fp ++ "/seed.bin") (uniformShuffleListM [1..10])) +-- "Seed: [183,178,143,77,132,163,109,14,157,105,82,99,148,82,109,173]" +-- "Seed: [60,105,117,203,187,138,69,39,157,105,82,99,148,82,109,173]" +-- [7,5,4,3,1,8,10,6,9,2] +-- +-- @since 1.3.0 +withSeedMutableGen :: (SeedGen g, ThawedGen g m) => Seed g -> (MutableGen g m -> m a) -> m (a, Seed g) +withSeedMutableGen seed f = withSeedM seed (`withMutableGen` f) + +-- | Just like `withSeedMutableGen`, except it doesn't return the final generator, only +-- the resulting value. This is slightly more efficient, since it doesn't incur overhead +-- from freezeing the mutable generator +-- +-- @since 1.3.0 +withSeedMutableGen_ :: (SeedGen g, ThawedGen g m) => Seed g -> (MutableGen g m -> m a) -> m a +withSeedMutableGen_ seed = withMutableGen_ (fromSeed seed) + + +-- | Generates a pseudo-random value using monadic interface and `Random` instance. +-- +-- ====__Examples__ +-- +-- >>> import System.Random.Stateful +-- >>> let pureGen = mkStdGen 139 +-- >>> g <- newIOGenM pureGen +-- >>> randomM g :: IO Double +-- 0.33775117339631733 +-- +-- You can use type applications to disambiguate the type of the generated numbers: +-- +-- >>> :seti -XTypeApplications +-- >>> randomM @Double g +-- 0.9156875994165681 +-- +-- @since 1.2.0 +randomM :: forall a g m. (Random a, RandomGen g, FrozenGen g m) => MutableGen g m -> m a +randomM = flip modifyGen random +{-# INLINE randomM #-} + +-- | 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 +-- +-- You can use type applications to disambiguate the type of the generated numbers: +-- +-- >>> :seti -XTypeApplications +-- >>> randomRM @Int (1, 100) g +-- 2 +-- +-- @since 1.2.0 +randomRM :: forall a g m. (Random a, RandomGen g, FrozenGen g m) => (a, a) -> MutableGen g m -> m a +randomRM r = flip modifyGen (randomR r) +{-# INLINE randomRM #-} + +-- | Generates a pseudo-random 'ByteString' of the specified size. +-- +-- @since 1.2.0 +uniformByteStringM :: StatefulGen g m => Int -> g -> m ByteString +uniformByteStringM n g = + shortByteStringToByteString . byteArrayToShortByteString + <$> uniformByteArrayM True n g +{-# INLINE uniformByteStringM #-} + +-- | 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, SplitGen, Storable, NFData) + +-- Standalone definition due to GHC-8.0 not supporting deriving with associated type families +instance SeedGen g => SeedGen (AtomicGen g) where + type SeedSize (AtomicGen g) = SeedSize g + fromSeed = coerce (fromSeed :: Seed g -> g) + toSeed = coerce (toSeed :: g -> Seed g) + +-- | Creates a new 'AtomicGenM'. +-- +-- @since 1.2.0 +newAtomicGenM :: MonadIO m => g -> m (AtomicGenM g) +newAtomicGenM = fmap AtomicGenM . liftIO . newIORef + + +-- | Global mutable standard pseudo-random number generator. This is the same +-- generator that was historically used by `randomIO` and `randomRIO` functions. +-- +-- >>> import Control.Monad (replicateM) +-- >>> replicateM 10 (uniformRM ('a', 'z') globalStdGen) +-- "tdzxhyfvgr" +-- +-- @since 1.2.1 +globalStdGen :: AtomicGenM StdGen +globalStdGen = AtomicGenM theStdGen + + +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 #-} + + +instance (RandomGen g, MonadIO m) => FrozenGen (AtomicGen g) m where + type MutableGen (AtomicGen g) m = AtomicGenM g + freezeGen = fmap AtomicGen . liftIO . readIORef . unAtomicGenM + modifyGen (AtomicGenM ioRef) f = + liftIO $ atomicModifyIORefHS ioRef $ \g -> + case f (AtomicGen g) of + (a, AtomicGen g') -> (g', a) + {-# INLINE modifyGen #-} + +instance (RandomGen g, MonadIO m) => ThawedGen (AtomicGen g) m where + 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 $ atomicModifyIORefHS gVar $ \g -> + case op g of + (a, g') -> (g', a) +{-# INLINE applyAtomicGen #-} + +-- HalfStrict version of atomicModifyIORef, i.e. strict in the modifcation of the contents +-- of the IORef, but not in the result produced. +atomicModifyIORefHS :: IORef a -> (a -> (a, b)) -> IO b +atomicModifyIORefHS ref f = do +#if __GLASGOW_HASKELL__ >= 808 + (_old, (_new, res)) <- atomicModifyIORef2Lazy ref $ \old -> + case f old of + r@(!_new, _res) -> r + pure res +#else + atomicModifyIORef ref $ \old -> + case f old of + r@(!_new, _res) -> r +#endif +{-# INLINE atomicModifyIORefHS #-} + +-- | 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, SplitGen, Storable, NFData) + +-- Standalone definition due to GHC-8.0 not supporting deriving with associated type families +instance SeedGen g => SeedGen (IOGen g) where + type SeedSize (IOGen g) = SeedSize g + fromSeed = coerce (fromSeed :: Seed g -> g) + toSeed = coerce (toSeed :: g -> Seed g) + +-- | 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 #-} + + +instance (RandomGen g, MonadIO m) => FrozenGen (IOGen g) m where + type MutableGen (IOGen g) m = IOGenM g + freezeGen = fmap IOGen . liftIO . readIORef . unIOGenM + modifyGen (IOGenM ref) f = liftIO $ do + g <- readIORef ref + let (a, IOGen g') = f (IOGen g) + g' `seq` writeIORef ref g' + pure a + {-# INLINE modifyGen #-} + overwriteGen (IOGenM ref) = liftIO . writeIORef ref . unIOGen + {-# INLINE overwriteGen #-} + +instance (RandomGen g, MonadIO m) => ThawedGen (IOGen g) m where + 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, SplitGen, Storable, NFData) + +-- Standalone definition due to GHC-8.0 not supporting deriving with associated type families +instance SeedGen g => SeedGen (STGen g) where + type SeedSize (STGen g) = SeedSize g + fromSeed = coerce (fromSeed :: Seed g -> g) + toSeed = coerce (toSeed :: g -> Seed g) + +-- | 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 #-} + +instance RandomGen g => FrozenGen (STGen g) (ST s) where + type MutableGen (STGen g) (ST s) = STGenM g s + freezeGen = fmap STGen . readSTRef . unSTGenM + modifyGen (STGenM ref) f = do + g <- readSTRef ref + let (a, STGen g') = f (STGen g) + g' `seq` writeSTRef ref g' + pure a + {-# INLINE modifyGen #-} + overwriteGen (STGenM ref) = writeSTRef ref . unSTGen + {-# INLINE overwriteGen #-} + +instance RandomGen g => ThawedGen (STGen g) (ST s) where + 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 + + +-- | Wraps a 'TVar' that holds a pure pseudo-random number generator. +-- +-- @since 1.2.1 +newtype TGenM g = TGenM { unTGenM :: TVar g } + +-- | Frozen version of mutable `TGenM` generator +-- +-- @since 1.2.1 +newtype TGen g = TGen { unTGen :: g } + deriving (Eq, Ord, Show, RandomGen, SplitGen, Storable, NFData) + +-- Standalone definition due to GHC-8.0 not supporting deriving with associated type families +instance SeedGen g => SeedGen (TGen g) where + type SeedSize (TGen g) = SeedSize g + fromSeed = coerce (fromSeed :: Seed g -> g) + toSeed = coerce (toSeed :: g -> Seed g) + +-- | Creates a new 'TGenM' in `STM`. +-- +-- @since 1.2.1 +newTGenM :: g -> STM (TGenM g) +newTGenM = fmap TGenM . newTVar + + +-- | Creates a new 'TGenM' in `IO`. +-- +-- @since 1.2.1 +newTGenMIO :: MonadIO m => g -> m (TGenM g) +newTGenMIO g = liftIO (TGenM <$> newTVarIO g) + + +-- | @since 1.2.1 +instance RandomGen g => StatefulGen (TGenM g) STM where + uniformWord32R r = applyTGen (genWord32R r) + {-# INLINE uniformWord32R #-} + uniformWord64R r = applyTGen (genWord64R r) + {-# INLINE uniformWord64R #-} + uniformWord8 = applyTGen genWord8 + {-# INLINE uniformWord8 #-} + uniformWord16 = applyTGen genWord16 + {-# INLINE uniformWord16 #-} + uniformWord32 = applyTGen genWord32 + {-# INLINE uniformWord32 #-} + uniformWord64 = applyTGen genWord64 + {-# INLINE uniformWord64 #-} + +-- | @since 1.2.1 +instance RandomGen g => FrozenGen (TGen g) STM where + type MutableGen (TGen g) STM = TGenM g + freezeGen = fmap TGen . readTVar . unTGenM + modifyGen (TGenM ref) f = do + g <- readTVar ref + let (a, TGen g') = f (TGen g) + g' `seq` writeTVar ref g' + pure a + {-# INLINE modifyGen #-} + overwriteGen (TGenM ref) = writeTVar ref . unTGen + {-# INLINE overwriteGen #-} + +instance RandomGen g => ThawedGen (TGen g) STM where + thawGen (TGen g) = newTGenM g + + +-- | Applies a pure operation to the wrapped pseudo-random number generator. +-- +-- ====__Examples__ +-- +-- >>> import Control.Concurrent.STM +-- >>> import System.Random.Stateful +-- >>> import Data.Int (Int32) +-- >>> let pureGen = mkStdGen 137 +-- >>> stmGen <- newTGenMIO pureGen +-- >>> atomically $ applyTGen uniform stmGen :: IO Int32 +-- 637238067 +-- +-- @since 1.2.1 +applyTGen :: (g -> (a, g)) -> TGenM g -> STM a +applyTGen f (TGenM tvar) = do + g <- readTVar tvar + case f g of + (a, !g') -> a <$ writeTVar tvar g' +{-# INLINE applyTGen #-} + +-- $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', 'Data.Word.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 +-- +-- 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. +-- +-- The 'UniformRange' instances for 'Float' and 'Double' use the following +-- procedure to generate a random value in a range for @uniformRM (l, h) g@: +-- +-- * If @__l == h__@, return: @__l__@. +-- * If @__`isInfinite` l == True__@ or @__`isInfinite` h == True__@, return: @__l + h__@ +-- * Otherwise: +-- +-- 1. Generate an unsigned integral of matching width @__w__@ uniformly. +-- +-- 2. Check whether @__h - l__@ overflows to infinity and, if it does, then convert +-- @__w__@ to a floating point number in @__[0.0, 1.0]__@ range through division +-- of @__w__@ by the highest possible value: +-- +-- @ +-- x = `fromIntegral` w / `fromIntegral` `maxBound` +-- @ +-- +-- Then we scale and clamp it before returning it: +-- +-- @ +-- `max` (`min` (x * l + (1 - x) * h) (`max` l h)) (`min` l h) +-- @ +-- +-- Clamping is necessary, because otherwise it would be possible to run into a +-- degenerate case when a scaled value is outside the specified range due to +-- rounding errors. +-- +-- 3. Whenever @__h - l__@ does not overflow, we use this common formula for scaling: +-- @__ l + (h - l) * x__@. However, instead of using @__[0.0, 1.0]__@ range we +-- use the top most bit of @__w__@ to decide whether we will treat the generated +-- floating point value as @__[0.0, 0.5]__@ range or @__[0.5, 1.0]__@ range and +-- use the left over bits to produce a floating point value in the half unit +-- range: +-- +-- @ +-- x = `fromIntegral` (`clearBit` w 31) / `fromIntegral` `maxBound` +-- @ +-- +-- Further scaling depends on the top most bit: +-- +-- @ +-- if `testBit` w 31 +-- then l + (h - l) * x +-- else h + (l - h) * x +-- @ +-- +-- Because of this clever technique the result does not need clamping, since +-- scaled values are guaranteed to stay within the specified range. Another reason +-- why this tecnique is used for the common case instead of the one described in +-- @2.@ is because it avoids usage of @__1 - x__@, which consequently reduces loss +-- of randomness due to rounding. +-- +-- +-- What happens when @__NaN__@ or @__Infinity__@ are given to 'uniformRM'? We first +-- define them as constants: +-- +-- >>> nan = read "NaN" :: Float +-- >>> inf = read "Infinity" :: Float +-- >>> g <- newIOGenM (mkStdGen 2024) +-- +-- * If at least one of \(l\) or \(h\) is @__NaN__@, the result is @__NaN__@. +-- +-- >>> uniformRM (nan, 1) g +-- NaN +-- >>> uniformRM (-1, nan) g +-- NaN +-- +-- * If \(l\) and \(h\) are both @__Infinity__@ with opposing signs, then the result is @__NaN__@. +-- +-- >>> uniformRM (-inf, inf) g +-- NaN +-- >>> uniformRM (inf, -inf) g +-- NaN +-- +-- * Otherwise, if \(l\) is @__Infinity__@ or @__-Infinity__@, the result is \(l\). +-- +-- >>> uniformRM (inf, 1) g +-- Infinity +-- >>> uniformRM (-inf, 1) g +-- -Infinity +-- +-- * Otherwise, if \(h\) is @__Infinity__@ or @__-Infinity__@, the result is \(h\). +-- +-- >>> uniformRM (1, inf) g +-- Infinity +-- >>> uniformRM (1, -inf) g +-- -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 a similar procedure to generate floating point values in a range. +-- +-- $implemenstatefulegen +-- +-- 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: +-- +-- > import qualified System.Random.MWC as MWC +-- > import qualified Data.Vector.Generic as G +-- +-- > instance (s ~ PrimState m, PrimMonad m) => StatefulGen (MWC.Gen s) m where +-- > uniformWord8 = MWC.uniform +-- > uniformWord16 = MWC.uniform +-- > uniformWord32 = MWC.uniform +-- > uniformWord64 = MWC.uniform +-- > uniformByteArrayM isPinned n g = stToPrim (fillByteArrayST isPinned n (MWC.uniform g)) +-- +-- > instance PrimMonad m => FrozenGen MWC.Seed m where +-- > type MutableGen MWC.Seed m = MWC.Gen (PrimState m) +-- > freezeGen = MWC.save +-- > overwriteGen (Gen mv) (Seed v) = G.copy mv v +-- +-- > instance PrimMonad m => ThawedGen MWC.Seed m where +-- > thawGen = MWC.restore +-- +-- === @FrozenGen@ +-- +-- `FrozenGen` gives us ability to use most of stateful pseudo-random number generator in +-- its immutable form, if one exists that is. 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) +-- >>> import Control.Monad (replicateM) +-- >>> :{ +-- myCustomRandomList :: ThawedGen 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] +-- +-- 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 +-- >>> writeIORef theStdGen $ mkStdGen 2021 +-- +-- >>> :seti -XFlexibleContexts +-- >>> :seti -XFlexibleInstances +-- >>> :seti -XMultiParamTypeClasses +-- >>> :seti -XTypeFamilies +-- >>> :seti -XUndecidableInstances +-- +-- diff --git a/test-inspection/Spec.hs b/test-inspection/Spec.hs new file mode 100644 --- /dev/null +++ b/test-inspection/Spec.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE CPP #-} +module Main (main) where +#if __GLASGOW_HASKELL__ >= 800 + +import qualified Spec.Inspection as Inspection +import Test.Tasty + +main :: IO () +main = + defaultMain $ + testGroup + "InspectionSpec" + [ Inspection.inspectionTests + ] + +#else + +main :: IO () +main = putStrLn "\nInspection testing is not supported for pre ghc-8.0 versions\n" + +#endif + + diff --git a/test-inspection/Spec/Inspection.hs b/test-inspection/Spec/Inspection.hs new file mode 100644 --- /dev/null +++ b/test-inspection/Spec/Inspection.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-missing-signatures -O -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-} + +module Spec.Inspection (inspectionTests) where + +import Data.Int +import Data.Void +import Data.Word +import GHC.Generics +import System.Random +import System.Random.Stateful +import Test.Tasty +import Test.Tasty.Inspection + +uniform' :: Uniform a => (a, StdGen) +uniform' = uniform (mkStdGen 42) + +uniform_Word8 = uniform' @Word8 +uniform_Int8 = uniform' @Int8 +uniform_Char = uniform' @Char + +data MyAction = Code (Maybe Bool) | Never Void | Eat (Bool, Bool) | Sleep () + deriving (Eq, Ord, Show, Generic, Finite) +instance Uniform MyAction + +uniform_MyAction = uniform' @MyAction + +uniformR' :: (Bounded a, UniformRange a) => (a, StdGen) +uniformR' = uniformR (minBound, maxBound) (mkStdGen 42) + +uniformR_Word8 = uniformR' @Word8 +uniformR_Int8 = uniformR' @Int8 +uniformR_Char = uniformR' @Char + +uniformR_Double = uniformR (0 :: Double, 1) (mkStdGen 42) + +inspectionTests :: TestTree +inspectionTests = testGroup "Inspection" $ + [ $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniform_Word8) + , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniform_Int8) + , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniform_Char) + , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoTypeClasses] 'uniform_MyAction) + +#if !MIN_VERSION_base(4,17,0) + -- Starting from GHC 9.4 and base-4.17 + -- 'error' :: M1 C ('MetaCons "Never" 'PrefixI 'False) .. + -- survives. This does not really matter, because Never is uninhabited, + -- but fails inspection testing. + , $(inspectTest $ hasNoGenerics 'uniform_MyAction) +#endif + + , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Word8) + , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Int8) + , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Char) + , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Double) + ] 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 essentially 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,325 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Main (main) where + +import Control.Monad (replicateM, forM_) +import Control.Monad.ST (runST) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as SBS +import Data.Int +import Data.List (sortOn) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Typeable +import Data.Void +import Data.Word +import Foreign.C.Types +import GHC.Generics +import GHC.Exts (fromList) +import Numeric.Natural (Natural) +import System.Random (uniformShortByteString) +import System.Random.Stateful hiding (uniformShortByteString) +import System.Random.Internal (newMutableByteArray, freezeMutableByteArray, writeWord8) +import Test.SmallCheck.Series as SC +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.SmallCheck as SC +#if __GLASGOW_HASKELL__ < 804 +import Data.Monoid ((<>)) +#endif + +import qualified Spec.Range as Range +import qualified Spec.Run as Run +import qualified Spec.Seed as Seed +import qualified Spec.Stateful as Stateful + +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) + , enumSpec (Proxy :: Proxy Colors) + , enumSpec (Proxy :: Proxy (Int, Int)) + , enumSpec (Proxy :: Proxy (Bool, Bool, Bool)) + , enumSpec (Proxy :: Proxy ((), Int, Bool, Word)) + , runSpec + , floatTests + , byteStringSpec + , fillMutableByteArraySpec + , SC.testProperty "uniformRangeWithinExcludedF" $ seeded Range.uniformRangeWithinExcludedF + , SC.testProperty "uniformRangeWithinExcludedD" $ seeded Range.uniformRangeWithinExcludedD + , randomSpec (Proxy :: Proxy (CFloat, CDouble)) + , randomSpec (Proxy :: Proxy (Int8, Int16, Int32)) + , randomSpec (Proxy :: Proxy (Int8, Int16, Int32, Int64)) + , randomSpec (Proxy :: Proxy (Word8, Word16, Word32, Word64, Word)) + , randomSpec (Proxy :: Proxy (Int8, Word8, Word16, Word32, Word64, Word)) + , randomSpec (Proxy :: Proxy (Int8, Int16, Word8, Word16, Word32, Word64, Word)) + , uniformSpec (Proxy :: Proxy (Int, Bool)) + , uniformSpec (Proxy :: Proxy (Int8, Int16, Int32)) + , uniformSpec (Proxy :: Proxy (Int8, Int16, Int32, Int64)) + , uniformSpec (Proxy :: Proxy (Word8, Word16, Word32, Word64, Word)) + , uniformSpec (Proxy :: Proxy (Int8, Word8, Word16, Word32, Word64, Word)) + , uniformSpec (Proxy :: Proxy (Int8, Int16, Word8, Word16, Word32, Word64, Word)) + , Stateful.statefulGenSpec + , Seed.spec + ] + +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" + ] + +showType :: forall t . Typeable t => Proxy t -> String +showType px = show (typeRep px) + +byteStringSpec :: TestTree +byteStringSpec = + testGroup + "ByteString" + [ SC.testProperty "uniformShortByteString" $ + seededWithLen $ \n g -> SBS.length (fst (uniformShortByteString n g)) == n + , SC.testProperty "uniformByteString" $ + seededWithLen $ \n g -> + SBS.toShort (fst (uniformByteString n g)) == fst (uniformShortByteString n g) + , testCase "uniformByteString/ShortByteString consistency" $ do + let g = mkStdGen 2021 + bs = [78,232,117,189,13,237,63,84,228,82,19,36,191,5,128,192] :: [Word8] + forM_ [0 .. length bs - 1] $ \ n -> do + xs <- SBS.unpack <$> runStateGenT_ g (uniformShortByteStringM n) + xs @?= take n bs + ys <- BS.unpack <$> runStateGenT_ g (uniformByteStringM n) + ys @?= xs + ] + +fillMutableByteArraySpec :: TestTree +fillMutableByteArraySpec = + testGroup + "MutableByteArray" + [ SC.testProperty "Same as uniformByteArray" $ + forAll $ \isPinned -> seededWithLen $ \n g -> + let baFilled = runST $ do + mba <- newMutableByteArray n + g' <- uniformFillMutableByteArray mba 0 n g + ba <- freezeMutableByteArray mba + pure (ba, g') + in baFilled == uniformByteArray isPinned n g + , SC.testProperty "Safe uniformFillMutableByteArray" $ + forAll $ \isPinned offset count -> seededWithLen $ \sz g -> + let (baFilled, gf) = runST $ do + mba <- newMutableByteArray sz + forM_ [0 .. sz - 1] (\i -> writeWord8 mba i 0) + g' <- uniformFillMutableByteArray mba offset count g + ba <- freezeMutableByteArray mba + pure (ba, g') + (baGen, gu) = uniformByteArray isPinned count' g + offset' = min sz (max 0 offset) + count' = min (sz - offset') (max 0 count) + prefix = replicate offset' 0 + suffix = replicate (sz - (count' + offset')) 0 + in gf == gu && baFilled == fromList prefix <> baGen <> fromList suffix + ] + +rangeSpec :: + forall a. + (SC.Serial IO a, Typeable a, Ord a, UniformRange a, Show a) + => Proxy a -> TestTree +rangeSpec px = + testGroup ("Range " ++ showType 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 (showType 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 + ] + +enumSpec :: + forall a. + (SC.Serial IO a, Typeable a, Ord a, UniformRange a, Show a) + => Proxy a -> TestTree +enumSpec = integralSpec + +floatingSpec :: + forall a. + (SC.Serial IO a, Typeable a, Num a, Ord a, Random a, UniformRange a, Read a, Show a) + => Proxy a -> TestTree +floatingSpec px = + testGroup (showType px) + [ SC.testProperty "uniformR" $ seeded $ Range.uniformRangeWithin px + , testCase "r = +inf, x = 0" $ positiveInf @?= fst (uniformR (0, positiveInf) (ConstGen 0)) + , testCase "r = +inf, x = 1" $ positiveInf @?= fst (uniformR (0, positiveInf) (ConstGen 1)) + , testCase "l = -inf, x = 0" $ negativeInf @?= fst (uniformR (negativeInf, 0) (ConstGen 0)) + , testCase "l = -inf, x = 1" $ negativeInf @?= fst (uniformR (negativeInf, 0) (ConstGen 1)) + -- TODO: Add more tests + ] + where + positiveInf, negativeInf :: a + positiveInf = read "Infinity" + negativeInf = read "-Infinity" + +randomSpec :: + forall a. + (Typeable a, Eq a, Random a, Show a) + => Proxy a -> TestTree +randomSpec px = + testGroup + ("Random " ++ showType px) + [ SC.testProperty "randoms" $ + seededWithLen $ \len g -> + take len (randoms g :: [a]) == runStateGen_ g (replicateM len . randomM) + , SC.testProperty "randomRs" $ + seededWithLen $ \len g -> + case random g of + (range, g') -> + take len (randomRs range g' :: [a]) == + runStateGen_ g' (replicateM len . randomRM range) + ] + +uniformSpec :: + forall a. + (Typeable a, Eq a, Random a, Uniform a, UniformRange a, Show a) + => Proxy a -> TestTree +uniformSpec px = + testGroup + ("Uniform " ++ showType px) + [ SC.testProperty "uniformList" $ + seededWithLen $ \len g -> + take len (randoms g :: [a]) == fst (uniformList len g) + , SC.testProperty "uniformListR" $ + seededWithLen $ \len g -> + case uniform g of + (range, g') -> + take len (randomRs range g' :: [a]) == fst (uniformListR len range g') + , SC.testProperty "uniformShuffleList" $ + seededWithLen $ \len g -> + case uniformList len g of + (xs, g') -> + let xs' = zip [0 :: Int ..] (xs :: [a]) + in sortOn fst (fst (uniformShuffleList xs' g')) == xs' + , SC.testProperty "uniforms" $ + seededWithLen $ \len g -> + take len (randoms g :: [a]) == take len (uniforms g) + , SC.testProperty "uniformRs" $ + seededWithLen $ \len g -> + case uniform g of + (range, g') -> + take len (randomRs range g' :: [a]) == take len (uniformRs range g') + ] + +runSpec :: TestTree +runSpec = testGroup "runStateGen_ 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 + +-- | Same as `seeded`, but also produces a length in range 0-65535 suitable for generating +-- lists and such +seededWithLen :: (Int -> StdGen -> a) -> Word16 -> Int -> a +seededWithLen f w16 = seeded (f (fromIntegral w16)) + +data MyBool = MyTrue | MyFalse + deriving (Eq, Ord, Show, Generic, Finite, Uniform) +instance Monad m => Serial m MyBool + +data MyAction = Code (Maybe MyBool) | Never Void | Eat (Bool, Bool) | Sleep () + deriving (Eq, Ord, Show, Generic, Finite) +instance Monad m => Serial m MyAction +instance Uniform MyAction + +data Foo + = Quux Char + | Bar Int | Baz Word + | Bar8 Int8 | Baz8 Word8 + | Bar16 Int16 | Baz16 Word16 + | Bar32 Int32 | Baz32 Word32 + | Bar64 Int64 | Baz64 Word64 + | Final () + deriving (Eq, Ord, Show, Generic, Finite, Uniform) +instance Monad m => Serial m Foo + +newtype ConstGen = ConstGen Word64 + +instance SeedGen ConstGen where + type SeedSize ConstGen = 8 + fromSeed64 (w :| _) = ConstGen w + toSeed64 (ConstGen w) = pure w + +instance RandomGen ConstGen where + genWord64 g@(ConstGen c) = (c, g) +instance SplitGen ConstGen where + splitGen g = (g, g) + +data Colors = Red | Green | Blue | Purple | Yellow | Black | White | Orange + deriving (Eq, Ord, Show, Generic, Enum, Bounded) +instance Monad m => Serial m Colors + +instance Uniform Colors where + uniformM = uniformEnumM + +instance UniformRange Colors where + uniformRM = uniformEnumRM + isInRange (lo, hi) x = isInRange (fromEnum lo, fromEnum hi) (fromEnum x) 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.Stateful +import Data.Proxy + +(===) :: (Eq a, Show a) => a -> a -> Either String String +x === y + | x == y = Right "OK" + | otherwise = Left $ "Expected equal, got " ++ show x ++ " /= " ++ show y + +symmetric :: (RandomGen g, UniformRange a, Eq a, Show a) => Proxy a -> g -> (a, a) -> Either String String +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) = isInRange (l, r) (fst (uniformR (l, r) g)) + +singleton :: (RandomGen g, UniformRange a, Eq a, Show a) => Proxy a -> g -> a -> Either String String +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 -> + isInRange (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/Spec/Seed.hs b/test/Spec/Seed.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Seed.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Spec.Seed where + +import Data.Bits +import Data.List.NonEmpty as NE +import Data.Maybe (fromJust) +import Data.Proxy +import Data.Word +import System.Random +import Test.Tasty +import Test.Tasty.SmallCheck as SC +import qualified Data.ByteString as BS +import GHC.TypeLits +import qualified GHC.Exts as GHC (IsList(..)) +import Test.SmallCheck.Series hiding (NonEmpty(..)) +import Spec.Stateful () + +newtype GenN (n :: Nat) = GenN BS.ByteString + deriving (Eq, Show) + +instance (KnownNat n, Monad m) => Serial m (GenN n) where + series = GenN . fst . uniformByteString n . mkStdGen <$> series + where + n = fromInteger (natVal (Proxy :: Proxy n)) + +instance (KnownNat n, Monad m) => Serial m (Gen64 n) where + series = + Gen64 . dropExtra . fst . uniformList n . mkStdGen <$> series + where + (n, r8) = + case fromInteger (natVal (Proxy :: Proxy n)) `quotRem` 8 of + (q, 0) -> (q, 0) + (q, r) -> (q + 1, (8 - r) * 8) + -- We need to drop extra top most bits in the last generated Word64 in order for + -- roundtrip to work, because that is exactly what SeedGen will do + dropExtra xs = + case NE.reverse (fromJust (NE.nonEmpty xs)) of + w64 :| rest -> NE.reverse ((w64 `shiftL` r8) `shiftR` r8 :| rest) + +instance (1 <= n, KnownNat n) => SeedGen (GenN n) where + type SeedSize (GenN n) = n + toSeed (GenN bs) = fromJust . mkSeed . GHC.fromList $ BS.unpack bs + fromSeed = GenN . BS.pack . GHC.toList . unSeed + +newtype Gen64 (n :: Nat) = Gen64 (NonEmpty Word64) + deriving (Eq, Show) + +instance (1 <= n, KnownNat n) => SeedGen (Gen64 n) where + type SeedSize (Gen64 n) = n + toSeed64 (Gen64 ws) = ws + fromSeed64 = Gen64 + +seedGenSpec :: + forall g. (SeedGen g, Eq g, Show g, Serial IO g) + => TestTree +seedGenSpec = + testGroup (seedGenTypeName @g) + [ testProperty "fromSeed/toSeed" $ + forAll $ \(g :: g) -> g == fromSeed (toSeed g) + , testProperty "fromSeed64/toSeed64" $ + forAll $ \(g :: g) -> g == fromSeed64 (toSeed64 g) + ] + + +spec :: TestTree +spec = + testGroup + "SeedGen" + [ seedGenSpec @StdGen + , seedGenSpec @(GenN 1) + , seedGenSpec @(GenN 2) + , seedGenSpec @(GenN 3) + , seedGenSpec @(GenN 4) + , seedGenSpec @(GenN 5) + , seedGenSpec @(GenN 6) + , seedGenSpec @(GenN 7) + , seedGenSpec @(GenN 8) + , seedGenSpec @(GenN 9) + , seedGenSpec @(GenN 10) + , seedGenSpec @(GenN 11) + , seedGenSpec @(GenN 12) + , seedGenSpec @(GenN 13) + , seedGenSpec @(GenN 14) + , seedGenSpec @(GenN 15) + , seedGenSpec @(GenN 16) + , seedGenSpec @(GenN 17) + , seedGenSpec @(Gen64 1) + , seedGenSpec @(Gen64 2) + , seedGenSpec @(Gen64 3) + , seedGenSpec @(Gen64 4) + , seedGenSpec @(Gen64 5) + , seedGenSpec @(Gen64 6) + , seedGenSpec @(Gen64 7) + , seedGenSpec @(Gen64 8) + , seedGenSpec @(Gen64 9) + , seedGenSpec @(Gen64 10) + , seedGenSpec @(Gen64 11) + , seedGenSpec @(Gen64 12) + , seedGenSpec @(Gen64 13) + , seedGenSpec @(Gen64 14) + , seedGenSpec @(Gen64 15) + , seedGenSpec @(Gen64 16) + , seedGenSpec @(Gen64 17) + ] + diff --git a/test/Spec/Stateful.hs b/test/Spec/Stateful.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Stateful.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Spec.Stateful where + +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.ST +import Data.Proxy +import Data.Typeable +import System.Random (uniformShortByteString) +import System.Random.Stateful hiding (uniformShortByteString) +import Test.SmallCheck.Series +import Test.Tasty +import Test.Tasty.SmallCheck as SC + +instance Monad m => Serial m StdGen where + series = mkStdGen <$> series + +instance (Monad m, Serial m g) => Serial m (AtomicGen g) where + series = AtomicGen <$> series + +instance (Monad m, Serial m g) => Serial m (IOGen g) where + series = IOGen <$> series + +instance (Monad m, Serial m g) => Serial m (STGen g) where + series = STGen <$> series + +instance (Monad m, Serial m g) => Serial m (TGen g) where + series = TGen <$> series + +instance (Monad m, Serial m g) => Serial m (StateGen g) where + series = StateGen <$> series + + +matchRandomGenSpec :: + forall f a sg m. (StatefulGen sg m, RandomGen f, Eq f, Show f, Eq a) + => (forall g n. StatefulGen g n => g -> n a) + -> (forall g. RandomGen g => g -> (a, g)) + -> (StdGen -> f) + -> (f -> StdGen) + -> (f -> (sg -> m a) -> IO (a, f)) + -> Property IO +matchRandomGenSpec genM gen fromStdGen toStdGen runStatefulGen = + forAll $ \seed -> monadic $ do + let stdGen = mkStdGen seed + g = fromStdGen stdGen + (x1, g1) = gen stdGen + (x2, g2) = gen g + (x3, g3) <- runStatefulGen g genM + pure $ and [x1 == x2, x2 == x3, g1 == toStdGen g2, g1 == toStdGen g3, g2 == g3] + +withMutableGenSpec :: + forall f m. (ThawedGen f m, Eq f, Show f) + => (forall a. m a -> IO a) + -> f + -> Property IO +withMutableGenSpec toIO frozen = + forAll $ \n -> monadic $ toIO $ do + let action = uniformListM n + x@(_, _) :: ([Word], f) <- withMutableGen frozen action + y@(r, _) <- withMutableGen frozen action + r' <- withMutableGen_ frozen action + pure $ x == y && r == r' + +overwriteMutableGenSpec :: + forall f m. (ThawedGen f m, Eq f, Show f) + => (forall a. m a -> IO a) + -> f + -> Property IO +overwriteMutableGenSpec toIO frozen = + forAll $ \n -> monadic $ toIO $ do + let action = uniformListM (abs n + 1) -- Non-empty + ((r1, r2), frozen') :: ((String, String), f) <- withMutableGen frozen $ \mutable -> do + r1 <- action mutable + overwriteGen mutable frozen + r2 <- action mutable + modifyGen mutable (const ((), frozen)) + pure (r1, r2) + pure $ r1 == r2 && frozen == frozen' + +indepMutableGenSpec :: + forall f m. (RandomGen f, ThawedGen f m, Eq f, Show f) + => (forall a. m a -> IO a) -> [f] -> Property IO +indepMutableGenSpec toIO fgs = + monadic $ toIO $ do + (fgs ==) <$> (mapM freezeGen =<< mapM thawGen fgs) + +immutableFrozenGenSpec :: + forall f m. (RandomGen f, ThawedGen f m, Eq f, Show f) + => (forall a. m a -> IO a) -> f -> Property IO +immutableFrozenGenSpec toIO frozen = + forAll $ \n -> monadic $ toIO $ do + let action = do + mg <- thawGen frozen + (,) <$> uniformWord8 mg <*> freezeGen mg + x <- action + xs <- replicateM n action + pure $ all (x ==) xs + +splitMutableGenSpec :: + forall f m. (SplitGen f, ThawedGen f m, Eq f, Show f) + => (forall a. m a -> IO a) + -> f + -> Property IO +splitMutableGenSpec toIO frozen = + monadic $ toIO $ do + (sfg1, fg1) <- withMutableGen frozen splitGenM + (smg2, fg2) <- withMutableGen frozen splitMutableGenM + sfg3 <- freezeGen smg2 + pure $ fg1 == fg2 && sfg1 == sfg3 + +thawedGenSpecFor :: + forall f m. (SplitGen f, ThawedGen f m, Eq f, Show f, Serial IO f, Typeable f) + => (forall a. m a -> IO a) + -> Proxy f + -> TestTree +thawedGenSpecFor toIO px = + testGroup + (showsTypeRep (typeRep px) "") + [ testProperty "withMutableGen" $ + forAll $ \(f :: f) -> withMutableGenSpec toIO f + , testProperty "overwriteGen" $ + forAll $ \(f :: f) -> overwriteMutableGenSpec toIO f + , testProperty "independent mutable generators" $ + forAll $ \(fs :: [f]) -> indepMutableGenSpec toIO fs + , testProperty "immutable frozen generators" $ + forAll $ \(f :: f) -> immutableFrozenGenSpec toIO f + , testProperty "splitGen" $ + forAll $ \(f :: f) -> splitMutableGenSpec toIO f + ] + +frozenGenSpecFor :: + forall f sg m. (RandomGen f, StatefulGen sg m, Eq f, Show f, Typeable f) + => (StdGen -> f) + -> (f -> StdGen) + -> (forall a. f -> (sg -> m a) -> IO (a, f)) + -> TestTree +frozenGenSpecFor fromStdGen toStdGen runStatefulGen = + testGroup (showsTypeRep (typeRep (Proxy :: Proxy f)) "") + [ testGroup "matchRandomGenSpec" + [ testProperty "uniformWord8/genWord8" $ + matchRandomGenSpec uniformWord8 genWord8 fromStdGen toStdGen runStatefulGen + , testProperty "uniformWord16/genWord16" $ + matchRandomGenSpec uniformWord16 genWord16 fromStdGen toStdGen runStatefulGen + , testProperty "uniformWord32/genWord32" $ + matchRandomGenSpec uniformWord32 genWord32 fromStdGen toStdGen runStatefulGen + , testProperty "uniformWord64/genWord64" $ + matchRandomGenSpec uniformWord64 genWord64 fromStdGen toStdGen runStatefulGen + , testProperty "uniformWord32R/genWord32R" $ + forAll $ \w32 -> + matchRandomGenSpec (uniformWord32R w32) (genWord32R w32) fromStdGen toStdGen runStatefulGen + , testProperty "uniformWord64R/genWord64R" $ + forAll $ \w64 -> + matchRandomGenSpec (uniformWord64R w64) (genWord64R w64) fromStdGen toStdGen runStatefulGen + , testProperty "uniformShortByteStringM/uniformShortByteString" $ + forAll $ \(NonNegative n') -> + let n = n' `mod` 100000 -- Ensure it is not too big + in matchRandomGenSpec + (uniformShortByteStringM n) + (uniformShortByteString n) + fromStdGen + toStdGen + runStatefulGen + , testProperty "uniformByteStringM/uniformByteString" $ + forAll $ \(NonNegative n') -> + let n = n' `mod` 100000 -- Ensure it is not too big + in matchRandomGenSpec + (uniformByteStringM n) + (uniformByteString n) + fromStdGen + toStdGen + runStatefulGen + , testProperty "uniformByteArrayM/genByteArray" $ + forAll $ \(NonNegative n', isPinned1 :: Bool, isPinned2 :: Bool) -> + let n = n' `mod` 100000 -- Ensure it is not too big + in matchRandomGenSpec + (uniformByteArrayM isPinned1 n) + (uniformByteArray isPinned2 n) + fromStdGen + toStdGen + runStatefulGen + ] + ] + + +statefulGenSpec :: TestTree +statefulGenSpec = + testGroup + "StatefulGen" + [ testGroup "ThawedGen" + [ thawedGenSpecFor id (Proxy :: Proxy (IOGen StdGen)) + , thawedGenSpecFor id (Proxy :: Proxy (AtomicGen StdGen)) + , thawedGenSpecFor stToIO (Proxy :: Proxy (STGen StdGen)) + , thawedGenSpecFor atomically (Proxy :: Proxy (TGen StdGen)) + ] + , testGroup "FrozenGen" + [ frozenGenSpecFor StateGen unStateGen runStateGenT + , frozenGenSpecFor IOGen unIOGen $ \g action -> do + mg <- newIOGenM (unIOGen g) + res <- action mg + g' <- freezeGen mg + pure (res, g') + , frozenGenSpecFor AtomicGen unAtomicGen $ \g action -> do + mg <- newAtomicGenM (unAtomicGen g) + res <- action mg + g' <- freezeGen mg + pure (res, g') + , frozenGenSpecFor STGen unSTGen $ \g action -> stToIO $ do + mg <- newSTGenM (unSTGen g) + res <- action mg + g' <- freezeGen mg + pure (res, g') + , frozenGenSpecFor TGen unTGen $ \g action -> atomically $ do + mg <- newTGenM (unTGen g) + res <- action mg + g' <- freezeGen mg + pure (res, g') + ] + ] 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)