{-# LANGUAGE RecursiveDo, RankNTypes #-}

-- |
-- Module     : Simulation.Aivika.Internal.Parameter
-- Copyright  : Copyright (c) 2009-2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 8.0.1
--
-- This is an internal implementation module that should never be used directly.
--
-- The module defines the 'Parameter' monad that allows representing the model
-- parameters. For example, they can be used when running the Monte-Carlo simulation.
--
-- In general, this monad is very useful for representing a computation which is external
-- relative to the model itself.
--
module Simulation.Aivika.Internal.Parameter
       (-- * Parameter
        Parameter(..),
        ParameterLift(..),
        invokeParameter,
        runParameter,
        runParameters,
        -- * Error Handling
        catchParameter,
        finallyParameter,
        throwParameter,
        -- * Predefined Parameters
        simulationIndex,
        simulationCount,
        simulationSpecs,
        starttime,
        stoptime,
        dt,
        generatorParameter,
        -- * Memoization
        memoParameter,
        -- * Utilities
        tableParameter) where

import Control.Exception
import Control.Concurrent.MVar

import Control.Monad
import Control.Monad.Trans
import Control.Monad.Fix
import Control.Monad.Fail
import qualified Control.Monad.Catch as MC
import Control.Applicative

import Data.IORef
import qualified Data.IntMap as M
import Data.Array

import Simulation.Aivika.Generator
import Simulation.Aivika.Internal.Specs

-- | The 'Parameter' monad that allows specifying the model parameters.
-- For example, they can be used when running the Monte-Carlo simulation.
-- 
-- In general, this monad is very useful for representing a computation which is external
-- relative to the model itself.
newtype Parameter a = Parameter (Run -> IO a)

instance Monad Parameter where
  Parameter a
m >>= :: forall a b. Parameter a -> (a -> Parameter b) -> Parameter b
>>= a -> Parameter b
k = Parameter a -> (a -> Parameter b) -> Parameter b
forall a b. Parameter a -> (a -> Parameter b) -> Parameter b
bindP Parameter a
m a -> Parameter b
k

returnP :: a -> Parameter a
{-# INLINE returnP #-}
returnP :: forall a. a -> Parameter a
returnP a
a = (Run -> IO a) -> Parameter a
forall a. (Run -> IO a) -> Parameter a
Parameter (\Run
r -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a)

bindP :: Parameter a -> (a -> Parameter b) -> Parameter b
{-# INLINE bindP #-}
bindP :: forall a b. Parameter a -> (a -> Parameter b) -> Parameter b
bindP (Parameter Run -> IO a
m) a -> Parameter b
k = 
  (Run -> IO b) -> Parameter b
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO b) -> Parameter b) -> (Run -> IO b) -> Parameter b
forall a b. (a -> b) -> a -> b
$ \Run
r -> 
  do a
a <- Run -> IO a
m Run
r
     let Parameter Run -> IO b
m' = a -> Parameter b
k a
a
     Run -> IO b
m' Run
r

-- | Run the parameter using the specified specs.
runParameter :: Parameter a -> Specs -> IO a
runParameter :: forall a. Parameter a -> Specs -> IO a
runParameter (Parameter Run -> IO a
m) Specs
sc =
  do EventQueue
q <- Specs -> IO EventQueue
newEventQueue Specs
sc
     Generator
g <- GeneratorType -> IO Generator
newGenerator (GeneratorType -> IO Generator) -> GeneratorType -> IO Generator
forall a b. (a -> b) -> a -> b
$ Specs -> GeneratorType
spcGeneratorType Specs
sc
     Run -> IO a
m Run { runSpecs :: Specs
runSpecs = Specs
sc,
             runIndex :: Int
runIndex = Int
1,
             runCount :: Int
runCount = Int
1,
             runEventQueue :: EventQueue
runEventQueue = EventQueue
q,
             runGenerator :: Generator
runGenerator = Generator
g }

-- | Run the given number of parameters using the specified specs, 
--   where each parameter is distinguished by its index 'parameterIndex'.
runParameters :: Parameter a -> Specs -> Int -> [IO a]
runParameters :: forall a. Parameter a -> Specs -> Int -> [IO a]
runParameters (Parameter Run -> IO a
m) Specs
sc Int
runs = (Int -> IO a) -> [Int] -> [IO a]
forall a b. (a -> b) -> [a] -> [b]
map Int -> IO a
f [Int
1 .. Int
runs]
  where f :: Int -> IO a
f Int
i = do EventQueue
q <- Specs -> IO EventQueue
newEventQueue Specs
sc
                 Generator
g <- GeneratorType -> IO Generator
newGenerator (GeneratorType -> IO Generator) -> GeneratorType -> IO Generator
forall a b. (a -> b) -> a -> b
$ Specs -> GeneratorType
spcGeneratorType Specs
sc
                 Run -> IO a
m Run { runSpecs :: Specs
runSpecs = Specs
sc,
                         runIndex :: Int
runIndex = Int
i,
                         runCount :: Int
runCount = Int
runs,
                         runEventQueue :: EventQueue
runEventQueue = EventQueue
q,
                         runGenerator :: Generator
runGenerator = Generator
g }

-- | Return the run index for the current simulation.
simulationIndex :: Parameter Int
simulationIndex :: Parameter Int
simulationIndex = (Run -> IO Int) -> Parameter Int
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO Int) -> Parameter Int)
-> (Run -> IO Int) -> Parameter Int
forall a b. (a -> b) -> a -> b
$ Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> (Run -> Int) -> Run -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> Int
runIndex

