module Simulation.Aivika.Dynamics.Internal.Simulation
(
Simulation(..),
SimulationLift(..),
Specs(..),
Method(..),
Run(..),
runSimulation,
runSimulations,
catchSimulation,
finallySimulation,
throwSimulation,
simulationIndex,
simulationCount,
simulationSpecs) where
import qualified Control.Exception as C
import Control.Exception (IOException, throw, finally)
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Fix
newtype Simulation a = Simulation (Run -> IO a)
data Specs = Specs { spcStartTime :: Double,
spcStopTime :: Double,
spcDT :: Double,
spcMethod :: Method
} deriving (Eq, Ord, Show)
data Method = Euler
| RungeKutta2
| RungeKutta4
deriving (Eq, Ord, Show)
data Run = Run { runSpecs :: Specs,
runIndex :: Int,
runCount :: Int
} deriving (Eq, Ord, Show)
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 =
m Run { runSpecs = sc,
runIndex = 1,
runCount = 1 }
runSimulations :: Simulation a -> Specs -> Int -> [IO a]
runSimulations (Simulation m) sc runs = map f [1 .. runs]
where f i = m Run { runSpecs = sc,
runIndex = i,
runCount = runs }
simulationIndex :: Simulation Int
simulationIndex = Simulation $ return . runIndex
simulationCount :: Simulation Int
simulationCount = Simulation $ return . runCount
simulationSpecs :: Simulation Specs
simulationSpecs = Simulation $ return . runSpecs
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
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 :: Simulation a -> Run -> IO a
invokeSimulation (Simulation m) r = m r
instance MonadFix Simulation where
mfix f =
Simulation $ \r ->
do { rec { a <- invokeSimulation (f a) r }; return a }