module Simulation.Aivika.Dynamics.Internal.Process
(ProcessID,
Process(..),
processQueue,
newProcessID,
holdProcess,
passivateProcess,
processPassive,
reactivateProcess,
processID,
runProcess) where
import Data.Maybe
import Data.IORef
import Control.Monad
import Control.Monad.Trans
import Simulation.Aivika.Dynamics.Internal.Simulation
import Simulation.Aivika.Dynamics.Internal.Dynamics
import Simulation.Aivika.Dynamics.Internal.Cont
import Simulation.Aivika.Dynamics.EventQueue
data ProcessID =
ProcessID { processQueue :: EventQueue,
processStarted :: IORef Bool,
processCont :: IORef (Maybe (() -> Dynamics ())) }
newtype Process a = Process (ProcessID -> Cont a)
holdProcess :: Double -> Process ()
holdProcess dt =
Process $ \pid ->
Cont $ \c ->
Dynamics $ \p ->
do let Dynamics m = enqueueCont (processQueue pid) (pointTime p + dt) c
m p
passivateProcess :: Process ()
passivateProcess =
Process $ \pid ->
Cont $ \c ->
Dynamics $ \p ->
do let x = processCont pid
a <- readIORef x
case a of
Nothing -> writeIORef x $ Just c
Just _ -> error "Cannot passivate the process twice: passivate"
processPassive :: ProcessID -> Dynamics Bool
processPassive pid =
Dynamics $ \p ->
do let Dynamics m = queueRun $ processQueue pid
m p
let x = processCont pid
a <- readIORef x
return $ isJust a
reactivateProcess :: ProcessID -> Dynamics ()
reactivateProcess pid =
Dynamics $ \p ->
do let Dynamics m = queueRun $ processQueue pid
m p
let x = processCont pid
a <- readIORef x
case a of
Nothing ->
return ()
Just c ->
do writeIORef x Nothing
let Dynamics m = enqueueCont (processQueue pid) (pointTime p) c
m p
runProcess :: Process () -> ProcessID -> Double -> Dynamics ()
runProcess (Process p) pid t =
runCont m return
where m = do y <- liftIO $ readIORef (processStarted pid)
if y
then error $
"A process with such ID " ++
"has been started already: runProc"
else liftIO $ writeIORef (processStarted pid) True
Cont $ \c -> enqueueCont (processQueue pid) t c
p pid
processID :: Process ProcessID
processID = Process $ \pid -> return pid
newProcessID :: EventQueue -> Simulation ProcessID
newProcessID q =
do x <- liftIO $ newIORef Nothing
y <- liftIO $ newIORef False
return ProcessID { processQueue = q,
processStarted = y,
processCont = x }
instance Eq ProcessID where
x == y = processCont x == processCont y
instance Monad Process where
return = returnP
m >>= k = bindP m k
instance Functor Process where
fmap = liftM
instance SimulationLift Process where
liftSimulation = liftSP
instance DynamicsLift Process where
liftDynamics = liftDP
instance MonadIO Process where
liftIO = liftIOP
returnP :: a -> Process a
returnP a = Process (\pid -> return a)
bindP :: Process a -> (a -> Process b) -> Process b
bindP (Process m) k =
Process $ \pid ->
do a <- m pid
let Process m' = k a
m' pid
liftSP :: Simulation a -> Process a
liftSP m = Process $ \pid -> liftSimulation m
liftDP :: Dynamics a -> Process a
liftDP m = Process $ \pid -> liftDynamics m
liftIOP :: IO a -> Process a
liftIOP m = Process $ \pid -> liftIO m