-- | Return the number of simulations currently run.
simulationCount :: Parameter Int
simulationCount :: Parameter Int
simulationCount = (Run -> IO Int) -> Parameter Int
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO Int) -> Parameter Int)
-> (Run -> IO Int) -> Parameter Int
forall a b. (a -> b) -> a -> b
$ Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> (Run -> Int) -> Run -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> Int
runCount

-- | Return the simulation specs.
simulationSpecs :: Parameter Specs
simulationSpecs :: Parameter Specs
simulationSpecs = (Run -> IO Specs) -> Parameter Specs
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO Specs) -> Parameter Specs)
-> (Run -> IO Specs) -> Parameter Specs
forall a b. (a -> b) -> a -> b
$ Specs -> IO Specs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Specs -> IO Specs) -> (Run -> Specs) -> Run -> IO Specs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> Specs
runSpecs

-- | Return the random number generator for the simulation run.
generatorParameter :: Parameter Generator
generatorParameter :: Parameter Generator
generatorParameter = (Run -> IO Generator) -> Parameter Generator
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO Generator) -> Parameter Generator)
-> (Run -> IO Generator) -> Parameter Generator
forall a b. (a -> b) -> a -> b
$ Generator -> IO Generator
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Generator -> IO Generator)
-> (Run -> Generator) -> Run -> IO Generator
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> Generator
runGenerator

instance Functor Parameter where
  fmap :: forall a b. (a -> b) -> Parameter a -> Parameter b
fmap = (a -> b) -> Parameter a -> Parameter b
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP

instance Applicative Parameter where
  pure :: forall a. a -> Parameter a
pure = a -> Parameter a
forall a. a -> Parameter a
returnP
  <*> :: forall a b. Parameter (a -> b) -> Parameter a -> Parameter b
(<*>) = Parameter (a -> b) -> Parameter a -> Parameter b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance MonadFail Parameter where
  fail :: forall a. String -> Parameter a
fail = String -> Parameter a
forall a. HasCallStack => String -> a
error

instance Eq (Parameter a) where
  Parameter a
x == :: Parameter a -> Parameter a -> Bool
== Parameter a
y = String -> Bool
forall a. HasCallStack => String -> a
error String
"Can't compare parameters." 

instance Show (Parameter a) where
  showsPrec :: Int -> Parameter a -> ShowS
showsPrec Int
_ Parameter a
x = String -> ShowS
showString String
"<< Parameter >>"

liftMP :: (a -> b) -> Parameter a -> Parameter b
{-# INLINE liftMP #-}
liftMP :: forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> b
f (Parameter Run -> IO a
x) =
  (Run -> IO b) -> Parameter b
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO b) -> Parameter b) -> (Run -> IO b) -> Parameter b
forall a b. (a -> b) -> a -> b
$ \Run
r -> do { a
a <- Run -> IO a
x Run
r; b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> IO b) -> b -> IO b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a }

