splitmix-0.1.0.5/0000755000000000000000000000000007346545000011715 5ustar0000000000000000splitmix-0.1.0.5/Changelog.md0000644000000000000000000000352707346545000014135 0ustar0000000000000000# 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` - Use smaller range in `bitmaskWithRejection32` and `64`, when upper bound is 2^n - 1. This changes generated values when they were on the boundary. # 0.0.4 - Add `bitmaskWithRejection32'` and `bitmaskWithRejection64'` which generate numbers in closed range `[0, n]`. Unticked variants generate in closed-open range `[0, n)`. # 0.0.3 - Add `System.Random.SplitMix32` module - Add `bitmaskWithRejection32` and `bitmaskWithRejection64` functions - Add `nextWord32`, `nextTwoWord32` and `nextFloat` - Add `random` flag, dropping dependency on `random` (breaks things, e.g. `QuickCheck`, when disabled). # 0.0.2 - Support back to GHC-7.0 - Add `Read SMGen` instance # 0.0.1 - Add `NFData SMGen` instance - Fix a bug. http://www.pcg-random.org/posts/bugs-in-splitmix.html The generated numbers will be different for the same seeds! splitmix-0.1.0.5/LICENSE0000644000000000000000000000276207346545000012731 0ustar0000000000000000Copyright (c) 2017, Oleg Grenrus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Oleg Grenrus nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. splitmix-0.1.0.5/README.md0000644000000000000000000000604107346545000013175 0ustar0000000000000000# splitmix Pure Haskell implementation of SplitMix pseudo-random number generator. ## dieharder > [Dieharder](http://webhome.phy.duke.edu/~rgb/General/dieharder.php) is a random number generator (rng) testing suite. It is intended to test generators, not files of possibly random numbers as the latter is a fallacious view of what it means to be random. Is the number 7 random? If it is generated by a random process, it might be. If it is made up to serve the purpose of some argument (like this one) it is not. Perfect random number generators produce "unlikely" sequences of random numbers – at exactly the right average rate. Testing a rng is therefore quite subtle. ``` time $(cabal-plan list-bin splitmix-dieharder) splitmix ``` The test-suite takes around half-an-hour to complete. From 30 runs, 2.49% were weak (3247 passed, 83 weak, 0 failed). In comparison, built-in [Marsenne Twister](https://en.wikipedia.org/wiki/Mersenne_Twister) test takes around 15min. ``` time dieharder -a ``` ## benchmarks ``` benchmarking list 64/random time 1.317 ms (1.303 ms .. 1.335 ms) 0.998 R² (0.998 R² .. 0.999 R²) mean 1.380 ms (1.365 ms .. 1.411 ms) std dev 70.83 μs (37.26 μs .. 131.8 μs) variance introduced by outliers: 39% (moderately inflated) benchmarking list 64/tf-random time 141.1 μs (140.4 μs .. 142.1 μs) 0.999 R² (0.998 R² .. 1.000 R²) mean 145.9 μs (144.6 μs .. 150.4 μs) std dev 7.131 μs (3.461 μs .. 14.75 μs) variance introduced by outliers: 49% (moderately inflated) benchmarking list 64/splitmix time 17.86 μs (17.72 μs .. 18.01 μs) 0.999 R² (0.998 R² .. 1.000 R²) mean 17.95 μs (17.75 μs .. 18.47 μs) std dev 1.000 μs (444.1 ns .. 1.887 μs) variance introduced by outliers: 64% (severely inflated) benchmarking tree 64/random time 800.3 μs (793.3 μs .. 806.5 μs) 0.999 R² (0.998 R² .. 0.999 R²) mean 803.2 μs (798.1 μs .. 811.2 μs) std dev 22.09 μs (14.69 μs .. 35.47 μs) variance introduced by outliers: 18% (moderately inflated) benchmarking tree 64/tf-random time 179.0 μs (176.6 μs .. 180.7 μs) 0.999 R² (0.998 R² .. 0.999 R²) mean 172.7 μs (171.3 μs .. 174.6 μs) std dev 5.590 μs (4.919 μs .. 6.382 μs) variance introduced by outliers: 29% (moderately inflated) benchmarking tree 64/splitmix time 51.54 μs (51.01 μs .. 52.15 μs) 0.999 R² (0.998 R² .. 0.999 R²) mean 52.50 μs (51.93 μs .. 53.55 μs) std dev 2.603 μs (1.659 μs .. 4.338 μs) variance introduced by outliers: 55% (severely inflated) ``` Note: the performance can be potentially further improved when GHC gets [SIMD Support](https://ghc.haskell.org/trac/ghc/wiki/SIMD/Implementation/Status). splitmix-0.1.0.5/Setup.hs0000644000000000000000000000005607346545000013352 0ustar0000000000000000import Distribution.Simple main = defaultMain splitmix-0.1.0.5/bench/0000755000000000000000000000000007346545000012774 5ustar0000000000000000splitmix-0.1.0.5/bench/Bench.hs0000644000000000000000000001233707346545000014355 0ustar0000000000000000module 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 :: (g -> (Int, g)) -> g -> [Int] genList next = unfoldr (Just . next) -- truncated genListN :: (g -> (Int, g)) -> g -> [Int] genListN next = take 2048 . genList next randomList :: Int -> [Int] randomList = genListN R.random . R.mkStdGen tfRandomList :: Word64 -> [Int] tfRandomList w64 = genListN R.random $ TF.seedTFGen (w64, w64, w64, w64) splitMixList :: Word64 -> [Int] splitMixList w64 = genListN SM.nextInt $ SM.mkSMGen w64 splitMix32List :: Word64 -> [Int] splitMix32List w64 = genListN SM32.nextInt $ SM32.mkSMGen $ fromIntegral w64 ------------------------------------------------------------------------------- -- Tree ------------------------------------------------------------------------------- genTree :: (g -> (Int, g)) -> (g -> (g, g)) -> g -> T.Tree Int genTree next split = go where go g = case next g of ~(i, g') -> T.Node i $ case split g' of (ga, gb) -> [go ga, go gb] genTreeN :: (g -> (Int, g)) -> (g -> (g, g)) -> g -> T.Tree Int genTreeN next split = cutTree 9 . genTree next split 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.next R.split . R.mkStdGen tfRandomTree :: Word64 -> T.Tree Int tfRandomTree w64 = genTreeN R.next R.split $ TF.seedTFGen (w64, w64, w64, w64) splitMixTree :: Word64 -> T.Tree Int splitMixTree w64 = genTreeN SM.nextInt SM.splitSMGen $ SM.mkSMGen w64 splitMix32Tree :: Word64 -> T.Tree Int splitMix32Tree w64 = genTreeN SM32.nextInt SM32.splitSMGen $ 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 ::(g -> (Word64, g)) -> (g -> (g, g)) -> g -> T.Tree Word64 genTree64 r split = go where go g = case r g of ~(i, g') -> T.Node i $ case split g' of (ga, gb) -> [go ga, go gb] genTreeN64 :: (g -> (Word64, g)) -> (g -> (g, g)) -> g -> T.Tree Word64 genTreeN64 r split = cutTree 9 . genTree64 r split 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.split . R.mkStdGen tfRandomTree64 :: Word64 -> T.Tree Word64 tfRandomTree64 w64 = genTreeN64 TF.random R.split $ TF.seedTFGen (w64, w64, w64, w64) splitMixTree64 :: Word64 -> T.Tree Word64 splitMixTree64 w64 = genTreeN64 SM.nextWord64 SM.splitSMGen $ SM.mkSMGen w64 splitMix32Tree64 :: Word64 -> T.Tree Word64 splitMix32Tree64 w64 = genTreeN64 SM32.nextWord64 SM32.splitSMGen $ 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 ] ] splitmix-0.1.0.5/bench/Range.hs0000644000000000000000000000533407346545000014371 0ustar0000000000000000-- 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.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 (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 splitmix-0.1.0.5/bench/SimpleSum.hs0000644000000000000000000000376107346545000015255 0ustar0000000000000000{-# 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) splitmix-0.1.0.5/cbits-unix/0000755000000000000000000000000007346545000014002 5ustar0000000000000000splitmix-0.1.0.5/cbits-unix/init.c0000644000000000000000000000154107346545000015112 0ustar0000000000000000#include #include #include #include #include #include uint64_t splitmix_init() { /* if there is /dev/urandom, read from it */ FILE *urandom = fopen("/dev/urandom", "r"); if (urandom) { uint64_t result = 0; size_t r = fread(&result, sizeof(uint64_t), 1, urandom); fclose(urandom); if (r == 1) { return result; } else { return 0xfeed1000; } } else { /* time of day */ struct timeval tp = {0, 0}; gettimeofday(&tp, NULL); /* cputime */ clock_t c = clock(); /* process id */ pid_t p = getpid(); return ((uint64_t) tp.tv_sec) ^ ((uint64_t) tp.tv_usec) ^ ((uint64_t) c << 16) ^ ((uint64_t) p << 32); } } splitmix-0.1.0.5/cbits-win/0000755000000000000000000000000007346545000013614 5ustar0000000000000000splitmix-0.1.0.5/cbits-win/init.c0000644000000000000000000000150507346545000014724 0ustar0000000000000000#include #include uint64_t splitmix_init() { /* Handy list at https://stackoverflow.com/a/3487338/1308058 */ uint64_t a = GetCurrentProcessId(); /* DWORD */ uint64_t b = GetCurrentThreadId(); /* DWORD */ uint64_t c = GetTickCount(); /* DWORD */ SYSTEMTIME t = {0,0,0,0,0,0,0,0}; GetSystemTime(&t); LARGE_INTEGER i; QueryPerformanceCounter(&i); return a ^ (b << 32) ^ (c << 16) ^ ((uint64_t) t.wYear << 56) ^ ((uint64_t) t.wMonth << 48) ^ ((uint64_t) t.wDayOfWeek << 40) ^ ((uint64_t) t.wDay << 32) ^ ((uint64_t) t.wHour << 24) ^ ((uint64_t) t.wMinute << 16) ^ ((uint64_t) t.wSecond << 8) ^ ((uint64_t) t.wMilliseconds << 0) ^ ((uint64_t) i.QuadPart); } splitmix-0.1.0.5/make-hugs.sh0000644000000000000000000000124607346545000014135 0ustar0000000000000000#!/bin/sh set -e TOPDIR=$(dirname "$0") TARGETDIR=$TOPDIR/splitmix-hugs while getopts 't:' opt do case "$opt" in t) TARGETDIR=$OPTARG ;; *) echo "Unknown flag $opt"; exit 1 ;; esac done # Check tool availability cpphs --version # For each of the source files find "$TOPDIR/src" "$TOPDIR/src-compat" -name '*.hs' | while read -r src; do tgt="$TARGETDIR/$(echo "$src" | sed "s/^$TOPDIR\/src"'\(-compat\|\)//')" echo "Processing $src -> $tgt" mkdir -p "$(dirname "$tgt")" cpphs --noline -D__HUGS__=1 "$src" > "$tgt" done echo "A Hugs-compatible version of splitmix is now" echo "available in the splitmix-hugs directory." echo "Load it with hugs -98." splitmix-0.1.0.5/splitmix.cabal0000644000000000000000000001463507346545000014563 0ustar0000000000000000cabal-version: >=1.10 name: splitmix version: 0.1.0.5 synopsis: Fast Splittable PRNG description: Pure Haskell implementation of SplitMix described in . Guy L. Steele, Jr., Doug Lea, and Christine H. Flood. 2014. Fast splittable pseudorandom number generators. In Proceedings of the 2014 ACM International Conference on Object Oriented Programming Systems Languages & Applications (OOPSLA '14). ACM, New York, NY, USA, 453-472. DOI: . The paper describes a new algorithm /SplitMix/ for /splittable/ pseudorandom number generator that is quite fast: 9 64 bit arithmetic/logical operations per 64 bits generated. . /SplitMix/ is tested with two standard statistical test suites (DieHarder and TestU01, this implementation only using the former) and it appears to be adequate for "everyday" use, such as Monte Carlo algorithms and randomized data structures where speed is important. . In particular, it __should not be used for cryptographic or security applications__, because generated sequences of pseudorandom values are too predictable (the mixing functions are easily inverted, and two successive outputs suffice to reconstruct the internal state). license: BSD3 license-file: LICENSE maintainer: Oleg Grenrus 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.4 || ==8.10.4 || ==9.0.2 || ==9.2.8 || ==9.4.7 || ==9.6.3 || ==9.8.1 , GHCJS ==8.4 extra-source-files: Changelog.md make-hugs.sh README.md test-hugs.sh flag optimised-mixer description: Use JavaScript for mix32 manual: True default: False library default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: src src-compat exposed-modules: System.Random.SplitMix System.Random.SplitMix32 other-modules: Data.Bits.Compat 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.20 , deepseq >=1.3.0.0 && <1.6 if flag(optimised-mixer) cpp-options: -DOPTIMISED_MIX32=1 -- 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 if impl(ghcjs) cpp-options: -DSPLITMIX_INIT_GHCJS=1 else if impl(ghc) cpp-options: -DSPLITMIX_INIT_C=1 if os(windows) c-sources: cbits-win/init.c else c-sources: cbits-unix/init.c else cpp-options: -DSPLITMIX_INIT_COMPAT=1 build-depends: time >=1.2.0.3 && <1.13 source-repository head type: git location: https://github.com/haskellari/splitmix.git 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.7 , random , splitmix , tf-random >=0.5 && <0.6 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 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 , random , splitmix if !impl(ghcjs) build-depends: clock >=0.8 && <0.9 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 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 build-depends: base , base-compat >=0.11.1 && <0.14 , 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 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 test-suite montecarlo-pi-32 type: exitcode-stdio-1.0 default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: tests main-is: SplitMixPi32.hs build-depends: base , splitmix test-suite splitmix-dieharder default-language: Haskell2010 type: exitcode-stdio-1.0 ghc-options: -Wall -threaded -rtsopts hs-source-dirs: tests main-is: Dieharder.hs build-depends: async >=2.2.1 && <2.3 , base , base-compat-batteries >=0.10.5 && <0.14 , bytestring >=0.9.1.8 && <0.13 , deepseq , process >=1.0.1.5 && <1.7 , random , splitmix , tf-random >=0.5 && <0.6 , vector >=0.11.0.0 && <0.14 test-suite splitmix-testu01 if !os(linux) buildable: False default-language: Haskell2010 type: exitcode-stdio-1.0 ghc-options: -Wall -threaded -rtsopts hs-source-dirs: tests main-is: TestU01.hs c-sources: tests/cbits/testu01.c extra-libraries: testu01 build-depends: base , base-compat-batteries >=0.10.5 && <0.14 , splitmix test-suite initialization default-language: Haskell2010 type: exitcode-stdio-1.0 ghc-options: -Wall -threaded -rtsopts hs-source-dirs: tests main-is: Initialization.hs build-depends: base , HUnit ==1.3.1.2 || >=1.6.0.0 && <1.7 , splitmix splitmix-0.1.0.5/src-compat/Data/Bits/0000755000000000000000000000000007346545000015537 5ustar0000000000000000splitmix-0.1.0.5/src-compat/Data/Bits/Compat.hs0000644000000000000000000000161407346545000017320 0ustar0000000000000000{-# 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 splitmix-0.1.0.5/src/System/Random/0000755000000000000000000000000007346545000015210 5ustar0000000000000000splitmix-0.1.0.5/src/System/Random/SplitMix.hs0000644000000000000000000003147207346545000017324 0ustar0000000000000000-- | -- /SplitMix/ is a splittable pseudorandom number generator (PRNG) that is quite fast. -- -- Guy L. Steele, Jr., Doug Lea, and Christine H. Flood. 2014. -- Fast splittable pseudorandom number generators. In Proceedings -- of the 2014 ACM International Conference on Object Oriented -- Programming Systems Languages & Applications (OOPSLA '14). ACM, -- New York, NY, USA, 453-472. DOI: -- -- -- The paper describes a new algorithm /SplitMix/ for /splittable/ -- pseudorandom number generator that is quite fast: 9 64 bit arithmetic/logical -- operations per 64 bits generated. -- -- /SplitMix/ is tested with two standard statistical test suites (DieHarder and -- TestU01, this implementation only using the former) and it appears to be -- adequate for "everyday" use, such as Monte Carlo algorithms and randomized -- data structures where speed is important. -- -- In particular, it __should not be used for cryptographic or security applications__, -- because generated sequences of pseudorandom values are too predictable -- (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, nextWord32, nextTwoWord32, nextInt, nextDouble, nextFloat, nextInteger, splitSMGen, -- * Generation bitmaskWithRejection32, bitmaskWithRejection32', bitmaskWithRejection64, bitmaskWithRejection64', -- * Initialisation mkSMGen, initSMGen, newSMGen, seedSMGen, seedSMGen', unseedSMGen, ) where import Data.Bits (complement, shiftL, shiftR, xor, (.&.), (.|.)) import Data.Bits.Compat (countLeadingZeros, popCount, zeroBits) import Data.IORef (IORef, atomicModifyIORef, newIORef) import Data.Word (Word32, Word64) import System.IO.Unsafe (unsafePerformIO) import System.Random.SplitMix.Init #if defined(__HUGS__) || !MIN_VERSION_base(4,8,0) import Data.Word (Word) #endif #ifndef __HUGS__ import Control.DeepSeq (NFData (..)) #endif -- $setup -- >>> import Text.Read (readMaybe) -- >>> import Data.List (unfoldr) -- >>> import Text.Printf (printf) ------------------------------------------------------------------------------- -- Generator ------------------------------------------------------------------------------- -- | SplitMix generator state. data SMGen = SMGen !Word64 !Word64 -- seed and gamma; gamma is odd deriving Show #ifndef __HUGS__ instance NFData SMGen where rnf (SMGen _ _) = () #endif -- | -- -- >>> readMaybe "SMGen 1 1" :: Maybe SMGen -- Just (SMGen 1 1) -- -- >>> readMaybe "SMGen 1 2" :: Maybe SMGen -- Nothing -- -- >>> readMaybe (show (mkSMGen 42)) :: Maybe SMGen -- Just (SMGen 9297814886316923340 13679457532755275413) -- instance Read SMGen where readsPrec d r = readParen (d > 10) (\r0 -> [ (SMGen seed gamma, r3) | ("SMGen", r1) <- lex r0 , (seed, r2) <- readsPrec 11 r1 , (gamma, r3) <- readsPrec 11 r2 , odd gamma ]) r ------------------------------------------------------------------------------- -- Operations ------------------------------------------------------------------------------- -- | Generate a 'Word64'. -- -- >>> take 3 $ map (printf "%x") $ unfoldr (Just . nextWord64) (mkSMGen 1337) :: [String] -- ["b5c19e300e8b07b3","d600e0e216c0ac76","c54efc3b3cc5af29"] -- nextWord64 :: SMGen -> (Word64, SMGen) nextWord64 (SMGen seed gamma) = (mix64 seed', SMGen seed' gamma) where seed' = seed `plus` gamma -- | Generate 'Word32' by truncating 'nextWord64'. -- -- @since 0.0.3 nextWord32 :: SMGen -> (Word32, SMGen) nextWord32 g = #ifdef __HUGS__ (fromIntegral $ w64 .&. 0xffffffff, g') #else (fromIntegral w64, g') #endif where (w64, g') = nextWord64 g -- | Generate two 'Word32'. -- -- @since 0.0.3 nextTwoWord32 :: SMGen -> (Word32, Word32, SMGen) nextTwoWord32 g = #ifdef __HUGS__ (fromIntegral $ w64 `shiftR` 32, fromIntegral $ w64 .&. 0xffffffff, g') #else (fromIntegral $ w64 `shiftR` 32, fromIntegral w64, g') #endif where (w64, g') = nextWord64 g -- | Generate an 'Int'. nextInt :: SMGen -> (Int, SMGen) nextInt g = case nextWord64 g of #ifdef __HUGS__ (w64, g') -> (fromIntegral $ w64 `shiftR` 32, g') #else (w64, g') -> (fromIntegral w64, g') #endif -- | Generate a 'Double' in @[0, 1)@ range. -- -- >>> take 8 $ map (printf "%0.3f") $ unfoldr (Just . nextDouble) (mkSMGen 1337) :: [String] -- ["0.710","0.836","0.771","0.409","0.297","0.527","0.589","0.067"] -- nextDouble :: SMGen -> (Double, SMGen) nextDouble g = case nextWord64 g of (w64, g') -> (fromIntegral (w64 `shiftR` 11) * doubleUlp, g') -- | Generate a 'Float' in @[0, 1)@ range. -- -- >>> take 8 $ map (printf "%0.3f") $ unfoldr (Just . nextFloat) (mkSMGen 1337) :: [String] -- ["0.057","0.089","0.237","0.383","0.680","0.320","0.826","0.007"] -- -- @since 0.0.3 nextFloat :: SMGen -> (Float, SMGen) nextFloat g = case nextWord32 g of (w32, g') -> (fromIntegral (w32 `shiftR` 8) * floatUlp, g') -- | Generate an 'Integer' in closed @[x, y]@ range. nextInteger :: Integer -> Integer -> SMGen -> (Integer, SMGen) nextInteger lo hi g = case compare lo hi of LT -> let (i, g') = nextInteger' (hi - lo) g in (i + lo, g') EQ -> (lo, g) GT -> let (i, g') = nextInteger' (lo - hi) g in (i + hi, g') -- invariant: first argument is positive -- Essentially bitmaskWithRejection but for Integers. -- nextInteger' :: Integer -> SMGen -> (Integer, SMGen) nextInteger' range = loop where leadMask :: Word64 restDigits :: Word (leadMask, restDigits) = go 0 range where go :: Word -> Integer -> (Word64, Word) go n x | x < two64 = (complement zeroBits `shiftR` countLeadingZeros (fromInteger x :: Word64), n) | otherwise = go (n + 1) (x `shiftR` 64) generate :: SMGen -> (Integer, SMGen) generate g0 = let (x, g') = nextWord64 g0 x' = x .&. leadMask in go (fromIntegral x') restDigits g' where go :: Integer -> Word -> SMGen -> (Integer, SMGen) go acc 0 g = acc `seq` (acc, g) go acc n g = let (x, g') = nextWord64 g in go (acc * two64 + fromIntegral x) (n - 1) g' loop g = let (x, g') = generate g in if x > range then loop g' else (x, g') two64 :: Integer two64 = 2 ^ (64 :: Int) ------------------------------------------------------------------------------- -- Splitting ------------------------------------------------------------------------------- -- | Split a generator into a two uncorrelated generators. splitSMGen :: SMGen -> (SMGen, SMGen) splitSMGen (SMGen seed gamma) = (SMGen seed'' gamma, SMGen (mix64 seed') (mixGamma seed'')) where seed' = seed `plus` gamma seed'' = seed' `plus` gamma ------------------------------------------------------------------------------- -- Algorithm ------------------------------------------------------------------------------- goldenGamma :: Word64 goldenGamma = 0x9e3779b97f4a7c15 floatUlp :: Float floatUlp = 1.0 / fromIntegral (1 `shiftL` 24 :: Word32) doubleUlp :: Double doubleUlp = 1.0 / fromIntegral (1 `shiftL` 53 :: Word64) -- Note: in JDK implementations the mix64 and mix64variant13 -- (which is inlined into mixGamma) are swapped. mix64 :: Word64 -> Word64 mix64 z0 = -- MurmurHash3Mixer let z1 = shiftXorMultiply 33 0xff51afd7ed558ccd z0 z2 = shiftXorMultiply 33 0xc4ceb9fe1a85ec53 z1 z3 = shiftXor 33 z2 in z3 -- used only in mixGamma mix64variant13 :: Word64 -> Word64 mix64variant13 z0 = -- Better Bit Mixing - Improving on MurmurHash3's 64-bit Finalizer -- http://zimbry.blogspot.fi/2011/09/better-bit-mixing-improving-on.html -- -- Stafford's Mix13 let z1 = shiftXorMultiply 30 0xbf58476d1ce4e5b9 z0 -- MurmurHash3 mix constants z2 = shiftXorMultiply 27 0x94d049bb133111eb z1 z3 = shiftXor 31 z2 in z3 mixGamma :: Word64 -> Word64 mixGamma z0 = let z1 = mix64variant13 z0 .|. 1 -- force to be odd n = popCount (z1 `xor` (z1 `shiftR` 1)) -- see: http://www.pcg-random.org/posts/bugs-in-splitmix.html -- let's trust the text of the paper, not the code. in if n >= 24 then z1 else z1 `xor` 0xaaaaaaaaaaaaaaaa shiftXor :: Int -> Word64 -> Word64 shiftXor n w = w `xor` (w `shiftR` n) shiftXorMultiply :: Int -> Word64 -> Word64 -> Word64 shiftXorMultiply n k w = shiftXor n w `mult` k ------------------------------------------------------------------------------- -- Generation ------------------------------------------------------------------------------- -- | /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'. -- -- @bitmaskWithRejection64 w64@ generates random numbers in closed-open -- range of @[0, w64)@. -- -- >>> take 20 $ unfoldr (Just . bitmaskWithRejection64 5) (mkSMGen 1337) -- [3,1,4,1,2,3,1,1,0,3,4,2,3,0,2,3,3,4,1,0] -- -- @since 0.0.3 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 mask = complement zeroBits `shiftR` countLeadingZeros (range .|. 1) go g = let (x, g') = nextWord32 g x' = x .&. mask in if x' > range then go g' else (x', g') {-# INLINEABLE bitmaskWithRejection32' #-} -- | /Bitmask with rejection/ method of generating subrange of 'Word64'. -- -- @bitmaskWithRejection64' w64@ generates random numbers in closed-closed -- range of @[0, w64]@. -- -- >>> take 20 $ unfoldr (Just . bitmaskWithRejection64' 5) (mkSMGen 1337) -- [3,1,4,1,2,3,1,1,0,3,4,5,2,3,0,2,3,5,3,4] -- -- @since 0.0.4 bitmaskWithRejection64' :: Word64 -> SMGen -> (Word64, SMGen) bitmaskWithRejection64' range = go where mask = complement zeroBits `shiftR` countLeadingZeros range go g = let (x, g') = nextWord64 g x' = x .&. mask in if x' > range then go g' else (x', g') {-# INLINEABLE bitmaskWithRejection64' #-} ------------------------------------------------------------------------------- -- Initialisation ------------------------------------------------------------------------------- -- | Create 'SMGen' using seed and gamma. -- -- >>> seedSMGen 2 2 -- SMGen 2 3 -- seedSMGen :: Word64 -- ^ seed -> Word64 -- ^ gamma -> SMGen seedSMGen seed gamma = SMGen seed (gamma .|. 1) -- | Like 'seedSMGen' but takes a pair. seedSMGen' :: (Word64, Word64) -> SMGen seedSMGen' = uncurry seedSMGen -- | Extract current state of 'SMGen'. unseedSMGen :: SMGen -> (Word64, Word64) unseedSMGen (SMGen seed gamma) = (seed, gamma) -- | Preferred way to deterministically construct 'SMGen'. -- -- >>> mkSMGen 42 -- SMGen 9297814886316923340 13679457532755275413 -- mkSMGen :: Word64 -> SMGen mkSMGen s = SMGen (mix64 s) (mixGamma (s `plus` goldenGamma)) -- | Initialize 'SMGen' using entropy available on the system (time, ...) initSMGen :: IO SMGen initSMGen = fmap mkSMGen initialSeed -- | Derive a new generator instance from the global 'SMGen' using 'splitSMGen'. newSMGen :: IO SMGen newSMGen = atomicModifyIORef theSMGen splitSMGen theSMGen :: IORef SMGen theSMGen = unsafePerformIO $ initSMGen >>= newIORef {-# NOINLINE theSMGen #-} ------------------------------------------------------------------------------- -- Hugs ------------------------------------------------------------------------------- mult, plus :: Word64 -> Word64 -> Word64 #ifndef __HUGS__ mult = (*) plus = (+) #else -- Hugs defines: -- -- x * y = fromInteger (toInteger x * toInteger y) -- x + y = fromInteger (toInteger x + toInteger y) -- -- which obviously overflows in our use cases, as fromInteger doesn't truncate -- mult x y = fromInteger ((toInteger x * toInteger y) `mod` 18446744073709551616) plus x y = fromInteger ((toInteger x + toInteger y) `mod` 18446744073709551616) #endif splitmix-0.1.0.5/src/System/Random/SplitMix/0000755000000000000000000000000007346545000016761 5ustar0000000000000000splitmix-0.1.0.5/src/System/Random/SplitMix/Init.hs0000644000000000000000000000206407346545000020222 0ustar0000000000000000{-# 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 splitmix-0.1.0.5/src/System/Random/SplitMix32.hs0000644000000000000000000002755207346545000017475 0ustar0000000000000000-- | -- /SplitMix/ is a splittable pseudorandom number generator (PRNG) that is quite fast. -- -- This is 32bit variant (original one is 32 bit). -- -- 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, nextWord64, nextTwoWord32, nextInt, nextDouble, nextFloat, nextInteger, splitSMGen, -- * Generation bitmaskWithRejection32, bitmaskWithRejection32', bitmaskWithRejection64, bitmaskWithRejection64', -- * Initialisation mkSMGen, initSMGen, newSMGen, seedSMGen, seedSMGen', unseedSMGen, ) where import Data.Bits (complement, shiftL, shiftR, xor, (.&.), (.|.)) import Data.Bits.Compat (countLeadingZeros, finiteBitSize, popCount, zeroBits) import Data.IORef (IORef, atomicModifyIORef, newIORef) import Data.Word (Word32, Word64) import System.IO.Unsafe (unsafePerformIO) import System.Random.SplitMix.Init #if defined(__HUGS__) || !MIN_VERSION_base(4,8,0) import Data.Word (Word) #endif #ifndef __HUGS__ import Control.DeepSeq (NFData (..)) #endif -- $setup -- >>> import Text.Read (readMaybe) -- >>> import Data.List (unfoldr) -- >>> import Text.Printf (printf) ------------------------------------------------------------------------------- -- Generator ------------------------------------------------------------------------------- -- | SplitMix generator state. data SMGen = SMGen {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 -- seed and gamma; gamma is odd deriving Show #ifndef __HUGS__ instance NFData SMGen where rnf (SMGen _ _) = () #endif -- | -- -- >>> readMaybe "SMGen 1 1" :: Maybe SMGen -- Just (SMGen 1 1) -- -- >>> readMaybe "SMGen 1 2" :: Maybe SMGen -- Nothing -- -- >>> readMaybe (show (mkSMGen 42)) :: Maybe SMGen -- Just (SMGen 142593372 1604540297) -- instance Read SMGen where readsPrec d r = readParen (d > 10) (\r0 -> [ (SMGen seed gamma, r3) | ("SMGen", r1) <- lex r0 , (seed, r2) <- readsPrec 11 r1 , (gamma, r3) <- readsPrec 11 r2 , odd gamma ]) r ------------------------------------------------------------------------------- -- Operations ------------------------------------------------------------------------------- -- | Generate a 'Word32'. -- -- >>> take 3 $ map (printf "%x") $ unfoldr (Just . nextWord32) (mkSMGen 1337) :: [String] -- ["e0cfe722","a6ced0f0","c3a6d889"] -- nextWord32 :: SMGen -> (Word32, SMGen) nextWord32 (SMGen seed gamma) = (mix32 seed', SMGen seed' gamma) where seed' = seed + gamma -- | Generate a 'Word64', by generating to 'Word32's. nextWord64 :: SMGen -> (Word64, SMGen) nextWord64 s0 = (fromIntegral w0 `shiftL` 32 .|. fromIntegral w1, s2) where (w0, s1) = nextWord32 s0 (w1, s2) = nextWord32 s1 -- | Generate two 'Word32'. nextTwoWord32 :: SMGen -> (Word32, Word32, SMGen) nextTwoWord32 s0 = (w0, w1, s2) where (w0, s1) = nextWord32 s0 (w1, s2) = nextWord32 s1 -- | Generate an 'Int'. nextInt :: SMGen -> (Int, SMGen) nextInt g | isBigInt = int64 | otherwise = int32 where int32 = case nextWord32 g of (w, g') -> (fromIntegral w, g') int64 = case nextWord64 g of (w, g') -> (fromIntegral w, g') isBigInt :: Bool isBigInt = finiteBitSize (undefined :: Int) > 32 -- | Generate a 'Double' in @[0, 1)@ range. -- -- >>> take 8 $ map (printf "%0.3f") $ unfoldr (Just . nextDouble) (mkSMGen 1337) :: [String] -- ["0.878","0.764","0.063","0.845","0.262","0.490","0.176","0.544"] -- nextDouble :: SMGen -> (Double, SMGen) nextDouble g = case nextWord64 g of (w64, g') -> (fromIntegral (w64 `shiftR` 11) * doubleUlp, g') -- | Generate a 'Float' in @[0, 1)@ range. -- -- >>> take 8 $ map (printf "%0.3f") $ unfoldr (Just . nextFloat) (mkSMGen 1337) :: [String] -- ["0.878","0.652","0.764","0.631","0.063","0.180","0.845","0.645"] -- nextFloat :: SMGen -> (Float, SMGen) nextFloat g = case nextWord32 g of (w32, g') -> (fromIntegral (w32 `shiftR` 8) * floatUlp, g') -- | Generate an 'Integer' in closed @[x, y]@ range. nextInteger :: Integer -> Integer -> SMGen -> (Integer, SMGen) nextInteger lo hi g = case compare lo hi of LT -> let (i, g') = nextInteger' (hi - lo) g in (i + lo, g') EQ -> (lo, g) GT -> let (i, g') = nextInteger' (lo - hi) g in (i + hi, g') -- invariant: first argument is positive -- Essentially bitmaskWithRejection but for Integers. -- nextInteger' :: Integer -> SMGen -> (Integer, SMGen) nextInteger' range = loop where leadMask :: Word32 restDigits :: Word (leadMask, restDigits) = go 0 range where go :: Word -> Integer -> (Word32, Word) go n x | x < two32 = (complement zeroBits `shiftR` countLeadingZeros (fromInteger x :: Word32), n) | otherwise = go (n + 1) (x `shiftR` 32) generate :: SMGen -> (Integer, SMGen) generate g0 = let (x, g') = nextWord32 g0 x' = x .&. leadMask in go (fromIntegral x') restDigits g' where go :: Integer -> Word -> SMGen -> (Integer, SMGen) go acc 0 g = acc `seq` (acc, g) go acc n g = let (x, g') = nextWord32 g in go (acc * two32 + fromIntegral x) (n - 1) g' loop g = let (x, g') = generate g in if x > range then loop g' else (x, g') two32 :: Integer two32 = 2 ^ (32 :: Int) ------------------------------------------------------------------------------- -- Splitting ------------------------------------------------------------------------------- -- | Split a generator into a two uncorrelated generators. splitSMGen :: SMGen -> (SMGen, SMGen) splitSMGen (SMGen seed gamma) = (SMGen seed'' gamma, SMGen (mix32 seed') (mixGamma seed'')) where seed' = seed + gamma seed'' = seed' + gamma ------------------------------------------------------------------------------- -- Algorithm ------------------------------------------------------------------------------- -- | (1 + sqrt 5) / 2 * (2 ^^ bits) goldenGamma :: Word32 goldenGamma = 0x9e3779b9 floatUlp :: Float floatUlp = 1.0 / fromIntegral (1 `shiftL` 24 :: Word32) doubleUlp :: Double doubleUlp = 1.0 / fromIntegral (1 `shiftL` 53 :: Word64) #if defined(__GHCJS__) && defined(OPTIMISED_MIX32) -- JavaScript Foreign Function Interface -- https://github.com/ghcjs/ghcjs/blob/master/doc/foreign-function-interface.md foreign import javascript unsafe "var x0 = $1 ^ $1 >>> 16; var x1 = x0 & 0xffff; var x2 = (((x0 >>> 16 & 0xffff) * 0x0000ca6b + x1 * 0x000085eb & 0xffff) << 16) + x1 * 0x0000ca6b; var x3 = x2 ^ x2 >>> 13; var x4 = x3 & 0xffff; var x5 = (((x3 >>> 16 & 0xffff) * 0x0000ae35 + x4 * 0x0000c2b2 & 0xffff) << 16) + x4 * 0x0000ae35; $r = (x5 ^ x5 >>> 16) | 0;" mix32 :: Word32 -> Word32 foreign import javascript unsafe "var x0 = $1 ^ $1 >>> 16; var x1 = x0 & 0xffff; var x2 = (((x0 >>> 16 & 0xffff) * 0x00006ccb + x1 * 0x000069ad & 0xffff) << 16) + x1 * 0x00006ccb; var x3 = x2 ^ x2 >>> 13; var x4 = x3 & 0xffff; var x5 = (((x3 >>> 16 & 0xffff) * 0x0000b5b3 + x4 * 0x0000cd9a & 0xffff) << 16) + x4 * 0x0000b5b3; $r = (x5 ^ x5 >>> 16) | 0;" mix32variant13 :: Word32 -> Word32 #else mix32 :: Word32 -> Word32 mix32 z0 = -- MurmurHash3Mixer 32bit let z1 = shiftXorMultiply 16 0x85ebca6b z0 z2 = shiftXorMultiply 13 0xc2b2ae35 z1 z3 = shiftXor 16 z2 in z3 -- used only in mixGamma mix32variant13 :: Word32 -> Word32 mix32variant13 z0 = -- See avalanche "executable" let z1 = shiftXorMultiply 16 0x69ad6ccb z0 z2 = shiftXorMultiply 13 0xcd9ab5b3 z1 z3 = shiftXor 16 z2 in z3 shiftXor :: Int -> Word32 -> Word32 shiftXor n w = w `xor` (w `shiftR` n) shiftXorMultiply :: Int -> Word32 -> Word32 -> Word32 shiftXorMultiply n k w = shiftXor n w * k #endif mixGamma :: Word32 -> Word32 mixGamma z0 = let z1 = mix32variant13 z0 .|. 1 -- force to be odd n = popCount (z1 `xor` (z1 `shiftR` 1)) -- see: http://www.pcg-random.org/posts/bugs-in-splitmix.html -- let's trust the text of the paper, not the code. in if n >= 12 then z1 else z1 `xor` 0xaaaaaaaa ------------------------------------------------------------------------------- -- Generation ------------------------------------------------------------------------------- -- | /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'. -- -- @bitmaskWithRejection64 w64@ generates random numbers in closed-open -- range of @[0, w64)@. -- -- >>> take 20 $ unfoldr (Just . bitmaskWithRejection64 5) (mkSMGen 1337) -- [0,2,4,2,1,4,2,4,2,2,3,0,3,2,2,2,3,1,2,2] -- 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 mask = complement zeroBits `shiftR` countLeadingZeros (range .|. 1) go g = let (x, g') = nextWord32 g x' = x .&. mask in if x' > range then go g' else (x', g') {-# INLINEABLE bitmaskWithRejection32' #-} -- | /Bitmask with rejection/ method of generating subrange of 'Word64'. -- -- @bitmaskWithRejection64' w64@ generates random numbers in closed-closed -- range of @[0, w64]@. -- -- >>> take 20 $ unfoldr (Just . bitmaskWithRejection64' 5) (mkSMGen 1337) -- [0,2,4,2,1,4,2,4,5,5,2,2,5,3,5,0,3,2,2,2] -- -- @since 0.0.4 bitmaskWithRejection64' :: Word64 -> SMGen -> (Word64, SMGen) bitmaskWithRejection64' range = go where mask = complement zeroBits `shiftR` countLeadingZeros (range .|. 1) go g = let (x, g') = nextWord64 g x' = x .&. mask in if x' > range then go g' else (x', g') {-# INLINEABLE bitmaskWithRejection64' #-} ------------------------------------------------------------------------------- -- Initialisation ------------------------------------------------------------------------------- -- | Create 'SMGen' using seed and gamma. -- -- >>> seedSMGen 2 2 -- SMGen 2 3 -- seedSMGen :: Word32 -- ^ seed -> Word32 -- ^ gamma -> SMGen seedSMGen seed gamma = SMGen seed (gamma .|. 1) -- | Like 'seedSMGen' but takes a pair. seedSMGen' :: (Word32, Word32) -> SMGen seedSMGen' = uncurry seedSMGen -- | Extract current state of 'SMGen'. unseedSMGen :: SMGen -> (Word32, Word32) unseedSMGen (SMGen seed gamma) = (seed, gamma) -- | Preferred way to deterministically construct 'SMGen'. -- -- >>> mkSMGen 42 -- SMGen 142593372 1604540297 -- mkSMGen :: Word32 -> SMGen mkSMGen s = SMGen (mix32 s) (mixGamma (s + goldenGamma)) -- | Initialize 'SMGen' using entropy available on the system (time, ...) initSMGen :: IO SMGen initSMGen = fmap mkSMGen initialSeed' -- | Derive a new generator instance from the global 'SMGen' using 'splitSMGen'. newSMGen :: IO SMGen newSMGen = atomicModifyIORef theSMGen splitSMGen theSMGen :: IORef SMGen theSMGen = unsafePerformIO $ initSMGen >>= newIORef {-# NOINLINE theSMGen #-} initialSeed' :: IO Word32 initialSeed' = do w64 <- initialSeed return (fromIntegral (shiftR w64 32) `xor` fromIntegral w64) splitmix-0.1.0.5/test-hugs.sh0000644000000000000000000000517507346545000014204 0ustar0000000000000000#!/bin/sh set -e CABAL=${CABAL:-cabal} HC=${HC:-ghc} # Install cpphs if it is not in path command -v cpphs || ${CABAL} v2-install --ignore-project --with-compiler "$HC" cpphs # Regenerate splitmix-hugs sh make-hugs.sh find splitmix-hugs die() { echo "TEST FAILED" exit 1 } dotest() { echo "TEST $2" echo "$2" | hugs -98 -P:splitmix-hugs -p'> ' "$1" | tee hugs.output grep "$3" hugs.output || die } # Simple tests dotest System.Random.SplitMix "nextInteger (-100) 73786976294838206464 (mkSMGen 42)" "(10417309031967932979,SMGen 18209985878117922550 13679457532755275413)" dotest System.Random.SplitMix32 "nextInteger (-100) 73786976294838206464 (mkSMGen 42)" "(63481308251723623759,SMGen 2735861347 1604540297)" dotest System.Random.SplitMix "nextWord64 (mkSMGen 42)" "(1275548033995301424,SMGen 4530528345362647137 13679457532755275413)" dotest System.Random.SplitMix "nextWord32 (mkSMGen 42)" "(3292324400,SMGen 4530528345362647137 13679457532755275413)" dotest System.Random.SplitMix "nextTwoWord32 (mkSMGen 42)" "(296986669,3292324400,SMGen 4530528345362647137 13679457532755275413)" dotest System.Random.SplitMix "nextInt (mkSMGen 42)" "(296986669,SMGen 4530528345362647137 13679457532755275413)" dotest System.Random.SplitMix "nextDouble (mkSMGen 42)" "(0.069147597478366,SMGen 4530528345362647137 13679457532755275413)" dotest System.Random.SplitMix "splitSMGen (mkSMGen 42)" "(SMGen 18209985878117922550 13679457532755275413,SMGen 1275548033995301424 10514482549683702313)" dotest System.Random.SplitMix "bitmaskWithRejection64 9 (mkSMGen 43)" "(5,SMGen 15756003094639068574 13432527470776545161)" dotest System.Random.SplitMix "bitmaskWithRejection64' 9 (mkSMGen 44)" "(1,SMGen 3943641360161606062 18105923034897077331)" dotest System.Random.SplitMix32 "nextWord64 (mkSMGen 42)" "(5568638952296597105,SMGen 3351673966 1604540297)" dotest System.Random.SplitMix32 "nextWord32 (mkSMGen 42)" "(1296549791,SMGen 1747133669 1604540297)" dotest System.Random.SplitMix32 "nextTwoWord32 (mkSMGen 42)" "(1296549791,2315961969,SMGen 3351673966 1604540297)" dotest System.Random.SplitMix32 "nextInt (mkSMGen 42)" "(1296549791,SMGen 1747133669 1604540297)" dotest System.Random.SplitMix32 "nextDouble (mkSMGen 42)" "(0.301876522493369,SMGen 3351673966 1604540297)" dotest System.Random.SplitMix32 "splitSMGen (mkSMGen 42)" "(SMGen 3351673966 1604540297,SMGen 1296549791 306293903)" dotest System.Random.SplitMix32 "bitmaskWithRejection64 9 (mkSMGen 43)" "(1,SMGen 261660480 2569677503)" dotest System.Random.SplitMix32 "bitmaskWithRejection64' 9 (mkSMGen 44)" "(8,SMGen 3882168239 2439575023)" splitmix-0.1.0.5/tests/0000755000000000000000000000000007346545000013057 5ustar0000000000000000splitmix-0.1.0.5/tests/Dieharder.hs0000644000000000000000000002214007346545000015301 0ustar0000000000000000{-# 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" splitmix-0.1.0.5/tests/Examples.hs0000644000000000000000000000050407346545000015170 0ustar0000000000000000module 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" splitmix-0.1.0.5/tests/Initialization.hs0000644000000000000000000000144607346545000016407 0ustar0000000000000000module Main (main) where import Control.Monad (forM_, replicateM) import Data.List (tails) import Test.HUnit (assertFailure) import qualified System.Random.SplitMix as SM import qualified System.Random.SplitMix32 as SM32 main :: IO () main = do g64 <- replicateM 10 (fmap show SM.initSMGen) putStrLn $ unlines g64 forM_ (tails g64) $ \xs' -> case xs' of [] -> return () (x:xs) -> if all (x /=) xs then return () else assertFailure "ERROR: duplicate" g32 <- replicateM 10 (fmap show SM32.initSMGen) putStrLn $ unlines g32 forM_ (tails g32) $ \xs' -> case xs' of [] -> return () (x:xs) -> if all (x /=) xs then return () else assertFailure "ERROR: duplicate" splitmix-0.1.0.5/tests/MiniQC.hs0000644000000000000000000000463107346545000014537 0ustar0000000000000000{-# 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 ("" : 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 splitmix-0.1.0.5/tests/SplitMixPi.hs0000644000000000000000000000123507346545000015456 0ustar0000000000000000module 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') splitmix-0.1.0.5/tests/SplitMixPi32.hs0000644000000000000000000000123307346545000015621 0ustar0000000000000000module 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') splitmix-0.1.0.5/tests/TestU01.hs0000644000000000000000000001342007346545000014620 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module Main (main) where import Prelude () import Prelude.Compat import Data.Char (isSpace) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) import Data.Word (Word32) import System.Environment (getArgs) import System.IO.Unsafe (unsafePerformIO) import qualified System.Random.SplitMix as SM64 import qualified System.Random.SplitMix32 as SM32 ------------------------------------------------------------------------------- -- SplitMix32 ------------------------------------------------------------------------------- sm32ref :: IORef SM32.SMGen sm32ref = unsafePerformIO $ newIORef $ SM32.mkSMGen 42 {-# NOINLINE sm32ref #-} foreign export ccall haskell_splitmix32 :: IO Word32 foreign export ccall haskell_splitmix32_double :: IO Double haskell_splitmix32 :: IO Word32 haskell_splitmix32 = do g <- readIORef sm32ref let !(w32, g') = SM32.nextWord32 g writeIORef sm32ref g' return w32 haskell_splitmix32_double :: IO Double haskell_splitmix32_double = do g <- readIORef sm32ref let !(d, g') = SM32.nextDouble g writeIORef sm32ref g' return d ------------------------------------------------------------------------------- -- SplitMix64 ------------------------------------------------------------------------------- sm64ref :: IORef SM64.SMGen sm64ref = unsafePerformIO $ newIORef $ SM64.mkSMGen 42 {-# NOINLINE sm64ref #-} foreign export ccall haskell_splitmix64 :: IO Word32 foreign export ccall haskell_splitmix64_double :: IO Double haskell_splitmix64 :: IO Word32 haskell_splitmix64 = do g <- readIORef sm64ref let !(w32, g') = SM64.nextWord32 g writeIORef sm64ref g' return w32 haskell_splitmix64_double :: IO Double haskell_splitmix64_double = do g <- readIORef sm64ref let !(d, g') = SM64.nextDouble g writeIORef sm64ref g' return d ------------------------------------------------------------------------------- -- Main ------------------------------------------------------------------------------- foreign import ccall "run_testu01" run_testu01_c :: Int -> Int -> IO () main :: IO () main = do args <- getArgs (gen, bat) <- parseArgsIO args $ (,) <$> optDef "-g" SplitMix <*> optDef "-b" SmallCrush run_testu01_c (fromEnum gen) (fromEnum bat) data Gen = SplitMixDouble | SplitMix | SplitMix32Double | SplitMix32 | SplitMix32Native deriving (Read, Enum) data Bat = SmallCrush | Crush | BigCrush | Sample deriving (Read, Enum) ------------------------------------------------------------------------------- -- 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" splitmix-0.1.0.5/tests/Tests.hs0000644000000000000000000001131007346545000014511 0ustar0000000000000000module 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) splitmix-0.1.0.5/tests/Uniformity.hs0000644000000000000000000000774107346545000015571 0ustar0000000000000000{-# 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) ' ' splitmix-0.1.0.5/tests/cbits/0000755000000000000000000000000007346545000014163 5ustar0000000000000000splitmix-0.1.0.5/tests/cbits/testu01.c0000644000000000000000000000641407346545000015641 0ustar0000000000000000#include "TestU01.h" #include /* Utilities */ inline unsigned int popcount32(uint32_t i) { i = i - ((i >> 1) & 0x55555555); i = (i & 0x33333333) + ((i >> 2) & 0x33333333); return (((i + (i >> 4)) & 0xF0F0F0F) * 0x1010101) >> 24; } inline uint64_t rotl64(uint64_t value, unsigned int count) { return value << count | value >> (64 - count); } /* For comparison, SplitMix32 generator in C */ #define GOLDEN_GAMMA 0x9e3779b9U static uint32_t seed = 0; static uint32_t gamma = 0; uint32_t mix32(uint32_t z) { z = (z ^ (z >> 16)) * 0x85ebca6b; z = (z ^ (z >> 13)) * 0xc2b2ae35; z = (z ^ (z >> 16)); return z; } uint32_t mix32gamma(uint32_t z) { z = (z ^ (z >> 16)) * 0x69ad6ccbU; z = (z ^ (z >> 13)) * 0xcd9ab5b3U; z = (z ^ (z >> 16)); return z; } void splitmix32_init(uint32_t s) { seed = mix32(s); gamma = mix32gamma(s + GOLDEN_GAMMA) | 0x1; if (popcount32(gamma ^ (gamma >> 1)) < 12) { gamma = gamma ^ 0xaaaaaaaa; } } unsigned int splitmix32() { seed = seed + gamma; return mix32(seed); } /* Exported from Haskell */ uint32_t haskell_splitmix32(); unsigned int exported_splitmix32() { return haskell_splitmix32(); } uint32_t haskell_splitmix64(); unsigned int exported_splitmix64() { return haskell_splitmix64(); } double haskell_splitmix64_double(); double haskell_splitmix32_double(); /* Test suite */ int run_testu01(int gen_k, int bat_k) { /* Create TestU01 PRNG object for our generator */ unsigned int (*funcBits)() = NULL; double (*func01)() = NULL; unif01_Gen* gen = NULL; switch (gen_k) { case 0: func01 = haskell_splitmix64_double; gen = unif01_CreateExternGen01 ("SplitMix (Double)", haskell_splitmix64_double); break; case 1: funcBits = exported_splitmix64; gen = unif01_CreateExternGenBits("SplitMix (low 32bit)", exported_splitmix64); break; case 2: func01 = haskell_splitmix32_double; gen = unif01_CreateExternGen01("SplitMix32 (Double)", haskell_splitmix32_double); break; case 3: funcBits = exported_splitmix32; gen = unif01_CreateExternGenBits("SplitMix32", exported_splitmix32); break; default: splitmix32_init(42); printf("Initial state: %u %u\n", seed, gamma); funcBits = splitmix32; gen = unif01_CreateExternGenBits("SplitMix32 (C implementation)", splitmix32); } /* Run the tests. */ switch (bat_k) { case 0: bbattery_SmallCrush(gen); break; case 1: bbattery_Crush(gen); break; case 2: bbattery_BigCrush(gen); break; default: if (funcBits != NULL) { for (int i = 0; i < 32; i++) { printf("%x\n", funcBits()); } } if (func01 != NULL) { for (int i = 0; i < 32; i++) { printf("%.09lf\n", func01()); } } } if (funcBits != NULL) { unif01_DeleteExternGenBits(gen); } else if (func01 != NULL) { unif01_DeleteExternGen01(gen); } return 0; }