{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
#include "MachDeps.h"
module Hedgehog.Internal.Seed (
Seed(..)
, random
, from
, split
, nextInteger
, nextDouble
, goldenGamma
, nextWord64
, nextWord32
, mix64
, mix64variant13
, mix32
, mixGamma
) where
import Control.Monad.IO.Class (MonadIO(..))
import Data.Bifunctor (first)
import Data.Bits ((.|.), xor, shiftR, popCount)
#if (SIZEOF_HSINT == 8)
import Data.Int (Int64)
#else
import Data.Int (Int32)
#endif
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.IORef (IORef)
import qualified Data.IORef as IORef
import Data.Word (Word32, Word64)
import System.IO.Unsafe (unsafePerformIO)
import System.Random (RandomGen)
import qualified System.Random as Random
data Seed =
Seed {
Seed -> Word64
seedValue :: !Word64
, Seed -> Word64
seedGamma :: !Word64
} deriving (Seed -> Seed -> Bool
(Seed -> Seed -> Bool) -> (Seed -> Seed -> Bool) -> Eq Seed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Seed -> Seed -> Bool
$c/= :: Seed -> Seed -> Bool
== :: Seed -> Seed -> Bool
$c== :: Seed -> Seed -> Bool
Eq, Eq Seed
Eq Seed =>
(Seed -> Seed -> Ordering)
-> (Seed -> Seed -> Bool)
-> (Seed -> Seed -> Bool)
-> (Seed -> Seed -> Bool)
-> (Seed -> Seed -> Bool)
-> (Seed -> Seed -> Seed)
-> (Seed -> Seed -> Seed)
-> Ord Seed
Seed -> Seed -> Bool
Seed -> Seed -> Ordering
Seed -> Seed -> Seed
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Seed -> Seed -> Seed
$cmin :: Seed -> Seed -> Seed
max :: Seed -> Seed -> Seed
$cmax :: Seed -> Seed -> Seed
>= :: Seed -> Seed -> Bool
$c>= :: Seed -> Seed -> Bool
> :: Seed -> Seed -> Bool
$c> :: Seed -> Seed -> Bool
<= :: Seed -> Seed -> Bool
$c<= :: Seed -> Seed -> Bool
< :: Seed -> Seed -> Bool
$c< :: Seed -> Seed -> Bool
compare :: Seed -> Seed -> Ordering
$ccompare :: Seed -> Seed -> Ordering
$cp1Ord :: Eq Seed
Ord)
instance Show Seed where
showsPrec :: Int -> Seed -> ShowS
showsPrec p :: Int
p (Seed v :: Word64
v g :: Word64
g) =
Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
String -> ShowS
showString "Seed " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Int -> Word64 -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 Word64
v ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Char -> ShowS
showChar ' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Int -> Word64 -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 Word64
g
instance Read Seed where
readsPrec :: Int -> ReadS Seed
readsPrec p :: Int
p =
Bool -> ReadS Seed -> ReadS Seed
forall a. Bool -> ReadS a -> ReadS a
readParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10) (ReadS Seed -> ReadS Seed) -> ReadS Seed -> ReadS Seed
forall a b. (a -> b) -> a -> b
$ \r0 :: String
r0 -> do
("Seed", r1 :: String
r1) <- ReadS String
lex String
r0
(v :: Word64
v, r2 :: String
r2) <- Int -> ReadS Word64
forall a. Read a => Int -> ReadS a
readsPrec 11 String
r1
(g :: Word64
g, r3 :: String
r3) <- Int -> ReadS Word64
forall a. Read a => Int -> ReadS a
readsPrec 11 String
r2
(Seed, String) -> [(Seed, String)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Word64 -> Seed
Seed Word64
v Word64
g, String
r3)
global :: IORef Seed
global :: IORef Seed
global =
IO (IORef Seed) -> IORef Seed
forall a. IO a -> a
unsafePerformIO (IO (IORef Seed) -> IORef Seed) -> IO (IORef Seed) -> IORef Seed
forall a b. (a -> b) -> a -> b
$ do
POSIXTime
seconds <- IO POSIXTime
getPOSIXTime
Seed -> IO (IORef Seed)
forall a. a -> IO (IORef a)
IORef.newIORef (Seed -> IO (IORef Seed)) -> Seed -> IO (IORef Seed)
forall a b. (a -> b) -> a -> b
$ Word64 -> Seed
from (POSIXTime -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime
seconds POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* 1000))
{-# NOINLINE global #-}
random :: MonadIO m => m Seed
random :: m Seed
random =
IO Seed -> m Seed
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Seed -> m Seed) -> IO Seed -> m Seed
forall a b. (a -> b) -> a -> b
$ IORef Seed -> (Seed -> (Seed, Seed)) -> IO Seed
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Seed
global Seed -> (Seed, Seed)
split
from :: Word64 -> Seed
from :: Word64 -> Seed
from x :: Word64
x =
Word64 -> Word64 -> Seed
Seed (Word64 -> Word64
mix64 Word64
x) (Word64 -> Word64
mixGamma (Word64
x Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
goldenGamma))
goldenGamma :: Word64
goldenGamma :: Word64
goldenGamma =
0x9e3779b97f4a7c15
next :: Seed -> (Word64, Seed)
next :: Seed -> (Word64, Seed)
next (Seed v0 :: Word64
v0 g :: Word64
g) =
let
v :: Word64
v = Word64
v0 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
g
in
(Word64
v, Word64 -> Word64 -> Seed
Seed Word64
v Word64
g)
split :: Seed -> (Seed, Seed)
split :: Seed -> (Seed, Seed)
split s0 :: Seed
s0 =
let
(v0 :: Word64
v0, s1 :: Seed
s1) = Seed -> (Word64, Seed)
next Seed
s0
(g0 :: Word64
g0, s2 :: Seed
s2) = Seed -> (Word64, Seed)
next Seed
s1
in
(Seed
s2, Word64 -> Word64 -> Seed
Seed (Word64 -> Word64
mix64 Word64
v0) (Word64 -> Word64
mixGamma Word64
g0))
nextWord64 :: Seed -> (Word64, Seed)
nextWord64 :: Seed -> (Word64, Seed)
nextWord64 s0 :: Seed
s0 =
let
(v0 :: Word64
v0, s1 :: Seed
s1) = Seed -> (Word64, Seed)
next Seed
s0
in
(Word64 -> Word64
mix64 Word64
v0, Seed
s1)
nextWord32 :: Seed -> (Word32, Seed)
nextWord32 :: Seed -> (Word32, Seed)
nextWord32 s0 :: Seed
s0 =
let
(v0 :: Word64
v0, s1 :: Seed
s1) = Seed -> (Word64, Seed)
next Seed
s0
in
(Word64 -> Word32
mix32 Word64
v0, Seed
s1)
nextInteger :: Integer -> Integer -> Seed -> (Integer, Seed)
nextInteger :: Integer -> Integer -> Seed -> (Integer, Seed)
nextInteger lo :: Integer
lo hi :: Integer
hi =
(Integer, Integer) -> Seed -> (Integer, Seed)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
Random.randomR (Integer
lo, Integer
hi)
nextDouble :: Double -> Double -> Seed -> (Double, Seed)
nextDouble :: Double -> Double -> Seed -> (Double, Seed)
nextDouble lo :: Double
lo hi :: Double
hi =
(Double, Double) -> Seed -> (Double, Seed)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
Random.randomR (Double
lo, Double
hi)
mix64 :: Word64 -> Word64
mix64 :: Word64 -> Word64
mix64 x :: Word64
x =
let
y :: Word64
y = (Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` (Word64
x Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 33)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* 0xff51afd7ed558ccd
z :: Word64
z = (Word64
y Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` (Word64
y Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 33)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* 0xc4ceb9fe1a85ec53
in
Word64
z Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` (Word64
z Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 33)
mix32 :: Word64 -> Word32
mix32 :: Word64 -> Word32
mix32 x :: Word64
x =
let
y :: Word64
y = (Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` (Word64
x Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 33)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* 0xff51afd7ed558ccd
z :: Word64
z = (Word64
y Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` (Word64
y Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 33)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* 0xc4ceb9fe1a85ec53
in
Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
z Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 32)
mix64variant13 :: Word64 -> Word64
mix64variant13 :: Word64 -> Word64
mix64variant13 x :: Word64
x =
let
y :: Word64
y = (Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` (Word64
x Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 30)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* 0xbf58476d1ce4e5b9
z :: Word64
z = (Word64
y Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` (Word64
y Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 27)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* 0x94d049bb133111eb
in
Word64
z Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` (Word64
z Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 31)
mixGamma :: Word64 -> Word64
mixGamma :: Word64 -> Word64
mixGamma x :: Word64
x =
let
y :: Word64
y = Word64 -> Word64
mix64variant13 Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. 1
n :: Int
n = Word64 -> Int
forall a. Bits a => a -> Int
popCount (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Word64
y Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` (Word64
y 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
y Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` 0xaaaaaaaaaaaaaaaa
else
Word64
y
#if (SIZEOF_HSINT == 8)
instance RandomGen Seed where
next =
first fromIntegral . nextWord64
genRange _ =
(fromIntegral (minBound :: Int64), fromIntegral (maxBound :: Int64))
split =
split
#else
instance RandomGen Seed where
next :: Seed -> (Int, Seed)
next =
(Word32 -> Int) -> (Word32, Seed) -> (Int, Seed)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32, Seed) -> (Int, Seed))
-> (Seed -> (Word32, Seed)) -> Seed -> (Int, Seed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seed -> (Word32, Seed)
nextWord32
genRange :: Seed -> (Int, Int)
genRange _ =
(Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
forall a. Bounded a => a
minBound :: Int32), Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
forall a. Bounded a => a
maxBound :: Int32))
split :: Seed -> (Seed, Seed)
split =
Seed -> (Seed, Seed)
split
#endif