{-# LANGUAGE RecursiveDo, MultiParamTypeClasses, FlexibleInstances #-}
module Simulation.Aivika.Trans.Internal.Dynamics
(
Dynamics(..),
DynamicsLift(..),
invokeDynamics,
runDynamicsInStartTime,
runDynamicsInStopTime,
runDynamicsInIntegTimes,
runDynamicsInTime,
runDynamicsInTimes,
catchDynamics,
finallyDynamics,
throwDynamics,
time,
isTimeInteg,
integIteration,
integPhase,
traceDynamics) where
import Control.Exception
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Fix
import Control.Applicative
import Debug.Trace (trace)
import Simulation.Aivika.Trans.Exception
import Simulation.Aivika.Trans.Comp
import Simulation.Aivika.Trans.Internal.Types
import Simulation.Aivika.Trans.Internal.Specs
import Simulation.Aivika.Trans.Internal.Parameter
import Simulation.Aivika.Trans.Internal.Simulation
instance Monad m => Monad (Dynamics m) where
{-# INLINE return #-}
return a = Dynamics $ \p -> return a
{-# INLINE (>>=) #-}
(Dynamics m) >>= k =
Dynamics $ \p ->
do a <- m p
let Dynamics m' = k a
m' p
runDynamicsInStartTime :: Dynamics m a -> Simulation m a
{-# INLINABLE runDynamicsInStartTime #-}
runDynamicsInStartTime (Dynamics m) =
Simulation $ m . integStartPoint
runDynamicsInStopTime :: Dynamics m a -> Simulation m a
{-# INLINABLE runDynamicsInStopTime #-}
runDynamicsInStopTime (Dynamics m) =
Simulation $ m . simulationStopPoint
runDynamicsInIntegTimes :: Monad m => Dynamics m a -> Simulation m [m a]
{-# INLINABLE runDynamicsInIntegTimes #-}
runDynamicsInIntegTimes (Dynamics m) =
Simulation $ return . map m . integPoints
runDynamicsInTime :: Double -> Dynamics m a -> Simulation m a
{-# INLINABLE runDynamicsInTime #-}
runDynamicsInTime t (Dynamics m) =
Simulation $ \r -> m $ pointAt r t
runDynamicsInTimes :: Monad m => [Double] -> Dynamics m a -> Simulation m [m a]
{-# INLINABLE runDynamicsInTimes #-}
runDynamicsInTimes ts (Dynamics m) =
Simulation $ \r -> return $ map (m . pointAt r) ts
instance Functor m => Functor (Dynamics m) where
{-# INLINE fmap #-}
fmap f (Dynamics x) = Dynamics $ \p -> fmap f $ x p
instance Applicative m => Applicative (Dynamics m) where
{-# INLINE pure #-}
pure = Dynamics . const . pure
{-# INLINE (<*>) #-}
(Dynamics x) <*> (Dynamics y) = Dynamics $ \p -> x p <*> y p
liftMD :: Monad m => (a -> b) -> Dynamics m a -> Dynamics m b
{-# INLINE liftMD #-}
liftMD f (Dynamics x) =
Dynamics $ \p -> do { a <- x p; return $ f a }
liftM2D :: Monad m => (a -> b -> c) -> Dynamics m a -> Dynamics m b -> Dynamics m c
{-# INLINE liftM2D #-}
liftM2D f (Dynamics x) (Dynamics y) =
Dynamics $ \p -> do { a <- x p; b <- y p; return $ f a b }
instance (Num a, Monad m) => Num (Dynamics m a) where
{-# INLINE (+) #-}
x + y = liftM2D (+) x y
{-# INLINE (-) #-}
x - y = liftM2D (-) x y
{-# INLINE (*) #-}
x * y = liftM2D (*) x y
{-# INLINE negate #-}
negate = liftMD negate
{-# INLINE abs #-}
abs = liftMD abs
{-# INLINE signum #-}
signum = liftMD signum
{-# INLINE fromInteger #-}
fromInteger i = return $ fromInteger i
instance (Fractional a, Monad m) => Fractional (Dynamics m a) where
{-# INLINE (/) #-}
x / y = liftM2D (/) x y
{-# INLINE recip #-}
recip = liftMD recip
{-# INLINE fromRational #-}
fromRational t = return $ fromRational t
instance (Floating a, Monad m) => Floating (Dynamics m a) where
{-# INLINE pi #-}
pi = return pi
{-# INLINE exp #-}
exp = liftMD exp
{-# INLINE log #-}
log = liftMD log
{-# INLINE sqrt #-}
sqrt = liftMD sqrt
{-# INLINE (**) #-}
x ** y = liftM2D (**) x y
{-# INLINE sin #-}
sin = liftMD sin
{-# INLINE cos #-}
cos = liftMD cos
{-# INLINE tan #-}
tan = liftMD tan
{-# INLINE asin #-}
asin = liftMD asin
{-# INLINE acos #-}
acos = liftMD acos
{-# INLINE atan #-}
atan = liftMD atan
{-# INLINE sinh #-}
sinh = liftMD sinh
{-# INLINE cosh #-}
cosh = liftMD cosh
{-# INLINE tanh #-}
tanh = liftMD tanh
{-# INLINE asinh #-}
asinh = liftMD asinh
{-# INLINE acosh #-}
acosh = liftMD acosh
{-# INLINE atanh #-}
atanh = liftMD atanh
instance MonadTrans Dynamics where
{-# INLINE lift #-}
lift = Dynamics . const
instance MonadIO m => MonadIO (Dynamics m) where
{-# INLINE liftIO #-}
liftIO = Dynamics . const . liftIO
instance Monad m => MonadCompTrans Dynamics m where
{-# INLINE liftComp #-}
liftComp = Dynamics . const
class DynamicsLift t m where
liftDynamics :: Dynamics m a -> t m a
instance Monad m => DynamicsLift Dynamics m where
{-# INLINE liftDynamics #-}
liftDynamics = id
instance Monad m => SimulationLift Dynamics m where
{-# INLINE liftSimulation #-}
liftSimulation (Simulation x) = Dynamics $ x . pointRun
instance Monad m => ParameterLift Dynamics m where
{-# INLINE liftParameter #-}
liftParameter (Parameter x) = Dynamics $ x . pointRun
catchDynamics :: (MonadException m, Exception e) => Dynamics m a -> (e -> Dynamics m a) -> Dynamics m a
{-# INLINABLE catchDynamics #-}
catchDynamics (Dynamics m) h =
Dynamics $ \p ->
catchComp (m p) $ \e ->
let Dynamics m' = h e in m' p
finallyDynamics :: MonadException m => Dynamics m a -> Dynamics m b -> Dynamics m a
{-# INLINABLE finallyDynamics #-}
finallyDynamics (Dynamics m) (Dynamics m') =
Dynamics $ \p ->
finallyComp (m p) (m' p)
throwDynamics :: (MonadException m, Exception e) => e -> Dynamics m a
{-# INLINABLE throwDynamics #-}
throwDynamics e =
Dynamics $ \p ->
throwComp e
instance MonadFix m => MonadFix (Dynamics m) where
{-# INLINE mfix #-}
mfix f =
Dynamics $ \p ->
do { rec { a <- invokeDynamics p (f a) }; return a }
time :: Monad m => Dynamics m Double
{-# INLINE time #-}
time = Dynamics $ return . pointTime
isTimeInteg :: Monad m => Dynamics m Bool
{-# INLINE isTimeInteg #-}
isTimeInteg = Dynamics $ \p -> return $ pointPhase p >= 0
integIteration :: Monad m => Dynamics m Int
{-# INLINE integIteration #-}
integIteration = Dynamics $ return . pointIteration
integPhase :: Monad m => Dynamics m Int
{-# INLINE integPhase #-}
integPhase = Dynamics $ return . pointPhase
traceDynamics :: Monad m => String -> Dynamics m a -> Dynamics m a
{-# INLINABLE traceDynamics #-}
traceDynamics message m =
Dynamics $ \p ->
trace ("t = " ++ show (pointTime p) ++ ": " ++ message) $
invokeDynamics p m