{-# LANGUAGE TypeFamilies, FlexibleInstances #-} -- | -- Module : Simulation.Aivika.Branch.Event -- Copyright : Copyright (c) 2016-2017, David Sorokin <david.sorokin@gmail.com> -- License : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability : experimental -- Tested with: GHC 7.10.3 -- -- The module defines an event queue, where 'BR' can be an instance of 'EventQueueing'. -- Also it defines basic functions for branching computations. -- module Simulation.Aivika.Branch.Event (branchEvent, futureEvent, futureEventWith) where import Data.IORef import Control.Monad import Control.Monad.Trans import qualified Simulation.Aivika.PriorityQueue.Pure as PQ import Simulation.Aivika.Trans import Simulation.Aivika.Trans.Internal.Types import Simulation.Aivika.Branch.Internal.BR -- | An implementation of the 'EventQueueing' type class. instance EventQueueing (BR IO) where -- | The event queue type. data EventQueue (BR IO) = EventQueue { queuePQ :: IORef (PQ.PriorityQueue (Point (BR IO) -> BR IO ())), -- ^ the underlying priority queue queueBusy :: IORef Bool, -- ^ whether the queue is currently processing events queueTime :: IORef Double -- ^ the actual time of the event queue } newEventQueue specs = do f <- liftIO $ newIORef False t <- liftIO $ newIORef (spcStartTime specs) pq <- liftIO $ newIORef PQ.emptyQueue return EventQueue { queuePQ = pq, queueBusy = f, queueTime = t } enqueueEvent t (Event m) = Event $ \p -> BR $ \ps -> let pq = queuePQ $ runEventQueue $ pointRun p in modifyIORef pq $ \x -> PQ.enqueue x t m runEventWith processing (Event e) = Dynamics $ \p -> do invokeDynamics p $ processEvents processing e p eventQueueCount = Event $ \p -> BR $ \ps -> let pq = queuePQ $ runEventQueue $ pointRun p in fmap PQ.queueCount $ readIORef pq -- | Process the pending events. processPendingEventsCore :: Bool -> Dynamics (BR IO) () processPendingEventsCore includingCurrentEvents = Dynamics r where r p = BR $ \ps -> do let q = runEventQueue $ pointRun p f = queueBusy q f' <- readIORef f unless f' $ do writeIORef f True call q p ps writeIORef f False call q p ps = do let pq = queuePQ q r = pointRun p f <- fmap PQ.queueNull $ readIORef pq unless f $ do (t2, c2) <- fmap PQ.queueFront $ readIORef pq let t = queueTime q t' <- readIORef t when (t2 < t') $ error "The time value is too small: processPendingEventsCore" when ((t2 < pointTime p) || (includingCurrentEvents && (t2 == pointTime p))) $ do writeIORef t t2 modifyIORef pq PQ.dequeue let sc = pointSpecs p t0 = spcStartTime sc dt = spcDT sc n2 = fromIntegral $ floor ((t2 - t0) / dt) invokeBR ps $ c2 $ p { pointTime = t2, pointIteration = n2, pointPhase = -1 } call q p ps -- | Process the pending events synchronously, i.e. without past. processPendingEvents :: Bool -> Dynamics (BR IO) () processPendingEvents includingCurrentEvents = Dynamics r where r p = BR $ \ps -> do let q = runEventQueue $ pointRun p t = queueTime q t' <- readIORef t if pointTime p < t' then error $ "The current time is less than " ++ "the time in the queue: processPendingEvents" else invokeBR ps $ invokeDynamics p $ processPendingEventsCore includingCurrentEvents -- | A memoized value. processEventsIncludingCurrent :: Dynamics (BR IO) () processEventsIncludingCurrent = processPendingEvents True -- | A memoized value. processEventsIncludingEarlier :: Dynamics (BR IO) () processEventsIncludingEarlier = processPendingEvents False -- | A memoized value. processEventsIncludingCurrentCore :: Dynamics (BR IO) () processEventsIncludingCurrentCore = processPendingEventsCore True -- | A memoized value. processEventsIncludingEarlierCore :: Dynamics (BR IO) () processEventsIncludingEarlierCore = processPendingEventsCore True -- | Process the events. processEvents :: EventProcessing -> Dynamics (BR IO) () processEvents CurrentEvents = processEventsIncludingCurrent processEvents EarlierEvents = processEventsIncludingEarlier processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore -- | Branch a new computation and return its result leaving the current computation intact. -- -- A new derivative branch with 'branchLevel' increased by 1 is created at the current modeling time. -- Then the result of the specified computation for the derivative branch is returned. -- -- The state of the current computation including its event queue and mutable references 'Ref' -- remain intact. In some sense we copy the state of the model to the derivative branch and then -- proceed with the derived simulation. The copying operation is relatively cheap. branchEvent :: Event (BR IO) a -> Event (BR IO) a branchEvent (Event m) = Event $ \p -> BR $ \ps-> do p2 <- clonePoint p ps2 <- newBRParams ps invokeBR ps2 (m p2) -- | Branch a new computation and return its result at the desired time -- in the future leaving the current computation intact. -- -- A new derivative branch with 'branchLevel' increased by 1 is created at the current modeling time. -- All pending events are processed till the specified time for that new branch. Then the result -- of the specified computation for the derivative branch is returned. -- -- The state of the current computation including its event queue and mutable references 'Ref' -- remain intact. In some sense we copy the state of the model to the derivative branch and then -- proceed with the derived simulation. The copying operation is relatively cheap. futureEvent :: Double -> Event (BR IO) a -> Event (BR IO) a futureEvent = futureEventWith CurrentEvents -- | Like 'futureEvent' but allows specifying how the pending events must be processed. futureEventWith :: EventProcessing -> Double -> Event (BR IO) a -> Event (BR IO) a futureEventWith processing t (Event m) = Event $ \p -> BR $ \ps -> do when (t < pointTime p) $ error "The specified time is less than the current modeling time: futureEventWith" p2 <- clonePoint p ps2 <- newBRParams ps let sc = pointSpecs p t0 = spcStartTime sc t' = spcStopTime sc dt = spcDT sc n = fromIntegral $ floor ((t - t0) / dt) p' = p2 { pointTime = t, pointIteration = n, pointPhase = -1 } invokeBR ps2 $ invokeDynamics p' $ processEvents processing invokeBR ps2 (m p') -- | Clone the time point. clonePoint :: Point (BR IO) -> IO (Point (BR IO)) clonePoint p = do let r = pointRun p q = runEventQueue r pq <- readIORef (queuePQ q) t <- readIORef (queueTime q) pq2 <- newIORef pq f2 <- newIORef False t2 <- newIORef t let q2 = EventQueue { queuePQ = pq2, queueBusy = f2, queueTime = t2 } r2 = r { runEventQueue = q2 } p2 = p { pointRun = r2 } return p2