{-# LANGUAGE RecursiveDo, RankNTypes #-}

-- |
-- Module     : Simulation.Aivika.Internal.Event
-- Copyright  : Copyright (c) 2009-2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 8.0.1
--
-- This is an internal implementation module that should never be used directly.
--
-- The module defines the 'Event' monad which is very similar to the 'Dynamics'
-- monad but only now the computation is strongly synchronized with the event queue.
--
-- The @Dynamics@ computation is defined in all time points simultaneously, while
-- the @Event@ computation can be described in every time point differently and can change
-- in discrete steps. Therefore, the former is destined for differential and difference
-- equations of System Dynamics, while the latter is destined for discrete event simulation,
-- being its core actually.
--
module Simulation.Aivika.Internal.Event
       (-- * Event Monad
        Event(..),
        EventLift(..),
        EventProcessing(..),
        invokeEvent,
        runEvent,
        runEventWith,
        runEventInStartTime,
        runEventInStopTime,
        -- * Event Queue
        EventPriority(..),
        enqueueEvent,
        enqueueEventWithPriority,
        enqueueEventWithCancellation,
        enqueueEventWithStartTime,
        enqueueEventWithStopTime,
        enqueueEventWithTimes,
        enqueueEventWithPoints,
        enqueueEventWithIntegTimes,
        yieldEvent,
        eventQueueCount,
        eventPriority,
        -- * Cancelling Event
        EventCancellation,
        cancelEvent,
        eventCancelled,
        eventFinished,
        -- * Error Handling
        catchEvent,
        finallyEvent,
        throwEvent,
        -- * Memoization
        memoEvent,
        memoEventInTime,
        -- * Disposable
        DisposableEvent(..),
        -- * Retrying Computation
        retryEvent,
        -- * Debugging
        traceEvent) where

import Data.IORef
import Data.Monoid hiding ((<>))
import Data.Semigroup (Semigroup(..))

import Control.Exception
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Fix
import Control.Monad.Fail
import qualified Control.Monad.Catch as MC
import Control.Applicative

import Debug.Trace (trace)

import qualified Simulation.Aivika.PriorityQueue.EventQueue as PQ

import Simulation.Aivika.Internal.Specs
import Simulation.Aivika.Internal.Parameter
import Simulation.Aivika.Internal.Simulation
import Simulation.Aivika.Internal.Dynamics

-- | A value in the 'Event' monad represents a polymorphic time varying function
-- which is strongly synchronized with the event queue.
newtype Event a = Event (Point -> IO a)

instance Monad Event where
  Event a
m >>= :: forall a b. Event a -> (a -> Event b) -> Event b
>>= a -> Event b
k = forall a b. Event a -> (a -> Event b) -> Event b
bindE Event a
m a -> Event b
k

returnE :: a -> Event a
{-# INLINE returnE #-}
returnE :: forall a. a -> Event a
returnE a
a = forall a. (Point -> IO a) -> Event a
Event (\Point
p -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a)

bindE :: Event a -> (a -> Event b) -> Event b
{-# INLINE bindE #-}
bindE :: forall a b. Event a -> (a -> Event b) -> Event b
bindE (Event Point -> IO a
m) a -> Event b
k = 
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p -> 
  do a
a <- Point -> IO a
m Point
p
     let Event Point -> IO b
m' = a -> Event b
k a
a
     Point -> IO b
m' Point
p

instance Functor Event where
  fmap :: forall a b. (a -> b) -> Event a -> Event b
fmap = forall a b. (a -> b) -> Event a -> Event b
liftME

instance Applicative Event where
  pure :: forall a. a -> Event a
pure = forall a. a -> Event a
returnE
  <*> :: forall a b. Event (a -> b) -> Event a -> Event b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance MonadFail Event where
  fail :: forall a. String -> Event a
fail = forall a. HasCallStack => String -> a
error

liftME :: (a -> b) -> Event a -> Event b
{-# INLINE liftME #-}
liftME :: forall a b. (a -> b) -> Event a -> Event b
liftME a -> b
f (Event Point -> IO a
x) =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p -> do { a
a <- Point -> IO a
x Point
p; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ a -> b
f a
a }

instance MonadIO Event where
  liftIO :: forall a. IO a -> Event a
liftIO IO a
m = forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const IO a
m

instance ParameterLift Event where
  liftParameter :: forall a. Parameter a -> Event a
liftParameter = forall a. Parameter a -> Event a
liftPS

instance SimulationLift Event where
  liftSimulation :: forall a. Simulation a -> Event a
liftSimulation = forall a. Simulation a -> Event a
liftES

instance DynamicsLift Event where
  liftDynamics :: forall a. Dynamics a -> Event a
liftDynamics = forall a. Dynamics a -> Event a
liftDS
    
liftPS :: Parameter a -> Event a
{-# INLINE liftPS #-}
liftPS :: forall a. Parameter a -> Event a
liftPS (Parameter Run -> IO a
m) =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p -> Run -> IO a
m forall a b. (a -> b) -> a -> b
$ Point -> Run
pointRun Point
p
    
liftES :: Simulation a -> Event a
{-# INLINE liftES #-}
liftES :: forall a. Simulation a -> Event a
liftES (Simulation Run -> IO a
m) =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p -> Run -> IO a
m forall a b. (a -> b) -> a -> b
$ Point -> Run
pointRun Point
p

liftDS :: Dynamics a -> Event a
{-# INLINE liftDS #-}
liftDS :: forall a. Dynamics a -> Event a
liftDS (Dynamics Point -> IO a
m) =
  forall a. (Point -> IO a) -> Event a
Event Point -> IO a
m

-- | A type class to lift the 'Event' computation to other computations.
class EventLift m where
  
  -- | Lift the specified 'Event' computation to another computation.
  liftEvent :: Event a -> m a

instance EventLift Event where
  liftEvent :: forall a. Event a -> Event a
liftEvent = forall a. a -> a
id
  
-- | Exception handling within 'Event' computations.
catchEvent :: Exception e => Event a -> (e -> Event a) -> Event a
catchEvent :: forall e a. Exception e => Event a -> (e -> Event a) -> Event a
catchEvent (Event Point -> IO a
m) e -> Event a
h =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p -> 
  forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Point -> IO a
m Point
p) forall a b. (a -> b) -> a -> b
$ \e
e ->
  let Event Point -> IO a
m' = e -> Event a
h e
e in Point -> IO a
m' Point
p
                           
-- | A computation with finalization part like the 'finally' function.
finallyEvent :: Event a -> Event b -> Event a
finallyEvent :: forall a b. Event a -> Event b -> Event a
finallyEvent (Event Point -> IO a
m) (Event Point -> IO b
m') =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
  forall a b. IO a -> IO b -> IO a
finally (Point -> IO a
m Point
p) (Point -> IO b
m' Point
p)

-- | Like the standard 'throw' function.
throwEvent :: Exception e => e -> Event a
throwEvent :: forall e a. Exception e => e -> Event a
throwEvent = forall a e. Exception e => e -> a
throw

-- | Runs an action with asynchronous exceptions disabled.
maskEvent :: ((forall a. Event a -> Event a) -> Event b) -> Event b
maskEvent :: forall b. ((forall a. Event a -> Event a) -> Event b) -> Event b
maskEvent (forall a. Event a -> Event a) -> Event b
a =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
  forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MC.mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
u ->
  forall a. Point -> Event a -> IO a
invokeEvent Point
p ((forall a. Event a -> Event a) -> Event b
a forall a b. (a -> b) -> a -> b
$ forall {a} {a}. (IO a -> IO a) -> Event a -> Event a
q forall a. IO a -> IO a
u)
  where q :: (IO a -> IO a) -> Event a -> Event a
q IO a -> IO a
u (Event Point -> IO a
b) = forall a. (Point -> IO a) -> Event a
Event (IO a -> IO a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> IO a
b)

-- | Like 'maskEvent', but the masked computation is not interruptible.
uninterruptibleMaskEvent :: ((forall a. Event a -> Event a) -> Event b) -> Event b
uninterruptibleMaskEvent :: forall b. ((forall a. Event a -> Event a) -> Event b) -> Event b
uninterruptibleMaskEvent (forall a. Event a -> Event a) -> Event b
a =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
  forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MC.uninterruptibleMask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
u ->
  forall a. Point -> Event a -> IO a
invokeEvent Point
p ((forall a. Event a -> Event a) -> Event b
a forall a b. (a -> b) -> a -> b
$ forall {a} {a}. (IO a -> IO a) -> Event a -> Event a
q forall a. IO a -> IO a
u)
  where q :: (IO a -> IO a) -> Event a -> Event a
q IO a -> IO a
u (Event Point -> IO a
b) = forall a. (Point -> IO a) -> Event a
Event (IO a -> IO a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> IO a
b)

-- | An implementation of 'generalBracket'.
generalBracketEvent :: Event a
                       -> (a -> MC.ExitCase b -> Event c)
                       -> (a -> Event b)
                       -> Event (b, c)
generalBracketEvent :: forall a b c.
Event a
-> (a -> ExitCase b -> Event c) -> (a -> Event b) -> Event (b, c)
generalBracketEvent Event a
acquire a -> ExitCase b -> Event c
release a -> Event b
use =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p -> do
    forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
MC.generalBracket
      (forall a. Point -> Event a -> IO a
invokeEvent Point
p Event a
acquire)
      (\a
resource ExitCase b
e -> forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ a -> ExitCase b -> Event c
release a
resource ExitCase b
e)
      (\a
resource -> forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ a -> Event b
use a
resource)

-- | Invoke the 'Event' computation.
invokeEvent :: Point -> Event a -> IO a
{-# INLINE invokeEvent #-}
invokeEvent :: forall a. Point -> Event a -> IO a
invokeEvent Point
p (Event Point -> IO a
m) = Point -> IO a
m Point
p

instance MonadFix Event where
  mfix :: forall a. (a -> Event a) -> Event a
mfix a -> Event a
f = 
    forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
    do { rec { a
a <- forall a. Point -> Event a -> IO a
invokeEvent Point
p (a -> Event a
f a
a) }; forall (m :: * -> *) a. Monad m => a -> m a
return a
a }

instance MC.MonadThrow Event where
  throwM :: forall e a. Exception e => e -> Event a
throwM = forall e a. Exception e => e -> Event a
throwEvent

instance MC.MonadCatch Event where
  catch :: forall e a. Exception e => Event a -> (e -> Event a) -> Event a
catch = forall e a. Exception e => Event a -> (e -> Event a) -> Event a
catchEvent

instance MC.MonadMask Event where
  mask :: forall b. ((forall a. Event a -> Event a) -> Event b) -> Event b
mask = forall b. ((forall a. Event a -> Event a) -> Event b) -> Event b
maskEvent
  uninterruptibleMask :: forall b. ((forall a. Event a -> Event a) -> Event b) -> Event b
uninterruptibleMask = forall b. ((forall a. Event a -> Event a) -> Event b) -> Event b
uninterruptibleMaskEvent
  generalBracket :: forall a b c.
Event a
-> (a -> ExitCase b -> Event c) -> (a -> Event b) -> Event (b, c)
generalBracket = forall a b c.
Event a
-> (a -> ExitCase b -> Event c) -> (a -> Event b) -> Event (b, c)
generalBracketEvent

-- | Defines how the events are processed.
data EventProcessing = CurrentEvents
                       -- ^ either process all earlier and then current events,
                       -- or raise an error if the current simulation time is less
                       -- than the actual time of the event queue (safe within
                       -- the 'Event' computation as this is protected by the type system)
                     | EarlierEvents
                       -- ^ either process all earlier events not affecting
                       -- the events at the current simulation time,
                       -- or raise an error if the current simulation time is less
                       -- than the actual time of the event queue (safe within
                       -- the 'Event' computation as this is protected by the type system)
                     | CurrentEventsOrFromPast
                       -- ^ either process all earlier and then current events,
                       -- or do nothing if the current simulation time is less
                       -- than the actual time of the event queue
                       -- (do not use unless the documentation states the opposite)
                     | EarlierEventsOrFromPast
                       -- ^ either process all earlier events,
                       -- or do nothing if the current simulation time is less
                       -- than the actual time of the event queue
                       -- (do not use unless the documentation states the opposite)
                     deriving (EventProcessing -> EventProcessing -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EventProcessing -> EventProcessing -> Bool
$c/= :: EventProcessing -> EventProcessing -> Bool
== :: EventProcessing -> EventProcessing -> Bool
$c== :: EventProcessing -> EventProcessing -> Bool
Eq, Eq EventProcessing
EventProcessing -> EventProcessing -> Bool
EventProcessing -> EventProcessing -> Ordering
EventProcessing -> EventProcessing -> EventProcessing
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EventProcessing -> EventProcessing -> EventProcessing
$cmin :: EventProcessing -> EventProcessing -> EventProcessing
max :: EventProcessing -> EventProcessing -> EventProcessing
$cmax :: EventProcessing -> EventProcessing -> EventProcessing
>= :: EventProcessing -> EventProcessing -> Bool
$c>= :: EventProcessing -> EventProcessing -> Bool
> :: EventProcessing -> EventProcessing -> Bool
$c> :: EventProcessing -> EventProcessing -> Bool
<= :: EventProcessing -> EventProcessing -> Bool
$c<= :: EventProcessing -> EventProcessing -> Bool
< :: EventProcessing -> EventProcessing -> Bool
$c< :: EventProcessing -> EventProcessing -> Bool
compare :: EventProcessing -> EventProcessing -> Ordering
$ccompare :: EventProcessing -> EventProcessing -> Ordering
Ord, Int -> EventProcessing -> ShowS
[EventProcessing] -> ShowS
EventProcessing -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EventProcessing] -> ShowS
$cshowList :: [EventProcessing] -> ShowS
show :: EventProcessing -> String
$cshow :: EventProcessing -> String
showsPrec :: Int -> EventProcessing -> ShowS
$cshowsPrec :: Int -> EventProcessing -> ShowS
Show)

-- | Enqueue the event which must be actuated at the specified time.
enqueueEvent :: Double -> Event () -> Event ()
enqueueEvent :: Double -> Event () -> Event ()
enqueueEvent Double
t (Event Point -> IO ()
m) =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
  let pq :: PriorityQueue (Point -> IO ())
pq = EventQueue -> PriorityQueue (Point -> IO ())
queuePQ forall a b. (a -> b) -> a -> b
$ Run -> EventQueue
runEventQueue forall a b. (a -> b) -> a -> b
$ Point -> Run
pointRun Point
p
  in forall a. PriorityQueue a -> Double -> Int -> a -> IO ()
PQ.enqueue PriorityQueue (Point -> IO ())
pq Double
t (Point -> Int
pointPriority Point
p) Point -> IO ()
m

-- | Enqueue the event which must be actuated at the specified time
-- given the priority.
enqueueEventWithPriority :: Double -> EventPriority -> Event () -> Event ()
enqueueEventWithPriority :: Double -> Int -> Event () -> Event ()
enqueueEventWithPriority Double
t Int
priority (Event Point -> IO ()
m) =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
  let pq :: PriorityQueue (Point -> IO ())
pq = EventQueue -> PriorityQueue (Point -> IO ())
queuePQ forall a b. (a -> b) -> a -> b
$ Run -> EventQueue
runEventQueue forall a b. (a -> b) -> a -> b
$ Point -> Run
pointRun Point
p
  in forall a. PriorityQueue a -> Double -> Int -> a -> IO ()
PQ.enqueue PriorityQueue (Point -> IO ())
pq Double
t Int
priority Point -> IO ()
m

-- | Process the pending events.
processPendingEventsCore :: Bool -> Dynamics ()
processPendingEventsCore :: Bool -> Dynamics ()
processPendingEventsCore Bool
includingCurrentEvents = forall a. (Point -> IO a) -> Dynamics a
Dynamics Point -> IO ()
r where
  r :: Point -> IO ()
r Point
p =
    do let q :: EventQueue
q = Run -> EventQueue
runEventQueue forall a b. (a -> b) -> a -> b
$ Point -> Run
pointRun Point
p
           f :: IORef Bool
f = EventQueue -> IORef Bool
queueBusy EventQueue
q
       Bool
f' <- forall a. IORef a -> IO a
readIORef IORef Bool
f
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f' forall a b. (a -> b) -> a -> b
$
         do forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
f Bool
True
            EventQueue -> Point -> IO ()
call EventQueue
q Point
p
            forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
f Bool
False
  call :: EventQueue -> Point -> IO ()
call EventQueue
q Point
p =
    do let pq :: PriorityQueue (Point -> IO ())
pq = EventQueue -> PriorityQueue (Point -> IO ())
queuePQ EventQueue
q
           r :: Run
r  = Point -> Run
pointRun Point
p
       Bool
f <- forall a. PriorityQueue a -> IO Bool
PQ.queueNull PriorityQueue (Point -> IO ())
pq
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f forall a b. (a -> b) -> a -> b
$
         do (Double
t2, Int
priority2, Point -> IO ()
c2) <- forall a. PriorityQueue a -> IO (Double, Int, a)
PQ.queueFront PriorityQueue (Point -> IO ())
pq
            let t :: IORef Double
t = EventQueue -> IORef Double
queueTime EventQueue
q
            Double
t' <- forall a. IORef a -> IO a
readIORef IORef Double
t
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
t2 forall a. Ord a => a -> a -> Bool
< Double
t') forall a b. (a -> b) -> a -> b
$ 
              forall a. HasCallStack => String -> a
error String
"The time value is too small: processPendingEventsCore"
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Double
t2 forall a. Ord a => a -> a -> Bool
< Point -> Double
pointTime Point
p) Bool -> Bool -> Bool
||
                  (Bool
includingCurrentEvents Bool -> Bool -> Bool
&& (Double
t2 forall a. Eq a => a -> a -> Bool
== Point -> Double
pointTime Point
p))) forall a b. (a -> b) -> a -> b
$
              do forall a. IORef a -> a -> IO ()
writeIORef IORef Double
t Double
t2
                 forall a. PriorityQueue a -> IO ()
PQ.dequeue PriorityQueue (Point -> IO ())
pq
                 let sc :: Specs
sc = Point -> Specs
pointSpecs Point
p
                     t0 :: Double
t0 = Specs -> Double
spcStartTime Specs
sc
                     dt :: Double
dt = Specs -> Double
spcDT Specs
sc
                     n2 :: Int
n2 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
floor ((Double
t2 forall a. Num a => a -> a -> a
- Double
t0) forall a. Fractional a => a -> a -> a
/ Double
dt)
                 Point -> IO ()
c2 forall a b. (a -> b) -> a -> b
$ Point
p { pointTime :: Double
pointTime = Double
t2,
                          pointPriority :: Int
pointPriority = Int
priority2,
                          pointIteration :: Int
pointIteration = Int
n2,
                          pointPhase :: Int
pointPhase = -Int
1 }
                 EventQueue -> Point -> IO ()
call EventQueue
q Point
p

-- | Process the pending events synchronously, i.e. without past.
processPendingEvents :: Bool -> Dynamics ()
processPendingEvents :: Bool -> Dynamics ()
processPendingEvents Bool
includingCurrentEvents = forall a. (Point -> IO a) -> Dynamics a
Dynamics Point -> IO ()
r where
  r :: Point -> IO ()
r Point
p =
    do let q :: EventQueue
q = Run -> EventQueue
runEventQueue forall a b. (a -> b) -> a -> b
$ Point -> Run
pointRun Point
p
           t :: IORef Double
t = EventQueue -> IORef Double
queueTime EventQueue
q
       Double
t' <- forall a. IORef a -> IO a
readIORef IORef Double
t
       if Point -> Double
pointTime Point
p forall a. Ord a => a -> a -> Bool
< Double
t'
         then forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
              String
"The current time is less than " forall a. [a] -> [a] -> [a]
++
              String
"the time in the queue: processPendingEvents"
         else forall a. Point -> Dynamics a -> IO a
invokeDynamics Point
p Dynamics ()
m
  m :: Dynamics ()
m = Bool -> Dynamics ()
processPendingEventsCore Bool
includingCurrentEvents

-- | A memoized value.
processEventsIncludingCurrent :: Dynamics ()
processEventsIncludingCurrent = Bool -> Dynamics ()
processPendingEvents Bool
True

-- | A memoized value.
processEventsIncludingEarlier :: Dynamics ()
processEventsIncludingEarlier = Bool -> Dynamics ()
processPendingEvents Bool
False

-- | A memoized value.
processEventsIncludingCurrentCore :: Dynamics ()
processEventsIncludingCurrentCore = Bool -> Dynamics ()
processPendingEventsCore Bool
True

-- | A memoized value.
processEventsIncludingEarlierCore :: Dynamics ()
processEventsIncludingEarlierCore = Bool -> Dynamics ()
processPendingEventsCore Bool
True

-- | Process the events.
processEvents :: EventProcessing -> Dynamics ()
processEvents :: EventProcessing -> Dynamics ()
processEvents EventProcessing
CurrentEvents = Dynamics ()
processEventsIncludingCurrent
processEvents EventProcessing
EarlierEvents = Dynamics ()
processEventsIncludingEarlier
processEvents EventProcessing
CurrentEventsOrFromPast = Dynamics ()
processEventsIncludingCurrentCore
processEvents EventProcessing
EarlierEventsOrFromPast = Dynamics ()
processEventsIncludingEarlierCore

-- | Run the 'Event' computation in the current simulation time
-- within the 'Dynamics' computation involving all pending
-- 'CurrentEvents' in the processing too.
runEvent :: Event a -> Dynamics a
runEvent :: forall a. Event a -> Dynamics a
runEvent = forall a. EventProcessing -> Event a -> Dynamics a
runEventWith EventProcessing
CurrentEvents

-- | Run the 'Event' computation in the current simulation time
-- within the 'Dynamics' computation specifying what pending events 
-- should be involved in the processing.
runEventWith :: EventProcessing -> Event a -> Dynamics a
runEventWith :: forall a. EventProcessing -> Event a -> Dynamics a
runEventWith EventProcessing
processing (Event Point -> IO a
e) =
  forall a. (Point -> IO a) -> Dynamics a
Dynamics forall a b. (a -> b) -> a -> b
$ \Point
p ->
  do forall a. Point -> Dynamics a -> IO a
invokeDynamics Point
p forall a b. (a -> b) -> a -> b
$ EventProcessing -> Dynamics ()
processEvents EventProcessing
processing
     Point -> IO a
e Point
p

-- | Run the 'Event' computation in the start time involving all
-- pending 'CurrentEvents' in the processing too.
runEventInStartTime :: Event a -> Simulation a
runEventInStartTime :: forall a. Event a -> Simulation a
runEventInStartTime = forall a. Dynamics a -> Simulation a
runDynamicsInStartTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Event a -> Dynamics a
runEvent

-- | Run the 'Event' computation in the stop time involving all
-- pending 'CurrentEvents' in the processing too.
runEventInStopTime :: Event a -> Simulation a
runEventInStopTime :: forall a. Event a -> Simulation a
runEventInStopTime = forall a. Dynamics a -> Simulation a
runDynamicsInStopTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Event a -> Dynamics a
runEvent

-- | Return the number of pending events that should
-- be yet actuated.
eventQueueCount :: Event Int
eventQueueCount :: Event Int
eventQueueCount =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ forall a. PriorityQueue a -> IO Int
PQ.queueCount forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventQueue -> PriorityQueue (Point -> IO ())
queuePQ forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> EventQueue
runEventQueue forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Run
pointRun

-- | Return the current event priority.
eventPriority :: Event EventPriority
eventPriority :: Event Int
eventPriority =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Int
pointPriority

-- | Actuate the event handler in the specified time points.
enqueueEventWithTimes :: [Double] -> Event () -> Event ()
enqueueEventWithTimes :: [Double] -> Event () -> Event ()
enqueueEventWithTimes [Double]
ts Event ()
e = [Double] -> Event ()
loop [Double]
ts
  where loop :: [Double] -> Event ()
loop []       = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        loop (Double
t : [Double]
ts) = Double -> Event () -> Event ()
enqueueEvent Double
t forall a b. (a -> b) -> a -> b
$ Event ()
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Double] -> Event ()
loop [Double]
ts
       
-- | Actuate the event handler in the specified time points.
enqueueEventWithPoints :: [Point] -> Event () -> Event ()
enqueueEventWithPoints :: [Point] -> Event () -> Event ()
enqueueEventWithPoints [Point]
xs (Event Point -> IO ()
e) = [Point] -> Event ()
loop [Point]
xs
  where loop :: [Point] -> Event ()
loop []       = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        loop (Point
x : [Point]
xs) = Double -> Event () -> Event ()
enqueueEvent (Point -> Double
pointTime Point
x) forall a b. (a -> b) -> a -> b
$ 
                        forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
                        do Point -> IO ()
e Point
x    -- N.B. we substitute the time point!
                           forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ [Point] -> Event ()
loop [Point]
xs
                           
-- | Actuate the event handler in the integration time points.
enqueueEventWithIntegTimes :: Event () -> Event ()
enqueueEventWithIntegTimes :: Event () -> Event ()
enqueueEventWithIntegTimes Event ()
e =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
  let points :: [Point]
points = Point -> [Point]
integPointsStartingFrom Point
p
  in forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ [Point] -> Event () -> Event ()
enqueueEventWithPoints [Point]
points Event ()
e

-- | Actuate the event handler in the start time point.
enqueueEventWithStartTime :: Event () -> Event ()
enqueueEventWithStartTime :: Event () -> Event ()
enqueueEventWithStartTime Event ()
e =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
  let p0 :: Point
p0 = Run -> Point
integStartPoint forall a b. (a -> b) -> a -> b
$ Point -> Run
pointRun Point
p
  in forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ [Point] -> Event () -> Event ()
enqueueEventWithPoints [Point
p0] Event ()
e

-- | Actuate the event handler in the final time point.
enqueueEventWithStopTime :: Event () -> Event ()
enqueueEventWithStopTime :: Event () -> Event ()
enqueueEventWithStopTime Event ()
e =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
  let p0 :: Point
p0 = Run -> Point
simulationStopPoint forall a b. (a -> b) -> a -> b
$ Point -> Run
pointRun Point
p
  in forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ [Point] -> Event () -> Event ()
enqueueEventWithPoints [Point
p0] Event ()
e

-- | It allows cancelling the event.
data EventCancellation =
  EventCancellation { EventCancellation -> Event ()
cancelEvent   :: Event (),
                      -- ^ Cancel the event.
                      EventCancellation -> Event Bool
eventCancelled :: Event Bool,
                      -- ^ Test whether the event was cancelled.
                      EventCancellation -> Event Bool
eventFinished :: Event Bool
                      -- ^ Test whether the event was processed and finished.
                    }

-- | Enqueue the event with an ability to cancel it.
enqueueEventWithCancellation :: Double -> Event () -> Event EventCancellation
enqueueEventWithCancellation :: Double -> Event () -> Event EventCancellation
enqueueEventWithCancellation Double
t Event ()
e =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
  do IORef Bool
cancelledRef <- forall a. a -> IO (IORef a)
newIORef Bool
False
     IORef Bool
cancellableRef <- forall a. a -> IO (IORef a)
newIORef Bool
True
     IORef Bool
finishedRef <- forall a. a -> IO (IORef a)
newIORef Bool
False
     let cancel :: Event ()
cancel =
           forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
           do Bool
x <- forall a. IORef a -> IO a
readIORef IORef Bool
cancellableRef
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
x forall a b. (a -> b) -> a -> b
$
                forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
cancelledRef Bool
True
         cancelled :: Event Bool
cancelled =
           forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p -> forall a. IORef a -> IO a
readIORef IORef Bool
cancelledRef
         finished :: Event Bool
finished =
           forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p -> forall a. IORef a -> IO a
readIORef IORef Bool
finishedRef
     forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$
       Double -> Event () -> Event ()
enqueueEvent Double
t forall a b. (a -> b) -> a -> b
$
       forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
       do forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
cancellableRef Bool
False
          Bool
x <- forall a. IORef a -> IO a
readIORef IORef Bool
cancelledRef
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
x forall a b. (a -> b) -> a -> b
$
            do forall a. Point -> Event a -> IO a
invokeEvent Point
p Event ()
e
               forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
finishedRef Bool
True
     forall (m :: * -> *) a. Monad m => a -> m a
return EventCancellation { cancelEvent :: Event ()
cancelEvent   = Event ()
cancel,
                                eventCancelled :: Event Bool
eventCancelled = Event Bool
cancelled,
                                eventFinished :: Event Bool
eventFinished = Event Bool
finished }

-- | Memoize the 'Event' computation, always returning the same value
-- within a simulation run.
memoEvent :: Event a -> Simulation (Event a)
memoEvent :: forall a. Event a -> Simulation (Event a)
memoEvent Event a
m =
  do IORef (Maybe a)
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
       do Maybe a
x <- forall a. IORef a -> IO a
readIORef IORef (Maybe a)
ref
          case Maybe a
x of
            Just a
v -> forall (m :: * -> *) a. Monad m => a -> m a
return a
v
            Maybe a
Nothing ->
              do a
v <- forall a. Point -> Event a -> IO a
invokeEvent Point
p Event a
m
                 forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe a)
ref (forall a. a -> Maybe a
Just a
v)
                 forall (m :: * -> *) a. Monad m => a -> m a
return a
v

-- | Memoize the 'Event' computation, always returning the same value
-- in the same modeling time. After the time changes, the value is
-- recalculated by demand.
--
-- It is possible to implement this function efficiently, for the 'Event'
-- computation is always synchronized with the event queue which time
-- flows in one direction only. This synchronization is a key difference
-- between the 'Event' and 'Dynamics' computations.
memoEventInTime :: Event a -> Simulation (Event a)
memoEventInTime :: forall a. Event a -> Simulation (Event a)
memoEventInTime Event a
m =
  do IORef (Maybe (Double, a))
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
       do Maybe (Double, a)
x <- forall a. IORef a -> IO a
readIORef IORef (Maybe (Double, a))
ref
          case Maybe (Double, a)
x of
            Just (Double
t, a
v) | Double
t forall a. Eq a => a -> a -> Bool
== Point -> Double
pointTime Point
p ->
              forall (m :: * -> *) a. Monad m => a -> m a
return a
v
            Maybe (Double, a)
_ ->
              do a
v <- forall a. Point -> Event a -> IO a
invokeEvent Point
p Event a
m
                 forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (Double, a))
ref (forall a. a -> Maybe a
Just (Point -> Double
pointTime Point
p, a
v))
                 forall (m :: * -> *) a. Monad m => a -> m a
return a
v

-- | Enqueue the event which must be actuated with the current modeling time but later.
yieldEvent :: Event () -> Event ()
yieldEvent :: Event () -> Event ()
yieldEvent Event ()
m =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
  forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$
  Double -> Event () -> Event ()
enqueueEvent (Point -> Double
pointTime Point
p) Event ()
m

-- | Defines a computation disposing some entity.
newtype DisposableEvent =
  DisposableEvent { DisposableEvent -> Event ()
disposeEvent :: Event ()
                    -- ^ Dispose something within the 'Event' computation.
                  }

instance Semigroup DisposableEvent where
  DisposableEvent Event ()
x <> :: DisposableEvent -> DisposableEvent -> DisposableEvent
<> DisposableEvent Event ()
y = Event () -> DisposableEvent
DisposableEvent forall a b. (a -> b) -> a -> b
$ Event ()
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Event ()
y

instance Monoid DisposableEvent where

  mempty :: DisposableEvent
mempty = Event () -> DisposableEvent
DisposableEvent forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
  mappend :: DisposableEvent -> DisposableEvent -> DisposableEvent
mappend = forall a. Semigroup a => a -> a -> a
(<>)

-- | Retry the current computation as possible, using the specified argument
-- as a 'SimulationRetry' exception message in case of failure.
retryEvent :: String -> Event a
retryEvent :: forall a. String -> Event a
retryEvent String
message = forall e a. Exception e => e -> Event a
throwEvent forall a b. (a -> b) -> a -> b
$ String -> SimulationRetry
SimulationRetry String
message

-- | Show the debug message with the current simulation time.
traceEvent :: String -> Event a -> Event a
traceEvent :: forall a. String -> Event a -> Event a
traceEvent String
message Event a
m =
  forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
  forall a. String -> a -> a
trace (String
"t = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Point -> Double
pointTime Point
p) forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
message) forall a b. (a -> b) -> a -> b
$
  forall a. Point -> Event a -> IO a
invokeEvent Point
p Event a
m