{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveLift #-}
-- |
-- This is a port of "Fast Splittable Pseudorandom Number Generators" by Steele
-- et. al. [1].
--
-- The paper's algorithm provides decent randomness for most purposes but
-- sacrifices cryptographic-quality randomness in favor of speed.  The original
-- implementation is tested with DieHarder and BigCrush; see the paper for
-- details.
--
-- This implementation, originally from [2], is a port from the paper.
--
-- It also takes in to account the SplittableRandom.java source code in OpenJDK
-- v8u40-b25 as well as splittable_random.ml in Jane Street's standard library
-- overlay (kernel) v113.33.03, and Random.fs in FsCheck v3.
--
-- Other than the choice of initial seed for 'from' this port should be
-- faithful.
--
-- 1. Guy L. Steele, Jr., Doug Lea, Christine H. Flood
--    Fast splittable pseudorandom number generators
--    Comm ACM, 49(10), Oct 2014, pp453-472.
--
-- 2. Nikos Baxevanis
--    https://github.com/moodmosaic/SplitMix/blob/master/SplitMix.hs
--

#include "MachDeps.h"

module Hedgehog.Internal.Seed (
    Seed(..)
  , random
  , from
  , split
  , nextInteger
  , nextDouble

  -- * Internal
  -- $internal
  , 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

-- | A splittable random number generator.
--
data Seed =
  Seed {
      Seed -> Word64
seedValue :: !Word64
    , Seed -> Word64
seedGamma :: !Word64 -- ^ must be an odd number
    } 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
    -- FIXME use /dev/urandom on posix
    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 #-}

-- | Create a random 'Seed' using an effectful source of randomness.
--
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

-- | Create a 'Seed' using a 'Word64'.
--
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))

-- | A predefined gamma value's needed for initializing the "root" instances of
--   'Seed'. That is, instances not produced by splitting an already existing
--   instance.
--
--   We choose: the odd integer closest to @2^64/φ@, where @φ = (1 + √5)/2@ is
--   the golden ratio.
--
goldenGamma :: Word64
goldenGamma :: Word64
goldenGamma =
  Word64
0x9e3779b97f4a7c15

-- | Get the next value in the SplitMix sequence.
--
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)

-- | Splits a random number generator in to two.
--
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))

-- | Generate a random 'Word64'.
--
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)

-- | Generate a random 'Word32'.
--
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)

-- | Generate a random 'Integer' in the [inclusive,inclusive] range.
--
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)

-- | Generate a random 'Double' in the [inclusive,exclusive) range.
--
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

------------------------------------------------------------------------
-- RandomGen instances

#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

------------------------------------------------------------------------
-- Internal

-- $internal
--
-- These functions are exported in case you need them in a pinch, but are not
-- part of the public API and may change at any time, even as part of a minor
-- update.