splitmix-0.0.5/0000755000000000000000000000000007346545000011556 5ustar0000000000000000splitmix-0.0.5/Changelog.md0000644000000000000000000000155407346545000013774 0ustar0000000000000000# 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.0.5/LICENSE0000644000000000000000000000276207346545000012572 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.0.5/README.md0000644000000000000000000000604107346545000013036 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.0.5/Setup.hs0000644000000000000000000000005607346545000013213 0ustar0000000000000000import Distribution.Simple main = defaultMain splitmix-0.0.5/bench/0000755000000000000000000000000007346545000012635 5ustar0000000000000000splitmix-0.0.5/bench/Bench.hs0000644000000000000000000001170007346545000014207 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 :: 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 ] ] splitmix-0.0.5/bench/Range.hs0000644000000000000000000000542007346545000014226 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 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 splitmix-0.0.5/bench/SimpleSum.hs0000644000000000000000000000376107346545000015116 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.0.5/make-hugs.sh0000644000000000000000000000124607346545000013776 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.0.5/splitmix.cabal0000644000000000000000000001244407346545000014420 0ustar0000000000000000cabal-version: >=1.10 name: splitmix version: 0.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/phadej/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 extra-source-files: README.md Changelog.md make-hugs.sh test-hugs.sh flag optimised-mixer description: Use JavaScript for mix32 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 exposed-modules: System.Random.SplitMix System.Random.SplitMix32 -- 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 if flag(optimised-mixer) cpp-options: -DOPTIMISED_MIX32=1 source-repository head type: git location: https://github.com/phadej/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.6 , 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 , clock >=0.8 && <0.9 , random , splitmix 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.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 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.12 , bytestring >=0.9.1.8 && <0.11 , deepseq , process >=1.0.1.5 && <1.7 , random , splitmix , tf-random >=0.5 && <0.6 , vector >=0.11.0.0 && <0.13 splitmix-0.0.5/src-compat/Data/Bits/0000755000000000000000000000000007346545000015400 5ustar0000000000000000splitmix-0.0.5/src-compat/Data/Bits/Compat.hs0000644000000000000000000000161407346545000017161 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.0.5/src/System/Random/0000755000000000000000000000000007346545000015051 5ustar0000000000000000splitmix-0.0.5/src/System/Random/SplitMix.hs0000644000000000000000000003220407346545000017157 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.Time.Clock.POSIX (getPOSIXTime) import Data.Word (Word32, Word64) import System.IO.Unsafe (unsafePerformIO) #if defined(__HUGS__) || !MIN_VERSION_base(4,8,0) import Data.Word (Word) #endif #ifndef __HUGS__ 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) -- >>> 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'. -- -- @since 0.0.3 bitmaskWithRejection32 :: Word32 -> SMGen -> (Word32, SMGen) bitmaskWithRejection32 0 = error "bitmaskWithRejection32 0" bitmaskWithRejection32 n = bitmaskWithRejection32' (n - 1) -- | /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) -- | /Bitmask with rejection/ method of generating subrange of 'Word32'. -- -- @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') -- | /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') ------------------------------------------------------------------------------- -- 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 system time. initSMGen :: IO SMGen initSMGen = fmap mkSMGen mkSeedTime -- | 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 #-} 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 ------------------------------------------------------------------------------- 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.0.5/src/System/Random/SplitMix32.hs0000644000000000000000000003005307346545000017324 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.Time.Clock.POSIX (getPOSIXTime) import Data.Word (Word32, Word64) import System.IO.Unsafe (unsafePerformIO) #if defined(__HUGS__) || !MIN_VERSION_base(4,8,0) import Data.Word (Word) #endif #ifndef __HUGS__ 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) -- >>> 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 :: Word32 -> SMGen -> (Word32, SMGen) bitmaskWithRejection32 0 = error "bitmaskWithRejection32 0" bitmaskWithRejection32 n = bitmaskWithRejection32' (n - 1) -- | /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) -- | /Bitmask with rejection/ method of generating subrange of 'Word32'. -- -- @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') -- | /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') ------------------------------------------------------------------------------- -- 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 system time. initSMGen :: IO SMGen initSMGen = fmap mkSMGen mkSeedTime -- | 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 #-} 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 splitmix-0.0.5/test-hugs.sh0000644000000000000000000000517507346545000014045 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.0.5/tests/0000755000000000000000000000000007346545000012720 5ustar0000000000000000splitmix-0.0.5/tests/Dieharder.hs0000644000000000000000000002213707346545000015150 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.0.5/tests/Examples.hs0000644000000000000000000000050407346545000015031 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.0.5/tests/MiniQC.hs0000644000000000000000000000463107346545000014400 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.0.5/tests/SplitMixPi.hs0000644000000000000000000000123507346545000015317 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.0.5/tests/SplitMixPi32.hs0000644000000000000000000000123307346545000015462 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.0.5/tests/Tests.hs0000644000000000000000000001131007346545000014352 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.0.5/tests/Uniformity.hs0000644000000000000000000000774107346545000015432 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) ' '