{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
module System.Random.SplitMix (
SMGen,
nextWord64,
nextWord32,
nextTwoWord32,
nextInt,
nextDouble,
nextFloat,
splitSMGen,
bitmaskWithRejection32,
bitmaskWithRejection32',
bitmaskWithRejection64,
bitmaskWithRejection64',
mkSMGen,
initSMGen,
newSMGen,
seedSMGen,
seedSMGen',
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)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Word (Word32, Word64)
import System.IO.Unsafe (unsafePerformIO)
#ifdef MIN_VERSION_random
import qualified System.Random as R
#endif
#if !__GHCJS__
import System.CPUTime (cpuTimePrecision, getCPUTime)
#endif
data SMGen = SMGen !Word64 !Word64
deriving Int -> SMGen -> ShowS
[SMGen] -> ShowS
SMGen -> String
(Int -> SMGen -> ShowS)
-> (SMGen -> String) -> ([SMGen] -> ShowS) -> Show SMGen
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
instance NFData SMGen where
rnf :: SMGen -> ()
rnf (SMGen _ _) = ()
instance Read SMGen where
readsPrec :: Int -> ReadS SMGen
readsPrec d :: Int
d r :: String
r = Bool -> ReadS SMGen -> ReadS SMGen
forall a. Bool -> ReadS a -> ReadS a
readParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10) (\r0 :: String
r0 ->
[ (Word64 -> Word64 -> SMGen
SMGen Word64
seed Word64
gamma, String
r3)
| ("SMGen", r1 :: String
r1) <- ReadS String
lex String
r0
, (seed :: Word64
seed, r2 :: String
r2) <- Int -> ReadS Word64
forall a. Read a => Int -> ReadS a
readsPrec 11 String
r1
, (gamma :: Word64
gamma, r3 :: String
r3) <- Int -> ReadS Word64
forall a. Read a => Int -> ReadS a
readsPrec 11 String
r2
, Word64 -> Bool
forall a. Integral a => a -> Bool
odd Word64
gamma
]) String
r
nextWord64 :: SMGen -> (Word64, SMGen)
nextWord64 :: SMGen -> (Word64, SMGen)
nextWord64 (SMGen seed :: Word64
seed gamma :: Word64
gamma) = (Word64 -> Word64
mix64 Word64
seed', Word64 -> Word64 -> SMGen
SMGen Word64
seed' Word64
gamma)
where
seed' :: Word64
seed' = Word64
seed Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
gamma
nextWord32 :: SMGen -> (Word32, SMGen)
nextWord32 :: SMGen -> (Word32, SMGen)
nextWord32 g :: SMGen
g = (Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w64, SMGen
g') where
(w64 :: Word64
w64, g' :: SMGen
g') = SMGen -> (Word64, SMGen)
nextWord64 SMGen
g
nextTwoWord32 :: SMGen -> (Word32, Word32, SMGen)
nextTwoWord32 :: SMGen -> (Word32, Word32, SMGen)
nextTwoWord32 g :: SMGen
g = (Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word32) -> Word64 -> Word32
forall a b. (a -> b) -> a -> b
$ Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 32, Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w64, SMGen
g') where
(w64 :: Word64
w64, g' :: SMGen
g') = SMGen -> (Word64, SMGen)
nextWord64 SMGen
g
nextInt :: SMGen -> (Int, SMGen)
nextInt :: SMGen -> (Int, SMGen)
nextInt g :: SMGen
g = case SMGen -> (Word64, SMGen)
nextWord64 SMGen
g of
(w64 :: Word64
w64, g' :: SMGen
g') -> (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w64, SMGen
g')
nextDouble :: SMGen -> (Double, SMGen)
nextDouble :: SMGen -> (Double, SMGen)
nextDouble g :: SMGen
g = case SMGen -> (Word64, SMGen)
nextWord64 SMGen
g of
(w64 :: Word64
w64, g' :: SMGen
g') -> (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 11) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
doubleUlp, SMGen
g')
nextFloat :: SMGen -> (Float, SMGen)
nextFloat :: SMGen -> (Float, SMGen)
nextFloat g :: SMGen
g = case SMGen -> (Word32, SMGen)
nextWord32 SMGen
g of
(w32 :: Word32
w32, g' :: SMGen
g') -> (Word32 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w32 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` 8) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
floatUlp, SMGen
g')
splitSMGen :: SMGen -> (SMGen, SMGen)
splitSMGen :: SMGen -> (SMGen, SMGen)
splitSMGen (SMGen seed :: Word64
seed gamma :: 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
forall a. Num a => a -> a -> a
+ Word64
gamma
seed'' :: Word64
seed'' = Word64
seed' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
gamma
goldenGamma :: Word64
goldenGamma :: Word64
goldenGamma = 0x9e3779b97f4a7c15
floatUlp :: Float
floatUlp :: Float
floatUlp = 1.0 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Word32 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` 24 :: Word32)
doubleUlp :: Double
doubleUlp :: Double
doubleUlp = 1.0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (1 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` 53 :: Word64)
mix64 :: Word64 -> Word64
mix64 :: Word64 -> Word64
mix64 z0 :: Word64
z0 =
let z1 :: Word64
z1 = Int -> Word64 -> Word64 -> Word64
shiftXorMultiply 33 0xff51afd7ed558ccd Word64
z0
z2 :: Word64
z2 = Int -> Word64 -> Word64 -> Word64
shiftXorMultiply 33 0xc4ceb9fe1a85ec53 Word64
z1
z3 :: Word64
z3 = Int -> Word64 -> Word64
shiftXor 33 Word64
z2
in Word64
z3
mix64variant13 :: Word64 -> Word64
mix64variant13 :: Word64 -> Word64
mix64variant13 z0 :: Word64
z0 =
let z1 :: Word64
z1 = Int -> Word64 -> Word64 -> Word64
shiftXorMultiply 30 0xbf58476d1ce4e5b9 Word64
z0
z2 :: Word64
z2 = Int -> Word64 -> Word64 -> Word64
shiftXorMultiply 27 0x94d049bb133111eb Word64
z1
z3 :: Word64
z3 = Int -> Word64 -> Word64
shiftXor 31 Word64
z2
in Word64
z3
mixGamma :: Word64 -> Word64
mixGamma :: Word64 -> Word64
mixGamma z0 :: Word64
z0 =
let z1 :: Word64
z1 = Word64 -> Word64
mix64variant13 Word64
z0 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. 1
n :: Int
n = Word64 -> Int
forall a. Bits a => a -> Int
popCount (Word64
z1 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` (Word64
z1 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 1))
in if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 24
then Word64
z1
else Word64
z1 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` 0xaaaaaaaaaaaaaaaa
shiftXor :: Int -> Word64 -> Word64
shiftXor :: Int -> Word64 -> Word64
shiftXor n :: Int
n w :: Word64
w = Word64
w Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` (Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
n)
shiftXorMultiply :: Int -> Word64 -> Word64 -> Word64
shiftXorMultiply :: Int -> Word64 -> Word64 -> Word64
shiftXorMultiply n :: Int
n k :: Word64
k w :: Word64
w = Int -> Word64 -> Word64
shiftXor Int
n Word64
w Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
k
bitmaskWithRejection32 :: Word32 -> SMGen -> (Word32, SMGen)
bitmaskWithRejection32 :: Word32 -> SMGen -> (Word32, SMGen)
bitmaskWithRejection32 range :: Word32
range = SMGen -> (Word32, SMGen)
go where
mask :: Word32
mask = Word32 -> Word32
forall a. Bits a => a -> a
complement Word32
forall a. Bits a => a
zeroBits Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Word32 -> Int
forall b. FiniteBits b => b -> Int
countLeadingZeros (Word32
range Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. 1)
go :: SMGen -> (Word32, SMGen)
go g :: SMGen
g = let (x :: Word32
x, g' :: SMGen
g') = SMGen -> (Word32, SMGen)
nextWord32 SMGen
g
x' :: Word32
x' = Word32
x Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
mask
in if Word32
x' Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
range
then SMGen -> (Word32, SMGen)
go SMGen
g'
else (Word32
x', SMGen
g')
bitmaskWithRejection64 :: Word64 -> SMGen -> (Word64, SMGen)
bitmaskWithRejection64 :: Word64 -> SMGen -> (Word64, SMGen)
bitmaskWithRejection64 range :: Word64
range = SMGen -> (Word64, SMGen)
go where
mask :: Word64
mask = Word64 -> Word64
forall a. Bits a => a -> a
complement Word64
forall a. Bits a => a
zeroBits Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Word64 -> Int
forall b. FiniteBits b => b -> Int
countLeadingZeros (Word64
range Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. 1)
go :: SMGen -> (Word64, SMGen)
go g :: SMGen
g = let (x :: Word64
x, g' :: SMGen
g') = SMGen -> (Word64, SMGen)
nextWord64 SMGen
g
x' :: Word64
x' = Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
mask
in if Word64
x' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
range
then SMGen -> (Word64, SMGen)
go SMGen
g'
else (Word64
x', SMGen
g')
bitmaskWithRejection32' :: Word32 -> SMGen -> (Word32, SMGen)
bitmaskWithRejection32' :: Word32 -> SMGen -> (Word32, SMGen)
bitmaskWithRejection32' range :: Word32
range = SMGen -> (Word32, SMGen)
go where
mask :: Word32
mask = Word32 -> Word32
forall a. Bits a => a -> a
complement Word32
forall a. Bits a => a
zeroBits Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Word32 -> Int
forall b. FiniteBits b => b -> Int
countLeadingZeros (Word32
range Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. 1)
go :: SMGen -> (Word32, SMGen)
go g :: SMGen
g = let (x :: Word32
x, g' :: SMGen
g') = SMGen -> (Word32, SMGen)
nextWord32 SMGen
g
x' :: Word32
x' = Word32
x Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
mask
in if Word32
x' Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
range
then SMGen -> (Word32, SMGen)
go SMGen
g'
else (Word32
x', SMGen
g')
bitmaskWithRejection64' :: Word64 -> SMGen -> (Word64, SMGen)
bitmaskWithRejection64' :: Word64 -> SMGen -> (Word64, SMGen)
bitmaskWithRejection64' range :: Word64
range = SMGen -> (Word64, SMGen)
go where
mask :: Word64
mask = Word64 -> Word64
forall a. Bits a => a -> a
complement Word64
forall a. Bits a => a
zeroBits Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Word64 -> Int
forall b. FiniteBits b => b -> Int
countLeadingZeros (Word64
range Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. 1)
go :: SMGen -> (Word64, SMGen)
go g :: SMGen
g = let (x :: Word64
x, g' :: SMGen
g') = SMGen -> (Word64, SMGen)
nextWord64 SMGen
g
x' :: Word64
x' = Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
mask
in if Word64
x' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
range
then SMGen -> (Word64, SMGen)
go SMGen
g'
else (Word64
x', SMGen
g')
seedSMGen
:: Word64
-> Word64
-> SMGen
seedSMGen :: Word64 -> Word64 -> SMGen
seedSMGen seed :: Word64
seed gamma :: Word64
gamma = Word64 -> Word64 -> SMGen
SMGen Word64
seed (Word64
gamma Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. 1)
seedSMGen' :: (Word64, Word64) -> SMGen
seedSMGen' :: (Word64, Word64) -> SMGen
seedSMGen' = (Word64 -> Word64 -> SMGen) -> (Word64, Word64) -> SMGen
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 seed :: Word64
seed gamma :: Word64
gamma) = (Word64
seed, Word64
gamma)
mkSMGen :: Word64 -> SMGen
mkSMGen :: Word64 -> SMGen
mkSMGen s :: Word64
s = Word64 -> Word64 -> SMGen
SMGen (Word64 -> Word64
mix64 Word64
s) (Word64 -> Word64
mixGamma (Word64
s Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
goldenGamma))
initSMGen :: IO SMGen
initSMGen :: IO SMGen
initSMGen = (Word64 -> SMGen) -> IO Word64 -> IO SMGen
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> SMGen
mkSMGen IO Word64
mkSeedTime
newSMGen :: IO SMGen
newSMGen :: IO SMGen
newSMGen = IORef SMGen -> (SMGen -> (SMGen, SMGen)) -> IO SMGen
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 = IO (IORef SMGen) -> IORef SMGen
forall a. IO a -> a
unsafePerformIO (IO (IORef SMGen) -> IORef SMGen)
-> IO (IORef SMGen) -> IORef SMGen
forall a b. (a -> b) -> a -> b
$ IO SMGen
initSMGen IO SMGen -> (SMGen -> IO (IORef SMGen)) -> IO (IORef SMGen)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SMGen -> IO (IORef SMGen)
forall a. a -> IO (IORef a)
newIORef
{-# NOINLINE theSMGen #-}
mkSeedTime :: IO Word64
mkSeedTime :: IO Word64
mkSeedTime = do
POSIXTime
now <- IO POSIXTime
getPOSIXTime
let lo :: Word32
lo = POSIXTime -> Word32
forall a b. (RealFrac a, Integral b) => a -> b
truncate POSIXTime
now :: Word32
#if __GHCJS__
let hi = lo
#else
Integer
cpu <- IO Integer
getCPUTime
let hi :: Word32
hi = Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
cpu Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
cpuTimePrecision) :: Word32
#endif
Word64 -> IO Word64
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> IO Word64) -> Word64 -> IO Word64
forall a b. (a -> b) -> a -> b
$ Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
hi Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` 32 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
lo
#ifdef MIN_VERSION_random
instance R.RandomGen SMGen where
next :: SMGen -> (Int, SMGen)
next = SMGen -> (Int, SMGen)
nextInt
split :: SMGen -> (SMGen, SMGen)
split = SMGen -> (SMGen, SMGen)
splitSMGen
#endif