aivika-0.6.1: Simulation/Aivika/Dynamics/EventQueue.hs
-- |
-- Module : Simulation.Aivika.Dynamics.EventQueue
-- Copyright : Copyright (c) 2009-2013, David Sorokin <david.sorokin@gmail.com>
-- License : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability : experimental
-- Tested with: GHC 7.6.3
--
-- The module introduces the event queue. An event handler is
-- the Dynamics computation that has a single purpose to perform
-- some side effect at the desired time. To pass in any message
-- to the event, you can use a closure.
--
module Simulation.Aivika.Dynamics.EventQueue
(EventQueue,
newQueue,
enqueue,
enqueueWithTimes,
enqueueWithIntegTimes,
enqueueWithStartTime,
enqueueWithStopTime,
enqueueWithCurrentTime,
runQueue,
runQueueSync,
runQueueBefore,
runQueueSyncBefore,
queueCount) where
import Data.IORef
import Control.Monad
import Simulation.Aivika.Dynamics.Internal.Simulation
import Simulation.Aivika.Dynamics.Internal.Dynamics
import qualified Simulation.Aivika.PriorityQueue as PQ
-- | The 'EventQueue' type represents the event queue.
data EventQueue = EventQueue {
queuePQ :: PQ.PriorityQueue (Dynamics ()),
queueBusy :: IORef Bool,
queueTime :: IORef Double,
-- Optimization
runQueue :: Dynamics (),
-- ^ Run the event queue processing its events.
-- There is no restiction on the time of the queue itself. It this time
-- is greater than the current simulation time then nothing happens.
runQueueSync :: Dynamics (),
-- ^ Run the event queue synchronously, i.e. the current time cannot be
-- less than the actual time of the queue itself.
--
-- You will rarely need to run the event queue explicitly, but
-- if you do want then this function is probably that one you should use.
runQueueBefore :: Dynamics (),
-- ^ Run the event queue processing only those events
-- which time is less than the current simulation time.
-- There is no restiction on the time of the queue itself. It this time
-- is greater than the current simulation time then nothing happens.
runQueueSyncBefore :: Dynamics ()
-- ^ Run the event queue synchronously processing only those events
-- which time is less than the current simulation time. But the current
-- time cannot be less than the actual time of the queue itself.
--
-- This function is usually called before a handler is subscribed
-- to the signal. Earlier 'runQueueSync' was called instead, which could
-- lead to the lost of the signal by the handler at time of direct
-- subscribing. Changed in version 0.6.1.
}
-- | Create a new event queue.
newQueue :: Simulation EventQueue
newQueue =
Simulation $ \r ->
do let sc = runSpecs r
f <- newIORef False
t <- newIORef $ spcStartTime sc
pq <- PQ.newQueue
let q = EventQueue { queuePQ = pq,
queueBusy = f,
queueTime = t,
runQueue = runQueueCore True q,
runQueueSync = runQueueSyncCore True q,
runQueueBefore = runQueueCore False q,
runQueueSyncBefore = runQueueSyncCore False q }
return q
-- | Enqueue the event which must be actuated at the specified time.
enqueue :: EventQueue -> Double -> Dynamics () -> Dynamics ()
enqueue q t c = Dynamics r where
r p = let pq = queuePQ q in PQ.enqueue pq t c
-- | Run the event queue processing its events.
runQueueCore :: Bool -> EventQueue -> Dynamics ()
runQueueCore includingCurrentTime q = Dynamics r where
r p =
do let f = queueBusy q
f' <- readIORef f
unless f' $
do writeIORef f True
call q p
writeIORef f False
call q p =
do let pq = queuePQ q
f <- PQ.queueNull pq
unless f $
do (t2, c2) <- PQ.queueFront pq
let t = queueTime q
t' <- readIORef t
when (t2 < t') $
error "The time value is too small: runQueueCore"
when ((t2 < pointTime p) ||
(includingCurrentTime && (t2 == pointTime p))) $
do writeIORef t t2
PQ.dequeue pq
let sc = pointSpecs p
t0 = spcStartTime sc
dt = spcDT sc
n2 = fromIntegral $ floor ((t2 - t0) / dt)
Dynamics k = c2
k $ p { pointTime = t2,
pointIteration = n2,
pointPhase = -1 }
call q p
-- | Run the event queue synchronously, i.e. without past.
runQueueSyncCore :: Bool -> EventQueue -> Dynamics ()
runQueueSyncCore includingCurrentTime q = Dynamics r where
r p =
do let t = queueTime q
t' <- readIORef t
if pointTime p < t'
then error $
"The current time is less than " ++
"the time in the queue: runQueueSyncCore"
else m p
Dynamics m = if includingCurrentTime
then runQueue q
else runQueueBefore q
-- | Return the number of pending events that should
-- be yet actuated.
queueCount :: EventQueue -> Dynamics Int
queueCount q = Dynamics r where
r p =
do let Dynamics m = runQueueSync q
m p
PQ.queueCount $ queuePQ q
-- | Actuate the event handler in the specified time points.
enqueueWithTimes :: EventQueue -> [Double] -> Dynamics () -> Dynamics ()
enqueueWithTimes q ts m = loop ts
where loop [] = return ()
loop (t : ts) = enqueue q t $ m >> loop ts
-- | Actuate the event handler in the specified time points.
enqueueWithPoints :: EventQueue -> [Point] -> Dynamics () -> Dynamics ()
enqueueWithPoints q xs (Dynamics m) = loop xs
where loop [] = return ()
loop (x : xs) = enqueue q (pointTime x) $
Dynamics $ \p ->
do m x -- N.B. we substitute the time point!
let Dynamics m' = loop xs
m' p
-- | Actuate the event handler in the integration time points.
enqueueWithIntegTimes :: EventQueue -> Dynamics () -> Dynamics ()
enqueueWithIntegTimes q m =
Dynamics $ \p ->
do let sc = pointSpecs p
(nl, nu) = integIterationBnds sc
points = map point [nl .. nu]
point n = Point { pointSpecs = sc,
pointRun = pointRun p,
pointTime = basicTime sc n 0,
pointIteration = n,
pointPhase = 0 }
Dynamics m' = enqueueWithPoints q points m
m' p
-- | Actuate the event handler in the start time.
enqueueWithStartTime :: EventQueue -> Dynamics () -> Dynamics ()
enqueueWithStartTime q m =
Dynamics $ \p ->
do let sc = pointSpecs p
(nl, nu) = integIterationBnds sc
point n = Point { pointSpecs = sc,
pointRun = pointRun p,
pointTime = basicTime sc n 0,
pointIteration = n,
pointPhase = 0 }
Dynamics m' = enqueueWithPoints q [point nl] m
m' p
-- | Actuate the event handler in the stop time.
enqueueWithStopTime :: EventQueue -> Dynamics () -> Dynamics ()
enqueueWithStopTime q m =
Dynamics $ \p ->
do let sc = pointSpecs p
(nl, nu) = integIterationBnds sc
point n = Point { pointSpecs = sc,
pointRun = pointRun p,
pointTime = basicTime sc n 0,
pointIteration = n,
pointPhase = 0 }
Dynamics m' = enqueueWithPoints q [point nu] m
m' p
-- | Actuate the event handler in the current time but
-- through the event queue, which allows continuing the
-- current tasks and then calling the handler after the
-- tasks are finished. The simulation time will be the same.
enqueueWithCurrentTime :: EventQueue -> Dynamics () -> Dynamics ()
enqueueWithCurrentTime q m =
Dynamics $ \p ->
do let Dynamics m' = enqueue q (pointTime p) m
m' p