{-# LANGUAGE TypeFamilies, FlexibleInstances #-}

-- |
-- Module     : Simulation.Aivika.RealTime.Internal.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 8.0.1
--
-- The module defines an event queue.
--
module Simulation.Aivika.RealTime.Internal.Event () where

import Data.Maybe
import Data.IORef
import Data.Time.Clock

import System.Timeout

import Control.Monad
import Control.Monad.Trans
import Control.Exception

import qualified Simulation.Aivika.PriorityQueue as PQ

import Simulation.Aivika.Trans
import Simulation.Aivika.Trans.Internal.Types

import Simulation.Aivika.RealTime.Internal.Channel
import Simulation.Aivika.RealTime.Internal.RT

-- | An implementation of the 'EventQueueing' type class.
instance MonadIO m => EventQueueing (RT m) where

  {-# SPECIALIZE instance EventQueueing (RT IO) #-}

  -- | The event queue type.
  data EventQueue (RT m) =
    EventQueueRT { EventQueue (RT m) -> PriorityQueue (Point (RT m) -> RT m ())
queuePQ :: PQ.PriorityQueue (Point (RT m) -> RT m ()),
                   -- ^ the underlying priority queue
                   EventQueue (RT m) -> IORef Bool
queueBusy :: IORef Bool,
                   -- ^ whether the queue is currently processing events
                   EventQueue (RT m) -> IORef Double
queueTime :: IORef Double,
                   -- ^ the actual time of the event queue
                   EventQueue (RT m) -> UTCTime
queueStartUTCTime :: UTCTime
                   -- ^ the system time of starting the simulation
                 }

  newEventQueue :: Specs (RT m) -> RT m (EventQueue (RT m))
newEventQueue Specs (RT m)
specs =
    do UTCTime
t0 <- IO UTCTime -> RT m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
       IORef Double
t  <- IO (IORef Double) -> RT m (IORef Double)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Double) -> RT m (IORef Double))
-> IO (IORef Double) -> RT m (IORef Double)
forall a b. (a -> b) -> a -> b
$ Double -> IO (IORef Double)
forall a. a -> IO (IORef a)
newIORef (Double -> IO (IORef Double)) -> Double -> IO (IORef Double)
forall a b. (a -> b) -> a -> b
$ Specs (RT m) -> Double
forall (m :: * -> *). Specs m -> Double
spcStartTime Specs (RT m)
specs
       IORef Bool
f  <- IO (IORef Bool) -> RT m (IORef Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Bool) -> RT m (IORef Bool))
-> IO (IORef Bool) -> RT m (IORef Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
       PriorityQueue (Point (RT m) -> RT m ())
pq <- IO (PriorityQueue (Point (RT m) -> RT m ()))
-> RT m (PriorityQueue (Point (RT m) -> RT m ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (PriorityQueue (Point (RT m) -> RT m ()))
forall a. IO (PriorityQueue a)
PQ.newQueue
       EventQueue (RT m) -> RT m (EventQueue (RT m))
forall (m :: * -> *) a. Monad m => a -> m a
return EventQueueRT :: forall (m :: * -> *).
PriorityQueue (Point (RT m) -> RT m ())
-> IORef Bool -> IORef Double -> UTCTime -> EventQueue (RT m)
EventQueueRT { queuePQ :: PriorityQueue (Point (RT m) -> RT m ())
queuePQ   = PriorityQueue (Point (RT m) -> RT m ())
pq,
                             queueBusy :: IORef Bool
queueBusy = IORef Bool
f,
                             queueTime :: IORef Double
queueTime = IORef Double
t,
                             queueStartUTCTime :: UTCTime
queueStartUTCTime = UTCTime
t0 }

  enqueueEvent :: Double -> Event (RT m) () -> Event (RT m) ()
enqueueEvent Double
t (Event Point (RT m) -> RT m ()
m) =
    (Point (RT m) -> RT m ()) -> Event (RT m) ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point (RT m) -> RT m ()) -> Event (RT m) ())
-> (Point (RT m) -> RT m ()) -> Event (RT m) ()
forall a b. (a -> b) -> a -> b
$ \Point (RT m)
p ->
    let pq :: PriorityQueue (Point (RT m) -> RT m ())
pq = EventQueue (RT m) -> PriorityQueue (Point (RT m) -> RT m ())
forall (m :: * -> *).
EventQueue (RT m) -> PriorityQueue (Point (RT m) -> RT m ())
queuePQ (EventQueue (RT m) -> PriorityQueue (Point (RT m) -> RT m ()))
-> EventQueue (RT m) -> PriorityQueue (Point (RT m) -> RT m ())
forall a b. (a -> b) -> a -> b
$ Run (RT m) -> EventQueue (RT m)
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run (RT m) -> EventQueue (RT m))
-> Run (RT m) -> EventQueue (RT m)
forall a b. (a -> b) -> a -> b
$ Point (RT m) -> Run (RT m)
forall (m :: * -> *). Point m -> Run m
pointRun Point (RT m)
p
    in IO () -> RT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RT m ()) -> IO () -> RT m ()
