diff --git a/System/Random/MWC.hs b/System/Random/MWC.hs index 134bd02..08201f5 100644 --- 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 #-} @@ -177,6 +177,9 @@ import System.IO.Unsafe (unsafePerformIO) 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. @@ -486,6 +489,28 @@ 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: diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs index dd93ad8..c759ba9 100644 --- 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 @@ main = do 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. @@ -148,6 +150,13 @@ main = do 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 diff --git a/tests/props.hs b/tests/props.hs index 00ed03d..b6ad685 100644 --- 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 Test.QuickCheck.Monadic 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 @@ main = do 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 @@ main = do ] 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 @@ -86,6 +92,14 @@ prop_SeedSaveRestore g = monadicIO $ do 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 let seed = toSeed $ U.replicate 258 0