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
data EventQueue = EventQueue {
queuePQ :: PQ.PriorityQueue (Dynamics ()),
queueBusy :: IORef Bool,
queueTime :: IORef Double,
runQueue :: Dynamics (),
runQueueSync :: Dynamics (),
runQueueBefore :: Dynamics (),
runQueueSyncBefore :: Dynamics ()
}
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 :: EventQueue -> Double -> Dynamics () -> Dynamics ()
enqueue q t c = Dynamics r where
r p = let pq = queuePQ q in PQ.enqueue pq t c
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
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
queueCount :: EventQueue -> Dynamics Int
queueCount q = Dynamics r where
r p =
do let Dynamics m = runQueueSync q
m p
PQ.queueCount $ queuePQ q
enqueueWithTimes :: EventQueue -> [Double] -> Dynamics () -> Dynamics ()
enqueueWithTimes q ts m = loop ts
where loop [] = return ()
loop (t : ts) = enqueue q t $ m >> loop ts
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
let Dynamics m' = loop xs
m' p
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
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
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
enqueueWithCurrentTime :: EventQueue -> Dynamics () -> Dynamics ()
enqueueWithCurrentTime q m =
Dynamics $ \p ->
do let Dynamics m' = enqueue q (pointTime p) m
m' p