forall a b. (a -> b) -> a -> b
$ PriorityQueue (Point (RT m) -> RT m ())
-> Double -> (Point (RT m) -> RT m ()) -> IO ()
forall a. PriorityQueue a -> Double -> a -> IO ()
PQ.enqueue PriorityQueue (Point (RT m) -> RT m ())
pq Double
t Point (RT m) -> RT m ()
m

  runEventWith :: EventProcessing -> Event (RT m) a -> Dynamics (RT m) a
runEventWith EventProcessing
processing (Event Point (RT m) -> RT m a
e) =
    (Point (RT m) -> RT m a) -> Dynamics (RT m) a
forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics ((Point (RT m) -> RT m a) -> Dynamics (RT m) a)
-> (Point (RT m) -> RT m a) -> Dynamics (RT m) a
forall a b. (a -> b) -> a -> b
$ \Point (RT m)
p ->
    do Point (RT m) -> Dynamics (RT m) () -> RT m ()
forall (m :: * -> *) a. Point m -> Dynamics m a -> m a
invokeDynamics Point (RT m)
p (Dynamics (RT m) () -> RT m ()) -> Dynamics (RT m) () -> RT m ()
forall a b. (a -> b) -> a -> b
$ EventProcessing -> Dynamics (RT m) ()
forall (m :: * -> *).
MonadIO m =>
EventProcessing -> Dynamics (RT m) ()
processEvents EventProcessing
processing
       Point (RT m) -> RT m a
e Point (RT m)
p

  eventQueueCount :: Event (RT m) Int
eventQueueCount =
    (Point (RT m) -> RT m Int) -> Event (RT m) Int
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point (RT m) -> RT m Int) -> Event (RT m) Int)
-> (Point (RT m) -> RT m Int) -> Event (RT m) Int
forall a b. (a -> b) -> a -> b
$ \Point (RT m)
p ->
    let pq :: PriorityQueue (Point (RT m) -> RT m ())
pq = EventQueue (RT m) -> PriorityQueue (Point (RT m) -> RT m ())
forall (m :: * -> *).
EventQueue (RT m) -> PriorityQueue (Point (RT m) -> RT m ())
queuePQ (EventQueue (RT m) -> PriorityQueue (Point (RT m) -> RT m ()))
-> EventQueue (RT m) -> PriorityQueue (Point (RT m) -> RT m ())
forall a b. (a -> b) -> a -> b
$ Run (RT m) -> EventQueue (RT m)
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run (RT m) -> EventQueue (RT m))
-> Run (RT m) -> EventQueue (RT m)
forall a b. (a -> b) -> a -> b
$ Point (RT m) -> Run (RT m)
forall (m :: * -> *). Point m -> Run m
pointRun Point (RT m)
p
    in IO Int -> RT m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> RT m Int) -> IO Int -> RT m Int
forall a b. (a -> b) -> a -> b
$ PriorityQueue (Point (RT m) -> RT m ()) -> IO Int
forall a. PriorityQueue a -> IO Int
PQ.queueCount PriorityQueue (Point (RT m) -> RT m ())
pq

-- | Return the current event point.
currentEventPoint :: MonadIO m => Event (RT m) (Point (RT m))
{-# INLINE currentEventPoint #-}
currentEventPoint :: Event (RT m) (Point (RT m))
currentEventPoint =
  (Point (RT m) -> RT m (Point (RT m)))
-> Event (RT m) (Point (RT m))
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point (RT m) -> RT m (Point (RT m)))
 -> Event (RT m) (Point (RT m)))
-> (Point (RT m) -> RT m (Point (RT m)))
-> Event (RT m) (Point (RT m))
forall a b. (a -> b) -> a -> b
$ \Point (RT m)
p ->
  do let q :: EventQueue (RT m)
