{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveLift #-}
#include "MachDeps.h"
module Hedgehog.Internal.Seed (
Seed(..)
, random
, from
, split
, nextInteger
, nextDouble
, goldenGamma
, nextWord64
, nextWord32
, mix64
, mix64variant13
, mix32
, mixGamma
, global
) 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 Language.Haskell.TH.Syntax (Lift)
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
$c== :: Seed -> Seed -> Bool
== :: Seed -> Seed -> Bool
$c/= :: Seed -> Seed -> Bool
/= :: 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
$ccompare :: Seed -> Seed -> Ordering
compare :: Seed -> Seed -> Ordering
$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
>= :: Seed -> Seed -> Bool
$cmax :: Seed -> Seed -> Seed
max :: Seed -> Seed -> Seed
$cmin :: Seed -> Seed -> Seed
min :: Seed -> Seed -> Seed
Ord, (forall (m :: * -> *). Quote m => Seed -> m Exp)
-> (forall (m :: * -> *). Quote m => Seed -> Code m Seed)
-> Lift Seed
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Seed -> m Exp
forall (m :: * -> *). Quote m => Seed -> Code m Seed
$clift :: forall (m :: * -> *). Quote m => Seed -> m Exp
lift :: forall (m :: * -> *). Quote m => Seed -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => Seed -> Code m Seed
liftTyped :: forall (m :: * -> *). Quote m => Seed -> Code m Seed
Lift)
instance Show Seed where
showsPrec :: Int -> Seed -> ShowS
showsPrec Int
p (Seed Word64
v Word64
g) =
Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
String -> ShowS
showString String
"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 Int
11 Word64
v ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Int -> Word64 -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Word64
g
instance Read Seed where
readsPrec :: Int -> ReadS Seed
readsPrec 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
> Int
10) (ReadS Seed -> ReadS Seed) -> ReadS Seed -> ReadS Seed
forall a b. (a -> b) -> a -> b
$ \String
r0 -> do
(String
"Seed", String
r1) <- ReadS String
lex String
r0
(Word64
v, String
r2) <- Int -> ReadS Word64
forall a. Read a => Int -> ReadS a
readsPrec Int
11 String
r1
(Word64
g, String
r3) <- Int -> ReadS Word64
forall a. Read a => Int -> ReadS a
readsPrec Int
11 String
r2
(Seed, String) -> [(Seed, String)]
forall a. a -> [a]
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 b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime
seconds POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
1000))
{-# NOINLINE global #-}
random :: MonadIO m => m Seed
random :: forall (m :: * -> *). MonadIO m => m Seed
random =
IO Seed -> m Seed
forall a. IO a -> m a
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 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 =
Word64
0x9e3779b97f4a7c15
next :: Seed -> (Word64, Seed)
next :: Seed -> (Word64, Seed)
next (Seed Word64
v0 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 Seed
s0 =
let
(Word64
v0, Seed
s1) = Seed -> (Word64, Seed)
next Seed
s0
(Word64
g0, 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 Seed
s0 =
let
(Word64
v0, 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 Seed
s0 =
let
(Word64
v0, 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 Integer
lo Integer
hi =
(Integer, Integer) -> Seed -> (Integer, Seed)
forall g. RandomGen g => (Integer, Integer) -> g -> (Integer, g)
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 Double
lo Double
hi =
(Double, Double) -> Seed -> (Double, Seed)
forall g. RandomGen g => (Double, Double) -> g -> (Double, g)
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 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` Int
33)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
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` Int
33)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
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` Int
33)
mix32 :: Word64 -> Word32
mix32 :: Word64 -> Word32
mix32 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` Int
33)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
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` Int
33)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
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` Int
32)
mix64variant13 :: Word64 -> Word64
mix64variant13 :: Word64 -> Word64
mix64variant13 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` Int
30)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
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` Int
27)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
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` Int
31)
mixGamma :: Word64 -> Word64
mixGamma :: Word64 -> Word64
mixGamma Word64
x =
let
y :: Word64
y = Word64 -> Word64
mix64variant13 Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
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` Int
1)
in
if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
24 then
Word64
y Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
0xaaaaaaaaaaaaaaaa
else
Word64
y
#if (SIZEOF_HSINT == 8)
instance RandomGen Seed where
next :: Seed -> (Int, Seed)
next =
(Word64 -> Int) -> (Word64, Seed) -> (Int, Seed)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64, Seed) -> (Int, Seed))
-> (Seed -> (Word64, Seed)) -> Seed -> (Int, Seed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seed -> (Word64, Seed)
nextWord64
genRange :: Seed -> (Int, Int)
genRange Seed
_ =
(Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
forall a. Bounded a => a
minBound :: Int64), Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
forall a. Bounded a => a
maxBound :: Int64))
split :: Seed -> (Seed, Seed)
split =
Seed -> (Seed, Seed)
split
#else
instance RandomGen Seed where
next =
first fromIntegral . nextWord32
genRange _ =
(fromIntegral (minBound :: Int32), fromIntegral (maxBound :: Int32))
split =
split
#endif