module Simulation.Aivika.Internal.Simulation
(
Simulation(..),
SimulationLift(..),
invokeSimulation,
runSimulation,
runSimulations,
catchSimulation,
finallySimulation,
throwSimulation,
simulationIndex,
simulationCount,
simulationSpecs,
simulationEventQueue) where
import qualified Control.Exception as C
import Control.Exception (IOException, throw, finally)
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Fix
import Simulation.Aivika.Internal.Specs
newtype Simulation a = Simulation (Run -> IO a)
instance Monad Simulation where
return = returnS
m >>= k = bindS m k
returnS :: a -> Simulation a
returnS a = Simulation (\r -> return a)
bindS :: Simulation a -> (a -> Simulation b) -> Simulation b
bindS (Simulation m) k =
Simulation $ \r ->
do a <- m r
let Simulation m' = k a
m' r
runSimulation :: Simulation a -> Specs -> IO a
runSimulation (Simulation m) sc =
do q <- newEventQueue sc
m Run { runSpecs = sc,
runIndex = 1,
runCount = 1,
runEventQueue = q }
runSimulations :: Simulation a -> Specs -> Int -> [IO a]
runSimulations (Simulation m) sc runs = map f [1 .. runs]
where f i = do q <- newEventQueue sc
m Run { runSpecs = sc,
runIndex = i,
runCount = runs,
runEventQueue = q }
simulationIndex :: Simulation Int
simulationIndex = Simulation $ return . runIndex
simulationCount :: Simulation Int
simulationCount = Simulation $ return . runCount
simulationSpecs :: Simulation Specs
simulationSpecs = Simulation $ return . runSpecs
simulationEventQueue :: Simulation EventQueue
simulationEventQueue = Simulation $ return . runEventQueue
instance Functor Simulation where
fmap = liftMS
instance Eq (Simulation a) where
x == y = error "Can't compare simulation runs."
instance Show (Simulation a) where
showsPrec _ x = showString "<< Simulation >>"
liftMS :: (a -> b) -> Simulation a -> Simulation b
liftMS f (Simulation x) =
Simulation $ \r -> do { a <- x r; return $ f a }
liftM2S :: (a -> b -> c) -> Simulation a -> Simulation b -> Simulation c
liftM2S f (Simulation x) (Simulation y) =
Simulation $ \r -> do { a <- x r; b <- y r; return $ f a b }
instance (Num a) => Num (Simulation a) where
x + y = liftM2S (+) x y
x y = liftM2S () x y
x * y = liftM2S (*) x y
negate = liftMS negate
abs = liftMS abs
signum = liftMS signum
fromInteger i = return $ fromInteger i
instance (Fractional a) => Fractional (Simulation a) where
x / y = liftM2S (/) x y
recip = liftMS recip
fromRational t = return $ fromRational t
instance (Floating a) => Floating (Simulation a) where
pi = return pi
exp = liftMS exp
log = liftMS log
sqrt = liftMS sqrt
x ** y = liftM2S (**) x y
sin = liftMS sin
cos = liftMS cos
tan = liftMS tan
asin = liftMS asin
acos = liftMS acos
atan = liftMS atan
sinh = liftMS sinh
cosh = liftMS cosh
tanh = liftMS tanh
asinh = liftMS asinh
acosh = liftMS acosh
atanh = liftMS atanh
instance MonadIO Simulation where
liftIO m = Simulation $ const m
class Monad m => SimulationLift m where
liftSimulation :: Simulation a -> m a
instance SimulationLift Simulation where
liftSimulation = id
catchSimulation :: Simulation a -> (IOException -> Simulation a) -> Simulation a
catchSimulation (Simulation m) h =
Simulation $ \r ->
C.catch (m r) $ \e ->
let Simulation m' = h e in m' r
finallySimulation :: Simulation a -> Simulation b -> Simulation a
finallySimulation (Simulation m) (Simulation m') =
Simulation $ \r ->
C.finally (m r) (m' r)
throwSimulation :: IOException -> Simulation a
throwSimulation = throw
invokeSimulation :: Run -> Simulation a -> IO a
invokeSimulation r (Simulation m) = m r
instance MonadFix Simulation where
mfix f =
Simulation $ \r ->
do { rec { a <- invokeSimulation r (f a) }; return a }