q = Run (RT m) -> EventQueue (RT m)
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run (RT m) -> EventQueue (RT m))
-> Run (RT m) -> EventQueue (RT m)
forall a b. (a -> b) -> a -> b
$ Point (RT m) -> Run (RT m)
forall (m :: * -> *). Point m -> Run m
pointRun Point (RT m)
p
     Double
t' <- IO Double -> RT m Double
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> RT m Double) -> IO Double -> RT m Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef (EventQueue (RT m) -> IORef Double
forall (m :: * -> *). EventQueue (RT m) -> IORef Double
queueTime EventQueue (RT m)
q)
     if Double
t' Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Point (RT m) -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point (RT m)
p
       then Point (RT m) -> RT m (Point (RT m))
forall (m :: * -> *) a. Monad m => a -> m a
return Point (RT m)
p
       else let sc :: Specs (RT m)
sc = Point (RT m) -> Specs (RT m)
forall (m :: * -> *). Point m -> Specs m
pointSpecs Point (RT m)
p
                t0 :: Double
t0 = Specs (RT m) -> Double
forall (m :: * -> *). Specs m -> Double
spcStartTime Specs (RT m)
sc
                dt :: Double
dt = Specs (RT m) -> Double
forall (m :: * -> *). Specs m -> Double
spcDT Specs (RT m)
sc
                n' :: Int
n' = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor ((Double
t' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
t0) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
dt)
            in Point (RT m) -> RT m (Point (RT m))
forall (m :: * -> *) a. Monad m => a -> m a
return Point (RT m)
p { pointTime :: Double
pointTime = Double
t',
                          pointIteration :: Int
pointIteration = Int
n',
                          pointPhase :: Int
pointPhase = -Int
1 }

-- | Process the pending events.
processPendingEventsCore :: MonadIO m => Bool -> Dynamics (RT m) ()
{-# INLINE processPendingEventsCore #-}
processPendingEventsCore :: Bool -> Dynamics (RT m) ()
processPendingEventsCore Bool
includingCurrentEvents = (Point (RT m) -> RT m ()) -> Dynamics (RT m) ()
forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics Point (RT m) -> RT m ()
r where
  r :: Point (RT m) -> RT m ()
r Point (RT m)
p =
    do let q :: EventQueue (RT m)
q = Run (RT m) -> EventQueue (RT m)
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run (RT m) -> EventQueue (RT m))
-> Run (RT m) -> EventQueue (RT m)
forall a b. (a -> b) -> a -> b
$ Point (RT m) -> Run (RT m)
forall (m :: * -> *). Point m -> Run m
pointRun Point (RT m)
p
           f :: IORef Bool
f = EventQueue (RT m) -> IORef Bool
forall (m :: * -> *). EventQueue (RT m) -> IORef Bool
queueBusy EventQueue (RT m)
q
       Bool
f' <- IO Bool -> RT m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RT m Bool) -> IO Bool -> RT m Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
f
       if Bool
f'
         then [Char] -> RT m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> RT m ()) -> [Char] -> RT m ()
forall a b. (a -> b) -> a -> b
$
              [Char]
"Detected an event loop, which may indicate to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
              [Char]
"a logical error in the model: processPendingEventsCore"
         else do IO () -> RT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RT m ()) -> IO () -> RT m ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
f Bool
True
                 EventQueue (RT m) -> Point (RT m) -> Point (RT m) -> RT m ()
call EventQueue (RT m)
q Point (RT m)
p Point (RT m)
p
                 IO () -> RT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RT m ()) -> IO () -> RT m ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
f Bool
False
  call :: EventQueue (RT m) -> Point (RT m) -> Point (RT m) -> RT m ()
call EventQueue (RT m)
q Point (RT m)
p Point (RT m)
p0 =
    do let pq :: PriorityQueue (Point (RT m) -> RT m ())
pq = EventQueue (RT m) -> PriorityQueue (Point (RT m) -> RT m ())
forall (m :: * -> *).
EventQueue (RT m) -> PriorityQueue (Point (RT m) -> RT m ())
queuePQ EventQueue (RT m)
q
           r :: Run (RT m)
r  = Point (RT m) -> Run (RT m)
forall (m :: * -> *). Point m -> Run m
pointRun Point (RT m)
p
       -- process external actions
       Point (RT m)
p1 <- Point (RT m) -> Event (RT m) (Point (RT m)) -> RT m (Point (RT m))
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point (RT m)
p0 Event (RT m) (Point (RT m))
forall (m :: * -> *). MonadIO m => Event (RT m) (Point (RT m))
currentEventPoint
       Point (RT m) -> Event (RT m) () -> RT m ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point (RT m)