liftM2P :: (a -> b -> c) -> Parameter a -> Parameter b -> Parameter c
{-# INLINE liftM2P #-}
liftM2P :: forall a b c.
(a -> b -> c) -> Parameter a -> Parameter b -> Parameter c
liftM2P a -> b -> c
f (Parameter Run -> IO a
x) (Parameter Run -> IO b
y) =
  (Run -> IO c) -> Parameter c
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO c) -> Parameter c) -> (Run -> IO c) -> Parameter c
forall a b. (a -> b) -> a -> b
$ \Run
r -> do { a
a <- Run -> IO a
x Run
r; b
b <- Run -> IO b
y Run
r; c -> IO c
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> IO c) -> c -> IO c
forall a b. (a -> b) -> a -> b
$ a -> b -> c
f a
a b
b }

instance (Num a) => Num (Parameter a) where
  Parameter a
x + :: Parameter a -> Parameter a -> Parameter a
+ Parameter a
y = (a -> a -> a) -> Parameter a -> Parameter a -> Parameter a
forall a b c.
(a -> b -> c) -> Parameter a -> Parameter b -> Parameter c
liftM2P a -> a -> a
forall a. Num a => a -> a -> a
(+) Parameter a
x Parameter a
y
  Parameter a
x - :: Parameter a -> Parameter a -> Parameter a
- Parameter a
y = (a -> a -> a) -> Parameter a -> Parameter a -> Parameter a
forall a b c.
(a -> b -> c) -> Parameter a -> Parameter b -> Parameter c
liftM2P (-) Parameter a
x Parameter a
y
  Parameter a
x * :: Parameter a -> Parameter a -> Parameter a
* Parameter a
y = (a -> a -> a) -> Parameter a -> Parameter a -> Parameter a
forall a b c.
(a -> b -> c) -> Parameter a -> Parameter b -> Parameter c
liftM2P a -> a -> a
forall a. Num a => a -> a -> a
(*) Parameter a
x Parameter a
y
  negate :: Parameter a -> Parameter a
negate = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Num a => a -> a
negate
  abs :: Parameter a -> Parameter a
abs = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Num a => a -> a
abs
  signum :: Parameter a -> Parameter a
signum = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Num a => a -> a
signum
  fromInteger :: Integer -> Parameter a
fromInteger Integer
i = a -> Parameter a
forall a. a -> Parameter a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Parameter a) -> a -> Parameter a
forall a b. (a -> b) -> a -> b
$ Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
i

instance (Fractional a) => Fractional (Parameter a) where
  Parameter a
x / :: Parameter a -> Parameter a -> Parameter a
/ Parameter a
y = (a -> a -> a) -> Parameter a -> Parameter a -> Parameter a
forall a b c.
(a -> b -> c) -> Parameter a -> Parameter b -> Parameter c
liftM2P a -> a -> a
forall a. Fractional a => a -> a -> a
(/) Parameter a
x Parameter a
y
  recip :: Parameter a -> Parameter a
recip = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Fractional a => a -> a
recip
  fromRational :: Rational -> Parameter a
fromRational Rational
t = a -> Parameter a
forall a. a -> Parameter a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Parameter a) -> a -> Parameter a
forall a b. (a -> b) -> a -> b
$ Rational -> a
forall a. Fractional a => Rational -> a
fromRational Rational
t

instance (Floating a) => Floating (Parameter a) where
  pi :: Parameter a
pi = a -> Parameter a
forall a. a -> Parameter a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Floating a => a
pi
  exp :: Parameter a -> Parameter a
exp = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Floating a => a -> a
exp
  log :: Parameter a -> Parameter a
log = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Floating a => a -> a
log
  sqrt :: Parameter a -> Parameter a
sqrt = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Floating a => a -> a
sqrt
  Parameter a
