{-# LANGUAGE CPP #-}
-- Module    : System.Random.TF.Init
-- Copyright : (c) 2013 Michał Pałka
-- License   : BSD3
--
-- Maintainer  : michal.palka@chalmers.se
-- Stability   : experimental
-- Portability : portable
--
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)

-- | Use system time create the random seed.
-- This method of seeding may not be relible.
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)

-- | Use the UNIX special file @\/dev\/urandom@ to create the seed.
-- Inspired by @random-mwc@.
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)

-- | Create a seed and used it to seed an instance of TFGen.
-- Uses 'mkSeedUnix' on UNIX, and 'mkSeedTime' otherwise.
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

-- | Derive a new generator instance from the global RNG using split.
-- This is the default way of obtaining a new RNG instance.
-- Initial generator is seeded using 'mkSeedUnix' on UNIX,
-- and 'mkSeedTime' otherwise. This should be eventually
-- replaced with proper seeding.

-- Inspired by System.Random
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

-- | Quick and dirty way of creating a deterministically
-- seeded generator.
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)