mwc-random 0.15.1.0 → 0.15.2.0
raw patch · 7 files changed
+109/−59 lines, 7 filesdep ~doctestdep ~randomdep ~tasty-quickcheck
Dependency ranges changed: doctest, random, tasty-quickcheck
Files
- System/Random/MWC.hs +59/−20
- System/Random/MWC/Distributions.hs +6/−10
- System/Random/MWC/SeedSource.hs +2/−3
- bench/Benchmark.hs +12/−16
- changelog.md +5/−0
- mwc-random.cabal +9/−8
- tests/props.hs +16/−2
System/Random/MWC.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, FlexibleContexts,+{-# LANGUAGE BangPatterns, CPP, DataKinds, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, MagicHash, Rank2Types, ScopedTypeVariables, TypeFamilies, UnboxedTuples, TypeOperators #-}@@ -158,7 +158,7 @@ #include "MachDeps.h" #endif -import Control.Monad (ap, liftM, unless)+import Control.Monad (unless) import Control.Monad.Primitive (PrimMonad, PrimBase, PrimState, unsafePrimToIO, stToPrim) import Control.Monad.ST (ST,runST) import Data.Bits ((.&.), (.|.), shiftL, shiftR, xor)@@ -177,6 +177,9 @@ import qualified Control.Exception as E import System.Random.MWC.SeedSource import qualified System.Random.Stateful as Random+#if MIN_VERSION_random(1,3,0)+import Data.List.NonEmpty (NonEmpty(..), toList)+#endif -- | NOTE: Consider use of more principled type classes -- 'Random.Uniform' and 'Random.UniformRange' instead.@@ -310,24 +313,24 @@ {-# INLINE uniformR #-} instance (Variate a, Variate b) => Variate (a,b) where- uniform g = (,) `liftM` uniform g `ap` uniform g- uniformR ((x1,y1),(x2,y2)) g = (,) `liftM` uniformR (x1,x2) g `ap` uniformR (y1,y2) g+ uniform g = (,) <$> uniform g <*> uniform g+ uniformR ((x1,y1),(x2,y2)) g = (,) <$> uniformR (x1,x2) g <*> uniformR (y1,y2) g {-# INLINE uniform #-} {-# INLINE uniformR #-} instance (Variate a, Variate b, Variate c) => Variate (a,b,c) where- uniform g = (,,) `liftM` uniform g `ap` uniform g `ap` uniform g+ uniform g = (,,) <$> uniform g <*> uniform g <*> uniform g uniformR ((x1,y1,z1),(x2,y2,z2)) g =- (,,) `liftM` uniformR (x1,x2) g `ap` uniformR (y1,y2) g `ap` uniformR (z1,z2) g+ (,,) <$> uniformR (x1,x2) g <*> uniformR (y1,y2) g <*> uniformR (z1,z2) g {-# INLINE uniform #-} {-# INLINE uniformR #-} instance (Variate a, Variate b, Variate c, Variate d) => Variate (a,b,c,d) where- uniform g = (,,,) `liftM` uniform g `ap` uniform g `ap` uniform g- `ap` uniform g+ uniform g = (,,,) <$> uniform g <*> uniform g <*> uniform g+ <*> uniform g uniformR ((x1,y1,z1,t1),(x2,y2,z2,t2)) g =- (,,,) `liftM` uniformR (x1,x2) g `ap` uniformR (y1,y2) g `ap`- uniformR (z1,z2) g `ap` uniformR (t1,t2) g+ (,,,) <$> uniformR (x1,x2) g <*> uniformR (y1,y2) g <*>+ uniformR (z1,z2) g <*> uniformR (t1,t2) g {-# INLINE uniform #-} {-# INLINE uniformR #-} @@ -463,15 +466,51 @@ {-# INLINE uniformWord32 #-} uniformWord64 = uniform {-# INLINE uniformWord64 #-}+#if MIN_VERSION_random(1,3,0)+ uniformByteArrayM isPinned n g = stToPrim (Random.fillByteArrayST isPinned n (uniform g))+ {-# INLINE uniformByteArrayM #-}+#else uniformShortByteString n g = stToPrim (Random.genShortByteStringST n (uniform g)) {-# INLINE uniformShortByteString #-}+#endif -- | @since 0.15.0.0 instance PrimMonad m => Random.FrozenGen Seed m where type MutableGen Seed m = Gen (PrimState m)- thawGen = restore freezeGen = save+#if MIN_VERSION_random(1,3,0)+ modifyGen gen@(Gen mv) f = do+ seed <- save gen+ case f seed of+ (a, Seed v) -> a <$ G.copy mv v+ overwriteGen (Gen mv) (Seed v) = G.copy mv v +instance PrimMonad m => Random.ThawedGen Seed m where+#endif+ thawGen = restore++#if MIN_VERSION_random(1,3,0)+instance Random.SeedGen Seed where+ type SeedSize Seed = 1032 -- == 4 * 258+ fromSeed64 seed64 = toSeed $ I.fromListN 258+ [ w32+ | !w64 <- toList seed64+ , !w32 <- [ fromIntegral (w64 `shiftR` 32)+ , fromIntegral w64 ]+ ]+ toSeed64 vSeed =+ let w32sToW64 :: Word32 -> Word32 -> Word64+ w32sToW64 w32u w32l =+ (fromIntegral w32u `shiftL` 32) .|. fromIntegral w32l+ v = fromSeed vSeed+ evens = I.ifilter (\i _ -> even i) v+ odds = I.ifilter (\i _ -> odd i) v+ in case I.toList $ I.zipWith w32sToW64 evens odds of+ [] ->+ error $ "Impossible: Seed had an unexpected length of: " ++ show (I.length v)+ x:xs -> x :| xs+#endif+ -- | Convert vector to 'Seed'. It acts similarly to 'initialize' and -- will accept any vector. If you want to pass seed immediately to -- restore you better call initialize directly since following law holds:@@ -482,12 +521,12 @@ -- | Save the state of a 'Gen', for later use by 'restore'. save :: PrimMonad m => Gen (PrimState m) -> m Seed-save (Gen q) = Seed `liftM` G.freeze q+save (Gen q) = Seed <$> G.freeze q {-# INLINE save #-} -- | Create a new 'Gen' that mirrors the state of a saved 'Seed'. restore :: PrimMonad m => Seed -> m (Gen (PrimState m))-restore (Seed s) = Gen `liftM` G.thaw s+restore (Seed s) = Gen <$> G.thaw s {-# INLINE restore #-} @@ -577,9 +616,9 @@ uniformWord32 :: PrimMonad m => Gen (PrimState m) -> m Word32 -- NOTE [Carry value] uniformWord32 (Gen q) = do- i <- nextIndex `liftM` M.unsafeRead q ioff- c <- fromIntegral `liftM` M.unsafeRead q coff- qi <- fromIntegral `liftM` M.unsafeRead q i+ i <- nextIndex <$> M.unsafeRead q ioff+ c <- fromIntegral <$> M.unsafeRead q coff+ qi <- fromIntegral <$> M.unsafeRead q i let t = aa * qi + c c' = fromIntegral (t `shiftR` 32) x = fromIntegral t + c'@@ -599,11 +638,11 @@ uniform2 :: PrimMonad m => (Word32 -> Word32 -> a) -> Gen (PrimState m) -> m a uniform2 f (Gen q) = do- i <- nextIndex `liftM` M.unsafeRead q ioff+ i <- nextIndex <$> M.unsafeRead q ioff let j = nextIndex i- c <- fromIntegral `liftM` M.unsafeRead q coff- qi <- fromIntegral `liftM` M.unsafeRead q i- qj <- fromIntegral `liftM` M.unsafeRead q j+ c <- fromIntegral <$> M.unsafeRead q coff+ qi <- fromIntegral <$> M.unsafeRead q i+ qj <- fromIntegral <$> M.unsafeRead q j let t = aa * qi + c c' = fromIntegral (t `shiftR` 32) x = fromIntegral t + c'
System/Random/MWC/Distributions.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE BangPatterns, CPP, GADTs, FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns, GADTs, FlexibleContexts, ScopedTypeVariables #-} -- | -- Module : System.Random.MWC.Distributions -- Copyright : (c) 2012 Bryan O'Sullivan@@ -40,13 +40,9 @@ ) where import Prelude hiding (mapM)-import Control.Monad (liftM) import Control.Monad.Primitive (PrimMonad, PrimState) import Data.Bits ((.&.)) import Data.Foldable (foldl')-#if !MIN_VERSION_base(4,8,0)-import Data.Traversable (Traversable)-#endif import Data.Traversable (mapM) import Data.Word (Word32) import System.Random.Stateful (StatefulGen(..),Uniform(..),UniformRange(..),uniformDoublePositive01M)@@ -83,7 +79,7 @@ standard gen = loop where loop = do- u <- (subtract 1 . (*2)) `liftM` uniformDoublePositive01M gen+ u <- subtract 1 . (*2) <$> uniformDoublePositive01M gen ri <- uniformM gen let i = fromIntegral ((ri :: Word32) .&. 127) bi = I.unsafeIndex blocks i@@ -102,8 +98,8 @@ else loop normalTail neg = tailing where tailing = do- x <- ((/rNorm) . log) `liftM` uniformDoublePositive01M gen- y <- log `liftM` uniformDoublePositive01M gen+ x <- (/ rNorm) . log <$> uniformDoublePositive01M gen+ y <- log <$> uniformDoublePositive01M gen if y * (-2) < x * x then tailing else return $! if neg then x - rNorm else rNorm - x@@ -257,7 +253,7 @@ -> g -- ^ Generator -> m Bool {-# INLINE bernoulli #-}-bernoulli p gen = (<p) `liftM` uniformDoublePositive01M gen+bernoulli p gen = (< p) <$> uniformDoublePositive01M gen -- | Random variate generator for categorical distribution. --@@ -274,7 +270,7 @@ | G.null v = pkgError "categorical" "empty weights!" | otherwise = do let cv = G.scanl1' (+) v- p <- (G.last cv *) `liftM` uniformDoublePositive01M gen+ p <- (G.last cv *) <$> uniformDoublePositive01M gen return $! case G.findIndex (>=p) cv of Just i -> i Nothing -> pkgError "categorical" "bad weights!"
System/Random/MWC/SeedSource.hs view
@@ -10,7 +10,6 @@ , randomSourceName ) where -import Control.Monad (liftM) import Data.Word (Word32,Word64) import Data.Bits (shiftR) import Data.Ratio ((%), numerator)@@ -31,8 +30,8 @@ -- Windows system. acquireSeedTime :: IO [Word32] acquireSeedTime = do- c <- (numerator . (% cpuTimePrecision)) `liftM` getCPUTime- t <- toRational `liftM` getPOSIXTime+ c <- numerator . (% cpuTimePrecision) <$> getCPUTime+ t <- toRational <$> getPOSIXTime let n = fromIntegral (numerator t) :: Word64 return [fromIntegral c, fromIntegral n, fromIntegral (n `shiftR` 32)]
bench/Benchmark.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} module Main(main) where import Control.Exception@@ -48,8 +49,9 @@ opts <- parseOptions ingredients (bench "Fake" (nf id ())) let iter = lookupOption opts -- Set up RNG- mwc <- create- mtg <- M.newMTGen . Just =<< uniform mwc+ mwc <- create+ seed <- save mwc+ mtg <- M.newMTGen . Just =<< uniform mwc defaultMainWithIngredients ingredients $ bgroup "All" [ bgroup "mwc" -- One letter group names are used so they will fit on the plot.@@ -91,6 +93,7 @@ , bench "exponential" $ whnfIO $ loop iter (exponential 3 mwc :: IO Double) , bench "gamma,a<1" $ whnfIO $ loop iter (gamma 0.5 1 mwc :: IO Double) , bench "gamma,a>1" $ whnfIO $ loop iter (gamma 2 1 mwc :: IO Double)+ , bench "beta" $ whnfIO $ loop iter (beta 2 3 mwc :: IO Double) , bench "chiSquare" $ whnfIO $ loop iter (chiSquare 4 mwc :: IO Double) -- NOTE: We switch between algorithms when Np=10 , bgroup "binomial"@@ -104,10 +107,6 @@ , (6000, 0.2), (6000, 0.8) ] ]- , bench "beta binomial 10" $ whnfIO $ loop iter (betaBinomial 600 400 10 mwc :: IO Int)- , bench "beta binomial 100" $ whnfIO $ loop iter (betaBinomial 600 400 100 mwc :: IO Int)- , bench "beta binomial table 10" $ whnfIO $ loop iter (betaBinomialTable 600 400 10 mwc :: IO Int)- , bench "beta binomial table 100" $ whnfIO $ loop iter (betaBinomialTable 600 400 100 mwc :: IO Int) ] -- Test sampling performance. Table creation must be floated out! , bgroup "CT/gen" $ concat@@ -148,14 +147,11 @@ bench "Double" $ whnfIO $ loop iter (M.random mtg :: IO Double) , bench "Int" $ whnfIO $ loop iter (M.random mtg :: IO Int) ]+#if MIN_VERSION_random(1,3,0)+ , bgroup "seed"+ [ bench "SeedGen.fromSeed" $ let rseed = R.toSeed seed :: R.Seed Seed+ in whnf R.fromSeed rseed+ , bench "SeedGen.toSeed" $ whnf R.toSeed seed+ ]+#endif ]--betaBinomial :: StatefulGen g m => Double -> Double -> Int -> g -> m Int-betaBinomial a b n g = do- p <- beta a b g- binomial n p g--betaBinomialTable :: StatefulGen g m => Double -> Double -> Int -> g -> m Int-betaBinomialTable a b n g = do- p <- beta a b g- genFromTable (tableBinomial n p) g
changelog.md view
@@ -1,3 +1,8 @@+## Changes in 0.15.2.0++ * Support for `random-1.3`.++ ## Changes in 0.15.1.0 * Additon of binomial sampler using the rejection sampling method in
mwc-random.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: mwc-random-version: 0.15.1.0+version: 0.15.2.0 license: BSD-2-Clause license-file: LICENSE copyright: 2009, 2010, 2011 Bryan O'Sullivan@@ -45,9 +45,10 @@ || ==9.0.2 || ==9.2.8 || ==9.4.8- || ==9.6.5- || ==9.6.5- || ==9.8.2+ || ==9.6.6+ || ==9.8.4+ || ==9.10.1+ || ==9.12.1 source-repository head@@ -73,7 +74,7 @@ , vector >= 0.7 , math-functions >= 0.2.1.0 - ghc-options: -Wall -funbox-strict-fields -fwarn-tabs+ ghc-options: -O2 -Wall -funbox-strict-fields -fwarn-tabs -- We want to be able to build benchmarks using both tasty-bench and tasty-papi.@@ -120,9 +121,9 @@ , QuickCheck >=2.2 , vector >=0.12.1 , tasty >=1.3.1- , tasty-quickcheck+ , tasty-quickcheck >=0.10.2 , tasty-hunit- , random >=1.2+ , random >=1.2 , mtl , math-functions >=0.3.4 @@ -141,7 +142,7 @@ build-depends: base -any , mwc-random -any- , doctest >=0.15 && <0.23+ , doctest >=0.15 && <0.24 -- , bytestring , primitive
tests/props.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} import Control.Monad import Data.Word@@ -16,6 +17,9 @@ import System.Random.MWC import System.Random.MWC.Distributions import System.Random.Stateful (StatefulGen)+#if MIN_VERSION_random(1,3,0)+import qualified System.Random.Stateful as Random (SeedGen(..))+#endif ---------------------------------------------------------------- --@@ -65,6 +69,9 @@ g0 <- createSystemRandom defaultMainWithIngredients ingredients $ testGroup "mwc" [ testProperty "save/restore" $ prop_SeedSaveRestore g0+#if MIN_VERSION_random(1,3,0)+ , testProperty "SeedGen" $ prop_SeedGen g0+#endif , testCase "user save/restore" $ saveRestoreUserSeed , testCase "empty seed data" $ emptySeed , testCase "output correct" $ do@@ -76,8 +83,7 @@ ] updateGenState :: GenIO -> IO ()-updateGenState g = replicateM_ 256 (uniform g :: IO Word32)-+updateGenState g = replicateM_ 250 (uniform g :: IO Word32) prop_SeedSaveRestore :: GenIO -> Property prop_SeedSaveRestore g = monadicIO $ do@@ -85,6 +91,14 @@ seed <- run $ save g seed' <- run $ save =<< restore seed return $ seed == seed'++#if MIN_VERSION_random(1,3,0)+prop_SeedGen :: GenIO -> Property+prop_SeedGen g = monadicIO $ do+ run $ updateGenState g+ seed <- run $ save g+ return $ seed == (Random.fromSeed . Random.toSeed) seed+#endif saveRestoreUserSeed :: IO () saveRestoreUserSeed = do