x ** :: Parameter a -> Parameter a -> Parameter a
** Parameter a
y = (a -> a -> a) -> Parameter a -> Parameter a -> Parameter a
forall a b c.
(a -> b -> c) -> Parameter a -> Parameter b -> Parameter c
liftM2P a -> a -> a
forall a. Floating a => a -> a -> a
(**) Parameter a
x Parameter a
y
  sin :: Parameter a -> Parameter a
sin = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Floating a => a -> a
sin
  cos :: Parameter a -> Parameter a
cos = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Floating a => a -> a
cos
  tan :: Parameter a -> Parameter a
tan = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Floating a => a -> a
tan
  asin :: Parameter a -> Parameter a
asin = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Floating a => a -> a
asin
  acos :: Parameter a -> Parameter a
acos = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Floating a => a -> a
acos
  atan :: Parameter a -> Parameter a
atan = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Floating a => a -> a
atan
  sinh :: Parameter a -> Parameter a
sinh = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Floating a => a -> a
sinh
  cosh :: Parameter a -> Parameter a
cosh = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Floating a => a -> a
cosh
  tanh :: Parameter a -> Parameter a
tanh = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Floating a => a -> a
tanh
  asinh :: Parameter a -> Parameter a
asinh = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Floating a => a -> a
asinh
  acosh :: Parameter a -> Parameter a
acosh = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Floating a => a -> a
acosh
  atanh :: Parameter a -> Parameter a
atanh = (a -> a) -> Parameter a -> Parameter a
forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP a -> a
forall a. Floating a => a -> a
atanh

instance MonadIO Parameter where
  liftIO :: forall a. IO a -> Parameter a
liftIO IO a
m = (Run -> IO a) -> Parameter a
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO a) -> Parameter a) -> (Run -> IO a) -> Parameter a
forall a b. (a -> b) -> a -> b
$ IO a -> Run -> IO a
forall a b. a -> b -> a
const IO a
m

-- | A type class to lift the parameters to other computations.
class ParameterLift m where
  
  -- | Lift the specified 'Parameter' computation to another computation.
  liftParameter :: Parameter a -> m a

instance ParameterLift Parameter where
  liftParameter :: forall a. Parameter a -> Parameter a
liftParameter = Parameter a -> Parameter a
forall a. a -> a
id
    
-- | Exception handling within 'Parameter' computations.
catchParameter :: Exception e => Parameter a -> (e -> Parameter a) -> Parameter a
catchParameter :: forall e a.
Exception e =>
Parameter a -> (e -> Parameter a) -> Parameter a
catchParameter (Parameter Run -> IO a
m) e -> Parameter a
h =
  (Run -> IO a) -> Parameter a
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO a) -> Parameter a) -> (Run -> IO a) -> Parameter a
forall a b. (a -> b) -> a -> b
$ \Run
r -> 
  IO a -> (e -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Run -> IO a
m Run
r) ((e -> IO a) -> IO a) -> (e -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \e
e ->
  let Parameter Run -> IO a
m' = e -> Parameter a
h e
e in Run -> IO a
m' Run
r
                           
-- | A computation with finalization part like the 'finally' function.
finallyParameter :: Parameter a -> Parameter b -> Parameter a
finallyParameter :: forall a b. Parameter a -> Parameter b -> Parameter a
finallyParameter (Parameter Run -> IO a
m) (Parameter Run -> IO b
m') =
  (Run -> IO a) -> Parameter a
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO a) -> Parameter a) -> (Run -> IO a) -> Parameter a
forall a b. (a -> b) -> a -> b
$ \Run
r ->
  IO a -> IO b -> IO a
forall a b. IO a -> IO b -> IO a
finally (Run -> IO a
m Run
r) (Run -> IO b
m' Run
r)

-- | Like the standard 'throw' function.
throwParameter :: Exception e => e -> Parameter a
throwParameter :: forall e a. Exception e => e -> Parameter a
throwParameter = e -> Parameter a
forall a e. Exception e => e -> a
throw

