{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
module System.Random.SplitMix (
SMGen,
nextWord64,
nextWord32,
nextTwoWord32,
nextInt,
nextDouble,
nextFloat,
nextInteger,
splitSMGen,
bitmaskWithRejection32,
bitmaskWithRejection32',
bitmaskWithRejection64,
bitmaskWithRejection64',
mkSMGen,
initSMGen,
newSMGen,
seedSMGen,
seedSMGen',
unseedSMGen,
) where
import Data.Bits (complement, shiftL, shiftR, xor, (.&.), (.|.))
import Data.Bits.Compat (countLeadingZeros, popCount, zeroBits)
import Data.IORef (IORef, atomicModifyIORef, newIORef)
import Data.Word (Word32, Word64)
import System.IO.Unsafe (unsafePerformIO)
import System.Random.SplitMix.Init
#if defined(__HUGS__) || !MIN_VERSION_base(4,8,0)
import Data.Word (Word)
#endif
#ifndef __HUGS__
import Control.DeepSeq (NFData (..))
#endif
data SMGen = SMGen !Word64 !Word64
deriving Int -> SMGen -> ShowS
[SMGen] -> ShowS
SMGen -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SMGen] -> ShowS
$cshowList :: [SMGen] -> ShowS
show :: SMGen -> String
$cshow :: SMGen -> String
showsPrec :: Int -> SMGen -> ShowS
$cshowsPrec :: Int -> SMGen -> ShowS
Show
#ifndef __HUGS__
instance NFData SMGen where
rnf :: SMGen -> ()
rnf (SMGen Word64
_ Word64
_) = ()
#endif
instance Read SMGen where
readsPrec :: Int -> ReadS SMGen
readsPrec Int
d String
r = forall a. Bool -> ReadS a -> ReadS a
readParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) (\String
r0 ->
[ (Word64 -> Word64 -> SMGen
SMGen Word64
seed Word64
gamma, String
r3)
| (String
"SMGen", String
r1) <- ReadS String
lex String
r0
, (Word64
seed, String
r2) <- forall a. Read a => Int -> ReadS a
readsPrec Int
11 String
r1
, (Word64
gamma, String
r3) <- forall a. Read a => Int -> ReadS a
readsPrec Int
11 String
r2
, forall a. Integral a => a -> Bool
odd Word64
gamma
]) String
r
nextWord64 :: SMGen -> (Word64, SMGen)
nextWord64 :: SMGen -> (Word64, SMGen)
nextWord64 (SMGen Word64
seed Word64
gamma) = (Word64 -> Word64
mix64 Word64
seed', Word64 -> Word64 -> SMGen
SMGen Word64
seed' Word64
gamma)
where
seed' :: Word64
seed' = Word64
seed Word64 -> Word64 -> Word64
`plus` Word64
gamma
nextWord32 :: SMGen -> (Word32, SMGen)
nextWord32 :: SMGen -> (Word32, SMGen)
nextWord32 SMGen
g =
#ifdef __HUGS__
(fromIntegral $ w64 .&. 0xffffffff, g')
#else
(forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w64, SMGen
g')
#endif
where
(Word64
w64, SMGen
g') = SMGen -> (Word64, SMGen)
nextWord64 SMGen
g
nextTwoWord32 :: SMGen -> (Word32, Word32, SMGen)
nextTwoWord32 :: SMGen -> (Word32, Word32, SMGen)
nextTwoWord32 SMGen
g =
#ifdef __HUGS__
(fromIntegral $ w64 `shiftR` 32, fromIntegral $ w64 .&. 0xffffffff, g')
#else
(forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word64
w64 forall a. Bits a => a -> Int -> a
`shiftR` Int
32, forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w64, SMGen
g')
#endif
where
(Word64
w64, SMGen
g') = SMGen -> (Word64, SMGen)
nextWord64 SMGen
g
nextInt :: SMGen -> (Int, SMGen)
nextInt :: SMGen -> (Int, SMGen)
nextInt SMGen
g = case SMGen -> (Word64, SMGen)
nextWord64 SMGen
g of
#ifdef __HUGS__
(w64, g') -> (fromIntegral $ w64 `shiftR` 32, g')
#else
(Word64
w64, SMGen
g') -> (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w64, SMGen
g')
#endif
nextDouble :: SMGen -> (Double, SMGen)
nextDouble :: SMGen -> (Double, SMGen)
nextDouble SMGen
g = case SMGen -> (Word64, SMGen)
nextWord64 SMGen
g of
(Word64
w64, SMGen
g') -> (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w64 forall a. Bits a => a -> Int -> a
`shiftR` Int
11) forall a. Num a => a -> a -> a
* Double
doubleUlp, SMGen
g')
nextFloat :: SMGen -> (Float, SMGen)
nextFloat :: SMGen -> (Float, SMGen)
nextFloat SMGen
g = case SMGen -> (Word32, SMGen)
nextWord32 SMGen
g of
(Word32
w32, SMGen
g') -> (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w32 forall a. Bits a => a -> Int -> a
`shiftR` Int
8) forall a. Num a => a -> a -> a
* Float
floatUlp, SMGen
g')
nextInteger :: Integer -> Integer -> SMGen -> (Integer, SMGen)
nextInteger :: Integer -> Integer -> SMGen -> (Integer, SMGen)
nextInteger Integer
lo Integer
hi SMGen
g = case forall a. Ord a => a -> a -> Ordering
compare Integer
lo Integer
hi of
Ordering
LT -> let (Integer
i, SMGen
g') = Integer -> SMGen -> (Integer, SMGen)
nextInteger' (Integer
hi forall a. Num a => a -> a -> a
- Integer
lo) SMGen
g in (Integer
i forall a. Num a => a -> a -> a
+ Integer
lo, SMGen
g')
Ordering
EQ -> (Integer
lo, SMGen
g)
Ordering
GT -> let (Integer
i, SMGen
g') = Integer -> SMGen -> (Integer, SMGen)
nextInteger' (Integer
lo forall a. Num a => a -> a -> a
- Integer
hi) SMGen
g in (Integer
i forall a. Num a => a -> a -> a
+ Integer
hi, SMGen
g')
nextInteger' :: Integer -> SMGen -> (Integer, SMGen)
nextInteger' :: Integer -> SMGen -> (Integer, SMGen)
nextInteger' Integer
range = SMGen -> (Integer, SMGen)
loop
where
leadMask :: Word64
restDigits :: Word
(Word64
leadMask, Word
restDigits) = Word -> Integer -> (Word64, Word)
go Word
0 Integer
range where
go :: Word -> Integer -> (Word64, Word)
go :: Word -> Integer -> (Word64, Word)
go Word
n Integer
x | Integer
x forall a. Ord a => a -> a -> Bool
< Integer
two64 = (forall a. Bits a => a -> a
complement forall a. Bits a => a
zeroBits forall a. Bits a => a -> Int -> a
`shiftR` forall b. FiniteBits b => b -> Int
countLeadingZeros (forall a. Num a => Integer -> a
fromInteger Integer
x :: Word64), Word
n)
| Bool
otherwise = Word -> Integer -> (Word64, Word)
go (Word
n forall a. Num a => a -> a -> a
+ Word
1) (Integer
x forall a. Bits a => a -> Int -> a
`shiftR` Int
64)
generate :: SMGen -> (Integer, SMGen)
generate :: SMGen -> (Integer, SMGen)
generate SMGen
g0 =
let (Word64
x, SMGen
g') = SMGen -> (Word64, SMGen)
nextWord64 SMGen
g0
x' :: Word64
x' = Word64
x forall a. Bits a => a -> a -> a
.&. Word64
leadMask
in Integer -> Word -> SMGen -> (Integer, SMGen)
go (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x') Word
restDigits SMGen
g'
where
go :: Integer -> Word -> SMGen -> (Integer, SMGen)
go :: Integer -> Word -> SMGen -> (Integer, SMGen)
go Integer
acc Word
0 SMGen
g = Integer
acc seq :: forall a b. a -> b -> b
`seq` (Integer
acc, SMGen
g)
go Integer
acc Word
n SMGen
g =
let (Word64
x, SMGen
g') = SMGen -> (Word64, SMGen)
nextWord64 SMGen
g
in Integer -> Word -> SMGen -> (Integer, SMGen)
go (Integer
acc forall a. Num a => a -> a -> a
* Integer
two64 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x) (Word
n forall a. Num a => a -> a -> a
- Word
1) SMGen
g'
loop :: SMGen -> (Integer, SMGen)
loop SMGen
g = let (Integer
x, SMGen
g') = SMGen -> (Integer, SMGen)
generate SMGen
g
in if Integer
x forall a. Ord a => a -> a -> Bool
> Integer
range
then SMGen -> (Integer, SMGen)
loop SMGen
g'
else (Integer
x, SMGen
g')
two64 :: Integer
two64 :: Integer
two64 = Integer
2 forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
64 :: Int)
splitSMGen :: SMGen -> (SMGen, SMGen)
splitSMGen :: SMGen -> (SMGen, SMGen)
splitSMGen (SMGen Word64
seed Word64
gamma) =
(Word64 -> Word64 -> SMGen
SMGen Word64
seed'' Word64
gamma, Word64 -> Word64 -> SMGen
SMGen (Word64 -> Word64
mix64 Word64
seed') (Word64 -> Word64
mixGamma Word64
seed''))
where
seed' :: Word64
seed' = Word64
seed Word64 -> Word64 -> Word64
`plus` Word64
gamma
seed'' :: Word64
seed'' = Word64
seed' Word64 -> Word64 -> Word64
`plus` Word64
gamma
goldenGamma :: Word64
goldenGamma :: Word64
goldenGamma = Word64
0x9e3779b97f4a7c15
floatUlp :: Float
floatUlp :: Float
floatUlp = Float
1.0 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
1 forall a. Bits a => a -> Int -> a
`shiftL` Int
24 :: Word32)
doubleUlp :: Double
doubleUlp :: Double
doubleUlp = Double
1.0 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
1 forall a. Bits a => a -> Int -> a
`shiftL` Int
53 :: Word64)
mix64 :: Word64 -> Word64
mix64 :: Word64 -> Word64
mix64 Word64
z0 =
let z1 :: Word64
z1 = Int -> Word64 -> Word64 -> Word64
shiftXorMultiply Int
33 Word64
0xff51afd7ed558ccd Word64
z0
z2 :: Word64
z2 = Int -> Word64 -> Word64 -> Word64
shiftXorMultiply Int
33 Word64
0xc4ceb9fe1a85ec53 Word64
z1
z3 :: Word64
z3 = Int -> Word64 -> Word64
shiftXor Int
33 Word64
z2
in Word64
z3
mix64variant13 :: Word64 -> Word64
mix64variant13 :: Word64 -> Word64
mix64variant13 Word64
z0 =
let z1 :: Word64
z1 = Int -> Word64 -> Word64 -> Word64
shiftXorMultiply Int
30 Word64
0xbf58476d1ce4e5b9 Word64
z0
z2 :: Word64
z2 = Int -> Word64 -> Word64 -> Word64
shiftXorMultiply Int
27 Word64
0x94d049bb133111eb Word64
z1
z3 :: Word64
z3 = Int -> Word64 -> Word64
shiftXor Int
31 Word64
z2
in Word64
z3
mixGamma :: Word64 -> Word64
mixGamma :: Word64 -> Word64
mixGamma Word64
z0 =
let z1 :: Word64
z1 = Word64 -> Word64
mix64variant13 Word64
z0 forall a. Bits a => a -> a -> a
.|. Word64
1
n :: Int
n = forall a. Bits a => a -> Int
popCount (Word64
z1 forall a. Bits a => a -> a -> a
`xor` (Word64
z1 forall a. Bits a => a -> Int -> a
`shiftR` Int
1))
in if Int
n forall a. Ord a => a -> a -> Bool
>= Int
24
then Word64
z1
else Word64
z1 forall a. Bits a => a -> a -> a
`xor` Word64
0xaaaaaaaaaaaaaaaa
shiftXor :: Int -> Word64 -> Word64
shiftXor :: Int -> Word64 -> Word64
shiftXor Int
n Word64
w = Word64
w forall a. Bits a => a -> a -> a
`xor` (Word64
w forall a. Bits a => a -> Int -> a
`shiftR` Int
n)
shiftXorMultiply :: Int -> Word64 -> Word64 -> Word64
shiftXorMultiply :: Int -> Word64 -> Word64 -> Word64
shiftXorMultiply Int
n Word64
k Word64
w = Int -> Word64 -> Word64
shiftXor Int
n Word64
w Word64 -> Word64 -> Word64
`mult` Word64
k
bitmaskWithRejection32 :: Word32 -> SMGen -> (Word32, SMGen)
bitmaskWithRejection32 :: Word32 -> SMGen -> (Word32, SMGen)
bitmaskWithRejection32 Word32
0 = forall a. HasCallStack => String -> a
error String
"bitmaskWithRejection32 0"
bitmaskWithRejection32 Word32
n = Word32 -> SMGen -> (Word32, SMGen)
bitmaskWithRejection32' (Word32
n forall a. Num a => a -> a -> a
- Word32
1)
{-# INLINEABLE bitmaskWithRejection32 #-}
bitmaskWithRejection64 :: Word64 -> SMGen -> (Word64, SMGen)
bitmaskWithRejection64 :: Word64 -> SMGen -> (Word64, SMGen)
bitmaskWithRejection64 Word64
0 = forall a. HasCallStack => String -> a
error String
"bitmaskWithRejection64 0"
bitmaskWithRejection64 Word64
n = Word64 -> SMGen -> (Word64, SMGen)
bitmaskWithRejection64' (Word64
n forall a. Num a => a -> a -> a
- Word64
1)
{-# INLINEABLE bitmaskWithRejection64 #-}
bitmaskWithRejection32' :: Word32 -> SMGen -> (Word32, SMGen)
bitmaskWithRejection32' :: Word32 -> SMGen -> (Word32, SMGen)
bitmaskWithRejection32' Word32
range = SMGen -> (Word32, SMGen)
go where
mask :: Word32
mask = forall a. Bits a => a -> a
complement forall a. Bits a => a
zeroBits forall a. Bits a => a -> Int -> a
`shiftR` forall b. FiniteBits b => b -> Int
countLeadingZeros (Word32
range forall a. Bits a => a -> a -> a
.|. Word32
1)
go :: SMGen -> (Word32, SMGen)
go SMGen
g = let (Word32
x, SMGen
g') = SMGen -> (Word32, SMGen)
nextWord32 SMGen
g
x' :: Word32
x' = Word32
x forall a. Bits a => a -> a -> a
.&. Word32
mask
in if Word32
x' forall a. Ord a => a -> a -> Bool
> Word32
range
then SMGen -> (Word32, SMGen)
go SMGen
g'
else (Word32
x', SMGen
g')
{-# INLINEABLE bitmaskWithRejection32' #-}
bitmaskWithRejection64' :: Word64 -> SMGen -> (Word64, SMGen)
bitmaskWithRejection64' :: Word64 -> SMGen -> (Word64, SMGen)
bitmaskWithRejection64' Word64
range = SMGen -> (Word64, SMGen)
go where
mask :: Word64
mask = forall a. Bits a => a -> a
complement forall a. Bits a => a
zeroBits forall a. Bits a => a -> Int -> a
`shiftR` forall b. FiniteBits b => b -> Int
countLeadingZeros Word64
range
go :: SMGen -> (Word64, SMGen)
go SMGen
g = let (Word64
x, SMGen
g') = SMGen -> (Word64, SMGen)
nextWord64 SMGen
g
x' :: Word64
x' = Word64
x forall a. Bits a => a -> a -> a
.&. Word64
mask
in if Word64
x' forall a. Ord a => a -> a -> Bool
> Word64
range
then SMGen -> (Word64, SMGen)
go SMGen
g'
else (Word64
x', SMGen
g')
{-# INLINEABLE bitmaskWithRejection64' #-}
seedSMGen
:: Word64
-> Word64
-> SMGen
seedSMGen :: Word64 -> Word64 -> SMGen
seedSMGen Word64
seed Word64
gamma = Word64 -> Word64 -> SMGen
SMGen Word64
seed (Word64
gamma forall a. Bits a => a -> a -> a
.|. Word64
1)
seedSMGen' :: (Word64, Word64) -> SMGen
seedSMGen' :: (Word64, Word64) -> SMGen
seedSMGen' = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word64 -> Word64 -> SMGen
seedSMGen
unseedSMGen :: SMGen -> (Word64, Word64)
unseedSMGen :: SMGen -> (Word64, Word64)
unseedSMGen (SMGen Word64
seed Word64
gamma) = (Word64
seed, Word64
gamma)
mkSMGen :: Word64 -> SMGen
mkSMGen :: Word64 -> SMGen
mkSMGen Word64
s = Word64 -> Word64 -> SMGen
SMGen (Word64 -> Word64
mix64 Word64
s) (Word64 -> Word64
mixGamma (Word64
s Word64 -> Word64 -> Word64
`plus` Word64
goldenGamma))
initSMGen :: IO SMGen
initSMGen :: IO SMGen
initSMGen = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> SMGen
mkSMGen IO Word64
initialSeed
newSMGen :: IO SMGen
newSMGen :: IO SMGen
newSMGen = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef SMGen
theSMGen SMGen -> (SMGen, SMGen)
splitSMGen
theSMGen :: IORef SMGen
theSMGen :: IORef SMGen
theSMGen = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ IO SMGen
initSMGen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO (IORef a)
newIORef
{-# NOINLINE theSMGen #-}
mult, plus :: Word64 -> Word64 -> Word64
#ifndef __HUGS__
mult :: Word64 -> Word64 -> Word64
mult = forall a. Num a => a -> a -> a
(*)
plus :: Word64 -> Word64 -> Word64
plus = forall a. Num a => a -> a -> a
(+)
#else
mult x y = fromInteger ((toInteger x * toInteger y) `mod` 18446744073709551616)
plus x y = fromInteger ((toInteger x + toInteger y) `mod` 18446744073709551616)
#endif