p1 Event (RT m) ()
forall (m :: * -> *). MonadIO m => Event (RT m) ()
processChannelActions
       -- proceed with processing the events
       Bool
f <- IO Bool -> RT m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RT m Bool) -> IO Bool -> RT m Bool
forall a b. (a -> b) -> a -> b
$ PriorityQueue (Point (RT m) -> RT m ()) -> IO Bool
forall a. PriorityQueue a -> IO Bool
PQ.queueNull PriorityQueue (Point (RT m) -> RT m ())
pq
       Bool -> RT m () -> RT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f (RT m () -> RT m ()) -> RT m () -> RT m ()
forall a b. (a -> b) -> a -> b
$
         do (Double
t2, Point (RT m) -> RT m ()
c2) <- IO (Double, Point (RT m) -> RT m ())
-> RT m (Double, Point (RT m) -> RT m ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Double, Point (RT m) -> RT m ())
 -> RT m (Double, Point (RT m) -> RT m ()))
-> IO (Double, Point (RT m) -> RT m ())
-> RT m (Double, Point (RT m) -> RT m ())
forall a b. (a -> b) -> a -> b
$ PriorityQueue (Point (RT m) -> RT m ())
-> IO (Double, Point (RT m) -> RT m ())
forall a. PriorityQueue a -> IO (Double, a)
PQ.queueFront PriorityQueue (Point (RT m) -> RT m ())
pq
            let t :: IORef Double
t = EventQueue (RT m) -> IORef Double
forall (m :: * -> *). EventQueue (RT m) -> IORef Double
queueTime EventQueue (RT m)
q
            Double
t' <- IO Double -> RT m Double
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> RT m Double) -> IO Double -> RT m Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef IORef Double
t
            Bool -> RT m () -> RT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
t2 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t') (RT m () -> RT m ()) -> RT m () -> RT m ()
forall a b. (a -> b) -> a -> b
$ 
              -- error "The time value is too small: processPendingEventsCore"
              [Char] -> RT m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> RT m ()) -> [Char] -> RT m ()
forall a b. (a -> b) -> a -> b
$
              [Char]
"The time value is too small (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
t2 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
              [Char]
" < " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
t' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"): processPendingEventsCore"
            Bool -> RT m () -> RT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Double
t2 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Point (RT m) -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point (RT m)
p) Bool -> Bool -> Bool
||
                  (Bool
includingCurrentEvents Bool -> Bool -> Bool
&& (Double
t2 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Point (RT m) -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point (RT m)
p))) (RT m () -> RT m ()) -> RT m () -> RT m ()
forall a b. (a -> b) -> a -> b
$
              do Bool
emulated <- Point (RT m) -> Event (RT m) Bool -> RT m Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point (RT m)
p1 (Event (RT m) Bool -> RT m Bool) -> Event (RT m) Bool -> RT m Bool
forall a b. (a -> b) -> a -> b
$ Double -> Event (RT m) Bool
forall (m :: * -> *). MonadIO m => Double -> Event (RT m) Bool
emulateRealTimeDelay Double
t2
                 if Bool
emulated
                   then do let sc :: Specs (RT m)
sc = Point (RT m) -> Specs (RT m)
forall (m :: * -> *). Point m -> Specs m
pointSpecs Point (RT m)
p
                               t0 :: Double
t0 = Specs (RT m) -> Double
forall (m :: * -> *). Specs m -> Double
spcStartTime Specs (RT m)
sc
                               dt :: Double
dt = Specs (RT m) -> Double
forall (m :: * -> *). Specs m -> Double
spcDT Specs (RT m)
sc
                               n2 :: Int
n2 = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor ((Double
t2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
t0) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
dt)
                               p2 :: Point (RT m)
p2 = Point (RT m)
p { pointTime :: Double
pointTime = Double
t2,
                                        pointIteration :: Int
pointIteration = Int
n2,
                                        pointPhase :: Int
pointPhase = -Int
1 }
                           IO () -> RT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RT m ()) -> IO () -> RT m ()
forall a b. (a -> b) -> a -> b
$ IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Double
t Double
t2
                           IO () -> RT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RT m ()) -> IO () -> RT m ()
forall a b. (a -> b) -> a -> b
$ PriorityQueue (Point (RT m) -> RT m ()) -> IO ()
forall a. PriorityQueue a -> IO ()
PQ.dequeue PriorityQueue (Point (RT m) -> RT m ())
pq
                           Point (RT m) -> RT m ()
