splitmix 0.0.5 → 0.1.3.2
raw patch · 21 files changed
Files
- Changelog.md +55/−0
- bench/Bench.hs +0/−151
- bench/Range.hs +0/−109
- bench/SimpleSum.hs +0/−57
- cbits-apple/init.c +8/−0
- cbits-unix/init.c +8/−0
- cbits-win/init.c +9/−0
- splitmix.cabal +53/−120
- src-compat/Data/Bits/Compat.hs +0/−44
- src/System/Random/SplitMix.hs +16/−41
- src/System/Random/SplitMix/Init.hs +58/−0
- src/System/Random/SplitMix32.hs +21/−40
- tests/Dieharder.hs +0/−275
- tests/Examples.hs +0/−15
- tests/MiniQC.hs +0/−83
- tests/SplitMixPi.hs +0/−27
- tests/SplitMixPi32.hs +0/−27
- tests/Tests.hs +0/−136
- tests/Uniformity.hs +0/−134
- tests/splitmix-examples.hs +15/−0
- tests/splitmix-th-test.hs +11/−0
Changelog.md view
@@ -1,3 +1,58 @@+# 0.1.3.1++- Fix linking issue `symbol not found in flat namespace '_kSecRandomDefault'`+ when using splitmix in TH on macOS.++# 0.1.3++- Use system specific entropy/randomess sources to initialise the default generator.+ Specifically `SecRandomCopyBytes` on Apple platforms and+ `RtlGenRandom` on Windows.++# 0.1.2++- Use `getentropy` for initialisation on unix-like systems (i.e. not Windows).++# 0.1.1++- Drop support for GHCs prior 8.6.5+- Support GHC-9.12++# 0.1.0.4++- Add TestU01 test-suite++# 0.1.0.3++- Fix oops bugs in 0.1.0.2++ - It's lowercase `windows.h`.+ I blame Microsoft docs for using capital case `Windows.h` in the docs.+ https://docs.microsoft.com/en-us/windows/win32/api/processthreadsapi/nf-processthreadsapi-getprocessid++ - accidental `shiftL` vs `shiftR` mixup for 32-bit generator initialization.+ Doesn't affect Linux.++# 0.1.0.2++- Drop `time` dependency in favour of handcoded initialization+ - On Unix platforms we use `/dev/urandom` if it exists,+ otherwise use `gettimeofday`, `clock` and `getpid`.+ - On Windows we use `GetCurrentProcessID`, `GetCurrentThreadId()`,+ `GetTickCount`, `GetSystemTime` and `QueryPerformanceCounter`.+ - On GHCJS use `Math.random()`+ - Using `time` is a fallback option (e.g. for Hugs).++# 0.1.0.1++- Add `INLINEABLE` pragmas to `bitmaskWithRejection*` functions+- Support GHC-9.0++# 0.1++- Drop `random` dependency unconditionally.+ https://github.com/phadej/splitmix/issues/34+ # 0.0.5 - Add `nextInteger`
− bench/Bench.hs
@@ -1,151 +0,0 @@-module Main (main) where--import Criterion.Main-import Data.List (unfoldr)-import Data.Word (Word64)--import qualified Data.Tree as T-import qualified System.Random as R-import qualified System.Random.TF as TF-import qualified System.Random.TF.Instances as TF-import qualified System.Random.SplitMix as SM-import qualified System.Random.SplitMix32 as SM32------------------------------------------------------------------------------------ List------------------------------------------------------------------------------------ infinite list-genList :: R.RandomGen g => g -> [Int]-genList = unfoldr (Just . R.next)---- truncated-genListN :: R.RandomGen g => g -> [Int]-genListN = take 2048 . genList--randomList :: Int -> [Int]-randomList = genListN . R.mkStdGen--tfRandomList :: Word64 -> [Int]-tfRandomList w64 = genListN $ TF.seedTFGen (w64, w64, w64, w64)--splitMixList :: Word64 -> [Int]-splitMixList w64 = genListN $ SM.mkSMGen w64--splitMix32List :: Word64 -> [Int]-splitMix32List w64 = genListN $ SM32.mkSMGen $ fromIntegral w64------------------------------------------------------------------------------------ Tree----------------------------------------------------------------------------------genTree :: R.RandomGen g => g -> T.Tree Int-genTree g = case R.next g of- ~(i, g') -> T.Node i $ case R.split g' of- (ga, gb) -> [genTree ga, genTree gb]--genTreeN :: R.RandomGen g => g -> T.Tree Int-genTreeN = cutTree 9 . genTree- where- cutTree :: Int -> T.Tree a -> T.Tree a- cutTree n (T.Node x forest)- | n <= 0 = T.Node x []- | otherwise = T.Node x (map (cutTree (n - 1)) forest)--randomTree :: Int -> T.Tree Int-randomTree = genTreeN . R.mkStdGen--tfRandomTree :: Word64 -> T.Tree Int-tfRandomTree w64 = genTreeN $ TF.seedTFGen (w64, w64, w64, w64)--splitMixTree :: Word64 -> T.Tree Int-splitMixTree w64 = genTreeN $ SM.mkSMGen w64--splitMix32Tree :: Word64 -> T.Tree Int-splitMix32Tree w64 = genTreeN $ SM32.mkSMGen $ fromIntegral w64------------------------------------------------------------------------------------ List Word64------------------------------------------------------------------------------------ infinite list-genList64 :: (g -> (Word64, g)) -> g -> [Word64]-genList64 r = unfoldr (Just . r)---- truncated-genListN64 :: (g -> (Word64, g)) -> g -> [Word64]-genListN64 r = take 2048 . genList64 r--randomList64 :: Int -> [Word64]-randomList64 = genListN64 R.random . R.mkStdGen--tfRandomList64 :: Word64 -> [Word64]-tfRandomList64 w64 = genListN64 TF.random $ TF.seedTFGen (w64, w64, w64, w64)--splitMixList64 :: Word64 -> [Word64]-splitMixList64 w64 = genListN64 SM.nextWord64 $ SM.mkSMGen w64--splitMix32List64 :: Word64 -> [Word64]-splitMix32List64 w64 = genListN64 SM32.nextWord64 $ SM32.mkSMGen $ fromIntegral w64------------------------------------------------------------------------------------ Tree Word64----------------------------------------------------------------------------------genTree64 :: R.RandomGen g => (g -> (Word64, g)) -> g -> T.Tree Word64-genTree64 r = go where- go g = case r g of- ~(i, g') -> T.Node i $ case R.split g' of- (ga, gb) -> [go ga, go gb]--genTreeN64 :: R.RandomGen g => (g -> (Word64, g)) -> g -> T.Tree Word64-genTreeN64 r = cutTree 9 . genTree64 r- where- cutTree :: Word64 -> T.Tree a -> T.Tree a- cutTree n (T.Node x forest)- | n <= 0 = T.Node x []- | otherwise = T.Node x (map (cutTree (n - 1)) forest)--randomTree64 :: Int -> T.Tree Word64-randomTree64 = genTreeN64 R.random . R.mkStdGen--tfRandomTree64 :: Word64 -> T.Tree Word64-tfRandomTree64 w64 = genTreeN64 TF.random $ TF.seedTFGen (w64, w64, w64, w64)--splitMixTree64 :: Word64 -> T.Tree Word64-splitMixTree64 w64 = genTreeN64 SM.nextWord64 $ SM.mkSMGen w64--splitMix32Tree64 :: Word64 -> T.Tree Word64-splitMix32Tree64 w64 = genTreeN64 SM32.nextWord64 $ SM32.mkSMGen $ fromIntegral w64------------------------------------------------------------------------------------ Main----------------------------------------------------------------------------------main :: IO ()-main = defaultMain- [ bgroup "list"- [ bench "random" $ nf randomList 42- , bench "tf-random" $ nf tfRandomList 42- , bench "splitmix" $ nf splitMixList 42- , bench "splitmix32" $ nf splitMix32List 42- ]- , bgroup "tree"- [ bench "random" $ nf randomTree 42- , bench "tf-random" $ nf tfRandomTree 42- , bench "splitmix" $ nf splitMixTree 42- , bench "splitmix32" $ nf splitMix32Tree 42- ]- , bgroup "list 64"- [ bench "random" $ nf randomList64 42- , bench "tf-random" $ nf tfRandomList64 42- , bench "splitmix" $ nf splitMixList64 42- , bench "splitmix32" $ nf splitMix32List64 42- ]- , bgroup "tree 64"- [ bench "random" $ nf randomTree64 42- , bench "tf-random" $ nf tfRandomTree64 42- , bench "splitmix" $ nf splitMixTree64 42- , bench "splitmix32" $ nf splitMix32Tree64 42- ]- ]
− bench/Range.hs
@@ -1,109 +0,0 @@--- http://www.pcg-random.org/posts/bounded-rands.html-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-module Main where--import Data.Bits-import Data.Bits.Compat-import Data.List (unfoldr)-import Data.Word (Word32, Word64)--import qualified System.Random as R-import qualified System.Random.SplitMix32 as SM--#if defined(__GHCJS__)-#else-import System.Clock (Clock (Monotonic), getTime, toNanoSecs)-import Text.Printf (printf)-#endif--main :: IO ()-main = do- gen <- SM.newSMGen-- bench gen (\g h -> R.randomR (0, pred h) g)- bench gen classicMod- bench gen intMult- bench gen bitmaskWithRejection--bench :: g -> (g -> Word32 -> (Word32, g)) -> IO ()-bench gen next = do- print $ take 70 $ unfoldr (\g -> Just (next g 10)) gen- clocked $ do- let x = sumOf next gen- print x--sumOf :: (g -> Word32 -> (Word32, g)) -> g -> Word32-sumOf next = go 0 2- where- go !acc !n g | n > 0xfffff = acc- | otherwise = let (w, g') = next g n in go (acc + w) (succ n) g'--classicMod :: SM.SMGen -> Word32 -> (Word32, SM.SMGen)-classicMod g h =- let (w32, g') = SM.nextWord32 g in (w32 `mod` h, g')----- @--- uint32_t bounded_rand(rng_t& rng, uint32_t range) {--- uint32_t x = rng();--- uint64_t m = uint64_t(x) * uint64_t(range);--- return m >> 32;--- }--- @----intMult :: SM.SMGen -> Word32 -> (Word32, SM.SMGen)-intMult g h =- (fromIntegral $ (fromIntegral w32 * fromIntegral h :: Word64) `shiftR` 32, g')- where- (w32, g') = SM.nextWord32 g---- @--- uint32_t bounded_rand(rng_t& rng, uint32_t range) {--- uint32_t mask = ~uint32_t(0);--- --range;--- mask >>= __builtin_clz(range|1);--- uint32_t x;--- do {--- x = rng() & mask;--- } while (x > range);--- return x;--- }--- @@-bitmaskWithRejection :: SM.SMGen -> Word32 -> (Word32, SM.SMGen)-bitmaskWithRejection g0 range = go g0- where- mask = complement zeroBits `shiftR` countLeadingZeros (range .|. 1)- go g = let (x, g') = SM.nextWord32 g- x' = x .&. mask- in if x' >= range- then go g'- else (x', g')------------------------------------------------------------------------------------ Poor man benchmarking with GHC and GHCJS----------------------------------------------------------------------------------clocked :: IO () -> IO ()-#if defined(__GHCJS__)-clocked action = do- start- action- stop--foreign import javascript unsafe- "console.time('loop');"- start :: IO ()--foreign import javascript unsafe- "console.timeEnd('loop');"- stop :: IO ()-#else-clocked action = do- start <- getTime Monotonic- action- end <- getTime Monotonic- printf "loop: %.03fms\n"- $ fromIntegral (toNanoSecs (end - start))- / (1e6 :: Double)-#endif
− bench/SimpleSum.hs
@@ -1,57 +0,0 @@-{-# LANGUAGE CPP #-}-module Main (main) where--import System.Environment (getArgs)-import Data.List (foldl')-import Data.Word (Word32)--import qualified System.Random as R-import qualified System.Random.SplitMix as SM-import qualified System.Random.SplitMix32 as SM32--newGen :: a -> (a -> g) -> IO g -> IO g-#if 0-newGen _ _ new = new-#else-newGen seed mk _ = return (mk seed)-#endif--main :: IO ()-main = do- putStrLn "Summing randoms..."- getArgs >>= \args -> case args of- "splitmix" : _ -> newGen 33 SM.mkSMGen SM.newSMGen >>= \g -> print $ benchSum g SM.nextTwoWord32- "splitmix32" : _ -> newGen 33 SM32.mkSMGen SM32.newSMGen >>= \g -> print $ benchSum g SM32.nextTwoWord32- "random" : _ -> R.newStdGen >>= \g -> print $ benchSum g randomNextTwoWord32-- "sm-integer" : _ -> SM.newSMGen >>= \g -> print $ benchSumInteger g (SM.nextInteger two64 (two64 * 5))- "r-integer" : _ -> R.newStdGen >>= \g -> print $ benchSumInteger g (R.randomR (two64, two64 * 5))-- -- after Closure Compiler getArgs return [] always?- -- _ -> newGen 33 SM.mkSMGen SM.newSMGen >>= \g -> print $ benchSum g SM.nextTwoWord32- _ -> newGen 33 SM32.mkSMGen SM32.newSMGen >>= \g -> print $ benchSum g SM32.nextTwoWord32---benchSum :: g -> (g -> (Word32, Word32, g)) -> Word32-benchSum g next = foldl' (+) 0 $ take 10000000 $ unfoldr2 next g--benchSumInteger :: g -> (g -> (Integer, g)) -> Integer-benchSumInteger g next = foldl' (+) 0 $ take 10000000 $ unfoldr next g---- | Infinite unfoldr with two element generator-unfoldr2 :: (s -> (a, a, s)) -> s -> [a]-unfoldr2 f = go where- go s = let (x, y, s') = f s in x : y : go s'---- | Infinite unfoldr with one element generator-unfoldr :: (s -> (a, s)) -> s -> [a]-unfoldr f = go where- go s = let (x, s') = f s in x : go s'--randomNextTwoWord32 :: R.StdGen -> (Word32, Word32, R.StdGen)-randomNextTwoWord32 s0 = (x, y, s2) where- (x, s1) = R.random s0- (y, s2) = R.random s1--two64 :: Integer-two64 = 2 ^ (64 :: Int)
+ cbits-apple/init.c view
@@ -0,0 +1,8 @@+#include <stdint.h>+#include <Security/SecRandom.h>++uint64_t splitmix_init() {+ uint64_t result;+ int r = SecRandomCopyBytes(kSecRandomDefault, sizeof(uint64_t), &result);+ return r == errSecSuccess ? result : 0xfeed1000;+}
+ cbits-unix/init.c view
@@ -0,0 +1,8 @@+#include <stdint.h>+#include <unistd.h>++uint64_t splitmix_init() {+ uint64_t result;+ int r = getentropy(&result, sizeof(uint64_t));+ return r == 0 ? result : 0xfeed1000;+}
+ cbits-win/init.c view
@@ -0,0 +1,9 @@+#include <stdint.h>+#include <windows.h>+#include <ntsecapi.h>++uint64_t splitmix_init() {+ uint64_t result;+ int r = RtlGenRandom(&result, sizeof(uint64_t));+ return r ? result : 0xfeed1000;+}
splitmix.cabal view
@@ -1,6 +1,6 @@-cabal-version: >=1.10+cabal-version: 2.4 name: splitmix-version: 0.0.5+version: 0.1.3.2 synopsis: Fast Splittable PRNG description: Pure Haskell implementation of SplitMix described in@@ -26,30 +26,30 @@ (the mixing functions are easily inverted, and two successive outputs suffice to reconstruct the internal state). -license: BSD3+license: BSD-3-Clause license-file: LICENSE maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>-bug-reports: https://github.com/phadej/splitmix/issues+bug-reports: https://github.com/haskellari/splitmix/issues category: System, Random build-type: Simple tested-with:- GHC ==7.0.4- || ==7.2.2- || ==7.4.2- || ==7.6.3- || ==7.8.4- || ==7.10.3- || ==8.0.2- || ==8.2.2- || ==8.4.4- || ==8.6.5- || ==8.8.3- || ==8.10.1- , GHCJS ==8.4+ GHC ==8.6.5+ || ==8.8.4+ || ==8.10.4+ || ==9.0.2+ || ==9.2.8+ || ==9.4.8+ || ==9.6.7+ || ==9.8.4+ || ==9.10.2+ || ==9.12.2+ || ==9.14.1 -extra-source-files:- README.md+extra-doc-files: Changelog.md+ README.md++extra-source-files: make-hugs.sh test-hugs.sh @@ -58,142 +58,75 @@ manual: True default: False -flag random- description: Providen RandomGen SMGen instance- manual: True- default: True- library default-language: Haskell2010 ghc-options: -Wall- hs-source-dirs: src src-compat- other-modules: Data.Bits.Compat+ hs-source-dirs: src exposed-modules: System.Random.SplitMix System.Random.SplitMix32 + other-modules:+ System.Random.SplitMix.Init+ -- dump-core -- build-depends: dump-core -- ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html build-depends:- base >=4.3 && <4.15- , deepseq >=1.3.0.0 && <1.5- , time >=1.2.0.3 && <1.10-- if flag(random)- build-depends: random >=1.0 && <1.2+ , base >=4.12.0.0 && <4.23+ , deepseq >=1.4.4.0 && <1.6 if flag(optimised-mixer) cpp-options: -DOPTIMISED_MIX32=1 -source-repository head- type: git- location: https://github.com/phadej/splitmix.git+ -- We don't want to depend on time, nor unix or Win32 packages+ -- because it's valuable that splitmix and QuickCheck doesn't+ -- depend on about anything -benchmark comparison- type: exitcode-stdio-1.0- default-language: Haskell2010- ghc-options: -Wall- hs-source-dirs: bench- main-is: Bench.hs- build-depends:- base- , containers >=0.4.2.1 && <0.7- , criterion >=1.1.0.0 && <1.6- , random- , splitmix- , tf-random >=0.5 && <0.6+ if impl(ghcjs)+ cpp-options: -DSPLITMIX_INIT_GHCJS=1 -benchmark simple-sum- type: exitcode-stdio-1.0- default-language: Haskell2010- ghc-options: -Wall- hs-source-dirs: bench- main-is: SimpleSum.hs- build-depends:- base- , random- , splitmix+ else+ if impl(ghc)+ cpp-options: -DSPLITMIX_INIT_C=1 -benchmark range- type: exitcode-stdio-1.0- default-language: Haskell2010- ghc-options: -Wall- hs-source-dirs: bench src-compat- main-is: Range.hs- other-modules: Data.Bits.Compat- build-depends:- base- , clock >=0.8 && <0.9- , random- , splitmix+ if os(windows)+ c-sources: cbits-win/init.c -test-suite examples- type: exitcode-stdio-1.0- default-language: Haskell2010- ghc-options: -Wall- hs-source-dirs: tests- main-is: Examples.hs- build-depends:- base- , HUnit ==1.3.1.2 || >=1.6.0.0 && <1.7- , splitmix+ elif (os(osx) || os(ios))+ c-sources: cbits-apple/init.c+ frameworks: Security -test-suite splitmix-tests- type: exitcode-stdio-1.0- default-language: Haskell2010- ghc-options: -Wall- hs-source-dirs: tests- main-is: Tests.hs- other-modules:- MiniQC- Uniformity+ else+ c-sources: cbits-unix/init.c - build-depends:- base- , base-compat >=0.11.1 && <0.12- , containers >=0.4.0.0 && <0.7- , HUnit ==1.3.1.2 || >=1.6.0.0 && <1.7- , math-functions ==0.1.7.0 || >=0.3.3.0 && <0.4- , splitmix- , test-framework >=0.8.2.0 && <0.9- , test-framework-hunit >=0.3.0.2 && <0.4+ else+ cpp-options: -DSPLITMIX_INIT_COMPAT=1+ build-depends: time >=1.2.0.3 && <1.16 -test-suite montecarlo-pi- type: exitcode-stdio-1.0- default-language: Haskell2010- ghc-options: -Wall- hs-source-dirs: tests- main-is: SplitMixPi.hs- build-depends:- base- , splitmix+source-repository head+ type: git+ location: https://github.com/haskellari/splitmix.git -test-suite montecarlo-pi-32+test-suite splitmix-examples type: exitcode-stdio-1.0 default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: tests- main-is: SplitMixPi32.hs+ main-is: splitmix-examples.hs build-depends:- base+ , base+ , HUnit >=1.6.0.0 && <1.7 , splitmix -test-suite splitmix-dieharder+test-suite splitmix-th-test default-language: Haskell2010 type: exitcode-stdio-1.0 ghc-options: -Wall -threaded -rtsopts hs-source-dirs: tests- main-is: Dieharder.hs+ main-is: splitmix-th-test.hs build-depends:- async >=2.2.1 && <2.3 , base- , base-compat-batteries >=0.10.5 && <0.12- , bytestring >=0.9.1.8 && <0.11- , deepseq- , process >=1.0.1.5 && <1.7- , random+ , template-haskell , splitmix- , tf-random >=0.5 && <0.6- , vector >=0.11.0.0 && <0.13
− src-compat/Data/Bits/Compat.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE CPP #-}-module Data.Bits.Compat (- popCount,- zeroBits,- finiteBitSize,- countLeadingZeros,- ) where--import Data.Bits--#if !MIN_VERSION_base(4,7,0)-#define FiniteBits Bits-#endif--#if !MIN_VERSION_base(4,5,0)-popCount :: Bits a => a -> Int-popCount = go 0- where- go c 0 = c `seq` c- go c w = go (c+1) (w .&. (w - 1)) -- clear the least significant-{-# INLINE popCount #-}-#endif--#if !MIN_VERSION_base(4,7,0)-zeroBits :: Bits a => a-zeroBits = clearBit (bit 0) 0-{-# INLINE zeroBits #-}--finiteBitSize :: Bits a => a -> Int-finiteBitSize = bitSize-{-# INLINE finiteBitSize #-}-#endif--#if !MIN_VERSION_base(4,8,0)-countLeadingZeros :: FiniteBits b => b -> Int-countLeadingZeros x = (w-1) - go (w-1)- where- go i | i < 0 = i -- no bit set- | testBit x i = i- | otherwise = go (i-1)-- w = finiteBitSize x-{-# INLINE countLeadingZeros #-}-#endif
src/System/Random/SplitMix.hs view
@@ -22,14 +22,8 @@ -- (the mixing functions are easily inverted, and two successive outputs -- suffice to reconstruct the internal state). ----- Note: This module supports all GHCs since GHC-7.0.4,--- but GHC-7.0 and GHC-7.2 have slow implementation, as there--- are no native 'popCount'.--- {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif module System.Random.SplitMix ( SMGen, nextWord64,@@ -55,13 +49,14 @@ ) where import Data.Bits (complement, shiftL, shiftR, xor, (.&.), (.|.))-import Data.Bits.Compat (countLeadingZeros, popCount, zeroBits)+import Data.Bits (countLeadingZeros, popCount, zeroBits) import Data.IORef (IORef, atomicModifyIORef, newIORef)-import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Word (Word32, Word64) import System.IO.Unsafe (unsafePerformIO) -#if defined(__HUGS__) || !MIN_VERSION_base(4,8,0)+import System.Random.SplitMix.Init++#if defined(__HUGS__) import Data.Word (Word) #endif @@ -69,14 +64,6 @@ import Control.DeepSeq (NFData (..)) #endif -#ifdef MIN_VERSION_random-import qualified System.Random as R-#endif--#if !__GHCJS__-import System.CPUTime (cpuTimePrecision, getCPUTime)-#endif- -- $setup -- >>> import Text.Read (readMaybe) -- >>> import Data.List (unfoldr)@@ -293,10 +280,14 @@ -- | /Bitmask with rejection/ method of generating subrange of 'Word32'. --+-- @bitmaskWithRejection32 w32@ generates random numbers in closed-open+-- range of @[0, w32)@.+-- -- @since 0.0.3 bitmaskWithRejection32 :: Word32 -> SMGen -> (Word32, SMGen) bitmaskWithRejection32 0 = error "bitmaskWithRejection32 0" bitmaskWithRejection32 n = bitmaskWithRejection32' (n - 1)+{-# INLINEABLE bitmaskWithRejection32 #-} -- | /Bitmask with rejection/ method of generating subrange of 'Word64'. --@@ -310,9 +301,13 @@ bitmaskWithRejection64 :: Word64 -> SMGen -> (Word64, SMGen) bitmaskWithRejection64 0 = error "bitmaskWithRejection64 0" bitmaskWithRejection64 n = bitmaskWithRejection64' (n - 1)+{-# INLINEABLE bitmaskWithRejection64 #-} -- | /Bitmask with rejection/ method of generating subrange of 'Word32'. --+-- @bitmaskWithRejection32' w32@ generates random numbers in closed-closed+-- range of @[0, w32]@.+-- -- @since 0.0.4 bitmaskWithRejection32' :: Word32 -> SMGen -> (Word32, SMGen) bitmaskWithRejection32' range = go where@@ -322,6 +317,7 @@ in if x' > range then go g' else (x', g')+{-# INLINEABLE bitmaskWithRejection32' #-} -- | /Bitmask with rejection/ method of generating subrange of 'Word64'. --@@ -340,6 +336,7 @@ in if x' > range then go g' else (x', g')+{-# INLINEABLE bitmaskWithRejection64' #-} -------------------------------------------------------------------------------@@ -373,9 +370,9 @@ mkSMGen :: Word64 -> SMGen mkSMGen s = SMGen (mix64 s) (mixGamma (s `plus` goldenGamma)) --- | Initialize 'SMGen' using system time.+-- | Initialize 'SMGen' using entropy available on the system (time, ...) initSMGen :: IO SMGen-initSMGen = fmap mkSMGen mkSeedTime+initSMGen = fmap mkSMGen initialSeed -- | Derive a new generator instance from the global 'SMGen' using 'splitSMGen'. newSMGen :: IO SMGen@@ -384,28 +381,6 @@ theSMGen :: IORef SMGen theSMGen = unsafePerformIO $ initSMGen >>= newIORef {-# NOINLINE theSMGen #-}--mkSeedTime :: IO Word64-mkSeedTime = do- now <- getPOSIXTime- let lo = truncate now :: Word32-#if __GHCJS__- let hi = lo-#else- cpu <- getCPUTime- let hi = fromIntegral (cpu `div` cpuTimePrecision) :: Word32-#endif- return $ fromIntegral hi `shiftL` 32 .|. fromIntegral lo------------------------------------------------------------------------------------ System.Random----------------------------------------------------------------------------------#ifdef MIN_VERSION_random-instance R.RandomGen SMGen where- next = nextInt- split = splitSMGen-#endif ------------------------------------------------------------------------------- -- Hugs
+ src/System/Random/SplitMix/Init.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}+-- | Initialization of global generator.+module System.Random.SplitMix.Init (+ initialSeed,+) where++import Data.Word (Word64)++#if defined(SPLITMIX_INIT_GHCJS) && __GHCJS__++import Data.Word (Word32)++#else+#if defined(SPLITMIX_INIT_C)++#else++import Data.Bits (xor)+import Data.Time.Clock.POSIX (getPOSIXTime)+#if !__GHCJS__+import System.CPUTime (cpuTimePrecision, getCPUTime)+#endif++#endif+#endif++initialSeed :: IO Word64++#if defined(SPLITMIX_INIT_GHCJS) && __GHCJS__++initialSeed = fmap fromIntegral initialSeedJS++foreign import javascript+ "$r = Math.floor(Math.random()*0x100000000);"+ initialSeedJS :: IO Word32++#else+#if defined(SPLITMIX_INIT_C)++initialSeed = initialSeedC++foreign import ccall "splitmix_init" initialSeedC :: IO Word64++#else++initialSeed = do+ now <- getPOSIXTime+ let timebits = truncate now :: Word64+#if __GHCJS__+ let cpubits = 0+#else+ cpu <- getCPUTime+ let cpubits = fromIntegral (cpu `div` cpuTimePrecision) :: Word64+#endif+ return $ timebits `xor` cpubits++#endif+#endif
src/System/Random/SplitMix32.hs view
@@ -5,14 +5,8 @@ -- -- You __really don't want to use this one__. ----- Note: This module supports all GHCs since GHC-7.0.4,--- but GHC-7.0 and GHC-7.2 have slow implementation, as there--- are no native 'popCount'.--- {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif module System.Random.SplitMix32 ( SMGen, nextWord32,@@ -38,14 +32,15 @@ ) where import Data.Bits (complement, shiftL, shiftR, xor, (.&.), (.|.))-import Data.Bits.Compat+import Data.Bits (countLeadingZeros, finiteBitSize, popCount, zeroBits) import Data.IORef (IORef, atomicModifyIORef, newIORef)-import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Word (Word32, Word64) import System.IO.Unsafe (unsafePerformIO) -#if defined(__HUGS__) || !MIN_VERSION_base(4,8,0)+import System.Random.SplitMix.Init++#if defined(__HUGS__) import Data.Word (Word) #endif @@ -53,14 +48,6 @@ import Control.DeepSeq (NFData (..)) #endif -#ifdef MIN_VERSION_random-import qualified System.Random as R-#endif--#if !__GHCJS__-import System.CPUTime (cpuTimePrecision, getCPUTime)-#endif- -- $setup -- >>> import Text.Read (readMaybe) -- >>> import Data.List (unfoldr)@@ -275,9 +262,14 @@ ------------------------------------------------------------------------------- -- | /Bitmask with rejection/ method of generating subrange of 'Word32'.+--+-- @bitmaskWithRejection32 w32@ generates random numbers in closed-open+-- range of @[0, w32)@.+-- bitmaskWithRejection32 :: Word32 -> SMGen -> (Word32, SMGen) bitmaskWithRejection32 0 = error "bitmaskWithRejection32 0" bitmaskWithRejection32 n = bitmaskWithRejection32' (n - 1)+{-# INLINEABLE bitmaskWithRejection32 #-} -- | /Bitmask with rejection/ method of generating subrange of 'Word64'. --@@ -290,9 +282,13 @@ bitmaskWithRejection64 :: Word64 -> SMGen -> (Word64, SMGen) bitmaskWithRejection64 0 = error "bitmaskWithRejection64 0" bitmaskWithRejection64 n = bitmaskWithRejection64' (n - 1)+{-# INLINEABLE bitmaskWithRejection64 #-} -- | /Bitmask with rejection/ method of generating subrange of 'Word32'. --+-- @bitmaskWithRejection32' w32@ generates random numbers in closed-closed+-- range of @[0, w32]@.+-- -- @since 0.0.4 bitmaskWithRejection32' :: Word32 -> SMGen -> (Word32, SMGen) bitmaskWithRejection32' range = go where@@ -302,6 +298,7 @@ in if x' > range then go g' else (x', g')+{-# INLINEABLE bitmaskWithRejection32' #-} -- | /Bitmask with rejection/ method of generating subrange of 'Word64'. --@@ -320,6 +317,7 @@ in if x' > range then go g' else (x', g')+{-# INLINEABLE bitmaskWithRejection64' #-} ------------------------------------------------------------------------------- -- Initialisation@@ -352,9 +350,9 @@ mkSMGen :: Word32 -> SMGen mkSMGen s = SMGen (mix32 s) (mixGamma (s + goldenGamma)) --- | Initialize 'SMGen' using system time.+-- | Initialize 'SMGen' using entropy available on the system (time, ...) initSMGen :: IO SMGen-initSMGen = fmap mkSMGen mkSeedTime+initSMGen = fmap mkSMGen initialSeed' -- | Derive a new generator instance from the global 'SMGen' using 'splitSMGen'. newSMGen :: IO SMGen@@ -364,24 +362,7 @@ theSMGen = unsafePerformIO $ initSMGen >>= newIORef {-# NOINLINE theSMGen #-} -mkSeedTime :: IO Word32-mkSeedTime = do- now <- getPOSIXTime- let lo = truncate now :: Word32-#if __GHCJS__- let hi = lo-#else- cpu <- getCPUTime- let hi = fromIntegral (cpu `div` cpuTimePrecision) :: Word32-#endif- return $ fromIntegral hi `shiftL` 32 .|. fromIntegral lo------------------------------------------------------------------------------------ System.Random----------------------------------------------------------------------------------#ifdef MIN_VERSION_random-instance R.RandomGen SMGen where- next = nextInt- split = splitSMGen-#endif+initialSeed' :: IO Word32+initialSeed' = do+ w64 <- initialSeed+ return (fromIntegral (shiftR w64 32) `xor` fromIntegral w64)
− tests/Dieharder.hs
@@ -1,275 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Main (main) where--import Prelude ()-import Prelude.Compat--import Control.Concurrent.QSem-import Control.DeepSeq (force)-import Control.Monad (when)-import Data.Bits (shiftL, (.|.))-import Data.Char (isSpace)-import Data.List (isInfixOf, unfoldr)-import Data.Maybe (fromMaybe)-import Data.Word (Word64)-import Foreign.C (Errno (..), ePIPE)-import Foreign.Ptr (castPtr)-import GHC.IO.Exception (IOErrorType (..), IOException (..))-import System.Environment (getArgs)-import System.IO (Handle, hGetContents, stdout)-import Text.Printf (printf)--import qualified Control.Concurrent.Async as A-import qualified Control.Exception as E-import qualified Data.ByteString as BS-import qualified Data.ByteString.Unsafe as BS (unsafePackCStringLen)-import qualified Data.Vector.Storable.Mutable as MSV-import qualified System.Process as Proc-import qualified System.Random.SplitMix as SM-import qualified System.Random.SplitMix32 as SM32-import qualified System.Random.TF as TF-import qualified System.Random.TF.Gen as TF-import qualified System.Random.TF.Init as TF--main :: IO ()-main = do- args <- getArgs- if null args- then return ()- else do- (cmd, runs, conc, seed, test, raw, _help) <- parseArgsIO args $ (,,,,,,)- <$> arg- <*> optDef "-n" 1- <*> optDef "-j" 1- <*> opt "-s"- <*> opt "-d"- <*> flag "-r"- <*> flag "-h"-- let run :: RunType g- run | raw = runRaw- | otherwise = runManaged-- case cmd of- "splitmix" -> do- g <- maybe SM.initSMGen (return . SM.mkSMGen) seed- run test runs conc SM.splitSMGen SM.nextWord64 g- "splitmix32" -> do- g <- maybe SM32.initSMGen (return . SM32.mkSMGen) (fmap fromIntegral seed)- run test runs conc SM32.splitSMGen SM32.nextWord64 g- "tfrandom" -> do- g <- TF.initTFGen- run test runs conc TF.split tfNext64 g- _ -> return ()--tfNext64 :: TF.TFGen -> (Word64, TF.TFGen)-tfNext64 g =- let (w, g') = TF.next g- (w', g'') = TF.next g'- in (fromIntegral w `shiftL` 32 .|. fromIntegral w', g'')------------------------------------------------------------------------------------ Dieharder----------------------------------------------------------------------------------type RunType g =- Maybe Int- -> Int- -> Int- -> (g -> (g, g))- -> (g -> (Word64, g))- -> g- -> IO () --runRaw :: RunType g-runRaw _test _runs _conc split word gen =- generate word split gen stdout--runManaged :: RunType g-runManaged test runs conc split word gen = do- qsem <- newQSem conc-- rs <- A.forConcurrently (take runs $ unfoldr (Just . split) gen) $ \g ->- E.bracket_ (waitQSem qsem) (signalQSem qsem) $- dieharder test (generate word split g)-- case mconcat rs of- Result p w f -> do- let total = fromIntegral (p + w + f) :: Double- printf "PASSED %4d %6.02f%%\n" p (fromIntegral p / total * 100)- printf "WEAK %4d %6.02f%%\n" w (fromIntegral w / total * 100)- printf "FAILED %4d %6.02f%%\n" f (fromIntegral f / total * 100)-{-# INLINE runManaged #-}--dieharder :: Maybe Int -> (Handle -> IO ()) -> IO Result-dieharder test gen = do- let proc = Proc.proc "dieharder" $ ["-g", "200"] ++ maybe ["-a"] (\t -> ["-d", show t]) test- (Just hin, Just hout, _, ph) <- Proc.createProcess proc- { Proc.std_in = Proc.CreatePipe- , Proc.std_out = Proc.CreatePipe- }-- out <- hGetContents hout- waitOut <- A.async $ E.evaluate $ force out-- E.catch (gen hin) $ \e -> case e of- IOError { ioe_type = ResourceVanished , ioe_errno = Just ioe }- | Errno ioe == ePIPE -> return ()- _ -> E.throwIO e-- res <- A.wait waitOut- _ <- Proc.waitForProcess ph-- return $ parseOutput res-{-# INLINE dieharder #-}--parseOutput :: String -> Result-parseOutput = foldMap parseLine . lines where- parseLine l- | any (`isInfixOf` l) doNotUse = mempty- | "PASSED" `isInfixOf` l = Result 1 0 0- | "WEAK" `isInfixOf` l = Result 0 1 0- | "FAILED" `isInfixOf` l = Result 0 1 0- | otherwise = mempty-- doNotUse = ["diehard_opso", "diehard_oqso", "diehard_dna", "diehard_weak"]------------------------------------------------------------------------------------ Results----------------------------------------------------------------------------------data Result = Result- { _passed :: Int- , _weak :: Int- , _failed :: Int- }- deriving Show--instance Semigroup Result where- Result p w f <> Result p' w' f' = Result (p + p') (w + w') (f + f')--instance Monoid Result where- mempty = Result 0 0 0- mappend = (<>)------------------------------------------------------------------------------------ Writer----------------------------------------------------------------------------------size :: Int-size = 512--generate- :: forall g. (g -> (Word64, g))- -> (g -> (g, g))- -> g -> Handle -> IO ()-generate word split gen0 h = do- vec <- MSV.new size- go gen0 vec- where- go :: g -> MSV.IOVector Word64 -> IO ()- go gen vec = do- let (g1, g2) = split gen- write g1 vec 0- MSV.unsafeWith vec $ \ptr -> do- bs <- BS.unsafePackCStringLen (castPtr ptr, size * 8)- BS.hPutStr h bs- go g2 vec-- write :: g -> MSV.IOVector Word64 -> Int -> IO ()- write !gen !vec !i = do- let (w64, gen') = word gen- MSV.unsafeWrite vec i w64- when (i < size) $- write gen' vec (i + 1)-{-# INLINE generate #-}------------------------------------------------------------------------------------ readMaybe----------------------------------------------------------------------------------readEither :: Read a => String -> Either String a-readEither s =- case [ x | (x,rest) <- reads s, all isSpace rest ] of- [x] -> Right x- [] -> Left "Prelude.read: no parse"- _ -> Left "Prelude.read: ambiguous parse"--readMaybe :: Read a => String -> Maybe a-readMaybe s = case readEither s of- Left _ -> Nothing- Right a -> Just a----------------------------------------------------------------------------------- Do it yourself command line parsing------------------------------------------------------------------------------------ | 'Parser' is not an 'Alternative', only a *commutative* 'Applicative'.------ Useful for quick cli parsers, like parametrising tests.-data Parser a where- Pure :: a -> Parser a- Ap :: Arg b -> Parser (b -> a) -> Parser a--instance Functor Parser where- fmap f (Pure a) = Pure (f a)- fmap f (Ap x y) = Ap x (fmap (f .) y)--instance Applicative Parser where- pure = Pure-- Pure f <*> z = fmap f z- Ap x y <*> z = Ap x (flip <$> y <*> z)--data Arg a where- Flag :: String -> Arg Bool- Opt :: String -> (String -> Maybe a) -> Arg (Maybe a)- Arg :: Arg String--arg :: Parser String-arg = Ap Arg (Pure id)--flag :: String -> Parser Bool-flag n = Ap (Flag n) (Pure id)--opt :: Read a => String -> Parser (Maybe a)-opt n = Ap (Opt n readMaybe) (Pure id)--optDef :: Read a => String -> a -> Parser a-optDef n d = Ap (Opt n readMaybe) (Pure (fromMaybe d))--parseArgsIO :: [String] -> Parser a -> IO a-parseArgsIO args p = either fail pure (parseArgs args p)--parseArgs :: [String] -> Parser a -> Either String a-parseArgs [] p = parserToEither p-parseArgs (x : xs) p = do- (xs', p') <- singleArg p x xs- parseArgs xs' p'--singleArg :: Parser a -> String -> [String] -> Either String ([String], Parser a)-singleArg (Pure _) x _ = Left $ "Extra argument " ++ x-singleArg (Ap Arg p) x xs- | null x || head x /= '-' = Right (xs, fmap ($ x) p)- | otherwise = fmap2 (Ap Arg) (singleArg p x xs)-singleArg (Ap f@(Flag n) p) x xs- | x == n = Right (xs, fmap ($ True) p)- | otherwise = fmap2 (Ap f) (singleArg p x xs)-singleArg (Ap o@(Opt n r) p) x xs- | x == n = case xs of- [] -> Left $ "Expected an argument for " ++ n- (x' : xs') -> case r x' of- Nothing -> Left $ "Cannot read an argument of " ++ n ++ ": " ++ x'- Just y -> Right (xs', fmap ($ Just y) p)- | otherwise = fmap2 (Ap o) (singleArg p x xs)--fmap2 :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)-fmap2 = fmap . fmap---- | Convert parser to 'Right' if there are only defaultable pieces left.-parserToEither :: Parser a -> Either String a-parserToEither (Pure x) = pure x-parserToEither (Ap (Flag _) p) = parserToEither $ fmap ($ False) p-parserToEither (Ap (Opt _ _) p) = parserToEither $ fmap ($ Nothing) p-parserToEither (Ap Arg _) = Left "argument required"
− tests/Examples.hs
@@ -1,15 +0,0 @@-module Main (main) where--import Test.HUnit ((@?=))--import qualified System.Random.SplitMix32 as SM32--main :: IO ()-main = do- let g = SM32.mkSMGen 42- show g @?= "SMGen 142593372 1604540297"- print g-- let (w32, g') = SM32.nextWord32 g- w32 @?= 1296549791- show g' @?= "SMGen 1747133669 1604540297"
− tests/MiniQC.hs
@@ -1,83 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}--- | This QC doesn't shrink :(-module MiniQC where--import Control.Monad (ap)-import Data.Int (Int32, Int64)-import Data.Word (Word32, Word64)-import Prelude ()-import Prelude.Compat-import Test.Framework.Providers.API (Test, TestName)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit (assertFailure)--import System.Random.SplitMix--newtype Gen a = Gen { unGen :: SMGen -> a }- deriving (Functor)--instance Applicative Gen where- pure x = Gen (const x)- (<*>) = ap--instance Monad Gen where- return = pure-- m >>= k = Gen $ \g ->- let (g1, g2) = splitSMGen g- in unGen (k (unGen m g1)) g2--class Arbitrary a where- arbitrary :: Gen a--instance Arbitrary Word32 where- arbitrary = Gen $ \g -> fst (nextWord32 g)-instance Arbitrary Word64 where- arbitrary = Gen $ \g -> fst (nextWord64 g)-instance Arbitrary Int32 where- arbitrary = Gen $ \g -> fromIntegral (fst (nextWord32 g))-instance Arbitrary Int64 where- arbitrary = Gen $ \g -> fromIntegral (fst (nextWord64 g))-instance Arbitrary Double where- arbitrary = Gen $ \g -> fst (nextDouble g)--newtype Property = Property { unProperty :: Gen ([String], Bool) }--class Testable a where- property :: a -> Property--instance Testable Property where- property = id--instance Testable Bool where- property b = Property $ pure ([show b], b)--instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where- property f = Property $ do- x <- arbitrary- (xs, b) <- unProperty (property (f x))- return (show x : xs, b)--forAllBlind :: Testable prop => Gen a -> (a -> prop) -> Property-forAllBlind g f = Property $ do- x <- g- (xs, b) <- unProperty (property (f x))- return ("<blind>" : xs, b)--counterexample :: Testable prop => String -> prop -> Property-counterexample msg prop = Property $ do- (xs, b) <- unProperty (property prop)- return (msg : xs, b)--testMiniProperty :: Testable prop => TestName -> prop -> Test-testMiniProperty name prop = testCase name $ do- g <- newSMGen- go (100 :: Int) g- where- go n _ | n <= 0 = return ()- go n g = do- let (g1, g2) = splitSMGen g- case unGen (unProperty (property prop)) g1 of- (_, True) -> return ()- (xs, False) -> assertFailure (unlines (reverse xs))- go (pred n) g2
− tests/SplitMixPi.hs
@@ -1,27 +0,0 @@-module Main (main) where--import Data.List (unfoldr, foldl')-import System.Random.SplitMix--doubles :: SMGen -> [Double]-doubles = unfoldr (Just . nextDouble)--monteCarloPi :: SMGen -> Double-monteCarloPi = (4 *) . calc . foldl' accum (P 0 0) . take 50000000 . pairs . doubles- where- calc (P n m) = fromIntegral n / fromIntegral m-- pairs (x : y : xs) = (x, y) : pairs xs- pairs _ = []-- accum (P n m) (x, y) | x * x + y * y >= 1 = P n (m + 1)- | otherwise = P (n + 1) (m + 1)--data P = P !Int !Int--main :: IO ()-main = do- pi' <- fmap monteCarloPi newSMGen- print (pi :: Double)- print pi'- print (pi - pi')
− tests/SplitMixPi32.hs
@@ -1,27 +0,0 @@-module Main (main) where--import Data.List (unfoldr, foldl')-import System.Random.SplitMix32--doubles :: SMGen -> [Float]-doubles = unfoldr (Just . nextFloat)--monteCarloPi :: SMGen -> Float-monteCarloPi = (4 *) . calc . foldl' accum (P 0 0) . take 50000000 . pairs . doubles- where- calc (P n m) = fromIntegral n / fromIntegral m-- pairs (x : y : xs) = (x, y) : pairs xs- pairs _ = []-- accum (P n m) (x, y) | x * x + y * y >= 1 = P n (m + 1)- | otherwise = P (n + 1) (m + 1)--data P = P !Int !Int--main :: IO ()-main = do- pi' <- fmap monteCarloPi newSMGen- print (pi :: Float)- print pi'- print (pi - pi')
− tests/Tests.hs
@@ -1,136 +0,0 @@-module Main (main) where--import Data.Bits ((.&.))-import Data.Int (Int64)-import Data.Word (Word64)-import Test.Framework (defaultMain, testGroup)--import qualified System.Random.SplitMix as SM-import qualified System.Random.SplitMix32 as SM32--import MiniQC (Arbitrary (..), Gen (..), counterexample, testMiniProperty)-import Uniformity--main :: IO ()-main = defaultMain- [ testUniformity "SM64 uniformity" (arbitrary :: Gen Word64) (.&. 0xf) 16- , testUniformity "SM64 uniformity" (arbitrary :: Gen Word64) (.&. 0xf0) 16-- , testUniformity "bitmaskWithRejection uniformity" (arbitrary :: Gen Word64mod7) id 7-- , testGroup "nextInteger"- [ testMiniProperty "valid" $ \a b c d seed -> do- let lo' = fromIntegral (a :: Int64) * fromIntegral (b :: Int64)- hi' = fromIntegral (c :: Int64) * fromIntegral (d :: Int64)-- lo = min lo' hi'- hi = max lo' hi'-- let g = SM.mkSMGen seed- (x, _) = SM.nextInteger lo' hi' g-- counterexample (show x) $ lo <= x && x <= hi-- , testMiniProperty "valid small" $ \a b seed -> do- let lo' = fromIntegral (a :: Int64) `rem` 10- hi' = fromIntegral (b :: Int64) `rem` 10-- lo = min lo' hi'- hi = max lo' hi'-- let g = SM.mkSMGen seed- (x, _) = SM.nextInteger lo' hi' g-- counterexample (show x) $ lo <= x && x <= hi-- , testMiniProperty "I1 valid" i1valid- , testUniformity "I1 uniform" arbitrary (\(I1 w) -> w) 15-- , testMiniProperty "I7 valid" i7valid- , testUniformity "I7 uniform" arbitrary (\(I7 w) -> w `mod` 7) 7- ]-- , testGroup "SM bitmaskWithRejection"- [ testMiniProperty "64" $ \w' seed -> do- let w = w' .&. 0xff- let w1 = w + 1- let g = SM.mkSMGen seed- let (x, _) = SM.bitmaskWithRejection64 w1 g- counterexample ("64-64 " ++ show x ++ " <= " ++ show w) (x < w1)- , testMiniProperty "64'" $ \w' seed -> do- let w = w' .&. 0xff- let g = SM.mkSMGen seed- let (x, _) = SM.bitmaskWithRejection64' w g- counterexample ("64-64 " ++ show x ++ " < " ++ show w) (x <= w)- , testMiniProperty "32" $ \w' seed -> do- let w = w' .&. 0xff- let u1 = w'- let g = SM.mkSMGen seed- let (x, _) = SM.bitmaskWithRejection32 u1 g- counterexample ("64-32 " ++ show x ++ " <= " ++ show w) (x < u1)- , testMiniProperty "32'" $ \w' seed -> do- let w = w' .&. 0xff- let u = w- let g = SM.mkSMGen seed- let (x, _) = SM.bitmaskWithRejection32' u g- counterexample ("64-32 " ++ show x ++ " < " ++ show w) (x <= u)- ]- , testGroup "SM32 bitmaskWithRejection"- [ testMiniProperty "64" $ \w' seed -> do- let w = w' .&. 0xff- let w1 = w + 1- let g = SM32.mkSMGen seed- let (x, _) = SM32.bitmaskWithRejection64 w1 g- counterexample ("64-64 " ++ show x ++ " <= " ++ show w) (x < w1)- , testMiniProperty "64'" $ \w' seed -> do- let w = w' .&. 0xff- let g = SM32.mkSMGen seed- let (x, _) = SM32.bitmaskWithRejection64' w g- counterexample ("64-64 " ++ show x ++ " < " ++ show w) (x <= w)- , testMiniProperty "32" $ \w' seed -> do- let w = w' .&. 0xff- let u1 = w'- let g = SM32.mkSMGen seed- let (x, _) = SM32.bitmaskWithRejection32 u1 g- counterexample ("64-32 " ++ show x ++ " <= " ++ show w) (x < u1)- , testMiniProperty "32'" $ \w' seed -> do- let w = w' .&. 0xff- let u = w- let g = SM32.mkSMGen seed- let (x, _) = SM32.bitmaskWithRejection32' u g- counterexample ("64-32 " ++ show x ++ " < " ++ show w) (x <= u)- ]- ]--newtype Word64mod7 = W7 Word64 deriving (Eq, Ord, Show)-instance Arbitrary Word64mod7 where- arbitrary = Gen $ \g -> W7 $ fst $ SM.bitmaskWithRejection64' 6 g--newtype Integer1 = I1 Integer deriving (Eq, Ord, Show)-instance Arbitrary Integer1 where- arbitrary = Gen $ \g -> I1 $ fst $ SM.nextInteger i1min i1max g--i1min :: Integer-i1min = -7--i1max :: Integer-i1max = 7--i1valid :: Integer1 -> Bool-i1valid (I1 i) = i1min <= i && i <= i1max--newtype Integer7 = I7 Integer deriving (Eq, Ord, Show)-instance Arbitrary Integer7 where- arbitrary = Gen $ \g -> I7 $ fst $ SM.nextInteger i7min i7max g--i7min :: Integer-i7min = negate two64--i7max :: Integer-i7max = two64 * 6 + 7 * 1234567--i7valid :: Integer7 -> Bool-i7valid (I7 i) = i7min <= i && i <= i7max--two64 :: Integer-two64 = 2 ^ (64 :: Int)
− tests/Uniformity.hs
@@ -1,134 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | Chi-Squared test for uniformity.-module Uniformity (testUniformity) where--import Data.List (intercalate)-import Data.List (foldl')-import Numeric (showFFloat)-import Numeric.SpecFunctions (incompleteGamma)-import Test.Framework.Providers.API (Test, TestName)--import qualified Data.Map as Map--import MiniQC as QC---- | \( \lim_{n\to\infty} \mathrm{Pr}(V \le v) = \ldots \)-chiDist- :: Int -- ^ k, categories- -> Double -- ^ v, value- -> Double-chiDist k x = incompleteGamma (0.5 * v) (0.5 * x) where- v = fromIntegral (k - 1)---- | When the distribution is uniform,------ \[--- \frac{1}{n} \sum_{s = 1}^k \frac{Y_s^2}{p_s} - n--- \]------ simplifies to------ \[--- \frac{k}{n} \sum_{s=1}^k Y_s^2 - n--- \]------ when \(p_s = \frac{1}{k} \), i.e. \(k\) is the number of buckets.----calculateV :: Int -> Map.Map k Int -> Double-calculateV k data_ = chiDist k v- where- v = fromIntegral k * fromIntegral sumY2 / fromIntegral n - fromIntegral n- V2 n sumY2 = foldl' sumF (V2 0 0) (Map.elems data_) where- sumF (V2 m m2) x = V2 (m + x) (m2 + x * x)---- Strict pair of 'Int's, used as an accumulator.-data V2 = V2 !Int !Int--countStream :: Ord a => Stream a -> Int -> Map.Map a Int-countStream = go Map.empty where- go !acc s n- | n <= 0 = acc- | otherwise = case s of- x :> xs -> go (Map.insertWith (+) x 1 acc) xs (pred n)--testUniformityRaw :: forall a. (Ord a, Show a) => Int -> Stream a -> Either String Double-testUniformityRaw k s- | Map.size m > k = Left $ "Got more elements (" ++ show (Map.size m, take 5 $ Map.keys m) ++ " than expected (" ++ show k ++ ")"- | p > 0.999999 = Left $- "Too impropabable p-value: " ++ show p ++ "\n" ++ table- [ [ show x, showFFloat (Just 3) (fromIntegral y / fromIntegral n :: Double) "" ]- | (x, y) <- take 20 $ Map.toList m- ]- | otherwise = Right p- where- -- each bucket to have roughly 128 elements- n :: Int- n = k * 128-- -- buckets from the stream- m :: Map.Map a Int- m = countStream s n-- -- calculate chi-squared value- p :: Double- p = calculateV k m--testUniformityQC :: (Ord a, Show a) => Int -> Stream a -> QC.Property-testUniformityQC k s = case testUniformityRaw k s of- Left err -> QC.counterexample err False- Right _ -> QC.property True---- | Test that generator produces values uniformly.------ The size is scaled to be at least 20.----testUniformity- :: forall a b. (Ord b, Show b)- => TestName- -> QC.Gen a -- ^ Generator to test- -> (a -> b) -- ^ Partitioning function- -> Int -- ^ Number of partittions- -> Test-testUniformity name gen f k = QC.testMiniProperty name- $ QC.forAllBlind (streamGen gen)- $ testUniformityQC k . fmap f------------------------------------------------------------------------------------ Infinite stream----------------------------------------------------------------------------------data Stream a = a :> Stream a deriving (Functor)-infixr 5 :>--streamGen :: QC.Gen a -> QC.Gen (Stream a)-streamGen g = gs where- gs = do- x <- g- xs <- gs- return (x :> xs)------------------------------------------------------------------------------------ Table----------------------------------------------------------------------------------table :: [[String]] -> String-table cells = unlines rows- where- cols :: Int- rowWidths :: [Int]- rows :: [String]-- (cols, rowWidths, rows) = foldr go (0, repeat 0, []) cells-- go :: [String] -> (Int, [Int], [String]) -> (Int, [Int], [String])- go xs (c, w, yss) =- ( max c (length xs)- , zipWith max w (map length xs ++ repeat 0)- , intercalate " " (take cols (zipWith fill xs rowWidths))- : yss- )-- fill :: String -> Int -> String- fill s n = s ++ replicate (n - length s) ' '
+ tests/splitmix-examples.hs view
@@ -0,0 +1,15 @@+module Main (main) where++import Test.HUnit ((@?=))++import qualified System.Random.SplitMix32 as SM32++main :: IO ()+main = do+ let g = SM32.mkSMGen 42+ show g @?= "SMGen 142593372 1604540297"+ print g++ let (w32, g') = SM32.nextWord32 g+ w32 @?= 1296549791+ show g' @?= "SMGen 1747133669 1604540297"
+ tests/splitmix-th-test.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TemplateHaskell #-}+module Main (main) where++import Language.Haskell.TH.Syntax++import System.Random.SplitMix++main :: IO ()+main = print val where+ val :: Double+ val = $(runIO (newSMGen >>= \g -> return (fst (nextDouble g))) >>= lift)