{-# LANGUAGE TypeFamilies #-}
module Simulation.Aivika.IO.Generator () where
import System.Random
import qualified System.Random.MWC as MWC
import Control.Monad
import Control.Monad.Trans
import Data.IORef
import Data.Vector
import Data.Functor
import Simulation.Aivika.Trans.Generator
import Simulation.Aivika.Trans.Generator.Primitive
instance MonadGenerator IO where
{-# SPECIALISE instance MonadGenerator IO #-}
data Generator IO =
Generator { Generator IO -> IO Double
generator01 :: IO Double,
Generator IO -> IO Double
generatorNormal01 :: IO Double,
Generator IO -> IO Int
generatorSequenceNo :: IO Int
}
{-# INLINE generateUniform #-}
generateUniform :: Generator IO -> Double -> Double -> IO Double
generateUniform = IO Double -> Double -> Double -> IO Double
forall (m :: * -> *).
Monad m =>
m Double -> Double -> Double -> m Double
generateUniform01 (IO Double -> Double -> Double -> IO Double)
-> (Generator IO -> IO Double)
-> Generator IO
-> Double
-> Double
-> IO Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generator IO -> IO Double
generator01
{-# INLINE generateUniformInt #-}
generateUniformInt :: Generator IO -> Int -> Int -> IO Int
generateUniformInt = IO Double -> Int -> Int -> IO Int
forall (m :: * -> *). Monad m => m Double -> Int -> Int -> m Int
generateUniformInt01 (IO Double -> Int -> Int -> IO Int)
-> (Generator IO -> IO Double)
-> Generator IO
-> Int
-> Int
-> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generator IO -> IO Double
generator01
{-# INLINE generateTriangular #-}
generateTriangular :: Generator IO -> Double -> Double -> Double -> IO Double
generateTriangular = IO Double -> Double -> Double -> Double -> IO Double
forall (m :: * -> *).
Monad m =>
m Double -> Double -> Double -> Double -> m Double
generateTriangular01 (IO Double -> Double -> Double -> Double -> IO Double)
-> (Generator IO -> IO Double)
-> Generator IO
-> Double
-> Double
-> Double
-> IO Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generator IO -> IO Double
generator01
{-# INLINE generateNormal #-}
generateNormal :: Generator IO -> Double -> Double -> IO Double
generateNormal = IO Double -> Double -> Double -> IO Double
forall (m :: * -> *).
Monad m =>
m Double -> Double -> Double -> m Double
generateNormal01 (IO Double -> Double -> Double -> IO Double)
-> (Generator IO -> IO Double)
-> Generator IO
-> Double
-> Double
-> IO Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generator IO -> IO Double
generatorNormal01
{-# INLINE generateLogNormal #-}
generateLogNormal :: Generator IO -> Double -> Double -> IO Double
generateLogNormal = IO Double -> Double -> Double -> IO Double
forall (m :: * -> *).
Monad m =>
m Double -> Double -> Double -> m Double
generateLogNormal01 (IO Double -> Double -> Double -> IO Double)
-> (Generator IO -> IO Double)
-> Generator IO
-> Double
-> Double
-> IO Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generator IO -> IO Double
generatorNormal01
{-# INLINE generateExponential #-}
generateExponential :: Generator IO -> Double -> IO Double
generateExponential = IO Double -> Double -> IO Double
forall (m :: * -> *). Monad m => m Double -> Double -> m Double
generateExponential01 (IO Double -> Double -> IO Double)
-> (Generator IO -> IO Double)
-> Generator IO
-> Double
-> IO Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generator IO -> IO Double
generator01
{-# INLINE generateErlang #-}
generateErlang :: Generator IO -> Double -> Int -> IO Double
generateErlang = IO Double -> Double -> Int -> IO Double
forall (m :: * -> *).
Monad m =>
m Double -> Double -> Int -> m Double
generateErlang01 (IO Double -> Double -> Int -> IO Double)
-> (Generator IO -> IO Double)
-> Generator IO
-> Double
-> Int
-> IO Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generator IO -> IO Double
generator01
{-# INLINE generatePoisson #-}
generatePoisson :: Generator IO -> Double -> IO Int
generatePoisson = IO Double -> Double -> IO Int
forall (m :: * -> *). Monad m => m Double -> Double -> m Int
generatePoisson01 (IO Double -> Double -> IO Int)
-> (Generator IO -> IO Double) -> Generator IO -> Double -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generator IO -> IO Double
generator01
{-# INLINE generateBinomial #-}
generateBinomial :: Generator IO -> Double -> Int -> IO Int
generateBinomial = IO Double -> Double -> Int -> IO Int
forall (m :: * -> *). Monad m => m Double -> Double -> Int -> m Int
generateBinomial01 (IO Double -> Double -> Int -> IO Int)
-> (Generator IO -> IO Double)
-> Generator IO
-> Double
-> Int
-> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generator IO -> IO Double
generator01
{-# INLINE generateGamma #-}
generateGamma :: Generator IO -> Double -> Double -> IO Double
generateGamma Generator IO
g = IO Double -> IO Double -> Double -> Double -> IO Double
forall (m :: * -> *).
Monad m =>
m Double -> m Double -> Double -> Double -> m Double
generateGamma01 (Generator IO -> IO Double
generatorNormal01 Generator IO
g) (Generator IO -> IO Double
generator01 Generator IO
g)
{-# INLINE generateBeta #-}
generateBeta :: Generator IO -> Double -> Double -> IO Double
generateBeta Generator IO
g = IO Double -> IO Double -> Double -> Double -> IO Double
forall (m :: * -> *).
Monad m =>
m Double -> m Double -> Double -> Double -> m Double
generateBeta01 (Generator IO -> IO Double
generatorNormal01 Generator IO
g) (Generator IO -> IO Double
generator01 Generator IO
g)
{-# INLINE generateWeibull #-}
generateWeibull :: Generator IO -> Double -> Double -> IO Double
generateWeibull = IO Double -> Double -> Double -> IO Double
forall (m :: * -> *).
Monad m =>
m Double -> Double -> Double -> m Double
generateWeibull01 (IO Double -> Double -> Double -> IO Double)
-> (Generator IO -> IO Double)
-> Generator IO
-> Double
-> Double
-> IO Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generator IO -> IO Double
generator01
{-# INLINE generateDiscrete #-}
generateDiscrete :: forall a. Generator IO -> DiscretePDF a -> IO a
generateDiscrete = IO Double -> DiscretePDF a -> IO a
forall (m :: * -> *) a. Monad m => m Double -> DiscretePDF a -> m a
generateDiscrete01 (IO Double -> DiscretePDF a -> IO a)
-> (Generator IO -> IO Double)
-> Generator IO
-> DiscretePDF a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generator IO -> IO Double
generator01
{-# INLINE generateSequenceNo #-}
generateSequenceNo :: Generator IO -> IO Int
generateSequenceNo = Generator IO -> IO Int
generatorSequenceNo
{-# INLINABLE newGenerator #-}
newGenerator :: GeneratorType IO -> IO (Generator IO)
newGenerator GeneratorType IO
tp =
case GeneratorType IO
tp of
GeneratorType IO
SimpleGenerator ->
Gen RealWorld -> IO Double
Gen (PrimState IO) -> IO Double
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m Double
MWC.uniform (Gen RealWorld -> IO Double)
-> IO (Gen RealWorld) -> IO (IO Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Gen RealWorld)
IO (Gen (PrimState IO))
MWC.createSystemRandom IO (IO Double)
-> (IO Double -> IO (Generator IO)) -> IO (Generator IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Double -> IO (Generator IO)
forall (m :: * -> *).
MonadGenerator m =>
m Double -> m (Generator m)
newRandomGenerator01
SimpleGeneratorWithSeed Word32
x ->
Gen RealWorld -> IO Double
Gen (PrimState IO) -> IO Double
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m Double
MWC.uniform (Gen RealWorld -> IO Double)
-> IO (Gen RealWorld) -> IO (IO Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Word32 -> IO (Gen (PrimState IO))
forall (m :: * -> *) (v :: * -> *).
(PrimMonad m, Vector v Word32) =>
v Word32 -> m (Gen (PrimState m))
MWC.initialize (Word32 -> Vector Word32
forall a. a -> Vector a
singleton Word32
x) IO (IO Double)
-> (IO Double -> IO (Generator IO)) -> IO (Generator IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Double -> IO (Generator IO)
forall (m :: * -> *).
MonadGenerator m =>
m Double -> m (Generator m)
newRandomGenerator01
CustomGenerator IO (Generator IO)
g ->
IO (Generator IO)
g
CustomGenerator01 IO Double
g ->
IO Double -> IO (Generator IO)
forall (m :: * -> *).
MonadGenerator m =>
m Double -> m (Generator m)
newRandomGenerator01 IO Double
g
{-# INLINABLE newRandomGenerator #-}
newRandomGenerator :: forall g. RandomGen g => g -> IO (Generator IO)
newRandomGenerator g
g =
do IORef g
r <- IO (IORef g) -> IO (IORef g)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef g) -> IO (IORef g)) -> IO (IORef g) -> IO (IORef g)
forall a b. (a -> b) -> a -> b
$ g -> IO (IORef g)
forall a. a -> IO (IORef a)
newIORef g
g
let g01 :: IO Double
g01 = do g
g <- IO g -> IO g
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO g -> IO g) -> IO g -> IO g
forall a b. (a -> b) -> a -> b
$ IORef g -> IO g
forall a. IORef a -> IO a
readIORef IORef g
r
let (Double
x, g
g') = g -> (Double, g)
forall g. RandomGen g => g -> (Double, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random g
g
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef g -> g -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef g
r g
g'
Double -> IO Double
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Double
x
IO Double -> IO (Generator IO)
forall (m :: * -> *).
MonadGenerator m =>
m Double -> m (Generator m)
newRandomGenerator01 IO Double
g01
{-# INLINABLE newRandomGenerator01 #-}
newRandomGenerator01 :: IO Double -> IO (Generator IO)
newRandomGenerator01 IO Double
g01 =
do IO Double
gNormal01 <- IO Double -> IO (IO Double)
forall (m :: * -> *). MonadIO m => m Double -> m (m Double)
newNormalGenerator01 IO Double
g01
IORef Int
gSeqNoRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
let gSeqNo :: IO Int
gSeqNo = do { Int
x <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
gSeqNoRef; IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Int
gSeqNoRef (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1); Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
x }
Generator IO -> IO (Generator IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Generator { generator01 :: IO Double
generator01 = IO Double
g01,
generatorNormal01 :: IO Double
generatorNormal01 = IO Double
gNormal01,
generatorSequenceNo :: IO Int
generatorSequenceNo = IO Int
gSeqNo }
newNormalGenerator01 :: MonadIO m
=> m Double
-> m (m Double)
{-# INLINABLE newNormalGenerator01 #-}
newNormalGenerator01 :: forall (m :: * -> *). MonadIO m => m Double -> m (m Double)
newNormalGenerator01 m Double
g =
do IORef Double
nextRef <- IO (IORef Double) -> m (IORef Double)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Double) -> m (IORef Double))
-> IO (IORef Double) -> m (IORef Double)
forall a b. (a -> b) -> a -> b
$ Double -> IO (IORef Double)
forall a. a -> IO (IORef a)
newIORef Double
0.0
IORef Bool
flagRef <- IO (IORef Bool) -> m (IORef Bool)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Bool) -> m (IORef Bool))
-> IO (IORef Bool) -> m (IORef Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
IORef Double
xi1Ref <- IO (IORef Double) -> m (IORef Double)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Double) -> m (IORef Double))
-> IO (IORef Double) -> m (IORef Double)
forall a b. (a -> b) -> a -> b
$ Double -> IO (IORef Double)
forall a. a -> IO (IORef a)
newIORef Double
0.0
IORef Double
xi2Ref <- IO (IORef Double) -> m (IORef Double)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Double) -> m (IORef Double))
-> IO (IORef Double) -> m (IORef Double)
forall a b. (a -> b) -> a -> b
$ Double -> IO (IORef Double)
forall a. a -> IO (IORef a)
newIORef Double
0.0
IORef Double
psiRef <- IO (IORef Double) -> m (IORef Double)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Double) -> m (IORef Double))
-> IO (IORef Double) -> m (IORef Double)
forall a b. (a -> b) -> a -> b
$ Double -> IO (IORef Double)
forall a. a -> IO (IORef a)
newIORef Double
0.0
let loop :: m ()
loop =
do Double
psi <- IO Double -> m Double
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> m Double) -> IO Double -> m Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef IORef Double
psiRef
if (Double
psi Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1.0) Bool -> Bool -> Bool
|| (Double
psi Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0.0)
then do Double
g1 <- m Double
g
Double
g2 <- m Double
g
let xi1 :: Double
xi1 = Double
2.0 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
g1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1.0
xi2 :: Double
xi2 = Double
2.0 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
g2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1.0
psi :: Double
psi = Double
xi1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
xi1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
xi2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
xi2
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Double
xi1Ref Double
xi1
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Double
xi2Ref Double
xi2
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Double
psiRef Double
psi
m ()
loop
else IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Double
psiRef (Double -> IO ()) -> Double -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Double
forall a. Floating a => a -> a
sqrt (- Double
2.0 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
log Double
psi Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
psi)
m Double -> m (m Double)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (m Double -> m (m Double)) -> m Double -> m (m Double)
forall a b. (a -> b) -> a -> b
$
do Bool
flag <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
flagRef
if Bool
flag
then do IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
flagRef Bool
False
IO Double -> m Double
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> m Double) -> IO Double -> m Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef IORef Double
nextRef
else do IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Double
xi1Ref Double
0.0
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Double
xi2Ref Double
0.0
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Double
psiRef Double
0.0
m ()
loop
Double
xi1 <- IO Double -> m Double
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> m Double) -> IO Double -> m Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef IORef Double
xi1Ref
Double
xi2 <- IO Double -> m Double
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> m Double) -> IO Double -> m Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef IORef Double
xi2Ref
Double
psi <- IO Double -> m Double
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> m Double) -> IO Double -> m Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef IORef Double
psiRef
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
flagRef Bool
True
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Double
nextRef (Double -> IO ()) -> Double -> IO ()
forall a b. (a -> b) -> a -> b
$ Double
xi2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
psi
Double -> m Double
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> m Double) -> Double -> m Double
forall a b. (a -> b) -> a -> b
$ Double
xi1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
psi