c2 Point (RT m)
p2
                           EventQueue (RT m) -> Point (RT m) -> Point (RT m) -> RT m ()
call EventQueue (RT m)
q Point (RT m)
p Point (RT m)
p2
                   else EventQueue (RT m) -> Point (RT m) -> Point (RT m) -> RT m ()
call EventQueue (RT m)
q Point (RT m)
p Point (RT m)
p1

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

-- | A memoized value.
processEventsIncludingCurrent :: MonadIO m => Dynamics (RT m) ()
{-# INLINE processEventsIncludingCurrent #-}
processEventsIncludingCurrent :: Dynamics (RT m) ()
processEventsIncludingCurrent = Bool -> Dynamics (RT m) ()
forall (m :: * -> *). MonadIO m => Bool -> Dynamics (RT m) ()
processPendingEvents Bool
True

-- | A memoized value.
processEventsIncludingEarlier :: MonadIO m => Dynamics (RT m) ()
{-# INLINE processEventsIncludingEarlier #-}
processEventsIncludingEarlier :: Dynamics (RT m) ()
processEventsIncludingEarlier = Bool -> Dynamics (RT m) ()
forall (m :: * -> *). MonadIO m => Bool -> Dynamics (RT m) ()
processPendingEvents Bool
False

-- | A memoized value.
processEventsIncludingCurrentCore :: MonadIO m => Dynamics (RT m) ()
{-# INLINE processEventsIncludingCurrentCore #-}
processEventsIncludingCurrentCore :: Dynamics (RT m) ()
processEventsIncludingCurrentCore = Bool -> Dynamics (RT m) ()
forall (m :: * -> *). MonadIO m => Bool -> Dynamics (RT m) ()
processPendingEventsCore Bool
True

-- | A memoized value.
processEventsIncludingEarlierCore :: MonadIO m => Dynamics (RT m) ()
{-# INLINE processEventsIncludingEarlierCore #-}
processEventsIncludingEarlierCore :: Dynamics (RT m) ()
processEventsIncludingEarlierCore = Bool -> Dynamics (RT m) ()
forall (m :: * -> *). MonadIO m => Bool -> Dynamics (RT m) ()
processPendingEventsCore Bool
True

-- | Process the events.
processEvents :: MonadIO m => EventProcessing -> Dynamics (RT m) ()
{-# INLINABLE processEvents #-}
processEvents :: EventProcessing -> Dynamics (RT m) ()
processEvents EventProcessing
CurrentEvents = Dynamics (RT m) ()
forall (m :: * -> *). MonadIO m => Dynamics (RT m) ()
processEventsIncludingCurrent
processEvents EventProcessing
EarlierEvents = Dynamics (RT m) ()
forall (m :: * -> *). MonadIO m => Dynamics (RT m) ()
processEventsIncludingEarlier
processEvents EventProcessing
CurrentEventsOrFromPast = Dynamics (RT m) ()
forall (m :: * -> *). MonadIO m => Dynamics (RT m) ()
processEventsIncludingCurrentCore
processEvents EventProcessing
EarlierEventsOrFromPast = Dynamics (RT m) ()
forall (m :: * -> *). MonadIO m => Dynamics (RT m) ()
processEventsIncludingEarlierCore

-- | Process the channel actions.
processChannelActions :: MonadIO m => Event (RT m) ()
{-# INLINABLE processChannelActions #-}
processChannelActions :: Event (RT m) ()
processChannelActions =
  (Point (RT m) -> RT m ()) -> Event (RT m) ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point (RT m) -> RT m ()) -> Event (RT m) ())
-> (Point (RT m) -> RT m ()) -> Event (RT m) ()
forall a b. (a -> b) -> a -> b
$ \Point (RT m)
p ->
  do Channel (Event (RT m) ())
ch <- RT m (Channel (Event (RT m) ()))
forall (m :: * -> *). Monad m => RT m (Channel (Event (RT m) ()))
rtChannel
     Bool
f  <- IO Bool -> RT m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RT m Bool) -> IO Bool -> RT m Bool
forall a b. (a -> b) -> a -> b
$ Channel (Event (RT m) ()) -> IO Bool
forall a. Channel a -> IO Bool
channelEmpty Channel (Event (RT m) ())
ch
     Bool -> RT m () -> RT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f (RT m () -> RT m ()) -> RT m () -> RT m ()
forall a b. (a -> b) -> a -> b
$
       do [Event (RT m) ()]
xs <- IO [Event (RT m) ()] -> RT m [Event (RT m) ()]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Event (RT m) ()] -> RT m [Event (RT m) ()])
-> IO [Event (RT m) ()] -> RT m [Event (RT m) ()]
forall a b. (a -> b) -> a -> b
$ Channel (Event (RT m) ()) -> IO [Event (RT m) ()]
forall a. Channel a -> IO [a]
readChannel Channel (Event (RT m) ())
ch
          [Event (RT m) ()] -> (Event (RT m) () -> RT m ()) -> RT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Event (RT m) ()]
