{-# 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 = forall a. Real a => a -> Rational
toRational forall a b. (a -> b) -> a -> b
$ UTCTime -> DiffTime
utctDayTime UTCTime
utcTm
      t1, t2 :: Word64
      t1 :: Word64
t1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Ratio a -> a
numerator Rational
daytime
      t2 :: Word64
t2 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Ratio a -> a
denominator Rational
daytime
      day :: Integer
day = Day -> Integer
toModifiedJulianDay forall a b. (a -> b) -> a -> b
$ UTCTime -> Day
utctDay UTCTime
utcTm
      d1 :: Word64
      d1 :: Word64
d1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
day
      c1 :: Word64
      c1 :: Word64
c1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
cpu
  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 :: String
rfile = String
"/dev/urandom"
  [Word64]
l <- forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
bytes forall a b. (a -> b) -> a -> b
$ \Ptr Word64
buf -> do
    Int
nread <- forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
rfile IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h ->
      forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
h Ptr Word64
buf Int
bytes
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
nread forall a. Eq a => a -> a -> Bool
/= Int
bytes) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"mkSeedUnix: Failed to read " forall a. [a] -> [a] -> [a]
++
        forall a. Show a => a -> String
show Int
bytes forall a. [a] -> [a] -> [a]
++ String
" from " forall a. [a] -> [a] -> [a]
++ String
rfile
    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
  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
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef TFGen
theTFGen forall g. RandomGen g => g -> (g, g)
split

{-# NOINLINE theTFGen #-}
theTFGen :: IORef TFGen
theTFGen :: IORef TFGen
theTFGen  = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
   TFGen
rng <- IO TFGen
initTFGen
   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
  | forall a. Bits a => a -> Int
bitSize Int
n forall a. Ord a => a -> a -> Bool
> Int
64 = forall a. HasCallStack => String -> a
error String
"mkTFGen: case where size of Int > 64 not implemented"
  | Bool
otherwise      = (Word64, Word64, Word64, Word64) -> TFGen
seedTFGen (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n, Word64
0, Word64
0, Word64
0)