-- | Runs an action with asynchronous exceptions disabled.
maskParameter :: ((forall a. Parameter a -> Parameter a) -> Parameter b) -> Parameter b
maskParameter :: forall b.
((forall a. Parameter a -> Parameter a) -> Parameter b)
-> Parameter b
maskParameter (forall a. Parameter a -> Parameter a) -> Parameter b
a =
  (Run -> IO b) -> Parameter b
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO b) -> Parameter b) -> (Run -> IO b) -> Parameter b
forall a b. (a -> b) -> a -> b
$ \Run
r ->
  ((forall a. IO a -> IO a) -> IO b) -> IO b
forall b.
HasCallStack =>
((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
MC.mask (((forall a. IO a -> IO a) -> IO b) -> IO b)
-> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
u ->
  Run -> Parameter b -> IO b
forall a. Run -> Parameter a -> IO a
invokeParameter Run
r ((forall a. Parameter a -> Parameter a) -> Parameter b
a ((forall a. Parameter a -> Parameter a) -> Parameter b)
-> (forall a. Parameter a -> Parameter a) -> Parameter b
forall a b. (a -> b) -> a -> b
$ (IO a -> IO a) -> Parameter a -> Parameter a
forall {a} {a}. (IO a -> IO a) -> Parameter a -> Parameter a
q IO a -> IO a
forall a. IO a -> IO a
u)
  where q :: (IO a -> IO a) -> Parameter a -> Parameter a
q IO a -> IO a
u (Parameter Run -> IO a
b) = (Run -> IO a) -> Parameter a
forall a. (Run -> IO a) -> Parameter a
Parameter (IO a -> IO a
u (IO a -> IO a) -> (Run -> IO a) -> Run -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> IO a
b)

-- | Like 'maskParameter', but the masked computation is not interruptible.
uninterruptibleMaskParameter :: ((forall a. Parameter a -> Parameter a) -> Parameter b) -> Parameter b
uninterruptibleMaskParameter :: forall b.
((forall a. Parameter a -> Parameter a) -> Parameter b)
-> Parameter b
uninterruptibleMaskParameter (forall a. Parameter a -> Parameter a) -> Parameter b
a =
  (Run -> IO b) -> Parameter b
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO b) -> Parameter b) -> (Run -> IO b) -> Parameter b
forall a b. (a -> b) -> a -> b
$ \Run
r ->
  ((forall a. IO a -> IO a) -> IO b) -> IO b
forall b.
HasCallStack =>
((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
MC.uninterruptibleMask (((forall a. IO a -> IO a) -> IO b) -> IO b)
-> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
u ->
  Run -> Parameter b -> IO b
forall a. Run -> Parameter a -> IO a
invokeParameter Run
r ((forall a. Parameter a -> Parameter a) -> Parameter b
a ((forall a. Parameter a -> Parameter a) -> Parameter b)
-> (forall a. Parameter a -> Parameter a) -> Parameter b
forall a b. (a -> b) -> a -> b
$ (IO a -> IO a) -> Parameter a -> Parameter a
forall {a} {a}. (IO a -> IO a) -> Parameter a -> Parameter a
q IO a -> IO a
forall a. IO a -> IO a
u)
  where q :: (IO a -> IO a) -> Parameter a -> Parameter a
q IO a -> IO a
u (Parameter Run -> IO a
b) = (Run -> IO a) -> Parameter a
forall a. (Run -> IO a) -> Parameter a
Parameter (IO a -> IO a
u (IO a -> IO a) -> (Run -> IO a) -> Run -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> IO a
b)

-- | An implementation of 'generalBracket'.
generalBracketParameter :: Parameter a
                           -> (a -> MC.ExitCase b -> Parameter c)
                           -> (a -> Parameter b)
                           -> Parameter (b, c)
generalBracketParameter :: forall a b c.
Parameter a
-> (a -> ExitCase b -> Parameter c)
-> (a -> Parameter b)
-> Parameter (b, c)
generalBracketParameter Parameter a
acquire a -> ExitCase b -> Parameter c
release a -> Parameter b
use =
  (Run -> IO (b, c)) -> Parameter (b, c)
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO (b, c)) -> Parameter (b, c))
-> (Run -> IO (b, c)) -> Parameter (b, c)
forall a b. (a -> b) -> a -> b
$ \Run
r -> do
    IO a -> (a -> ExitCase b -> IO c) -> (a -> IO b) -> IO (b, c)
