Hello community, here is the log from the commit of package ghc-splitmix for openSUSE:Factory checked in at 2020-06-19 17:18:34 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-splitmix (Old) and /work/SRC/openSUSE:Factory/.ghc-splitmix.new.3606 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-splitmix" Fri Jun 19 17:18:34 2020 rev:5 rq:815179 version:0.0.5 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-splitmix/ghc-splitmix.changes 2020-03-09 14:17:05.366653165 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-splitmix.new.3606/ghc-splitmix.changes 2020-06-19 17:18:40.295099294 +0200 @@ -1,0 +2,9 @@ +Tue Jun 9 09:53:40 UTC 2020 - [email protected] + +- Update splitmix to version 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. + +------------------------------------------------------------------- @@ -5,4 +14,3 @@ - Upstream has edited the change log file since the last release in - a non-trivial way, i.e. they did more than just add a new entry - at the top. You can review the file at: - http://hackage.haskell.org/package/splitmix-0.0.4/src/Changelog.md + - Add `bitmaskWithRejection32'` and `bitmaskWithRejection64'` + which generate numbers in closed range `[0, n]`. + - Unticked variants generate in closed-open range `[0, n)`. @@ -19,2 +26,0 @@ - # 0.0.3 - Old: ---- splitmix-0.0.4.tar.gz New: ---- splitmix-0.0.5.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-splitmix.spec ++++++ --- /var/tmp/diff_new_pack.dk1TfH/_old 2020-06-19 17:18:41.163101574 +0200 +++ /var/tmp/diff_new_pack.dk1TfH/_new 2020-06-19 17:18:41.167101586 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-splitmix # -# Copyright (c) 2020 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2020 SUSE LLC # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name splitmix %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.0.4 +Version: 0.0.5 Release: 0 Summary: Fast Splittable PRNG License: BSD-3-Clause @@ -34,8 +34,13 @@ BuildRequires: ghc-HUnit-devel BuildRequires: ghc-async-devel BuildRequires: ghc-base-compat-batteries-devel +BuildRequires: ghc-base-compat-devel BuildRequires: ghc-bytestring-devel +BuildRequires: ghc-containers-devel +BuildRequires: ghc-math-functions-devel BuildRequires: ghc-process-devel +BuildRequires: ghc-test-framework-devel +BuildRequires: ghc-test-framework-hunit-devel BuildRequires: ghc-tf-random-devel BuildRequires: ghc-vector-devel %endif ++++++ splitmix-0.0.4.tar.gz -> splitmix-0.0.5.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/splitmix-0.0.4/Changelog.md new/splitmix-0.0.5/Changelog.md --- old/splitmix-0.0.4/Changelog.md 2001-09-09 03:46:40.000000000 +0200 +++ new/splitmix-0.0.5/Changelog.md 2001-09-09 03:46:40.000000000 +0200 @@ -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)`. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/splitmix-0.0.4/bench/SimpleSum.hs new/splitmix-0.0.5/bench/SimpleSum.hs --- old/splitmix-0.0.4/bench/SimpleSum.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/splitmix-0.0.5/bench/SimpleSum.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/splitmix-0.0.4/make-hugs.sh new/splitmix-0.0.5/make-hugs.sh --- old/splitmix-0.0.4/make-hugs.sh 1970-01-01 01:00:00.000000000 +0100 +++ new/splitmix-0.0.5/make-hugs.sh 2001-09-09 03:46:40.000000000 +0200 @@ -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." diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/splitmix-0.0.4/splitmix.cabal new/splitmix-0.0.5/splitmix.cabal --- old/splitmix-0.0.4/splitmix.cabal 2001-09-09 03:46:40.000000000 +0200 +++ new/splitmix-0.0.5/splitmix.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -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 <[email protected]> -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/splitmix-0.0.4/src/System/Random/SplitMix.hs new/splitmix-0.0.5/src/System/Random/SplitMix.hs --- old/splitmix-0.0.4/src/System/Random/SplitMix.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/splitmix-0.0.5/src/System/Random/SplitMix.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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,7 +284,8 @@ 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 @@ -345,3 +406,23 @@ 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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/splitmix-0.0.4/src/System/Random/SplitMix32.hs new/splitmix-0.0.5/src/System/Random/SplitMix32.hs --- old/splitmix-0.0.4/src/System/Random/SplitMix32.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/splitmix-0.0.5/src/System/Random/SplitMix32.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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'. -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/splitmix-0.0.4/src-compat/Data/Bits/Compat.hs new/splitmix-0.0.5/src-compat/Data/Bits/Compat.hs --- old/splitmix-0.0.4/src-compat/Data/Bits/Compat.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/splitmix-0.0.5/src-compat/Data/Bits/Compat.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/splitmix-0.0.4/test-hugs.sh new/splitmix-0.0.5/test-hugs.sh --- old/splitmix-0.0.4/test-hugs.sh 1970-01-01 01:00:00.000000000 +0100 +++ new/splitmix-0.0.5/test-hugs.sh 2001-09-09 03:46:40.000000000 +0200 @@ -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)" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/splitmix-0.0.4/tests/MiniQC.hs new/splitmix-0.0.5/tests/MiniQC.hs --- old/splitmix-0.0.4/tests/MiniQC.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/splitmix-0.0.5/tests/MiniQC.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/splitmix-0.0.4/tests/Tests.hs new/splitmix-0.0.5/tests/Tests.hs --- old/splitmix-0.0.4/tests/Tests.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/splitmix-0.0.5/tests/Tests.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/splitmix-0.0.4/tests/Uniformity.hs new/splitmix-0.0.5/tests/Uniformity.hs --- old/splitmix-0.0.4/tests/Uniformity.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/splitmix-0.0.5/tests/Uniformity.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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) ' '
