{-# LANGUAGE RecursiveDo, RankNTypes #-}
module Simulation.Aivika.Internal.Parameter
(
Parameter(..),
ParameterLift(..),
invokeParameter,
runParameter,
runParameters,
catchParameter,
finallyParameter,
throwParameter,
simulationIndex,
simulationCount,
simulationSpecs,
starttime,
stoptime,
dt,
generatorParameter,
memoParameter,
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
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 = 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 = forall a. (Run -> IO a) -> Parameter a
Parameter (\Run
r -> 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 =
forall a. (Run -> IO a) -> Parameter a
Parameter 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
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 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 }
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 = 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 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 }
simulationIndex :: Parameter Int
simulationIndex :: Parameter Int
simulationIndex = forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> Int
runIndex
simulationCount :: Parameter Int
simulationCount :: Parameter Int
simulationCount = forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> Int
runCount
simulationSpecs :: Parameter Specs
simulationSpecs :: Parameter Specs
simulationSpecs = forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> Specs
runSpecs
generatorParameter :: Parameter Generator
generatorParameter :: Parameter Generator
generatorParameter = forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP
instance Applicative Parameter where
pure :: forall a. a -> Parameter a
pure = forall a. a -> Parameter a
returnP
<*> :: forall a 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 = forall a. HasCallStack => String -> a
error
instance Eq (Parameter a) where
Parameter a
x == :: Parameter a -> Parameter a -> Bool
== Parameter a
y = 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) =
forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ \Run
r -> do { a
a <- Run -> IO a
x Run
r; forall (m :: * -> *) a. Monad m => a -> m a
return 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) =
forall a. (Run -> IO a) -> Parameter a
Parameter 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; forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a b c.
(a -> b -> c) -> Parameter a -> Parameter b -> Parameter c
liftM2P 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 = 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 = forall a b c.
(a -> b -> c) -> Parameter a -> Parameter b -> Parameter c
liftM2P forall a. Num a => a -> a -> a
(*) Parameter a
x Parameter a
y
negate :: Parameter a -> Parameter a
negate = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Num a => a -> a
negate
abs :: Parameter a -> Parameter a
abs = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Num a => a -> a
abs
signum :: Parameter a -> Parameter a
signum = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Num a => a -> a
signum
fromInteger :: Integer -> Parameter a
fromInteger Integer
i = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = forall a b c.
(a -> b -> c) -> Parameter a -> Parameter b -> Parameter c
liftM2P forall a. Fractional a => a -> a -> a
(/) Parameter a
x Parameter a
y
recip :: Parameter a -> Parameter a
recip = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Fractional a => a -> a
recip
fromRational :: Rational -> Parameter a
fromRational Rational
t = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Fractional a => Rational -> a
fromRational Rational
t
instance (Floating a) => Floating (Parameter a) where
pi :: Parameter a
pi = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Floating a => a
pi
exp :: Parameter a -> Parameter a
exp = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Floating a => a -> a
exp
log :: Parameter a -> Parameter a
log = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Floating a => a -> a
log
sqrt :: Parameter a -> Parameter a
sqrt = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Floating a => a -> a
sqrt
Parameter a
x ** :: Parameter a -> Parameter a -> Parameter a
** Parameter a
y = forall a b c.
(a -> b -> c) -> Parameter a -> Parameter b -> Parameter c
liftM2P forall a. Floating a => a -> a -> a
(**) Parameter a
x Parameter a
y
sin :: Parameter a -> Parameter a
sin = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Floating a => a -> a
sin
cos :: Parameter a -> Parameter a
cos = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Floating a => a -> a
cos
tan :: Parameter a -> Parameter a
tan = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Floating a => a -> a
tan
asin :: Parameter a -> Parameter a
asin = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Floating a => a -> a
asin
acos :: Parameter a -> Parameter a
acos = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Floating a => a -> a
acos
atan :: Parameter a -> Parameter a
atan = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Floating a => a -> a
atan
sinh :: Parameter a -> Parameter a
sinh = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Floating a => a -> a
sinh
cosh :: Parameter a -> Parameter a
cosh = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Floating a => a -> a
cosh
tanh :: Parameter a -> Parameter a
tanh = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Floating a => a -> a
tanh
asinh :: Parameter a -> Parameter a
asinh = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Floating a => a -> a
asinh
acosh :: Parameter a -> Parameter a
acosh = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Floating a => a -> a
acosh
atanh :: Parameter a -> Parameter a
atanh = forall a b. (a -> b) -> Parameter a -> Parameter b
liftMP forall a. Floating a => a -> a
atanh
instance MonadIO Parameter where
liftIO :: forall a. IO a -> Parameter a
liftIO IO a
m = forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const IO a
m
class ParameterLift m where
liftParameter :: Parameter a -> m a
instance ParameterLift Parameter where
liftParameter :: forall a. Parameter a -> Parameter a
liftParameter = forall a. a -> a
id
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 =
forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ \Run
r ->
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Run -> IO a
m Run
r) 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
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') =
forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ \Run
r ->
forall a b. IO a -> IO b -> IO a
finally (Run -> IO a
m Run
r) (Run -> IO b
m' Run
r)
throwParameter :: Exception e => e -> Parameter a
throwParameter :: forall e a. Exception e => e -> Parameter a
throwParameter = forall a e. Exception e => e -> a
throw
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 =
forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ \Run
r ->
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MC.mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
u ->
forall a. Run -> Parameter a -> IO a
invokeParameter Run
r ((forall a. Parameter a -> Parameter a) -> Parameter b
a forall a b. (a -> b) -> a -> b
$ forall {a} {a}. (IO a -> IO a) -> Parameter a -> Parameter a
q 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) = forall a. (Run -> IO a) -> Parameter a
Parameter (IO a -> IO a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> IO a
b)
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 =
forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ \Run
r ->
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MC.uninterruptibleMask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
u ->
forall a. Run -> Parameter a -> IO a
invokeParameter Run
r ((forall a. Parameter a -> Parameter a) -> Parameter b
a forall a b. (a -> b) -> a -> b
$ forall {a} {a}. (IO a -> IO a) -> Parameter a -> Parameter a
q 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) = forall a. (Run -> IO a) -> Parameter a
Parameter (IO a -> IO a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> IO a
b)
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 =
forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ \Run
r -> do
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
MC.generalBracket
(forall a. Run -> Parameter a -> IO a
invokeParameter Run
r Parameter a
acquire)
(\a
resource ExitCase b
e -> forall a. Run -> Parameter a -> IO a
invokeParameter Run
r forall a b. (a -> b) -> a -> b
$ a -> ExitCase b -> Parameter c
release a
resource ExitCase b
e)
(\a
resource -> forall a. Run -> Parameter a -> IO a
invokeParameter Run
r forall a b. (a -> b) -> a -> b
$ a -> Parameter b
use a
resource)
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 =
forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ \Run
r ->
do { rec { a
a <- forall a. Run -> Parameter a -> IO a
invokeParameter Run
r (a -> Parameter a
f a
a) }; forall (m :: * -> *) a. Monad m => a -> m a
return a
a }
instance MC.MonadThrow Parameter where
throwM :: forall e a. Exception e => e -> Parameter a
throwM = forall e a. Exception e => e -> Parameter a
throwParameter
instance MC.MonadCatch Parameter where
catch :: forall e a.
Exception e =>
Parameter a -> (e -> Parameter a) -> Parameter a
catch = forall e a.
Exception e =>
Parameter a -> (e -> Parameter a) -> Parameter a
catchParameter
instance MC.MonadMask Parameter where
mask :: forall b.
((forall a. Parameter a -> Parameter a) -> Parameter b)
-> Parameter b
mask = forall b.
((forall a. Parameter a -> Parameter a) -> Parameter b)
-> Parameter b
maskParameter
uninterruptibleMask :: forall b.
((forall a. Parameter a -> Parameter a) -> Parameter b)
-> Parameter b
uninterruptibleMask = forall b.
((forall a. Parameter a -> Parameter a) -> Parameter b)
-> Parameter b
uninterruptibleMaskParameter
generalBracket :: forall a b c.
Parameter a
-> (a -> ExitCase b -> Parameter c)
-> (a -> Parameter b)
-> Parameter (b, c)
generalBracket = forall a b c.
Parameter a
-> (a -> ExitCase b -> Parameter c)
-> (a -> Parameter b)
-> Parameter (b, c)
generalBracketParameter
memoParameter :: Parameter a -> IO (Parameter a)
memoParameter :: forall a. Parameter a -> IO (Parameter a)
memoParameter Parameter a
x =
do MVar ()
lock <- forall a. a -> IO (MVar a)
newMVar ()
IORef (IntMap a)
dict <- forall a. a -> IO (IORef a)
newIORef forall a. IntMap a
M.empty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ \Run
r ->
do let i :: Int
i = Run -> Int
runIndex Run
r
IntMap a
m <- forall a. IORef a -> IO a
readIORef IORef (IntMap a)
dict
if forall a. Int -> IntMap a -> Bool
M.member Int
i IntMap a
m
then do let Just a
v = forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap a
m
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
else forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock forall a b. (a -> b) -> a -> b
$
\() -> do { IntMap a
m <- forall a. IORef a -> IO a
readIORef IORef (IntMap a)
dict;
if forall a. Int -> IntMap a -> Bool
M.member Int
i IntMap a
m
then do let Just a
v = forall a. Int -> IntMap a -> Maybe a
M.lookup Int
i IntMap a
m
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
else do a
v <- forall a. Run -> Parameter a -> IO a
invokeParameter Run
r Parameter a
x
forall a. IORef a -> a -> IO ()
writeIORef IORef (IntMap a)
dict forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
i a
v IntMap a
m
forall (m :: * -> *) a. Monad m => a -> m a
return a
v }
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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Array Int a
t forall i e. Ix i => Array i e -> i -> e
! (((Int
i forall a. Num a => a -> a -> a
- Int
i1) forall a. Integral a => a -> a -> a
`mod` Int
n) forall a. Num a => a -> a -> a
+ Int
i1)
where (Int
i1, Int
i2) = forall i e. Array i e -> (i, i)
bounds Array Int a
t
n :: Int
n = Int
i2 forall a. Num a => a -> a -> a
- Int
i1 forall a. Num a => a -> a -> a
+ Int
1
starttime :: Parameter Double
starttime :: Parameter Double
starttime =
forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Specs -> Double
spcStartTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> Specs
runSpecs
stoptime :: Parameter Double
stoptime :: Parameter Double
stoptime =
forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Specs -> Double
spcStopTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> Specs
runSpecs
dt :: Parameter Double
dt :: Parameter Double
dt =
forall a. (Run -> IO a) -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Specs -> Double
spcDT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> Specs
runSpecs