random-fu 0.1.4 → 0.2
raw patch · 28 files changed
+234/−1357 lines, 28 filesdep +gammadep +random-sourcedep +rvardep −MonadPromptdep −arraydep −containersdep ~vector
Dependencies added: gamma, random-source, rvar, transformers
Dependencies removed: MonadPrompt, array, containers, mersenne-random-pure64, mwc-random, random, stateref, tagged
Dependency ranges changed: vector
Files
- random-fu.cabal +14/−40
- src/Data/Random.hs +1/−0
- src/Data/Random/Distribution/Bernoulli.hs +0/−3
- src/Data/Random/Distribution/Beta.hs +0/−3
- src/Data/Random/Distribution/Binomial.hs +0/−3
- src/Data/Random/Distribution/Categorical.hs +115/−79
- src/Data/Random/Distribution/ChiSquare.hs +28/−0
- src/Data/Random/Distribution/Exponential.hs +0/−3
- src/Data/Random/Distribution/Gamma.hs +9/−0
- src/Data/Random/Distribution/Normal.hs +3/−3
- src/Data/Random/Distribution/Poisson.hs +0/−3
- src/Data/Random/Distribution/Rayleigh.hs +0/−3
- src/Data/Random/Distribution/Triangular.hs +0/−3
- src/Data/Random/Distribution/Uniform.hs +23/−26
- src/Data/Random/Distribution/Ziggurat.hs +2/−2
- src/Data/Random/Internal/Primitives.hs +0/−249
- src/Data/Random/Internal/TH.hs +0/−3
- src/Data/Random/Internal/Words.hs +0/−128
- src/Data/Random/Lift.hs +28/−5
- src/Data/Random/List.hs +1/−1
- src/Data/Random/RVar.hs +10/−218
- src/Data/Random/Sample.hs +0/−3
- src/Data/Random/Source.hs +0/−100
- src/Data/Random/Source/DevRandom.hs +0/−62
- src/Data/Random/Source/MWC.hs +0/−41
- src/Data/Random/Source/PureMT.hs +0/−168
- src/Data/Random/Source/Std.hs +0/−20
- src/Data/Random/Source/StdGen.hs +0/−188
random-fu.cabal view
@@ -1,5 +1,5 @@ name: random-fu-version: 0.1.4+version: 0.2 stability: provisional cabal-version: >= 1.6@@ -29,33 +29,18 @@ a fair bit slower than straight C implementations of the same algorithms. - Warning to anyone upgrading from \"< 0.1\": 'Discrete'- has been renamed 'Categorical', the entropy source - classes have been redesigned, and many things are no- longer exported from the root module "Data.Random"- (In particular, DevRandom - this is not available on - windows, so it will likely move to its own package - eventually so that client code dependencies on it will - be made explicit).- - Support for "base" packages earlier than version 4- (and thus GHC releases earlier than 6.10) has been - dropped, as too many of this package's dependencies do- not support older versions.+ Warning to anyone upgrading from \"< 0.2\": The old+ random-fu package has been split into three parts: + random-source, rvar, and this new random-fu. The+ end-user interface is mostly the same. - The "Data.Random" module itself should now have a- relatively stable interface, but the other modules- are still subject to change. Specifically, I am - considering hiding data constructors for most or all - of the distributions.--Tested-with: GHC == 6.10.4, GHC == 6.12.1, GHC == 6.12.3,+tested-with: GHC == 6.10.4, GHC == 6.12.1, GHC == 6.12.3, GHC == 7.0.1, GHC == 7.0.2 source-repository head type: git location: https://github.com/mokus0/random-fu.git- branch: v0.1-series+ subdir: random-fu Flag base4_2 Description: base-4.2 has an incompatible change in Data.Fixed (HasResolution)@@ -72,6 +57,7 @@ Data.Random.Distribution.Beta Data.Random.Distribution.Binomial Data.Random.Distribution.Categorical+ Data.Random.Distribution.ChiSquare Data.Random.Distribution.Dirichlet Data.Random.Distribution.Exponential Data.Random.Distribution.Gamma@@ -85,18 +71,11 @@ Data.Random.Distribution.Ziggurat Data.Random.Internal.Find Data.Random.Internal.Fixed- Data.Random.Internal.Primitives Data.Random.Internal.TH- Data.Random.Internal.Words Data.Random.Lift Data.Random.List Data.Random.RVar Data.Random.Sample- Data.Random.Source- Data.Random.Source.MWC- Data.Random.Source.PureMT- Data.Random.Source.Std- Data.Random.Source.StdGen if flag(base4_2) build-depends: base >= 4.2 && <5 else@@ -109,23 +88,18 @@ else build-depends: mtl == 1.* - build-depends: array,- containers,- mersenne-random-pure64,+ build-depends: gamma, monad-loops >= 0.3.0.1,- MonadPrompt,- mwc-random,- random, random-shuffle,- stateref >= 0.3 && < 0.4,+ random-source == 0.3.*,+ rvar == 0.2.*, syb,- tagged, template-haskell,- vector- + transformers,+ vector >= 0.7+ if os(Windows) cpp-options: -Dwindows build-depends: erf-native else build-depends: erf- exposed-modules: Data.Random.Source.DevRandom
src/Data/Random.hs view
@@ -64,6 +64,7 @@ import Data.Random.Sample import Data.Random.Source (MonadRandom, RandomSource)+import Data.Random.Source.IO () import Data.Random.Source.MWC () import Data.Random.Source.StdGen () import Data.Random.Source.PureMT ()
src/Data/Random/Distribution/Bernoulli.hs view
@@ -1,6 +1,3 @@-{-- - ``Data/Random/Distribution/Bernoulli''- -} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,
src/Data/Random/Distribution/Beta.hs view
@@ -1,6 +1,3 @@-{-- - ``Data/Random/Distribution/Beta''- -} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,
src/Data/Random/Distribution/Binomial.hs view
@@ -1,6 +1,3 @@-{-- - ``Data/Random/Distribution/Binomial''- -} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,
src/Data/Random/Distribution/Categorical.hs view
@@ -1,12 +1,15 @@-{-- - ``Data/Random/Distribution/Categorical''- -} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} -module Data.Random.Distribution.Categorical where+module Data.Random.Distribution.Categorical+ ( categorical, categoricalT+ , fromList, toList+ , fromWeightedList, fromObservations+ , mapCategoricalPs, normalizeCategoricalPs+ , collectEvents, collectEventsBy+ ) where import Data.Random.RVar import Data.Random.Distribution@@ -14,91 +17,108 @@ import Control.Arrow import Control.Monad+import Control.Monad.ST import Control.Applicative import Data.Foldable (Foldable(foldMap))+import Data.STRef import Data.Traversable (Traversable(traverse, sequenceA)) import Data.List import Data.Function+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV -- |Construct a 'Categorical' random variable from a list of probabilities -- and categories, where the probabilities all sum to 1.-categorical :: Distribution (Categorical p) a => [(p,a)] -> RVar a-categorical ps = rvar (Categorical ps)+categorical :: (Num p, Distribution (Categorical p) a) => [(p,a)] -> RVar a+categorical = rvar . fromList --- |Construct a 'Categorical' random process from a list of probabilities+-- |Construct a 'Categorical' random process from a list of probabilities -- and categories, where the probabilities all sum to 1.-categoricalT :: Distribution (Categorical p) a => [(p,a)] -> RVarT m a-categoricalT ps = rvarT (Categorical ps)+categoricalT :: (Num p, Distribution (Categorical p) a) => [(p,a)] -> RVarT m a+categoricalT = rvarT . fromList --- | Construct a 'Categorical' distribution from a list of weighted categories,+-- | Construct a 'Categorical' distribution from a list of weighted categories.+{-# INLINE fromList #-}+fromList :: (Num p) => [(p,a)] -> Categorical p a+fromList xs = Categorical (V.fromList (scanl1 f xs))+ where f (p0, _) (p1, y) = (p0 + p1, y)++{-# INLINE toList #-}+toList :: (Num p) => Categorical p a -> [(p,a)]+toList (Categorical ds) = V.foldr' g [] ds+ where+ g x [] = [x]+ g x@(p0,_) ((p1, y):xs) = x : (p1-p0,y) : xs++-- |Construct a 'Categorical' distribution from a list of weighted categories, -- where the weights do not necessarily sum to 1.-{-# INLINE weightedCategorical #-}-weightedCategorical :: (Fractional p) => [(p,a)] -> Categorical p a-weightedCategorical = normalizeCategoricalPs . Categorical+fromWeightedList :: (Fractional p, Ord a) => [(p,a)] -> Categorical p a+fromWeightedList = normalizeCategoricalPs . fromList -- |Construct a 'Categorical' distribution from a list of observed outcomes. -- Equivalent events will be grouped and counted, and the probabilities of each -- event in the returned distribution will be proportional to the number of -- occurrences of that event.-empirical :: (Fractional p, Ord a) => [a] -> Categorical p a-empirical xs = normalizeCategoricalPs (Categorical bins)- where bins = [ (genericLength bin, x)- | bin@(x:_) <- group (sort xs)- ]+fromObservations :: (Fractional p, Ord a) => [a] -> Categorical p a+fromObservations = fromWeightedList . map (genericLength &&& head) . group . sort -- |Categorical distribution; a list of events with corresponding probabilities. -- The sum of the probabilities must be 1, and no event should have a zero -- or negative probability (at least, at time of sampling; very clever users -- can do what they want with the numbers before sampling, just make sure -- that if you're one of those clever ones, you normalize before sampling).-newtype Categorical p a = Categorical [(p, a)]- deriving (Eq, Show)+newtype Categorical p a = Categorical (V.Vector (p, a))+ deriving Eq -instance (Fractional p, Ord p, Distribution StdUniform p) => Distribution (Categorical p) a where- rvarT (Categorical []) = fail "categorical distribution over empty set cannot be sampled"- rvarT (Categorical ds) = do- let (ps, xs) = unzip ds- cs = scanl1 (+) ps- - u <- stdUniformT- getEvent u cs xs- - where- -- In the (hopefully) extremely rare event that, due to numerical- -- instability, the last 'c' is less than 1 _and_ a number greater than - -- it is drawn, simply retry the sampling. If it comes to that, also- -- do one last sanity check that lastC > 0, to make sure that there- -- is some nonzero chance of termination.- getEvent u cs0 xs0 = go 0 cs0 xs0- where- go lastC [] _- | lastC > 0 = do {newU <- stdUniformT; getEvent newU cs0 xs0}- | otherwise = fail "categorical distribution sampling error: total probablility not greater than zero"- go lastC (c:cs) (x:xs)- | c < lastC = fail "categorical distribution sampling error: negative probability for an event!"- | u > c = go c cs xs- | c == c = return x- | otherwise = fail "categorical distribution sampling error: NaN probability"- - go _ _ _ = error "rvar/Categorical: programming error! this case should be impossible!"+instance (Num p, Show a) => Show (Categorical p a) where+ showsPrec p cat = showParen (p>10)+ ( showString "fromList "+ . showsPrec 11 (toList cat)+ ) +instance (Fractional p, Ord p, Distribution Uniform p) => Distribution (Categorical p) a where+ rvarT (Categorical ds)+ | V.null ds = fail "categorical distribution over empty set cannot be sampled"+ | n == 1 = return (snd (V.head ds))+ | otherwise = do+ u <- uniformT 0 (fst (V.last ds))+ + let p i = fst (ds V.! i)+ x i = snd (ds V.! i)+ + -- find the smallest entry whose cumulative probability is+ -- greater than or equal to u+ -- invariant: p j >= u+ -- variant: at every step, either i increases or j decreases.+ findEvent i j+ | i >= j = x j+ | p m >= u = findEvent i m+ | otherwise = findEvent (max m (i+1)) j+ where+ -- midpoint rounding down+ m = (i + j) `div` 2+ + return (findEvent 0 (n-1))+ where n = V.length ds++ instance Functor (Categorical p) where- fmap f (Categorical ds) = Categorical [(p, f x) | ~(p, x) <- ds]+ fmap f (Categorical ds) = Categorical (V.map (second f) ds) instance Foldable (Categorical p) where- foldMap f (Categorical ds) = foldMap (f . snd) ds+ foldMap f (Categorical ds) = foldMap (f . snd) (V.toList ds) instance Traversable (Categorical p) where- traverse f (Categorical ds) = Categorical <$> traverse (\(p,e) -> (\e' -> (p,e')) <$> f e) ds- sequenceA (Categorical ds) = Categorical <$> traverse (\(p,e) -> (\e' -> (p,e')) <$> e) ds+ traverse f (Categorical ds) = Categorical . V.fromList <$> traverse (\(p,e) -> (\e' -> (p,e')) <$> f e) (V.toList ds)+ sequenceA (Categorical ds) = Categorical . V.fromList <$> traverse (\(p,e) -> (\e' -> (p,e')) <$> e) (V.toList ds) -instance Fractional p => Monad (Categorical p) where- return x = Categorical [(1, x)]+instance Num p => Monad (Categorical p) where+ return x = Categorical (V.singleton (1, x)) -- I'm not entirely sure whether this is a valid form of failure; see next -- set of comments.- fail _ = Categorical []+ fail _ = Categorical V.empty -- Should the normalize step be included here, or should normalization -- be assumed? It seems like there is (at least) 1 valid situation where@@ -114,11 +134,9 @@ -- user (who really better know what they mean if they're returning -- non-normalized probability anyway) to normalize explicitly than to -- undo any normalization that was done automatically.- (Categorical xs) >>= f = {- normalizeCategoricalPs . -} Categorical $ do- (p, x) <- xs- - let Categorical fx = f x- (q, y) <- fx+ xs >>= f = {- normalizeCategoricalPs . -} fromList $ do+ (p, x) <- toList xs+ (q, y) <- toList (f x) return (p * q, y) @@ -128,32 +146,50 @@ -- |Like 'fmap', but for the probabilities of a categorical distribution. mapCategoricalPs :: (p -> q) -> Categorical p e -> Categorical q e-mapCategoricalPs f (Categorical ds) = Categorical [(f p, x) | (p, x) <- ds]+mapCategoricalPs f (Categorical ds) = Categorical (V.map (first f) ds) -- |Adjust all the weights of a categorical distribution so that they -- sum to unity. normalizeCategoricalPs :: (Fractional p) => Categorical p e -> Categorical p e normalizeCategoricalPs orig@(Categorical ds) = - -- For practical purposes the scale factor is strict anyway,- -- so check if the total probability is 1 and, if so, skip - -- the actual scaling part.- --- -- Along the way, discard any zero-probability events.- if null ds || ps =~ 1+ if V.null ds then orig- else Categorical- [ (p * scale, e)- | (p, e) <- ds- , p /= 0- ] + else runST $ do+ let n = V.length ds+ lastP <- newSTRef 0+ dups <- newSTRef 0+ normalized <- V.thaw ds+ + let skip = modifySTRef' dups (1+)+ save i p x = do+ d <- readSTRef dups+ MV.write normalized (i-d) (p, x)+ + sequence_+ [ do+ let (p,x) = ds V.! i+ p0 <- readSTRef lastP+ if p == p0+ then skip+ else do+ save i (p * scale) x+ writeSTRef lastP p+ | i <- [0..n-1]+ ]+ + -- force last element to 1+ d <- readSTRef dups+ MV.write normalized (n-d-1) (1,lastX)+ Categorical <$> V.unsafeFreeze (MV.unsafeSlice 0 (n-d) normalized) where- ps = foldl1' (+) (map fst ds)+ (ps, lastX) = V.last ds scale = recip ps- - -- Using same implicit-epsilon trick as in Distribution instance- -- (see comments there)- x =~ y = (100 + (x-y) == 100) +modifySTRef' :: STRef s a -> (a -> a) -> ST s ()+modifySTRef' x f = do+ v <- readSTRef x+ let fv = f v+ fv `seq` writeSTRef x fv -- |Simplify a categorical distribution by combining equivalent categories (the new -- category will have a probability equal to the sum of all the originals).@@ -165,9 +201,9 @@ -- The comparator function is used to identify events to combine. Once chosen, -- the events and their weights are combined by the provided probability and -- event aggregation function.-collectEventsBy :: (e -> e -> Ordering) -> ([(p,e)] -> (p,e))-> Categorical p e -> Categorical p e-collectEventsBy compareE combine (Categorical ds) = - Categorical . map combine . groupEvents . sortEvents $ ds+collectEventsBy :: Num p => (e -> e -> Ordering) -> ([(p,e)] -> (p,e))-> Categorical p e -> Categorical p e+collectEventsBy compareE combine = + fromList . map combine . groupEvents . sortEvents . toList where groupEvents = groupBy (\x y -> snd x `compareE` snd y == EQ) sortEvents = sortBy (compareE `on` snd)
+ src/Data/Random/Distribution/ChiSquare.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE+ MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,+ UndecidableInstances+ #-}+module Data.Random.Distribution.ChiSquare where++import Data.Random.RVar+import Data.Random.Distribution+import Data.Random.Distribution.Gamma++import Math.Gamma (p)++chiSquare :: Distribution ChiSquare t => Integer -> RVar t+chiSquare = rvar . ChiSquare++chiSquareT :: Distribution ChiSquare t => Integer -> RVarT m t+chiSquareT = rvarT . ChiSquare++newtype ChiSquare b = ChiSquare Integer++instance (Fractional t, Distribution Gamma t) => Distribution ChiSquare t where+ rvarT (ChiSquare 0) = return 0+ rvarT (ChiSquare n)+ | n > 0 = gammaT (0.5 * fromInteger n) 2+ | otherwise = fail "chi-square distribution: degrees of freedom must be positive"++instance (Real t, Distribution ChiSquare t) => CDF ChiSquare t where+ cdf (ChiSquare n) x = p (0.5 * fromInteger n) (0.5 * realToFrac x)
src/Data/Random/Distribution/Exponential.hs view
@@ -1,6 +1,3 @@-{-- - ``Data/Random/Distribution/Exponential''- -} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,
src/Data/Random/Distribution/Gamma.hs view
@@ -21,6 +21,8 @@ import Data.Ratio +import Math.Gamma (p)+ -- |derived from Marsaglia & Tang, "A Simple Method for generating gamma -- variables", ACM Transactions on Mathematical Software, Vol 26, No 3 (2000), p363-372. {-# SPECIALIZE mtGamma :: Double -> Double -> RVarT m Double #-}@@ -77,5 +79,12 @@ {-# SPECIALIZE instance Distribution Gamma Float #-} rvarT (Gamma a b) = mtGamma a b +instance (Real a, Distribution Gamma a) => CDF Gamma a where+ cdf (Gamma a b) x = p (realToFrac a) (realToFrac x / realToFrac b)+ instance (Integral a, Floating b, Ord b, Distribution Normal b, Distribution StdUniform b) => Distribution (Erlang a) b where rvarT (Erlang a) = mtGamma (fromIntegral a) 1++instance (Integral a, Real b, Distribution (Erlang a) b) => CDF (Erlang a) b where+ cdf (Erlang a) x = p (fromIntegral a) (realToFrac x)+
src/Data/Random/Distribution/Normal.hs view
@@ -138,7 +138,7 @@ getIU :: (Num a, Distribution Uniform a) => RVarT m (Int, a) getIU = do- i <- getRandomPrim PrimWord8+ i <- getRandomWord8 u <- uniformT (-1) 1 return (fromIntegral i .&. (2^p-1), u) @@ -164,7 +164,7 @@ where getIU :: RVarT m (Int, Double) getIU = do- !w <- getRandomPrim PrimWord64+ !w <- getRandomWord64 let (u,i) = wordToDoubleWithExcess w return $! (fromIntegral i .&. (doubleStdNormalC-1), u+u-1) @@ -190,7 +190,7 @@ where getIU :: RVarT m (Int, Float) getIU = do- !w <- getRandomPrim PrimWord32+ !w <- getRandomWord32 let (u,i) = word32ToFloatWithExcess w return (fromIntegral i .&. (floatStdNormalC-1), u+u-1)
src/Data/Random/Distribution/Poisson.hs view
@@ -1,6 +1,3 @@-{-- - ``Data/Random/Distribution/Poisson''- -} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances,
src/Data/Random/Distribution/Rayleigh.hs view
@@ -1,6 +1,3 @@-{-- - ``Data/Random/Distribution/Rayleigh''- -} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,
src/Data/Random/Distribution/Triangular.hs view
@@ -1,6 +1,3 @@-{-- - ``Data/Random/Distribution/Triangular''- -} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,
src/Data/Random/Distribution/Uniform.hs view
@@ -1,6 +1,3 @@-{-- - ``Data/Random/Distribution/Uniform''- -} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances, @@ -48,7 +45,6 @@ import Data.Fixed import Data.Word import Data.Int-import Data.List import Control.Monad.Loops @@ -77,7 +73,7 @@ (bytes, nPossible) = bytesNeeded m nReject = nPossible `mod` m - !prim = getRandomPrim (PrimNByteInteger bytes)+ !prim = getRandomNByteInteger bytes !shift = \(!z) -> l + (fromInteger $! (z `mod` m)) loop = do@@ -121,13 +117,13 @@ -- |Compute a uniform random 'Float' value in the range [0,1) floatStdUniform :: RVarT m Float floatStdUniform = do- x <- getRandomPrim PrimWord32+ x <- getRandomWord32 return (word32ToFloat x) -- |Compute a uniform random 'Double' value in the range [0,1) {-# INLINE doubleStdUniform #-} doubleStdUniform :: RVarT m Double-doubleStdUniform = getRandomPrim PrimDouble+doubleStdUniform = getRandomDouble -- |Compute a uniform random value in the range [0,1) for any 'RealFloat' type realFloatStdUniform :: RealFloat a => RVarT m a@@ -283,27 +279,27 @@ instance CDF Uniform Int where cdf (Uniform a b) = integralUniformCDF a b |]) -instance Distribution StdUniform Word8 where rvarT ~StdUniform = getRandomPrim PrimWord8-instance Distribution StdUniform Word16 where rvarT ~StdUniform = getRandomPrim PrimWord16-instance Distribution StdUniform Word32 where rvarT ~StdUniform = getRandomPrim PrimWord32-instance Distribution StdUniform Word64 where rvarT ~StdUniform = getRandomPrim PrimWord64+instance Distribution StdUniform Word8 where rvarT _ = getRandomWord8+instance Distribution StdUniform Word16 where rvarT _ = getRandomWord16+instance Distribution StdUniform Word32 where rvarT _ = getRandomWord32+instance Distribution StdUniform Word64 where rvarT _ = getRandomWord64 -instance Distribution StdUniform Int8 where rvarT ~StdUniform = fromIntegral `fmap` getRandomPrim PrimWord8-instance Distribution StdUniform Int16 where rvarT ~StdUniform = fromIntegral `fmap` getRandomPrim PrimWord16-instance Distribution StdUniform Int32 where rvarT ~StdUniform = fromIntegral `fmap` getRandomPrim PrimWord32-instance Distribution StdUniform Int64 where rvarT ~StdUniform = fromIntegral `fmap` getRandomPrim PrimWord64+instance Distribution StdUniform Int8 where rvarT _ = fromIntegral `fmap` getRandomWord8+instance Distribution StdUniform Int16 where rvarT _ = fromIntegral `fmap` getRandomWord16+instance Distribution StdUniform Int32 where rvarT _ = fromIntegral `fmap` getRandomWord32+instance Distribution StdUniform Int64 where rvarT _ = fromIntegral `fmap` getRandomWord64 instance Distribution StdUniform Int where- rvar ~StdUniform =+ rvar _ = $(if toInteger (maxBound :: Int) > toInteger (maxBound :: Int32)- then [|fromIntegral `fmap` getRandomPrim PrimWord64|]- else [|fromIntegral `fmap` getRandomPrim PrimWord32|])+ then [|fromIntegral `fmap` getRandomWord64 :: RVar Int|]+ else [|fromIntegral `fmap` getRandomWord32 :: RVar Int|]) instance Distribution StdUniform Word where- rvar ~StdUniform =+ rvar _ = $(if toInteger (maxBound :: Word) > toInteger (maxBound :: Word32)- then [|fromIntegral `fmap` getRandomPrim PrimWord64|]- else [|fromIntegral `fmap` getRandomPrim PrimWord32|])+ then [|fromIntegral `fmap` getRandomWord64 :: RVar Word|]+ else [|fromIntegral `fmap` getRandomWord32 :: RVar Word|]) -- Integer has no StdUniform... @@ -318,15 +314,16 @@ instance CDF StdUniform Int64 where cdf _ = integralUniformCDF minBound maxBound instance CDF StdUniform Int where cdf _ = integralUniformCDF minBound maxBound + instance Distribution Uniform Float where rvarT (Uniform a b) = floatUniform a b instance Distribution Uniform Double where rvarT (Uniform a b) = doubleUniform a b instance CDF Uniform Float where cdf (Uniform a b) = realUniformCDF a b instance CDF Uniform Double where cdf (Uniform a b) = realUniformCDF a b -instance Distribution StdUniform Float where rvarT ~StdUniform = floatStdUniform-instance Distribution StdUniform Double where rvarT ~StdUniform = getRandomPrim PrimDouble; rvarT ~StdUniform = getRandomPrim PrimDouble-instance CDF StdUniform Float where cdf ~StdUniform = realStdUniformCDF-instance CDF StdUniform Double where cdf ~StdUniform = realStdUniformCDF+instance Distribution StdUniform Float where rvarT _ = floatStdUniform+instance Distribution StdUniform Double where rvarT _ = getRandomDouble+instance CDF StdUniform Float where cdf _ = realStdUniformCDF+instance CDF StdUniform Double where cdf _ = realStdUniformCDF instance HasResolution r => Distribution Uniform (Fixed r) where rvarT (Uniform a b) = fixedUniform a b@@ -347,7 +344,7 @@ instance Distribution StdUniform () where rvarT ~StdUniform = return () instance CDF StdUniform () where cdf ~StdUniform = return 1-instance Distribution StdUniform Bool where rvarT ~StdUniform = fmap even (getRandomPrim PrimWord8)+instance Distribution StdUniform Bool where rvarT ~StdUniform = fmap even (getRandomWord8) instance CDF StdUniform Bool where cdf ~StdUniform = boundedEnumStdUniformCDF instance Distribution StdUniform Char where rvarT ~StdUniform = boundedEnumStdUniform
src/Data/Random/Distribution/Ziggurat.hs view
@@ -218,7 +218,7 @@ (r,v) = findBin0 c f fInv fInt fVol -- |Build a lazy recursive ziggurat. Uses a lazily-constructed ziggurat--- as its tail distribution (with another as its tail, ad nauseum).+-- as its tail distribution (with another as its tail, ad nauseam). -- -- Arguments: -- @@ -251,7 +251,7 @@ mkZigguratRec m f fInv fInt fVol c getIU = z where fix :: ((forall m. a -> RVarT m a) -> (forall m. a -> RVarT m a)) -> (forall m. a -> RVarT m a)- fix f = f (fix f)+ fix g = g (fix g) z = mkZiggurat m f fInv fInt fVol c getIU (fix (mkTail m f fInv fInt fVol c getIU z)) mkTail ::
− src/Data/Random/Internal/Primitives.hs
@@ -1,249 +0,0 @@-{-# LANGUAGE GADTs, RankNTypes, DeriveDataTypeable #-}--- |This is an experimental interface to support an extensible set of primitives,--- where a RandomSource will be able to support whatever subset of them they want--- and have well-founded defaults generated automatically for any unsupported--- primitives.------ The purpose, in case it's not clear, is to decouple the implementations of--- entropy sources from any particular set of primitives, so that implementors--- of random variates can make use of a large number of primitives, supported--- on all entropy sources, while the burden on entropy-source implementors--- is only to provide one or two basic primitives of their choice.--- --- One challenge I foresee with this interface is optimization - different --- compilers or even different versions of GHC may treat this interface --- radically differently, making it very hard to achieve reliable performance--- on all platforms. It may even be that no compiler optimizes sufficiently--- to make the flexibility this system provides worth the overhead. I hope--- this is not the case, but if it turns out to be a major problem, this--- system may disappear or be modified in significant ways.-module Data.Random.Internal.Primitives (Prim(..), getPrimWhere, decomposePrimWhere) where--import Data.Random.Internal.Words-import Data.Word-import Data.Bits-import Data.Typeable--import Control.Monad.Prompt---- |A 'Prompt' GADT describing a request for a primitive random variate.--- Random variable definitions will request their entropy via these prompts,--- and entropy sources will satisfy some or all of them. The 'decomposePrimWhere'--- function extends an entropy source's incomplete definition to a complete --- definition, essentially defining a very flexible implementation-defaulting--- system.--- --- Some possible future additions:--- PrimFloat :: Prim Float--- PrimInt :: Prim Int--- PrimPair :: Prim a -> Prim b -> Prim (a :*: b)--- PrimNormal :: Prim Double--- PrimChoice :: [(Double :*: a)] -> Prim a------ Unfortunately, I cannot get Haddock to accept my comments about the --- data constructors, but hopefully they should be reasonably self-explanatory.-data Prim a where- -- An unsigned byte, uniformly distributed from 0 to 0xff- PrimWord8 :: Prim Word8- -- An unsigned 16-bit word, uniformly distributed from 0 to 0xffff- PrimWord16 :: Prim Word16- -- An unsigned 32-bit word, uniformly distributed from 0 to 0xffffffff- PrimWord32 :: Prim Word32- -- An unsigned 64-bit word, uniformly distributed from 0 to 0xffffffffffffffff- PrimWord64 :: Prim Word64- -- A double-precision float U, uniformly distributed 0 <= U < 1- PrimDouble :: Prim Double- -- A uniformly distributed 'Integer' 0 <= U < 2^(8*n)- PrimNByteInteger :: !Int -> Prim Integer- deriving (Typeable)--instance Show (Prim a) where- showsPrec _p PrimWord8 = showString "PrimWord8"- showsPrec _p PrimWord16 = showString "PrimWord16"- showsPrec _p PrimWord32 = showString "PrimWord32"- showsPrec _p PrimWord64 = showString "PrimWord64"- showsPrec _p PrimDouble = showString "PrimDouble"- showsPrec p (PrimNByteInteger n) = showParen (p > 10) (showString "PrimNByteInteger " . showsPrec 11 n)---- |This function wraps up the most common calling convention for 'decomposePrimWhere'.--- Given a predicate identifying \"supported\" 'Prim's, and a (possibly partial) --- function that maps those 'Prim's to implementations, derives a total function--- mapping all 'Prim's to implementations.-{-# INLINE getPrimWhere #-}-{-# SPECIALIZE getPrimWhere :: Monad m => (forall t. Prim t -> Bool) -> (forall t. Prim t -> m t) -> Prim Word8 -> m Word8 #-}-{-# SPECIALIZE getPrimWhere :: Monad m => (forall t. Prim t -> Bool) -> (forall t. Prim t -> m t) -> Prim Word16 -> m Word16 #-}-{-# SPECIALIZE getPrimWhere :: Monad m => (forall t. Prim t -> Bool) -> (forall t. Prim t -> m t) -> Prim Word32 -> m Word32 #-}-{-# SPECIALIZE getPrimWhere :: Monad m => (forall t. Prim t -> Bool) -> (forall t. Prim t -> m t) -> Prim Word64 -> m Word64 #-}-{-# SPECIALIZE getPrimWhere :: Monad m => (forall t. Prim t -> Bool) -> (forall t. Prim t -> m t) -> Prim Double -> m Double #-}-{-# SPECIALIZE getPrimWhere :: Monad m => (forall t. Prim t -> Bool) -> (forall t. Prim t -> m t) -> Prim Integer -> m Integer #-}-getPrimWhere :: Monad m => (forall t. Prim t -> Bool) -> (forall t. Prim t -> m t) -> Prim a -> m a-getPrimWhere supported getPrim prim = runPromptM getPrim (decomposePrimWhere supported prim)---- |This is essentially a suite of interrelated default implementations,--- each definition making use of only \"supported\" primitives. It _really_--- ought to be inlined to the point where the @supported@ predicate--- is able to be inlined into it and eliminated. --- --- When inlined sufficiently, it should in theory be optimized down to the--- static set of "best" definitions for each required primitive in terms of --- only supported primitives.--- --- Hopefully it does not impose too much overhead when not inlined.-{-# INLINE decomposePrimWhere #-}-{-# SPECIALIZE decomposePrimWhere :: (forall t. Prim t -> Bool) -> Prim Word8 -> Prompt Prim Word8 #-}-{-# SPECIALIZE decomposePrimWhere :: (forall t. Prim t -> Bool) -> Prim Word16 -> Prompt Prim Word16 #-}-{-# SPECIALIZE decomposePrimWhere :: (forall t. Prim t -> Bool) -> Prim Word32 -> Prompt Prim Word32 #-}-{-# SPECIALIZE decomposePrimWhere :: (forall t. Prim t -> Bool) -> Prim Word64 -> Prompt Prim Word64 #-}-{-# SPECIALIZE decomposePrimWhere :: (forall t. Prim t -> Bool) -> Prim Double -> Prompt Prim Double #-}-{-# SPECIALIZE decomposePrimWhere :: (forall t. Prim t -> Bool) -> Prim Integer -> Prompt Prim Integer #-}-decomposePrimWhere :: (forall t. Prim t -> Bool) -> Prim a -> Prompt Prim a-decomposePrimWhere supported requested = decomp requested- where- {-# INLINE decomp #-}-- {-# SPECIALIZE decomp :: Prim Word8 -> Prompt Prim Word8 #-}- {-# SPECIALIZE decomp :: Prim Word16 -> Prompt Prim Word16 #-}- {-# SPECIALIZE decomp :: Prim Word32 -> Prompt Prim Word32 #-}- {-# SPECIALIZE decomp :: Prim Word64 -> Prompt Prim Word64 #-}- {-# SPECIALIZE decomp :: Prim Double -> Prompt Prim Double #-}- {-# SPECIALIZE decomp :: Prim Integer -> Prompt Prim Integer #-}- -- First, all supported prims should just be evaluated directly.- decomp :: Prim a -> Prompt Prim a- decomp prim- | supported prim = prompt prim- -- beyond this point, all definitions must be in terms of- -- 'prompt's referring to other supported primitives or - -- 'decomp's referring to other primitives in a well-founded way- - decomp PrimWord8- | supported PrimWord16 = do- w <- prompt PrimWord16- return (fromIntegral w)- | supported PrimWord32 = do- w <- prompt PrimWord32- return (fromIntegral w)- | supported PrimWord64 = do- w <- prompt PrimWord64- return (fromIntegral w)- | supported PrimDouble = do- d <- prompt PrimDouble- return (truncate (d * 256))- | supported (PrimNByteInteger 1) = do- i <- prompt (PrimNByteInteger 1)- return (fromInteger i)- - decomp PrimWord16- | supported PrimWord8 = do- b0 <- prompt PrimWord8- b1 <- prompt PrimWord8- return (buildWord16 b0 b1)- | supported PrimWord32 = do- w <- prompt PrimWord32- return (fromIntegral w)- | supported PrimWord64 = do- w <- prompt PrimWord64- return (fromIntegral w)- | supported PrimDouble = do- d <- prompt PrimDouble- return (truncate (d * 65536))- | supported (PrimNByteInteger 2) = do- i <- prompt (PrimNByteInteger 2)- return (fromInteger i)- - decomp PrimWord32- | supported PrimWord16 = do- w0 <- prompt PrimWord16- w1 <- prompt PrimWord16- - return (buildWord32' w0 w1)- | supported PrimWord8 = do- b0 <- prompt PrimWord8- b1 <- prompt PrimWord8- b2 <- prompt PrimWord8- b3 <- prompt PrimWord8- - return (buildWord32 b0 b1 b2 b3)- | supported PrimWord64 = do- w <- prompt PrimWord64- return (fromIntegral w)- | supported PrimDouble = do- d <- prompt PrimDouble- return (truncate (d * 4294967296))- | supported (PrimNByteInteger 4) = do- i <- prompt (PrimNByteInteger 4)- return (fromInteger i)- - decomp PrimWord64- | supported PrimWord32 = do- w0 <- prompt PrimWord32- w1 <- prompt PrimWord32- - return (buildWord64'' w0 w1)- | supported PrimWord16 = do- w0 <- prompt PrimWord16- w1 <- prompt PrimWord16- w2 <- prompt PrimWord16- w3 <- prompt PrimWord16- - return (buildWord64' w0 w1 w2 w3)- | supported PrimWord8 = do- b0 <- prompt PrimWord8- b1 <- prompt PrimWord8- b2 <- prompt PrimWord8- b3 <- prompt PrimWord8- b4 <- prompt PrimWord8- b5 <- prompt PrimWord8- b6 <- prompt PrimWord8- b7 <- prompt PrimWord8- - return (buildWord64 b0 b1 b2 b3 b4 b5 b6 b7)- | supported PrimDouble = do- -- Need 2 doubles, because a uniform [0,1) double only has- -- about 52 bits of reliable entropy- d0 <- prompt PrimDouble- d1 <- prompt PrimDouble- - let w0 = truncate (d0 * 4294967296)- w1 = truncate (d1 * 4294967296)- - return (w0 .|. (w1 `shiftL` 32))- | supported (PrimNByteInteger 8) = do- i <- prompt (PrimNByteInteger 8)- return (fromInteger i)- - decomp PrimDouble = do- word <- decomp PrimWord64- return (wordToDouble word)- - decomp (PrimNByteInteger 1) = do- x <- decomp PrimWord8- return $! toInteger x- decomp (PrimNByteInteger 2) = do- x <- decomp PrimWord16- return $! toInteger x- decomp (PrimNByteInteger 4) = do- x <- decomp PrimWord32- return $! toInteger x- decomp (PrimNByteInteger 8) = do- x <- decomp PrimWord64- return $! toInteger x- decomp (PrimNByteInteger (n+8)) = do- x <- decomp PrimWord64- y <- decomp (PrimNByteInteger n)- return $! (toInteger x `shiftL` (n `shiftL` 3)) .|. y- decomp (PrimNByteInteger (n+4)) = do- x <- decomp PrimWord32- y <- decomp (PrimNByteInteger n)- return $! (toInteger x `shiftL` (n `shiftL` 3)) .|. y- decomp (PrimNByteInteger (n+2)) = do- x <- decomp PrimWord16- y <- decomp (PrimNByteInteger n)- return $! (toInteger x `shiftL` (n `shiftL` 3)) .|. y--- REDUNDANT CASE--- decomp (PrimNByteInteger (n+1)) = do--- x <- decomp PrimWord8--- y <- decomp (PrimNByteInteger n)--- return $! (toInteger x `shiftL` (n `shiftL` 3)) .|. y- decomp (PrimNByteInteger _) = return 0- - decomp _ = error ("decomposePrimWhere: no supported primitive to satisfy " ++ show requested)
src/Data/Random/Internal/TH.hs view
@@ -1,6 +1,3 @@-{-- - ``Data/Random/Internal/TH''- -} {-# LANGUAGE TemplateHaskell #-}
− src/Data/Random/Internal/Words.hs
@@ -1,128 +0,0 @@-{-- - ``Data/Random/Internal/Words''- -}---- |A few little functions I found myself writing inline over and over again.-module Data.Random.Internal.Words where--import Foreign---- TODO: add a build flag for endianness-invariance, or just find a way--- to make sure these operations all do the right thing without costing --- anything extra at runtime--{-# INLINE buildWord16 #-}--- |Build a word out of 2 bytes. No promises are made regarding the order--- in which the bytes are stuffed. Note that this means that a 'RandomSource'--- or 'MonadRandom' making use of the default definition of 'getRandomWord', etc.,--- may return different random values on different platforms when started --- with the same seed, depending on the platform's endianness.-buildWord16 :: Word8 -> Word8 -> Word16-buildWord16 b0 b1- = unsafePerformIO . allocaBytes 2 $ \p -> do- pokeByteOff p 0 b0- pokeByteOff p 1 b1- peek (castPtr p)--{-# INLINE buildWord32 #-}--- |Build a word out of 4 bytes. No promises are made regarding the order--- in which the bytes are stuffed. Note that this means that a 'RandomSource'--- or 'MonadRandom' making use of the default definition of 'getRandomWord', etc.,--- may return different random values on different platforms when started --- with the same seed, depending on the platform's endianness.-buildWord32 :: Word8 -> Word8 -> Word8 -> Word8 -> Word32-buildWord32 b0 b1 b2 b3- = unsafePerformIO . allocaBytes 4 $ \p -> do- pokeByteOff p 0 b0- pokeByteOff p 1 b1- pokeByteOff p 2 b2- pokeByteOff p 3 b3- peek (castPtr p)--{-# INLINE buildWord32' #-}-buildWord32' :: Word16 -> Word16 -> Word32-buildWord32' w0 w1- = unsafePerformIO . allocaBytes 4 $ \p -> do- pokeByteOff p 0 w0- pokeByteOff p 2 w1- peek (castPtr p)--{-# INLINE buildWord64 #-}--- |Build a word out of 8 bytes. No promises are made regarding the order--- in which the bytes are stuffed. Note that this means that a 'RandomSource'--- or 'MonadRandom' making use of the default definition of 'getRandomWord', etc.,--- may return different random values on different platforms when started --- with the same seed, depending on the platform's endianness.-buildWord64 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word64-buildWord64 b0 b1 b2 b3 b4 b5 b6 b7- = unsafePerformIO . allocaBytes 8 $ \p -> do- pokeByteOff p 0 b0- pokeByteOff p 1 b1- pokeByteOff p 2 b2- pokeByteOff p 3 b3- pokeByteOff p 4 b4- pokeByteOff p 5 b5- pokeByteOff p 6 b6- pokeByteOff p 7 b7- peek (castPtr p)--{-# INLINE buildWord64' #-}-buildWord64' :: Word16 -> Word16 -> Word16 -> Word16 -> Word64-buildWord64' w0 w1 w2 w3- = unsafePerformIO . allocaBytes 8 $ \p -> do- pokeByteOff p 0 w0- pokeByteOff p 2 w1- pokeByteOff p 4 w2- pokeByteOff p 6 w3- peek (castPtr p)--{-# INLINE buildWord64'' #-}-buildWord64'' :: Word32 -> Word32 -> Word64-buildWord64'' w0 w1- = unsafePerformIO . allocaBytes 8 $ \p -> do- pokeByteOff p 0 w0- pokeByteOff p 4 w1- peek (castPtr p)--{-# INLINE word32ToFloat #-}--- |Pack the low 23 bits from a 'Word32' into a 'Float' in the range [0,1).--- Used to convert a 'stdUniform' 'Word32' to a 'stdUniform' 'Double'.-word32ToFloat :: Word32 -> Float-word32ToFloat x = (encodeFloat $! toInteger (x .&. 0x007fffff {- 2^23-1 -} )) $ (-23)--{-# INLINE word32ToFloatWithExcess #-}--- |Same as word32ToFloat, but also return the unused bits (as the 9--- least significant bits of a 'Word32')-word32ToFloatWithExcess :: Word32 -> (Float, Word32)-word32ToFloatWithExcess x = (word32ToFloat x, x `shiftR` 23)--{-# INLINE wordToFloat #-}--- |Pack the low 23 bits from a 'Word64' into a 'Float' in the range [0,1).--- Used to convert a 'stdUniform' 'Word64' to a 'stdUniform' 'Double'.-wordToFloat :: Word64 -> Float-wordToFloat x = (encodeFloat $! toInteger (x .&. 0x007fffff {- 2^23-1 -} )) $ (-23)--{-# INLINE wordToFloatWithExcess #-}--- |Same as wordToFloat, but also return the unused bits (as the 41--- least significant bits of a 'Word64')-wordToFloatWithExcess :: Word64 -> (Float, Word64)-wordToFloatWithExcess x = (wordToFloat x, x `shiftR` 23)--{-# INLINE wordToDouble #-}--- |Pack the low 52 bits from a 'Word64' into a 'Double' in the range [0,1).--- Used to convert a 'stdUniform' 'Word64' to a 'stdUniform' 'Double'.-wordToDouble :: Word64 -> Double-wordToDouble x = (encodeFloat $! toInteger (x .&. 0x000fffffffffffff {- 2^52-1 -})) $ (-52)--{-# INLINE word32ToDouble #-}--- |Pack a 'Word32' into a 'Double' in the range [0,1). Note that a Double's --- mantissa is 52 bits, so this does not fill all of them.-word32ToDouble :: Word32 -> Double-word32ToDouble x = (encodeFloat $! toInteger x) $ (-32)--{-# INLINE wordToDoubleWithExcess #-}--- |Same as wordToDouble, but also return the unused bits (as the 12--- least significant bits of a 'Word64')-wordToDoubleWithExcess :: Word64 -> (Double, Word64)-wordToDoubleWithExcess x = (wordToDouble x, x `shiftR` 52)-
src/Data/Random/Lift.hs view
@@ -1,10 +1,16 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, IncoherentInstances #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, IncoherentInstances, CPP #-} module Data.Random.Lift where -import Control.Monad.Identity-import qualified Control.Monad.Trans as T+import Data.RVar+import qualified Data.Functor.Identity as T+import qualified Control.Monad.Trans.Class as T+import Data.Random.Source.Std +#ifndef MTL2+import qualified Control.Monad.Identity as MTL+#endif+ -- | A class for \"liftable\" data structures. Conceptually -- an extension of 'T.MonadTrans' to allow deep lifting, -- but lifting need not be done between monads only. Eg lifting@@ -31,5 +37,22 @@ -- | This instance is incoherent with the other two. However, -- by the law @lift (return x) == return x@, the results -- must always be the same.-instance Monad m => Lift Identity m where- lift = return . runIdentity+instance Monad m => Lift T.Identity m where+ lift = return . T.runIdentity++instance Lift (RVarT T.Identity) (RVarT m) where+ lift x = runRVar x StdRandom++#ifndef MTL2++-- | This instance is incoherent with the other two. However,+-- by the law @lift (return x) == return x@, the results+-- must always be the same.+instance Monad m => Lift MTL.Identity m where+ lift = return . MTL.runIdentity++instance Lift (RVarT MTL.Identity) (RVarT m) where+ lift x = runRVar x StdRandom++#endif+
src/Data/Random/List.hs view
@@ -36,7 +36,7 @@ shuffleNofM 0 _ _ = return [] shuffleNofM n m xs | n > m = error "shuffleNofM: n > m"- | otherwise = do+ | n >= 0 = do is <- sequence [uniform 0 i | i <- take n [m-1, m-2 ..1]] return (take n $ SRS.shuffle (take m xs) is) shuffleNofM _ _ _ = error "shuffleNofM: negative length specified"
src/Data/Random/RVar.hs view
@@ -1,222 +1,14 @@-{-- - ``Data/Random/RVar''- -}-{-# LANGUAGE- RankNTypes,- MultiParamTypeClasses,- FlexibleInstances, - GADTs,- ScopedTypeVariables- #-}---- |Random variables. An 'RVar' is a sampleable random variable. Because--- probability distributions form a monad, they are quite easy to work with--- in the standard Haskell monadic styles. For examples, see the source for--- any of the 'Distribution' instances - they all are defined in terms of--- 'RVar's.+{-# LANGUAGE RankNTypes, FlexibleInstances, MultiParamTypeClasses #-} module Data.Random.RVar- ( RVar- , runRVar- , RVarT- , runRVarT- , runRVarTWith+ ( RVar, runRVar+ , RVarT, runRVarT, runRVarTWith ) where --import Data.Random.Internal.Primitives-import Data.Random.Source-import Data.Random.Lift as L--import qualified Control.Monad.Trans as T-import Control.Applicative-import Control.Monad.Identity-import Control.Monad.Prompt (PromptT, runPromptT, prompt)---- |An opaque type modeling a \"random variable\" - a value --- which depends on the outcome of some random event. 'RVar's --- can be conveniently defined by an imperative-looking style:--- --- > normalPair = do--- > u <- stdUniform--- > t <- stdUniform--- > let r = sqrt (-2 * log u)--- > theta = (2 * pi) * t--- > --- > x = r * cos theta--- > y = r * sin theta--- > return (x,y)--- --- OR by a more applicative style:--- --- > logNormal = exp <$> stdNormal------ Once defined (in any style), there are several ways to sample 'RVar's:--- --- * In a monad, using a 'RandomSource':--- --- > sampleFrom DevRandom (uniform 1 100) :: IO Int--- --- * In a monad, using a 'MonadRandom' instance:------ > sample (uniform 1 100) :: State PureMT Int--- --- * As a pure function transforming a functional RNG:--- --- > sampleState (uniform 1 100) :: StdGen -> (Int, StdGen)-type RVar = RVarT Identity---- |\"Run\" an 'RVar' - samples the random variable from the provided--- source of entropy. Typically 'sample', 'sampleFrom' or 'sampleState' will--- be more convenient to use.-runRVar :: RandomSource m s => RVar a -> s -> m a-runRVar = runRVarT---- |A random variable with access to operations in an underlying monad. Useful--- examples include any form of state for implementing random processes with hysteresis,--- or writer monads for implementing tracing of complicated algorithms.--- --- For example, a simple random walk can be implemented as an 'RVarT' 'IO' value:------ > rwalkIO :: IO (RVarT IO Double)--- > rwalkIO d = do--- > lastVal <- newIORef 0--- > --- > let x = do--- > prev <- lift (readIORef lastVal)--- > change <- rvarT StdNormal--- > --- > let new = prev + change--- > lift (writeIORef lastVal new)--- > return new--- > --- > return x------ To run the random walk, it must first be initialized, and then it can be sampled as usual:------ > do--- > rw <- rwalkIO--- > x <- sampleFrom DevURandom rw--- > y <- sampleFrom DevURandom rw--- > ...------ The same random-walk process as above can be implemented using MTL types--- as follows (using @import Control.Monad.Trans as MTL@):--- --- > rwalkState :: RVarT (State Double) Double--- > rwalkState = do--- > prev <- MTL.lift get--- > change <- rvarT StdNormal--- > --- > let new = prev + change--- > MTL.lift (put new)--- > return new--- --- Invocation is straightforward (although a bit noisy) if you're used --- to MTL, but there is a gotcha lurking here: @sample@ and 'runRVarT' --- inherit the extreme generality of 'lift', so there will almost always--- need to be an explicit type signature lurking somewhere in any client --- code making use of 'RVarT' with MTL types. In this example, the --- inferred type of @start@ would be too general to be practical, so the--- signature for @rwalk@ explicitly fixes it to 'Double'. Alternatively, --- in this case @sample@ could be replaced with--- @\\x -> runRVarTWith MTL.lift x StdRandom@.--- --- > rwalk :: Int -> Double -> StdGen -> ([Double], StdGen)--- > rwalk count start gen = evalState (runStateT (sample (replicateM count rwalkState)) gen) start-newtype RVarT m a = RVarT { unRVarT :: PromptT Prim m a }---- | \"Runs\" an 'RVarT', sampling the random variable it defines.--- --- The 'Lift' context allows random variables to be defined using a minimal--- underlying functor ('Identity' is sufficient for \"conventional\" random--- variables) and then sampled in any monad into which the underlying functor --- can be embedded (which, for 'Identity', is all monads).--- --- The lifting is very important - without it, every 'RVar' would have--- to either be given access to the full capability of the monad in which it--- will eventually be sampled (which, incidentally, would also have to be --- monomorphic so you couldn't sample one 'RVar' in more than one monad)--- or functions manipulating 'RVar's would have to use higher-ranked --- types to enforce the same kind of isolation and polymorphism.--- --- For non-standard liftings or those where you would rather not introduce a--- 'Lift' instance, see 'runRVarTWith'.-{-# INLINE runRVarT #-}-runRVarT :: - forall n m s a.- (Lift n m, RandomSource m s) - => RVarT n a -> s -> m a-runRVarT (RVarT m) src = runPromptT return bindP bindN m- where- bindP :: forall t x. Prim t -> (t -> m x) -> m x- bindP prim cont = getRandomPrimFrom src prim >>= cont- bindN :: forall t x. n t -> (t -> m x) -> m x- bindN nExp cont = lift nExp >>= cont---- |Like 'runRVarT' but allowing a user-specified lift operation. This --- operation must obey the \"monad transformer\" laws:------ > lift . return = return--- > lift (x >>= f) = (lift x) >>= (lift . f)------ One example of a useful non-standard lifting would be one that takes @State s@ to--- another monad with a different state representation (such as @IO@ with the--- state mapped to an @IORef@):------ > embedState :: (Monad m) => m s -> (s -> m ()) -> State s a -> m a--- > embedState get put = \m -> do--- > s <- get--- > (res,s) <- return (runState m s)--- > put s--- > return res-{-# INLINE runRVarTWith #-}-runRVarTWith :: - forall n m s a.- (RandomSource m s) - => (forall t. n t -> m t) -> RVarT n a -> s -> m a-runRVarTWith liftN (RVarT m) src = runPromptT return bindP bindN m- where- bindP :: forall t x. Prim t -> (t -> m x) -> m x- bindP prim cont = getRandomPrimFrom src prim >>= cont- bindN :: forall t x. n t -> (t -> m x) -> m x- bindN nExp cont = liftN nExp >>= cont--instance Functor (RVarT n) where- fmap = liftM--instance Monad (RVarT n) where- return x = RVarT (return $! x)- fail s = RVarT (fail s)- (RVarT m) >>= k = RVarT (m >>= \x -> x `seq` unRVarT (k x))--instance Applicative (RVarT n) where- pure = return- (<*>) = ap--instance T.MonadTrans RVarT where- lift m = RVarT (T.lift m)--instance Lift (RVarT Identity) (RVarT m) where- lift (RVarT m) = RVarT (runPromptT return bindP bindN m)- where- bindP :: Prim a -> (a -> PromptT Prim m b) -> PromptT Prim m b- bindP prim cont = prompt prim >>= cont- bindN :: Identity a -> (a -> PromptT Prim m b) -> PromptT Prim m b- bindN idExp cont = cont (runIdentity idExp)--instance T.MonadIO m => T.MonadIO (RVarT m) where- liftIO = T.lift . T.liftIO--instance MonadRandom (RVarT n) where- getRandomPrim p = RVarT (prompt p)+import Data.Random.Lift+import Data.Random.Internal.Source+import Data.RVar hiding (runRVarT) --- I would really like to be able to do this, but I can't because of the--- blasted Eq and Show in Num's class context...--- instance (Applicative m, Num a) => Num (RVarT m a) where--- (+) = liftA2 (+)--- (-) = liftA2 (-)--- (*) = liftA2 (*)--- negate = liftA negate--- signum = liftA signum--- abs = liftA abs--- fromInteger = pure . fromInteger+-- |Like 'runRVarTWith', but using an implicit lifting (provided by the +-- 'Lift' class)+runRVarT :: (Lift n m, RandomSource m s) => RVarT n a -> s -> m a+runRVarT = runRVarTWith lift
src/Data/Random/Sample.hs view
@@ -1,6 +1,3 @@-{-- - ``Data/Random/Sample''- -} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,
− src/Data/Random/Source.hs
@@ -1,100 +0,0 @@-{-- - ``Data/Random/Source''- -}-{-# LANGUAGE- MultiParamTypeClasses, FlexibleInstances, GADTs- #-}--module Data.Random.Source- ( MonadRandom(..)- , RandomSource(..)- , Prim(..)- ) where--import Data.Word--import Data.Random.Internal.Primitives---- |A typeclass for monads with a chosen source of entropy. For example,--- 'RVar' is such a monad - the source from which it is (eventually) sampled--- is the only source from which a random variable is permitted to draw, so--- when directly requesting entropy for a random variable these functions--- are used.--- --- Occasionally one might want a 'RandomSource' specifying the 'MonadRandom'--- instance (for example, when using 'runRVar'). For those cases, --- "Data.Random.Source.Std".'StdRandom' provides a 'RandomSource' that--- maps to the 'MonadRandom' instance.--- --- For example, @State StdGen@ has a 'MonadRandom' instance, so to run an--- 'RVar' (called @x@ in this example) in this monad one could write--- @runRVar x StdRandom@ (or more concisely with the 'sample' function: @sample x@).--- -class Monad m => MonadRandom m where- -- |Generate a random value corresponding to the specified primitive.- -- The 'Prim' type has many variants, and is also somewhat unstable.- -- 'getPrimWhere' is a useful function for abstracting over the type,- -- semi-automatically extending a partial implementation to the full- -- 'Prim' type.- getRandomPrim :: Prim t -> m t---- |A source of entropy which can be used in the given monad.--- --- See also 'MonadRandom'.-class Monad m => RandomSource m s where- -- |Generate a random value corresponding to the specified primitive.- -- The 'Prim' type has many variants, and is also somewhat unstable.- -- 'getPrimWhere' is a useful function for abstracting over the type,- -- semi-automatically extending a partial implementation to the full- -- 'Prim' type.- getRandomPrimFrom :: s -> Prim t -> m t--instance Monad m => RandomSource m (m Word8) where- getRandomPrimFrom f = getPrimWhere supported (getPrim f)- where- supported :: Prim a -> Bool- supported PrimWord8 = True- supported _ = False- - getPrim :: m Word8 -> Prim a -> m a- getPrim f PrimWord8 = f--instance Monad m => RandomSource m (m Word16) where- getRandomPrimFrom f = getPrimWhere supported (getPrim f)- where- supported :: Prim a -> Bool- supported PrimWord16 = True- supported _ = False- - getPrim :: m Word16 -> Prim a -> m a- getPrim f PrimWord16 = f--instance Monad m => RandomSource m (m Word32) where- getRandomPrimFrom f = getPrimWhere supported (getPrim f)- where- supported :: Prim a -> Bool- supported PrimWord32 = True- supported _ = False- - getPrim :: m Word32 -> Prim a -> m a- getPrim f PrimWord32 = f--instance Monad m => RandomSource m (m Word64) where- getRandomPrimFrom f = getPrimWhere supported (getPrim f)- where- supported :: Prim a -> Bool- supported PrimWord64 = True- supported _ = False- - getPrim :: m Word64 -> Prim a -> m a- getPrim f PrimWord64 = f--instance Monad m => RandomSource m (m Double) where- getRandomPrimFrom f = getPrimWhere supported (getPrim f)- where- supported :: Prim a -> Bool- supported PrimDouble = True- supported _ = False- - getPrim :: m Double -> Prim a -> m a- getPrim f PrimDouble = f
− src/Data/Random/Source/DevRandom.hs
@@ -1,62 +0,0 @@-{-- - ``Data/Random/Source/DevRandom''- -}-{-# LANGUAGE- MultiParamTypeClasses, GADTs- #-}--module Data.Random.Source.DevRandom - ( DevRandom(..)- ) where--import Data.Random.Source-import Data.Random.Internal.Primitives--import System.IO (openBinaryFile, hGetBuf, Handle, IOMode(..))-import Foreign---- |On systems that have it, \/dev\/random is a handy-dandy ready-to-use source--- of nonsense. Keep in mind that on some systems, Linux included, \/dev\/random--- collects \"real\" entropy, and if you don't have a good source of it, such as--- special hardware for the purpose or a *lot* of network traffic, it's pretty easy--- to suck the entropy pool dry with entropy-intensive applications. For many--- purposes other than cryptography, \/dev\/urandom is preferable because when it--- runs out of real entropy it'll still churn out pseudorandom data.-data DevRandom = DevRandom | DevURandom- deriving (Eq, Show)--{-# NOINLINE devRandom #-}-devRandom :: Handle-devRandom = unsafePerformIO (openBinaryFile "/dev/random" ReadMode)-{-# NOINLINE devURandom #-}-devURandom :: Handle-devURandom = unsafePerformIO (openBinaryFile "/dev/urandom" ReadMode)--dev :: DevRandom -> Handle-dev DevRandom = devRandom-dev DevURandom = devURandom--instance RandomSource IO DevRandom where- getRandomPrimFrom src = getPrimWhere supported getPrim- where- supported :: Prim a -> Bool- supported PrimWord8 = True- supported PrimWord16 = True- supported PrimWord32 = True- supported PrimWord64 = True- supported _ = False- - getPrim :: Prim a -> IO a- getPrim PrimWord8 = allocaBytes 1 $ \buf -> do- 1 <- hGetBuf (dev src) buf 1- peek buf- getPrim PrimWord16 = allocaBytes 2 $ \buf -> do- 2 <- hGetBuf (dev src) buf 2- peek (castPtr buf)- getPrim PrimWord32 = allocaBytes 4 $ \buf -> do- 4 <- hGetBuf (dev src) buf 4- peek (castPtr buf)- getPrim PrimWord64 = allocaBytes 8 $ \buf -> do- 8 <- hGetBuf (dev src) buf 8- peek (castPtr buf)- getPrim prim = error ("getRandomPrimFrom/" ++ show src ++ ": unsupported prim requested: " ++ show prim)
− src/Data/Random/Source/MWC.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE- MultiParamTypeClasses,- FlexibleInstances,- GADTs- #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |This module defines the following instances:--- --- > instance RandomSource (ST s) (Gen s)--- > instance RandomSource IO (Gen RealWorld)-module Data.Random.Source.MWC where--import Data.Random.Internal.Primitives-import Data.Random.Internal.Words-import Data.Random.Source-import System.Random.MWC-import Control.Monad.ST--instance RandomSource (ST s) (Gen s) where- getRandomPrimFrom src = getPrimWhere supported (getPrim src)- where- {-# INLINE supported #-}- supported :: Prim a -> Bool- supported PrimWord8 = True- supported PrimWord16 = True- supported PrimWord32 = True- supported PrimWord64 = True- supported PrimDouble = True- supported _ = False- - {-# INLINE getPrim #-}- getPrim :: Gen s -> Prim a -> ST s a- getPrim gen PrimWord8 = uniform gen- getPrim gen PrimWord16 = uniform gen- getPrim gen PrimWord32 = uniform gen- getPrim gen PrimWord64 = uniform gen- getPrim gen PrimDouble = fmap wordToDouble (uniform gen)- getPrim gen p = error ("getSupportedRandomPrimFrom/Gen s: unsupported prim requested: " ++ show p)--instance RandomSource IO (Gen RealWorld) where- getRandomPrimFrom src = stToIO . getRandomPrimFrom src
− src/Data/Random/Source/PureMT.hs
@@ -1,168 +0,0 @@-{-# LANGUAGE- CPP,- BangPatterns,- MultiParamTypeClasses,- FlexibleContexts, FlexibleInstances,- UndecidableInstances,- GADTs, RankNTypes,- ScopedTypeVariables- #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- |This module provides functions useful for implementing new 'MonadRandom'--- and 'RandomSource' instances for state-abstractions containing 'PureMT'--- values (the pure pseudorandom generator provided by the--- mersenne-random-pure64 package), as well as instances for some common--- cases.--- --- A 'PureMT' generator is immutable, so 'PureMT' by itself cannot be a --- 'RandomSource' (if it were, it would always give the same \"random\"--- values). Some form of mutable state must be used, such as an 'IORef',--- 'State' monad, etc.. A few default instances are provided by this module--- along with more-general functions ('getRandomPrimFromMTRef' and--- 'getRandomPrimFromMTState') usable as implementations for new cases--- users might need.-module Data.Random.Source.PureMT - ( PureMT, newPureMT, pureMT- , module Data.Random.Source.PureMT - ) where--import Data.Random.Internal.Primitives-import Data.Random.Source-import System.Random.Mersenne.Pure64--import Data.StateRef--import Control.Monad.State-import qualified Control.Monad.ST.Strict as S-import qualified Control.Monad.State.Strict as S---- |Given a function for applying a 'PureMT' transformation to some hidden --- state, this function derives a function able to generate all 'Prim's--- in the given monad. This is then suitable for either a 'MonadRandom' or--- 'RandomSource' instance, where the 'supportedPrims' or--- 'supportedPrimsFrom' function (respectively) is @const True@.-{-# INLINE getRandomPrimBy #-}-getRandomPrimBy :: Monad m => (forall t. (PureMT -> (t, PureMT)) -> m t) -> Prim a -> m a-getRandomPrimBy getThing = getPrimWhere supported (\prim -> getThing (genPrim prim))- where - {-# INLINE supported #-}- supported :: Prim a -> Bool- supported PrimWord64 = True- supported PrimDouble = True- supported _ = False- - {-# INLINE genPrim #-}- genPrim :: Prim a -> (PureMT -> (a, PureMT))- genPrim PrimWord64 = randomWord64- genPrim PrimDouble = randomDouble- genPrim p = error ("getRandomPrimBy: genPrim called for unsupported prim " ++ show p)---- |Given a mutable reference to a 'PureMT' generator, we can implement--- 'RandomSource' for in any monad in which the reference can be modified.--- --- Typically this would be used to define a new 'RandomSource' instance for--- some new reference type or new monad in which an existing reference type--- can be modified atomically. As an example, the following instance could--- be used to describe how 'IORef' 'PureMT' can be a 'RandomSource' in the--- 'IO' monad:--- --- > instance RandomSource IO (IORef PureMT) where--- > supportedPrimsFrom _ _ = True--- > getSupportedRandomPrimFrom = getRandomPrimFromMTRef--- --- (note that there is actually a more general instance declared already--- covering this as a a special case, so there's no need to repeat this--- declaration anywhere)--- --- Example usage:--- --- > main = do--- > src <- newIORef (pureMT 1234) -- OR: newPureMT >>= newIORef--- > x <- sampleFrom src (uniform 0 100) -- OR: runRVar (uniform 0 100) src--- > print x-getRandomPrimFromMTRef ::- forall sr m t.- (Monad m, ModifyRef sr m PureMT) => sr -> Prim t -> m t-getRandomPrimFromMTRef ref = getRandomPrimBy getThing- where- {-# INLINE getThing #-}- getThing :: forall a. (PureMT -> (a, PureMT)) -> m a- getThing thing = atomicModifyReference ref $ \(!oldMT) -> - case thing oldMT of (!w, !newMT) -> (newMT, w)- ---- |Similarly, @getRandomPrimFromMTState x@ can be used in any \"state\"--- monad in the mtl sense whose state is a 'PureMT' generator.--- Additionally, the standard mtl state monads have 'MonadRandom' instances--- which do precisely that, allowing an easy conversion of 'RVar's and--- other 'Distribution' instances to \"pure\" random variables (e.g., by--- @runState . sample :: Distribution d t => d t -> PureMT -> (t, PureMT)@.--- 'PureMT' in the type there can be replaced by 'StdGen' or anything else --- satisfying @MonadRandom (State s) => s@).--- --- For example, this module includes the following declaration:--- --- > instance MonadRandom (State PureMT) where--- > supportedPrims _ _ = True--- > getSupportedRandomPrim = getRandomPrimFromMTState--- --- This describes a \"standard\" way of getting random values in 'State'--- 'PureMT', which can then be used in various ways, for example (assuming --- some 'RVar' @foo@ and some 'Word64' @seed@):--- --- > runState (runRVar foo StdRandom) (pureMT seed)--- > runState (sampleFrom StdRandom foo) (pureMT seed)--- > runState (sample foo) (pureMT seed)--- --- Of course, the initial 'PureMT' state could also be obtained by any other--- convenient means, such as 'newPureMT' if you don't care what seed is used.-getRandomPrimFromMTState :: - forall m t.- MonadState PureMT m - => Prim t -> m t-getRandomPrimFromMTState = getRandomPrimBy getThing- where- {-# INLINE getThing #-}- getThing :: forall a. (PureMT -> (a, PureMT)) -> m a- getThing thing = do- !mt <- get- let (!ws, !newMt) = thing mt- put newMt- return ws--#ifndef MTL2-instance MonadRandom (State PureMT) where- getRandomPrim = getRandomPrimFromMTState--instance MonadRandom (S.State PureMT) where- getRandomPrim = getRandomPrimFromMTState-#endif--instance (Monad m1, ModifyRef (Ref m2 PureMT) m1 PureMT) => RandomSource m1 (Ref m2 PureMT) where- getRandomPrimFrom = getRandomPrimFromMTRef- -instance Monad m => MonadRandom (StateT PureMT m) where- getRandomPrim = getRandomPrimFromMTState--instance Monad m => MonadRandom (S.StateT PureMT m) where- getRandomPrim = getRandomPrimFromMTState--instance (Monad m, ModifyRef (IORef PureMT) m PureMT) => RandomSource m (IORef PureMT) where- {-# SPECIALIZE instance RandomSource IO (IORef PureMT) #-}- getRandomPrimFrom = getRandomPrimFromMTRef- -instance (Monad m, ModifyRef (STRef s PureMT) m PureMT) => RandomSource m (STRef s PureMT) where- {-# SPECIALIZE instance RandomSource (ST s) (STRef s PureMT) #-}- {-# SPECIALIZE instance RandomSource (S.ST s) (STRef s PureMT) #-}- getRandomPrimFrom = getRandomPrimFromMTRef---- Note that this instance is probably a Bad Idea. STM allows random variables--- to interact in spooky quantum-esque ways - One transaction can 'retry' until--- it gets a \"random\" answer it likes, which causes it to selectively consume --- entropy, biasing the supply from which other random variables will draw.--- instance (Monad m, ModifyRef (TVar PureMT) m PureMT) => RandomSource m (TVar PureMT) where--- {-# SPECIALIZE instance RandomSource IO (TVar PureMT) #-}--- {-# SPECIALIZE instance RandomSource STM (TVar PureMT) #-}--- getRandomPrimFrom = getRandomPrimFromMTRef-
− src/Data/Random/Source/Std.hs
@@ -1,20 +0,0 @@-{-- - ``Data/Random/Source/Std''- -}-{-# LANGUAGE- MultiParamTypeClasses, FlexibleInstances- #-}--module Data.Random.Source.Std where--import Data.Random.Source---- |A token representing the \"standard\" entropy source in a 'MonadRandom'--- monad. Its sole purpose is to make the following true (when the types check):------ > sampleFrom StdRandom === sample-data StdRandom = StdRandom--instance MonadRandom m => RandomSource m StdRandom where- {-SPECIALIZE instance MonadRandom m => RandomSource m StdRandom -}- getRandomPrimFrom StdRandom = getRandomPrim
− src/Data/Random/Source/StdGen.hs
@@ -1,188 +0,0 @@-{-# LANGUAGE- CPP,- MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, GADTs,- BangPatterns, RankNTypes,- ScopedTypeVariables- #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- |This module provides functions useful for implementing new 'MonadRandom'--- and 'RandomSource' instances for state-abstractions containing 'StdGen'--- values (the pure pseudorandom generator provided by the System.Random--- module in the \"random\" package), as well as instances for some common--- cases.-module Data.Random.Source.StdGen where--import Data.Random.Internal.Words-import Data.Random.Internal.Primitives-import Data.Random.Source-import System.Random-import Control.Monad.Prompt-import Control.Monad.State-import qualified Control.Monad.ST.Strict as S-import qualified Control.Monad.State.Strict as S-import Data.StateRef-import Data.Word---instance (Monad m1, ModifyRef (Ref m2 StdGen) m1 StdGen) => RandomSource m1 (Ref m2 StdGen) where- getRandomPrimFrom = getRandomPrimFromRandomGenRef--instance (Monad m, ModifyRef (IORef StdGen) m StdGen) => RandomSource m (IORef StdGen) where- {-# SPECIALIZE instance RandomSource IO (IORef StdGen) #-}- getRandomPrimFrom = getRandomPrimFromRandomGenRef---- Note that this instance is probably a Bad Idea. STM allows random variables--- to interact in spooky quantum-esque ways - One transaction can 'retry' until--- it gets a \"random\" answer it likes, which causes it to selectively consume --- entropy, biasing the supply from which other random variables will draw.--- instance (Monad m, ModifyRef (TVar StdGen) m StdGen) => RandomSource m (TVar StdGen) where--- {-# SPECIALIZE instance RandomSource IO (TVar StdGen) #-}--- {-# SPECIALIZE instance RandomSource STM (TVar StdGen) #-}--- supportedPrimsFrom _ _ = True--- getSupportedRandomPrimFrom = getRandomPrimFromRandomGenRef--instance (Monad m, ModifyRef (STRef s StdGen) m StdGen) => RandomSource m (STRef s StdGen) where- {-# SPECIALIZE instance RandomSource (ST s) (STRef s StdGen) #-}- {-# SPECIALIZE instance RandomSource (S.ST s) (STRef s StdGen) #-}- getRandomPrimFrom = getRandomPrimFromRandomGenRef--getRandomPrimFromStdGenIO :: Prim a -> IO a-getRandomPrimFromStdGenIO prim- | supported prim = genPrim prim- | otherwise = runPromptM getRandomPrimFromStdGenIO (decomposePrimWhere supported prim)- where - {-# INLINE supported #-}- supported :: Prim a -> Bool- supported PrimWord8 = True- supported PrimWord16 = True- supported PrimWord32 = True- supported PrimWord64 = True- supported PrimDouble = True- supported (PrimNByteInteger _) = True- supported _ = False- - -- based on reading the source of the "random" library's implementation, I do- -- not believe that the randomRIO (0,1) implementation for Double is capable of producing- -- the value 0. Therefore, I'm not using it. If this is an incorrect reading on- -- my part, or if this changes, then feel free to change the implementation.- -- Same goes for the other getRandomDouble... functions here.-- {-# INLINE genPrim #-}- genPrim :: Prim a -> IO a- genPrim PrimWord8 = fmap fromIntegral (randomRIO (0, 0xff) :: IO Int)- genPrim PrimWord16 = fmap fromIntegral (randomRIO (0, 0xffff) :: IO Int)- genPrim PrimWord32 = fmap fromInteger (randomRIO (0, 0xffffffff))- genPrim PrimWord64 = fmap fromInteger (randomRIO (0, 0xffffffffffffffff))- genPrim PrimDouble = fmap (wordToDouble . fromInteger) (randomRIO (0, 0xffffffffffffffff))- genPrim (PrimNByteInteger n) = randomRIO (0, iterate (*256) 1 !! n)- genPrim p = error ("getRandomPrimFromStdGenIO: genPrim called for unsupported prim " ++ show p)---- |Given a mutable reference to a 'RandomGen' generator, we can make a--- 'RandomSource' usable in any monad in which the reference can be modified.--- --- See "Data.Random.Source.PureMT".'getRandomPrimFromMTRef' for more detailed--- usage hints - this function serves exactly the same purpose except for a--- 'StdGen' generator instead of a 'PureMT' generator.-getRandomPrimFromRandomGenRef :: - forall sr m g t.- (Monad m, ModifyRef sr m g, RandomGen g) =>- sr -> Prim t -> m t-getRandomPrimFromRandomGenRef ref prim- | supported prim = genPrim prim getThing- | otherwise = runPromptM (getRandomPrimFromRandomGenRef ref) (decomposePrimWhere supported prim)- where - {-# INLINE supported #-}- supported :: forall a. Prim a -> Bool- supported PrimWord8 = True- supported PrimWord16 = True- supported PrimWord32 = True- supported PrimWord64 = True- supported PrimDouble = True- supported (PrimNByteInteger _) = True- supported _ = False- - {-# INLINE genPrim #-}- genPrim :: forall a c g. (RandomGen g) => Prim a -> (forall b. (g -> (b, g)) -> (b -> a) -> c) -> c- genPrim PrimWord8 f = f (randomR (0, 0xff)) (fromIntegral :: Int -> Word8)- genPrim PrimWord16 f = f (randomR (0, 0xffff)) (fromIntegral :: Int -> Word16)- genPrim PrimWord32 f = f (randomR (0, 0xffffffff)) (fromInteger)- genPrim PrimWord64 f = f (randomR (0, 0xffffffffffffffff)) (fromInteger)- genPrim PrimDouble f = f (randomR (0, 0x000fffffffffffff)) (flip encodeFloat (-52))- genPrim (PrimNByteInteger n) f = f (randomR (0, iterate (*256) 1 !! n)) (id :: Integer -> Integer)- genPrim p _ = error ("getRandomPrimFromRandomGenRef: genPrim called for unsupported prim " ++ show p)- - {-# INLINE getThing #-}- getThing :: forall a b. (g -> (a, g)) -> (a -> b) -> m b- getThing thing f = atomicModifyReference ref $ \(!oldMT) -> case thing oldMT of (!w, !newMT) -> (newMT, f w)----- |Similarly, @getRandomWordFromRandomGenState x@ can be used in any \"state\"--- monad in the mtl sense whose state is a 'RandomGen' generator.--- Additionally, the standard mtl state monads have 'MonadRandom' instances--- which do precisely that, allowing an easy conversion of 'RVar's and--- other 'Distribution' instances to \"pure\" random variables.--- --- Again, see "Data.Random.Source.PureMT".'getRandomPrimFromMTState' for more--- detailed usage hints - this function serves exactly the same purpose except --- for a 'StdGen' generator instead of a 'PureMT' generator.-{-# SPECIALIZE getRandomPrimFromRandomGenState :: Prim a -> State StdGen a #-}-{-# SPECIALIZE getRandomPrimFromRandomGenState :: Monad m => Prim a -> StateT StdGen m a #-}-getRandomPrimFromRandomGenState :: - forall g m t.- (RandomGen g, MonadState g m) - => Prim t -> m t-getRandomPrimFromRandomGenState prim- = runPromptM genSupported (decomposePrimWhere supported prim)- where - {-# INLINE genSupported #-}- genSupported :: forall a. Prim a -> m a- genSupported prim = genPrim prim getThing- - {-# INLINE supported #-}- supported :: Prim a -> Bool- supported PrimWord8 = True- supported PrimWord16 = True- supported PrimWord32 = True- supported PrimWord64 = True- supported PrimDouble = True- supported (PrimNByteInteger _) = True- supported _ = False- - {-# INLINE genPrim #-}- genPrim :: Prim a -> (forall b. (g -> (b, g)) -> (b -> a) -> c) -> c- genPrim PrimWord8 f = f (randomR (0, 0xff)) (fromIntegral :: Int -> Word8)- genPrim PrimWord16 f = f (randomR (0, 0xffff)) (fromIntegral :: Int -> Word16)- genPrim PrimWord32 f = f (randomR (0, 0xffffffff)) (fromInteger)- genPrim PrimWord64 f = f (randomR (0, 0xffffffffffffffff)) (fromInteger)- genPrim PrimDouble f = f (randomR (0, 0x000fffffffffffff)) (flip encodeFloat (-52))- {- not using the Random Double instance for 2 reasons. 1st, it only generates 32 bits of entropy, when - a [0,1) Double has room for 52. Second, it appears there's a bug where it can actually generate a - negative number in the case where randomIvalInteger returns minBound::Int32. -}--- genPrim PrimDouble f = f (randomR (0, 1.0)) (id)- genPrim (PrimNByteInteger n) f = f (randomR (0, iterate (*256) 1 !! n)) id- genPrim p _ = error ("getRandomPrimFromRandomGenState: genPrim called for unsupported prim " ++ show p)- - {-# INLINE getThing #-}- getThing :: forall a b. (g -> (a, g)) -> (a -> b) -> m b- getThing thing f = do- !oldGen <- get- case thing oldGen of- (!i,!newGen) -> do- put newGen- return (f $! i)--#ifndef MTL2-instance MonadRandom (State StdGen) where- getRandomPrim = getRandomPrimFromRandomGenState--instance MonadRandom (S.State StdGen) where- getRandomPrim = getRandomPrimFromRandomGenState-#endif--instance Monad m => MonadRandom (StateT StdGen m) where- getRandomPrim = getRandomPrimFromRandomGenState--instance Monad m => MonadRandom (S.StateT StdGen m) where- getRandomPrim = getRandomPrimFromRandomGenState-