diff --git a/System/Random/MWC.hs b/System/Random/MWC.hs --- a/System/Random/MWC.hs +++ b/System/Random/MWC.hs @@ -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' diff --git a/System/Random/MWC/Distributions.hs b/System/Random/MWC/Distributions.hs --- a/System/Random/MWC/Distributions.hs +++ b/System/Random/MWC/Distributions.hs @@ -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 = ( 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!" diff --git a/System/Random/MWC/SeedSource.hs b/System/Random/MWC/SeedSource.hs --- a/System/Random/MWC/SeedSource.hs +++ b/System/Random/MWC/SeedSource.hs @@ -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)] diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs --- a/bench/Benchmark.hs +++ b/bench/Benchmark.hs @@ -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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 diff --git a/mwc-random.cabal b/mwc-random.cabal --- a/mwc-random.cabal +++ b/mwc-random.cabal @@ -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 diff --git a/tests/props.hs b/tests/props.hs --- a/tests/props.hs +++ b/tests/props.hs @@ -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