{-# LANGUAGE RecursiveDo, RankNTypes #-}
module Simulation.Aivika.Internal.Event
(
Event(..),
EventLift(..),
EventProcessing(..),
invokeEvent,
runEvent,
runEventWith,
runEventInStartTime,
runEventInStopTime,
EventPriority(..),
enqueueEvent,
enqueueEventWithPriority,
enqueueEventWithCancellation,
enqueueEventWithStartTime,
enqueueEventWithStopTime,
enqueueEventWithTimes,
enqueueEventWithPoints,
enqueueEventWithIntegTimes,
yieldEvent,
eventQueueCount,
eventPriority,
EventCancellation,
cancelEvent,
eventCancelled,
eventFinished,
catchEvent,
finallyEvent,
throwEvent,
memoEvent,
memoEventInTime,
DisposableEvent(..),
retryEvent,
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
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
class EventLift m where
liftEvent :: Event a -> m a
instance EventLift Event where
liftEvent :: forall a. Event a -> Event a
liftEvent = forall a. a -> a
id
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
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)
throwEvent :: Exception e => e -> Event a
throwEvent :: forall e a. Exception e => e -> Event a
throwEvent = forall a e. Exception e => e -> a
throw
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)
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)
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)
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
data EventProcessing = CurrentEvents
| EarlierEvents
| CurrentEventsOrFromPast
| EarlierEventsOrFromPast
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)
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
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
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
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
processEventsIncludingCurrent :: Dynamics ()
processEventsIncludingCurrent = Bool -> Dynamics ()
processPendingEvents Bool
True
processEventsIncludingEarlier :: Dynamics ()
processEventsIncludingEarlier = Bool -> Dynamics ()
processPendingEvents Bool
False
processEventsIncludingCurrentCore :: Dynamics ()
processEventsIncludingCurrentCore = Bool -> Dynamics ()
processPendingEventsCore Bool
True
processEventsIncludingEarlierCore :: Dynamics ()
processEventsIncludingEarlierCore = Bool -> Dynamics ()
processPendingEventsCore Bool
True
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
runEvent :: Event a -> Dynamics a
runEvent :: forall a. Event a -> Dynamics a
runEvent = forall a. EventProcessing -> Event a -> Dynamics a
runEventWith EventProcessing
CurrentEvents
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
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
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
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
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
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
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
forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ [Point] -> Event ()
loop [Point]
xs
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
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
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
data EventCancellation =
EventCancellation { EventCancellation -> Event ()
cancelEvent :: Event (),
EventCancellation -> Event Bool
eventCancelled :: Event Bool,
EventCancellation -> Event Bool
eventFinished :: Event Bool
}
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 }
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
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
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
newtype DisposableEvent =
DisposableEvent { DisposableEvent -> Event ()
disposeEvent :: Event ()
}
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
(<>)
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
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