forall a b c.
HasCallStack =>
IO a -> (a -> ExitCase b -> IO c) -> (a -> IO b) -> IO (b, c)
forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
MC.generalBracket
      (Run -> Parameter a -> IO a
forall a. Run -> Parameter a -> IO a
invokeParameter Run
r Parameter a
acquire)
      (\a
resource ExitCase b
e -> Run -> Parameter c -> IO c
forall a. Run -> Parameter a -> IO a
invokeParameter Run
r (Parameter c -> IO c) -> Parameter c -> IO c
forall a b. (a -> b) -> a -> b
$ a -> ExitCase b -> Parameter c
release a
resource ExitCase b
e)
      (\a
resource -> Run -> Parameter b -> IO b
forall a. Run -> Parameter a -> IO a
invokeParameter Run
r (Parameter b -> IO b) -> Parameter b -> IO b
forall a b. (a -> b) -> a -> b
$ a -> Parameter b
use a
resource)

-- | Invoke the 'Parameter' computation.
invokeParameter :: Run -> Parameter a -> IO a
{-# INLINE invokeParameter #-}
invokeParameter :: forall a. Run -> Parameter a -> IO a
invokeParameter Run
r (Parameter Run -> IO a
m) = Run -> IO a
m Run
r

instance MonadFix Parameter where
  mfix :: forall a. (a -> Parameter a) -> Parameter a
mfix a -> Parameter a
f = 
    (Run -> IO a) -> Parameter a
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO a) -> Parameter a) -> (Run -> IO a) -> Parameter a
forall a b. (a -> b) -> a -> b
$ \Run
r ->
    do { rec { a
a <- Run -> Parameter a -> IO a
forall a. Run -> Parameter a -> IO a
invokeParameter Run
r (a -> Parameter a
f a
a) }; a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a }  

instance MC.MonadThrow Parameter where
  throwM :: forall e a. (HasCallStack, Exception e) => e -> Parameter a
throwM = e -> Parameter a
forall e a. Exception e => e -> Parameter a
throwParameter

instance MC.MonadCatch Parameter where
  catch :: forall e a.
(HasCallStack, Exception e) =>
Parameter a -> (e -> Parameter a) -> Parameter a
catch = Parameter a -> (e -> Parameter a) -> Parameter a
forall e a.
Exception e =>
Parameter a -> (e -> Parameter a) -> Parameter a
catchParameter

instance MC.MonadMask Parameter where
  mask :: forall b.
HasCallStack =>
((forall a. Parameter a -> Parameter a) -> Parameter b)
-> Parameter b
mask = ((forall a. Parameter a -> Parameter a) -> Parameter b)
-> Parameter b
forall b.
((forall a. Parameter a -> Parameter a) -> Parameter b)
-> Parameter b
maskParameter
  uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. Parameter a -> Parameter a) -> Parameter b)
-> Parameter b
uninterruptibleMask = ((forall a. Parameter a -> Parameter a) -> Parameter b)
-> Parameter b
forall b.
((forall a. Parameter a -> Parameter a) -> Parameter b)
-> Parameter b
uninterruptibleMaskParameter
  generalBracket :: forall a b c.
HasCallStack =>
Parameter a
-> (a -> ExitCase b -> Parameter c)
-> (a -> Parameter b)
-> Parameter (b, c)
generalBracket = Parameter a
-> (a -> ExitCase b -> Parameter c)
-> (a -> Parameter b)
-> Parameter (b, c)
forall a b c.
Parameter a
-> (a -> ExitCase b -> Parameter c)
-> (a -> Parameter b)
-> Parameter (b, c)
generalBracketParameter
  
-- | Memoize the 'Parameter' computation, always returning the same value
-- within a simulation run. However, the value will be recalculated for other
-- simulation runs. Also it is thread-safe when different simulation runs
-- are executed in parallel on physically different operating system threads.
memoParameter :: Parameter a -> IO (Parameter a)
memoParameter :: forall a. Parameter a -> IO (Parameter a)
memoParameter Parameter a
x = 
  do MVar ()
lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
     IORef (IntMap a)
