module Simulation.Aivika.Trans.Internal.Simulation
(
SimulationLift(..),
runSimulation,
runSimulations,
catchSimulation,
finallySimulation,
throwSimulation,
memoSimulation,
SimulationException(..),
SimulationAbort(..)) where
import Control.Exception
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Fix
import Control.Applicative
import Simulation.Aivika.Trans.Exception
import Simulation.Aivika.Trans.Session
import Simulation.Aivika.Trans.ProtoRef
import Simulation.Aivika.Trans.Generator
import Simulation.Aivika.Trans.Comp
import Simulation.Aivika.Trans.Internal.Specs
import Simulation.Aivika.Trans.Internal.Parameter
import Simulation.Aivika.Simulation (SimulationException, SimulationAbort)
instance Monad m => Monad (Simulation m) where
return a = Simulation $ \r -> return a
(Simulation m) >>= k =
Simulation $ \r ->
do a <- m r
let Simulation m' = k a
m' r
runSimulation :: MonadComp m => Simulation m a -> Specs m -> m a
runSimulation (Simulation m) sc =
do s <- newSession
q <- newEventQueue s sc
g <- newGenerator s $ spcGeneratorType sc
m Run { runSpecs = sc,
runSession = s,
runIndex = 1,
runCount = 1,
runEventQueue = q,
runGenerator = g }
runSimulations :: MonadComp m => Simulation m a -> Specs m -> Int -> [m a]
runSimulations (Simulation m) sc runs = map f [1 .. runs]
where f i = do s <- newSession
q <- newEventQueue s sc
g <- newGenerator s $ spcGeneratorType sc
m Run { runSpecs = sc,
runSession = s,
runIndex = i,
runCount = runs,
runEventQueue = q,
runGenerator = g }
instance Functor m => Functor (Simulation m) where
fmap f (Simulation x) = Simulation $ \r -> fmap f $ x r
instance Applicative m => Applicative (Simulation m) where
pure = Simulation . const . pure
(Simulation x) <*> (Simulation y) = Simulation $ \r -> x r <*> y r
liftMS :: Monad m => (a -> b) -> Simulation m a -> Simulation m b
liftMS f (Simulation x) =
Simulation $ \r -> do { a <- x r; return $ f a }
instance MonadTrans Simulation where
lift = Simulation . const
instance MonadCompTrans Simulation where
liftComp = Simulation . const
instance MonadIO m => MonadIO (Simulation m) where
liftIO = Simulation . const . liftIO
class SimulationLift t where
liftSimulation :: MonadComp m => Simulation m a -> t m a
instance SimulationLift Simulation where
liftSimulation = id
instance ParameterLift Simulation where
liftParameter (Parameter x) = Simulation x
catchSimulation :: (MonadComp m, Exception e) => Simulation m a -> (e -> Simulation m a) -> Simulation m a
catchSimulation (Simulation m) h =
Simulation $ \r ->
catchComp (m r) $ \e ->
let Simulation m' = h e in m' r
finallySimulation :: MonadComp m => Simulation m a -> Simulation m b -> Simulation m a
finallySimulation (Simulation m) (Simulation m') =
Simulation $ \r ->
finallyComp (m r) (m' r)
throwSimulation :: (MonadComp m, Exception e) => e -> Simulation m a
throwSimulation = throw
instance MonadFix m => MonadFix (Simulation m) where
mfix f =
Simulation $ \r ->
do { rec { a <- invokeSimulation r (f a) }; return a }
memoSimulation :: MonadComp m => Simulation m a -> Simulation m (Simulation m a)
memoSimulation m =
Simulation $ \r ->
do let s = runSession r
ref <- newProtoRef s Nothing
return $ Simulation $ \r ->
do x <- readProtoRef ref
case x of
Just v -> return v
Nothing ->
do v <- invokeSimulation r m
writeProtoRef ref (Just v)
return v