xs ((Event (RT m) () -> RT m ()) -> RT m ())
-> (Event (RT m) () -> RT m ()) -> RT m ()
forall a b. (a -> b) -> a -> b
$ Point (RT m) -> Event (RT m) () -> RT m ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point (RT m)
p

-- | Try to emulate the real time delay till the specified
-- modeling time without interruption.
emulateRealTimeDelay :: MonadIO m => Double -> Event (RT m) Bool
{-# INLINABLE emulateRealTimeDelay #-}
emulateRealTimeDelay :: Double -> Event (RT m) Bool
emulateRealTimeDelay Double
t2 =
  (Point (RT m) -> RT m Bool) -> Event (RT m) Bool
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point (RT m) -> RT m Bool) -> Event (RT m) Bool)
-> (Point (RT m) -> RT m Bool) -> Event (RT m) Bool
forall a b. (a -> b) -> a -> b
$ \Point (RT m)
p ->
  do RTParams
ps  <- RT m RTParams
forall (m :: * -> *). Monad m => RT m RTParams
rtParams
     UTCTime
utc <- IO UTCTime -> RT m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
     let scaling :: RTScaling
scaling = RTParams -> RTScaling
rtScaling RTParams
ps
         delta :: Double
delta   = RTParams -> Double
rtIntervalDelta RTParams
ps
         sc :: Specs (RT m)
sc = Point (RT m) -> Specs (RT m)
forall (m :: * -> *). Point m -> Specs m
pointSpecs Point (RT m)
p
         t0 :: Double
t0 = Specs (RT m) -> Double
forall (m :: * -> *). Specs m -> Double
spcStartTime Specs (RT m)
sc
         t :: Double
t  = Point (RT m) -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point (RT m)
p
         dt :: Double
dt = RTScaling -> Double -> Double -> Double
rtScale RTScaling
scaling Double
t0 Double
t2
         q :: EventQueue (RT m)
q  = Run (RT m) -> EventQueue (RT m)
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Point (RT m) -> Run (RT m)
forall (m :: * -> *). Point m -> Run m
pointRun Point (RT m)
p)
         utc0 :: UTCTime
utc0 = EventQueue (RT m) -> UTCTime
forall (m :: * -> *). EventQueue (RT m) -> UTCTime
queueStartUTCTime EventQueue (RT m)
q
         utc' :: UTCTime
utc' = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> NominalDiffTime) -> Rational -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ Double -> Rational
forall a. Real a => a -> Rational
toRational Double
dt) UTCTime
utc0
         rdt :: Double
rdt  = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
utc' UTCTime
utc)
     if Double
rdt Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
delta
       then Bool -> RT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       else do Channel (Event (RT m) ())
ch <- RT m (Channel (Event (RT m) ()))
forall (m :: * -> *). Monad m => RT m (Channel (Event (RT m) ()))
rtChannel
               let dt :: Int
dt = Double -> Int
secondsToMicroseconds Double
rdt
               Maybe ()
interrupted <- IO (Maybe ()) -> RT m (Maybe ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ()) -> RT m (Maybe ()))
-> IO (Maybe ()) -> RT m (Maybe ())
forall a b. (a -> b) -> a -> b
$
                              Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
dt (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ Channel (Event (RT m) ()) -> IO ()
forall a. Channel a -> IO ()
awaitChannel Channel (Event (RT m) ())
ch
               Bool -> RT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> RT m Bool) -> Bool -> RT m Bool
forall a b. (a -> b) -> a -> b
$ Maybe () -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ()
interrupted

-- | Convert seconds to microseconds.
secondsToMicroseconds :: Double -> Int
secondsToMicroseconds :: Double -> Int
secondsToMicroseconds Double
x = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Integral a => a -> Integer
toInteger (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
1000000 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x)