dict <- IntMap a -> IO (IORef (IntMap a))
forall a. a -> IO (IORef a)
newIORef IntMap a
forall a. IntMap a
M.empty
     Parameter a -> IO (Parameter a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parameter a -> IO (Parameter a))
-> Parameter a -> IO (Parameter a)
forall a b. (a -> b) -> a -> b
$ (Run -> IO a) -> Parameter a
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO a) -> Parameter a) -> (Run -> IO a) -> Parameter a
forall a b. (a -> b) -> a -> b
$ \Run
r ->
       do let i :: Int
i = Run -> Int
runIndex Run
r
          IntMap a
m <- IORef (IntMap a) -> IO (IntMap a)
forall a. IORef a -> IO a
readIORef IORef (IntMap a)
dict
          if Int -> IntMap a -> Bool
forall a. Int -> IntMap a -> Bool
M.member Int
i IntMap a
m
            then do let Just a
v = Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap a
m
                    a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
            else MVar () -> (() -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO a) -> IO a) -> (() -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ 
                 \() -> do { IntMap a
m <- IORef (IntMap a) -> IO (IntMap a)
forall a. IORef a -> IO a
readIORef IORef (IntMap a)
dict;
                             if Int -> IntMap a -> Bool
forall a. Int -> IntMap a -> Bool
M.member Int
i IntMap a
m
                             then do let Just a
v = Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap a
m
                                     a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
                             else do a
v <- Run -> Parameter a -> IO a
forall a. Run -> Parameter a -> IO a
invokeParameter Run
r Parameter a
x
                                     IORef (IntMap a) -> IntMap a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (IntMap a)
dict (IntMap a -> IO ()) -> IntMap a -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> a -> IntMap a -> IntMap a
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
i a
v IntMap a
m
                                     a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v }

-- | Return a parameter which value is taken consequently from the specified table
-- based on the run index of the current simulation starting from zero. After all
-- values from the table are used, it takes again the first value of the table,
-- then the second one and so on.
tableParameter :: Array Int a -> Parameter a
tableParameter :: forall a. Array Int a -> Parameter a
tableParameter Array Int a
t =
  do Int
i <- Parameter Int
simulationIndex
     a -> Parameter a
forall a. a -> Parameter a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Parameter a) -> a -> Parameter a
forall a b. (a -> b) -> a -> b
$ Array Int a
t Array Int a -> Int -> a
forall i e. Ix i => Array i e -> i -> e
! (((Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i1)
  where (Int
i1, Int
i2) = Array Int a -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds Array Int a
t
        n :: Int
n = Int
i2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

-- | Computation that returns the start simulation time.
starttime :: Parameter Double
starttime :: Parameter Double
starttime =
  (Run -> IO Double) -> Parameter Double
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO Double) -> Parameter Double)
-> (Run -> IO Double) -> Parameter Double
forall a b. (a -> b) -> a -> b
$ Double -> IO Double
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> IO Double) -> (Run -> Double) -> Run -> IO Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Specs -> Double
spcStartTime (Specs -> Double) -> (Run -> Specs) -> Run -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> Specs
runSpecs

-- | Computation that returns the final simulation time.
stoptime :: Parameter Double
stoptime :: Parameter Double
stoptime =
  (Run -> IO Double) -> Parameter Double
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO Double) -> Parameter Double)
-> (Run -> IO Double) -> Parameter Double
forall a b. (a -> b) -> a -> b
$ Double -> IO Double
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> IO Double) -> (Run -> Double) -> Run -> IO Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Specs -> Double
spcStopTime (Specs -> Double) -> (Run -> Specs) -> Run -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> Specs
runSpecs

-- | Computation that returns the integration time step.
dt :: Parameter Double
dt :: Parameter Double
dt =
  (Run -> IO Double) -> Parameter Double
forall a. (Run -> IO a) -> Parameter a
Parameter ((Run -> IO Double) -> Parameter Double)
-> (Run -> IO Double) -> Parameter Double
forall a b. (a -> b) -> a -> b
$ Double -> IO Double
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> IO Double) -> (Run -> Double) -> Run -> IO Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Specs -> Double
spcDT (Specs -> Double) -> (Run -> Specs) -> Run -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> Specs
runSpecs