splitmix 0.0.4 → 0.0.5
raw patch · 11 files changed
+646/−46 lines, 11 filesdep +base-compatdep +math-functionsdep +test-frameworkdep ~basedep ~base-compat-batteriesdep ~containers
Dependencies added: base-compat, math-functions, test-framework, test-framework-hunit
Dependency ranges changed: base, base-compat-batteries, containers
Files
- Changelog.md +8/−0
- bench/SimpleSum.hs +14/−0
- make-hugs.sh +31/−0
- splitmix.cabal +26/−4
- src-compat/Data/Bits/Compat.hs +1/−2
- src/System/Random/SplitMix.hs +106/−25
- src/System/Random/SplitMix32.hs +59/−15
- test-hugs.sh +48/−0
- tests/MiniQC.hs +83/−0
- tests/Tests.hs +136/−0
- tests/Uniformity.hs +134/−0
Changelog.md view
@@ -1,4 +1,12 @@+# 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)`.
bench/SimpleSum.hs view
@@ -24,6 +24,9 @@ "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@@ -32,12 +35,23 @@ 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)
+ make-hugs.sh view
@@ -0,0 +1,31 @@+#!/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.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: splitmix-version: 0.0.4+version: 0.0.5 synopsis: Fast Splittable PRNG description: Pure Haskell implementation of SplitMix described in@@ -29,7 +29,7 @@ license: BSD3 license-file: LICENSE maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>-bug-reports: https://github.com/phadej/splitmix#issues+bug-reports: https://github.com/phadej/splitmix/issues category: System, Random build-type: Simple tested-with:@@ -43,13 +43,15 @@ || ==8.2.2 || ==8.4.4 || ==8.6.5- || ==8.8.2+ || ==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@@ -138,6 +140,26 @@ , 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@@ -167,7 +189,7 @@ build-depends: async >=2.2.1 && <2.3 , base- , base-compat-batteries >=0.10.5 && <0.11+ , base-compat-batteries >=0.10.5 && <0.12 , bytestring >=0.9.1.8 && <0.11 , deepseq , process >=1.0.1.5 && <1.7
src-compat/Data/Bits/Compat.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-} module Data.Bits.Compat ( popCount, zeroBits,@@ -17,7 +16,7 @@ popCount :: Bits a => a -> Int popCount = go 0 where- go !c 0 = c+ go c 0 = c `seq` c go c w = go (c+1) (w .&. (w - 1)) -- clear the least significant {-# INLINE popCount #-} #endif
src/System/Random/SplitMix.hs view
@@ -26,9 +26,9 @@ -- but GHC-7.0 and GHC-7.2 have slow implementation, as there -- are no native 'popCount'. ---{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Trustworthy #-} #endif module System.Random.SplitMix ( SMGen,@@ -38,6 +38,7 @@ nextInt, nextDouble, nextFloat,+ nextInteger, splitSMGen, -- * Generation bitmaskWithRejection32,@@ -53,7 +54,6 @@ unseedSMGen, ) where -import Control.DeepSeq (NFData (..)) import Data.Bits (complement, shiftL, shiftR, xor, (.&.), (.|.)) import Data.Bits.Compat (countLeadingZeros, popCount, zeroBits) import Data.IORef (IORef, atomicModifyIORef, newIORef)@@ -61,6 +61,14 @@ 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@@ -82,8 +90,10 @@ data SMGen = SMGen !Word64 !Word64 -- seed and gamma; gamma is odd deriving Show +#ifndef __HUGS__ instance NFData SMGen where rnf (SMGen _ _) = ()+#endif -- | --@@ -117,26 +127,42 @@ nextWord64 :: SMGen -> (Word64, SMGen) nextWord64 (SMGen seed gamma) = (mix64 seed', SMGen seed' gamma) where- seed' = seed + gamma+ seed' = seed `plus` gamma -- | Generate 'Word32' by truncating 'nextWord64'. -- -- @since 0.0.3 nextWord32 :: SMGen -> (Word32, SMGen)-nextWord32 g = (fromIntegral w64, g') where+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 = (fromIntegral $ w64 `shiftR` 32, fromIntegral w64, g') where+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. --@@ -157,13 +183,57 @@ 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 + gamma- seed'' = seed' + gamma+ seed' = seed `plus` gamma+ seed'' = seed' `plus` gamma ------------------------------------------------------------------------------- -- Algorithm@@ -214,8 +284,9 @@ shiftXor n w = w `xor` (w `shiftR` n) shiftXorMultiply :: Int -> Word64 -> Word64 -> Word64-shiftXorMultiply n k w = shiftXor n w * k+shiftXorMultiply n k w = shiftXor n w `mult` k + ------------------------------------------------------------------------------- -- Generation -------------------------------------------------------------------------------@@ -224,13 +295,8 @@ -- -- @since 0.0.3 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')+bitmaskWithRejection32 0 = error "bitmaskWithRejection32 0"+bitmaskWithRejection32 n = bitmaskWithRejection32' (n - 1) -- | /Bitmask with rejection/ method of generating subrange of 'Word64'. --@@ -242,13 +308,8 @@ -- -- @since 0.0.3 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')+bitmaskWithRejection64 0 = error "bitmaskWithRejection64 0"+bitmaskWithRejection64 n = bitmaskWithRejection64' (n - 1) -- | /Bitmask with rejection/ method of generating subrange of 'Word32'. --@@ -273,7 +334,7 @@ -- @since 0.0.4 bitmaskWithRejection64' :: Word64 -> SMGen -> (Word64, SMGen) bitmaskWithRejection64' range = go where- mask = complement zeroBits `shiftR` countLeadingZeros (range .|. 1)+ mask = complement zeroBits `shiftR` countLeadingZeros range go g = let (x, g') = nextWord64 g x' = x .&. mask in if x' > range@@ -310,7 +371,7 @@ -- SMGen 9297814886316923340 13679457532755275413 -- mkSMGen :: Word64 -> SMGen-mkSMGen s = SMGen (mix64 s) (mixGamma (s + goldenGamma))+mkSMGen s = SMGen (mix64 s) (mixGamma (s `plus` goldenGamma)) -- | Initialize 'SMGen' using system time. initSMGen :: IO SMGen@@ -344,4 +405,24 @@ 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
src/System/Random/SplitMix32.hs view
@@ -21,6 +21,7 @@ nextInt, nextDouble, nextFloat,+ nextInteger, splitSMGen, -- * Generation bitmaskWithRejection32,@@ -36,7 +37,6 @@ unseedSMGen, ) where -import Control.DeepSeq (NFData (..)) import Data.Bits (complement, shiftL, shiftR, xor, (.&.), (.|.)) import Data.Bits.Compat (countLeadingZeros, finiteBitSize, popCount, zeroBits)@@ -45,6 +45,14 @@ 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@@ -66,8 +74,10 @@ data SMGen = SMGen {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 -- seed and gamma; gamma is odd deriving Show +#ifndef __HUGS__ instance NFData SMGen where rnf (SMGen _ _) = ()+#endif -- | --@@ -147,6 +157,50 @@ 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) =@@ -222,13 +276,8 @@ -- | /Bitmask with rejection/ method of generating subrange of 'Word32'. 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')+bitmaskWithRejection32 0 = error "bitmaskWithRejection32 0"+bitmaskWithRejection32 n = bitmaskWithRejection32' (n - 1) -- | /Bitmask with rejection/ method of generating subrange of 'Word64'. --@@ -239,13 +288,8 @@ -- [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 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')+bitmaskWithRejection64 0 = error "bitmaskWithRejection64 0"+bitmaskWithRejection64 n = bitmaskWithRejection64' (n - 1) -- | /Bitmask with rejection/ method of generating subrange of 'Word32'. --
+ test-hugs.sh view
@@ -0,0 +1,48 @@+#!/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)"
+ tests/MiniQC.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveFunctor #-}+-- | This QC doesn't shrink :(+module MiniQC where++import Control.Monad (ap)+import Data.Int (Int32, Int64)+import Data.Word (Word32, Word64)+import Prelude ()+import Prelude.Compat+import Test.Framework.Providers.API (Test, TestName)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertFailure)++import System.Random.SplitMix++newtype Gen a = Gen { unGen :: SMGen -> a }+ deriving (Functor)++instance Applicative Gen where+ pure x = Gen (const x)+ (<*>) = ap++instance Monad Gen where+ return = pure++ m >>= k = Gen $ \g ->+ let (g1, g2) = splitSMGen g+ in unGen (k (unGen m g1)) g2++class Arbitrary a where+ arbitrary :: Gen a++instance Arbitrary Word32 where+ arbitrary = Gen $ \g -> fst (nextWord32 g)+instance Arbitrary Word64 where+ arbitrary = Gen $ \g -> fst (nextWord64 g)+instance Arbitrary Int32 where+ arbitrary = Gen $ \g -> fromIntegral (fst (nextWord32 g))+instance Arbitrary Int64 where+ arbitrary = Gen $ \g -> fromIntegral (fst (nextWord64 g))+instance Arbitrary Double where+ arbitrary = Gen $ \g -> fst (nextDouble g)++newtype Property = Property { unProperty :: Gen ([String], Bool) }++class Testable a where+ property :: a -> Property++instance Testable Property where+ property = id++instance Testable Bool where+ property b = Property $ pure ([show b], b)++instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where+ property f = Property $ do+ x <- arbitrary+ (xs, b) <- unProperty (property (f x))+ return (show x : xs, b)++forAllBlind :: Testable prop => Gen a -> (a -> prop) -> Property+forAllBlind g f = Property $ do+ x <- g+ (xs, b) <- unProperty (property (f x))+ return ("<blind>" : xs, b)++counterexample :: Testable prop => String -> prop -> Property+counterexample msg prop = Property $ do+ (xs, b) <- unProperty (property prop)+ return (msg : xs, b)++testMiniProperty :: Testable prop => TestName -> prop -> Test+testMiniProperty name prop = testCase name $ do+ g <- newSMGen+ go (100 :: Int) g+ where+ go n _ | n <= 0 = return ()+ go n g = do+ let (g1, g2) = splitSMGen g+ case unGen (unProperty (property prop)) g1 of+ (_, True) -> return ()+ (xs, False) -> assertFailure (unlines (reverse xs))+ go (pred n) g2
+ tests/Tests.hs view
@@ -0,0 +1,136 @@+module Main (main) where++import Data.Bits ((.&.))+import Data.Int (Int64)+import Data.Word (Word64)+import Test.Framework (defaultMain, testGroup)++import qualified System.Random.SplitMix as SM+import qualified System.Random.SplitMix32 as SM32++import MiniQC (Arbitrary (..), Gen (..), counterexample, testMiniProperty)+import Uniformity++main :: IO ()+main = defaultMain+ [ testUniformity "SM64 uniformity" (arbitrary :: Gen Word64) (.&. 0xf) 16+ , testUniformity "SM64 uniformity" (arbitrary :: Gen Word64) (.&. 0xf0) 16++ , testUniformity "bitmaskWithRejection uniformity" (arbitrary :: Gen Word64mod7) id 7++ , testGroup "nextInteger"+ [ testMiniProperty "valid" $ \a b c d seed -> do+ let lo' = fromIntegral (a :: Int64) * fromIntegral (b :: Int64)+ hi' = fromIntegral (c :: Int64) * fromIntegral (d :: Int64)++ lo = min lo' hi'+ hi = max lo' hi'++ let g = SM.mkSMGen seed+ (x, _) = SM.nextInteger lo' hi' g++ counterexample (show x) $ lo <= x && x <= hi++ , testMiniProperty "valid small" $ \a b seed -> do+ let lo' = fromIntegral (a :: Int64) `rem` 10+ hi' = fromIntegral (b :: Int64) `rem` 10++ lo = min lo' hi'+ hi = max lo' hi'++ let g = SM.mkSMGen seed+ (x, _) = SM.nextInteger lo' hi' g++ counterexample (show x) $ lo <= x && x <= hi++ , testMiniProperty "I1 valid" i1valid+ , testUniformity "I1 uniform" arbitrary (\(I1 w) -> w) 15++ , testMiniProperty "I7 valid" i7valid+ , testUniformity "I7 uniform" arbitrary (\(I7 w) -> w `mod` 7) 7+ ]++ , testGroup "SM bitmaskWithRejection"+ [ testMiniProperty "64" $ \w' seed -> do+ let w = w' .&. 0xff+ let w1 = w + 1+ let g = SM.mkSMGen seed+ let (x, _) = SM.bitmaskWithRejection64 w1 g+ counterexample ("64-64 " ++ show x ++ " <= " ++ show w) (x < w1)+ , testMiniProperty "64'" $ \w' seed -> do+ let w = w' .&. 0xff+ let g = SM.mkSMGen seed+ let (x, _) = SM.bitmaskWithRejection64' w g+ counterexample ("64-64 " ++ show x ++ " < " ++ show w) (x <= w)+ , testMiniProperty "32" $ \w' seed -> do+ let w = w' .&. 0xff+ let u1 = w'+ let g = SM.mkSMGen seed+ let (x, _) = SM.bitmaskWithRejection32 u1 g+ counterexample ("64-32 " ++ show x ++ " <= " ++ show w) (x < u1)+ , testMiniProperty "32'" $ \w' seed -> do+ let w = w' .&. 0xff+ let u = w+ let g = SM.mkSMGen seed+ let (x, _) = SM.bitmaskWithRejection32' u g+ counterexample ("64-32 " ++ show x ++ " < " ++ show w) (x <= u)+ ]+ , testGroup "SM32 bitmaskWithRejection"+ [ testMiniProperty "64" $ \w' seed -> do+ let w = w' .&. 0xff+ let w1 = w + 1+ let g = SM32.mkSMGen seed+ let (x, _) = SM32.bitmaskWithRejection64 w1 g+ counterexample ("64-64 " ++ show x ++ " <= " ++ show w) (x < w1)+ , testMiniProperty "64'" $ \w' seed -> do+ let w = w' .&. 0xff+ let g = SM32.mkSMGen seed+ let (x, _) = SM32.bitmaskWithRejection64' w g+ counterexample ("64-64 " ++ show x ++ " < " ++ show w) (x <= w)+ , testMiniProperty "32" $ \w' seed -> do+ let w = w' .&. 0xff+ let u1 = w'+ let g = SM32.mkSMGen seed+ let (x, _) = SM32.bitmaskWithRejection32 u1 g+ counterexample ("64-32 " ++ show x ++ " <= " ++ show w) (x < u1)+ , testMiniProperty "32'" $ \w' seed -> do+ let w = w' .&. 0xff+ let u = w+ let g = SM32.mkSMGen seed+ let (x, _) = SM32.bitmaskWithRejection32' u g+ counterexample ("64-32 " ++ show x ++ " < " ++ show w) (x <= u)+ ]+ ]++newtype Word64mod7 = W7 Word64 deriving (Eq, Ord, Show)+instance Arbitrary Word64mod7 where+ arbitrary = Gen $ \g -> W7 $ fst $ SM.bitmaskWithRejection64' 6 g++newtype Integer1 = I1 Integer deriving (Eq, Ord, Show)+instance Arbitrary Integer1 where+ arbitrary = Gen $ \g -> I1 $ fst $ SM.nextInteger i1min i1max g++i1min :: Integer+i1min = -7++i1max :: Integer+i1max = 7++i1valid :: Integer1 -> Bool+i1valid (I1 i) = i1min <= i && i <= i1max++newtype Integer7 = I7 Integer deriving (Eq, Ord, Show)+instance Arbitrary Integer7 where+ arbitrary = Gen $ \g -> I7 $ fst $ SM.nextInteger i7min i7max g++i7min :: Integer+i7min = negate two64++i7max :: Integer+i7max = two64 * 6 + 7 * 1234567++i7valid :: Integer7 -> Bool+i7valid (I7 i) = i7min <= i && i <= i7max++two64 :: Integer+two64 = 2 ^ (64 :: Int)
+ tests/Uniformity.hs view
@@ -0,0 +1,134 @@+{-# 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) ' '