{-# LANGUAGE CPP #-}
module System.Random.TF.Init
(newTFGen, mkTFGen, mkSeedTime, mkSeedUnix, initTFGen)
where
import System.Random.TF.Gen (TFGen, seedTFGen, split)
import Control.Monad (when)
import Data.Bits (bitSize)
import Data.IORef
import Data.Word
import Foreign (allocaBytes, peekArray)
import Data.Ratio (numerator, denominator)
import Data.Time
import System.CPUTime
import System.IO
import System.IO.Unsafe (unsafePerformIO)
mkSeedTime :: IO (Word64, Word64, Word64, Word64)
mkSeedTime :: IO (Word64, Word64, Word64, Word64)
mkSeedTime = do
UTCTime
utcTm <- IO UTCTime
getCurrentTime
Integer
cpu <- IO Integer
getCPUTime
let daytime :: Rational
daytime = DiffTime -> Rational
forall a. Real a => a -> Rational
toRational (DiffTime -> Rational) -> DiffTime -> Rational
forall a b. (a -> b) -> a -> b
$ UTCTime -> DiffTime
utctDayTime UTCTime
utcTm
t1, t2 :: Word64
t1 :: Word64
t1 = Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word64) -> Integer -> Word64
forall a b. (a -> b) -> a -> b
$ Rational -> Integer
forall a. Ratio a -> a
numerator Rational
daytime
t2 :: Word64
t2 = Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word64) -> Integer -> Word64
forall a b. (a -> b) -> a -> b
$ Rational -> Integer
forall a. Ratio a -> a
denominator Rational
daytime
day :: Integer
day = Day -> Integer
toModifiedJulianDay (Day -> Integer) -> Day -> Integer
forall a b. (a -> b) -> a -> b
$ UTCTime -> Day
utctDay UTCTime
utcTm
d1 :: Word64
d1 :: Word64
d1 = Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
day
c1 :: Word64
c1 :: Word64
c1 = Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
cpu
(Word64, Word64, Word64, Word64)
-> IO (Word64, Word64, Word64, Word64)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
t1, Word64
t2, Word64
d1, Word64
c1)
mkSeedUnix :: IO (Word64, Word64, Word64, Word64)
mkSeedUnix :: IO (Word64, Word64, Word64, Word64)
mkSeedUnix = do
let bytes :: Int
bytes = Int
32
rfile :: [Char]
rfile = [Char]
"/dev/urandom"
[Word64]
l <- Int -> (Ptr Word64 -> IO [Word64]) -> IO [Word64]
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
bytes ((Ptr Word64 -> IO [Word64]) -> IO [Word64])
-> (Ptr Word64 -> IO [Word64]) -> IO [Word64]
forall a b. (a -> b) -> a -> b
$ \Ptr Word64
buf -> do
Int
nread <- [Char] -> IOMode -> (Handle -> IO Int) -> IO Int
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile [Char]
rfile IOMode
ReadMode ((Handle -> IO Int) -> IO Int) -> (Handle -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
Handle -> Ptr Word64 -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
h Ptr Word64
buf Int
bytes
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
nread Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
bytes) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"mkSeedUnix: Failed to read " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
Int -> [Char]
forall a. Show a => a -> [Char]
show Int
bytes [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" from " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
rfile
Int -> Ptr Word64 -> IO [Word64]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
4 Ptr Word64
buf
let [Word64
x1, Word64
x2, Word64
x3, Word64
x4] = [Word64]
l
(Word64, Word64, Word64, Word64)
-> IO (Word64, Word64, Word64, Word64)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
x1, Word64
x2, Word64
x3, Word64
x4)
initTFGen :: IO TFGen
initTFGen :: IO TFGen
initTFGen = do
#ifdef UNIX
s <- mkSeedUnix
#else
(Word64, Word64, Word64, Word64)
s <- IO (Word64, Word64, Word64, Word64)
mkSeedTime
#endif
TFGen -> IO TFGen
forall (m :: * -> *) a. Monad m => a -> m a
return (TFGen -> IO TFGen) -> TFGen -> IO TFGen
forall a b. (a -> b) -> a -> b
$ (Word64, Word64, Word64, Word64) -> TFGen
seedTFGen (Word64, Word64, Word64, Word64)
s
newTFGen :: IO TFGen
newTFGen :: IO TFGen
newTFGen = IORef TFGen -> (TFGen -> (TFGen, TFGen)) -> IO TFGen
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef TFGen
theTFGen TFGen -> (TFGen, TFGen)
forall g. RandomGen g => g -> (g, g)
split
{-# NOINLINE theTFGen #-}
theTFGen :: IORef TFGen
theTFGen :: IORef TFGen
theTFGen = IO (IORef TFGen) -> IORef TFGen
forall a. IO a -> a
unsafePerformIO (IO (IORef TFGen) -> IORef TFGen)
-> IO (IORef TFGen) -> IORef TFGen
forall a b. (a -> b) -> a -> b
$ do
TFGen
rng <- IO TFGen
initTFGen
TFGen -> IO (IORef TFGen)
forall a. a -> IO (IORef a)
newIORef TFGen
rng
mkTFGen :: Int -> TFGen
mkTFGen :: Int -> TFGen
mkTFGen Int
n
| Int -> Int
forall a. Bits a => a -> Int
bitSize Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
64 = [Char] -> TFGen
forall a. HasCallStack => [Char] -> a
error [Char]
"mkTFGen: case where size of Int > 64 not implemented"
| Bool
otherwise = (Word64, Word64, Word64, Word64) -> TFGen
seedTFGen (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n, Word64
0, Word64
0, Word64
0)