{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}
module Simulation.Aivika.IO.Event () where
import Control.Monad
import Control.Monad.Trans
import Data.IORef
import qualified Simulation.Aivika.PriorityQueue.EventQueue as PQ
import Simulation.Aivika.Trans.Ref.Base
import Simulation.Aivika.Trans.DES
import Simulation.Aivika.Trans.Comp
import Simulation.Aivika.Trans.Internal.Types
import Simulation.Aivika.Trans.Event
instance EventQueueing IO where
{-# SPECIALISE instance EventQueueing IO #-}
data EventQueue IO =
EventQueue { EventQueue IO -> PriorityQueue (Point IO -> IO ())
queuePQ :: PQ.PriorityQueue (Point IO -> IO ()),
EventQueue IO -> IORef Bool
queueBusy :: IORef Bool,
EventQueue IO -> IORef Double
queueTime :: IORef Double
}
{-# INLINABLE newEventQueue #-}
newEventQueue :: Specs IO -> IO (EventQueue IO)
newEventQueue Specs IO
specs =
IO (EventQueue IO) -> IO (EventQueue IO)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (EventQueue IO) -> IO (EventQueue IO))
-> IO (EventQueue IO) -> IO (EventQueue IO)
forall a b. (a -> b) -> a -> b
$
do IORef Bool
f <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
IORef Double
t <- 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 IO -> Double
forall (m :: * -> *). Specs m -> Double
spcStartTime Specs IO
specs
PriorityQueue (Point IO -> IO ())
pq <- IO (PriorityQueue (Point IO -> IO ()))
forall a. IO (PriorityQueue a)
PQ.newQueue
EventQueue IO -> IO (EventQueue IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return EventQueue { queuePQ :: PriorityQueue (Point IO -> IO ())
queuePQ = PriorityQueue (Point IO -> IO ())
pq,
queueBusy :: IORef Bool
queueBusy = IORef Bool
f,
queueTime :: IORef Double
queueTime = IORef Double
t }
{-# INLINE enqueueEventWithPriority #-}
enqueueEventWithPriority :: Double -> Int -> Event IO () -> Event IO ()
enqueueEventWithPriority Double
t Int
priority (Event Point IO -> IO ()
m) =
(Point IO -> IO ()) -> Event IO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point IO -> IO ()) -> Event IO ())
-> (Point IO -> IO ()) -> Event IO ()
forall a b. (a -> b) -> a -> b
$ \Point IO
p ->
let pq :: PriorityQueue (Point IO -> IO ())
pq = EventQueue IO -> PriorityQueue (Point IO -> IO ())
queuePQ (EventQueue IO -> PriorityQueue (Point IO -> IO ()))
-> EventQueue IO -> PriorityQueue (Point IO -> IO ())
forall a b. (a -> b) -> a -> b
$ Run IO -> EventQueue IO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run IO -> EventQueue IO) -> Run IO -> EventQueue IO
forall a b. (a -> b) -> a -> b
$ Point IO -> Run IO
forall (m :: * -> *). Point m -> Run m
pointRun Point IO
p
in IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ PriorityQueue (Point IO -> IO ())
-> Double -> Int -> (Point IO -> IO ()) -> IO ()
forall a. PriorityQueue a -> Double -> Int -> a -> IO ()
PQ.enqueue PriorityQueue (Point IO -> IO ())
pq Double
t Int
priority Point IO -> IO ()
m
{-# INLINE runEventWith #-}
runEventWith :: forall a. EventProcessing -> Event IO a -> Dynamics IO a
runEventWith EventProcessing
processing (Event Point IO -> IO a
e) =
(Point IO -> IO a) -> Dynamics IO a
forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics ((Point IO -> IO a) -> Dynamics IO a)
-> (Point IO -> IO a) -> Dynamics IO a
forall a b. (a -> b) -> a -> b
$ \Point IO
p ->
do Point IO -> Dynamics IO () -> IO ()
forall (m :: * -> *) a. Point m -> Dynamics m a -> m a
invokeDynamics Point IO
p (Dynamics IO () -> IO ()) -> Dynamics IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ EventProcessing -> Dynamics IO ()
processEvents EventProcessing
processing
Point IO -> IO a
e Point IO
p
{-# INLINE eventQueueCount #-}
eventQueueCount :: Event IO Int
eventQueueCount =
(Point IO -> IO Int) -> Event IO Int
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point IO -> IO Int) -> Event IO Int)
-> (Point IO -> IO Int) -> Event IO Int
forall a b. (a -> b) -> a -> b
$
IO Int -> IO Int
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> IO Int) -> (Point IO -> IO Int) -> Point IO -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PriorityQueue (Point IO -> IO ()) -> IO Int
forall a. PriorityQueue a -> IO Int
PQ.queueCount (PriorityQueue (Point IO -> IO ()) -> IO Int)
-> (Point IO -> PriorityQueue (Point IO -> IO ()))
-> Point IO
-> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventQueue IO -> PriorityQueue (Point IO -> IO ())
queuePQ (EventQueue IO -> PriorityQueue (Point IO -> IO ()))
-> (Point IO -> EventQueue IO)
-> Point IO
-> PriorityQueue (Point IO -> IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run IO -> EventQueue IO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run IO -> EventQueue IO)
-> (Point IO -> Run IO) -> Point IO -> EventQueue IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point IO -> Run IO
forall (m :: * -> *). Point m -> Run m
pointRun
processPendingEventsCore :: Bool -> Dynamics IO ()
{-# INLINE processPendingEventsCore #-}
processPendingEventsCore :: Bool -> Dynamics IO ()
processPendingEventsCore Bool
includingCurrentEvents = (Point IO -> IO ()) -> Dynamics IO ()
forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics Point IO -> IO ()
r where
r :: Point IO -> IO ()
r Point IO
p =
do let q :: EventQueue IO
q = Run IO -> EventQueue IO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run IO -> EventQueue IO) -> Run IO -> EventQueue IO
forall a b. (a -> b) -> a -> b
$ Point IO -> Run IO
forall (m :: * -> *). Point m -> Run m
pointRun Point IO
p
f :: IORef Bool
f = EventQueue IO -> IORef Bool
queueBusy EventQueue IO
q
Bool
f' <- IO Bool -> IO Bool
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
f
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f' (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
f Bool
True
EventQueue IO -> Point IO -> IO ()
call EventQueue IO
q Point IO
p
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
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 IO -> Point IO -> IO ()
call EventQueue IO
q Point IO
p =
do let pq :: PriorityQueue (Point IO -> IO ())
pq = EventQueue IO -> PriorityQueue (Point IO -> IO ())
queuePQ EventQueue IO
q
r :: Run IO
r = Point IO -> Run IO
forall (m :: * -> *). Point m -> Run m
pointRun Point IO
p
Bool
f <- IO Bool -> IO Bool
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ PriorityQueue (Point IO -> IO ()) -> IO Bool
forall a. PriorityQueue a -> IO Bool
PQ.queueNull PriorityQueue (Point IO -> IO ())
pq
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do (Double
t2, Int
priority2, Point IO -> IO ()
c2) <- IO (Double, Int, Point IO -> IO ())
-> IO (Double, Int, Point IO -> IO ())
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Double, Int, Point IO -> IO ())
-> IO (Double, Int, Point IO -> IO ()))
-> IO (Double, Int, Point IO -> IO ())
-> IO (Double, Int, Point IO -> IO ())
forall a b. (a -> b) -> a -> b
$ PriorityQueue (Point IO -> IO ())
-> IO (Double, Int, Point IO -> IO ())
forall a. PriorityQueue a -> IO (Double, Int, a)
PQ.queueFront PriorityQueue (Point IO -> IO ())
pq
let t :: IORef Double
t = EventQueue IO -> IORef Double
queueTime EventQueue IO
q
Double
t' <- IO Double -> IO Double
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> IO Double) -> IO Double -> IO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef IORef Double
t
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
t2 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"The time value is too small: processPendingEventsCore"
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Double
t2 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Point IO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point IO
p) Bool -> Bool -> Bool
||
(Bool
includingCurrentEvents Bool -> Bool -> Bool
&& (Double
t2 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Point IO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point IO
p))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Double
t Double
t2
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ PriorityQueue (Point IO -> IO ()) -> IO ()
forall a. PriorityQueue a -> IO ()
PQ.dequeue PriorityQueue (Point IO -> IO ())
pq
let sc :: Specs IO
sc = Point IO -> Specs IO
forall (m :: * -> *). Point m -> Specs m
pointSpecs Point IO
p
t0 :: Double
t0 = Specs IO -> Double
forall (m :: * -> *). Specs m -> Double
spcStartTime Specs IO
sc
dt :: Double
dt = Specs IO -> Double
forall (m :: * -> *). Specs m -> Double
spcDT Specs IO
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 b. Integral b => Double -> b
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)
Point IO -> IO ()
c2 (Point IO -> IO ()) -> Point IO -> IO ()
forall a b. (a -> b) -> a -> b
$ Point IO
p { pointTime = t2,
pointIteration = n2,
pointPriority = priority2,
pointPhase = -1 }
EventQueue IO -> Point IO -> IO ()
call EventQueue IO
q Point IO
p
processPendingEvents :: Bool -> Dynamics IO ()
{-# INLINE processPendingEvents #-}
processPendingEvents :: Bool -> Dynamics IO ()
processPendingEvents Bool
includingCurrentEvents = (Point IO -> IO ()) -> Dynamics IO ()
forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics Point IO -> IO ()
r where
r :: Point IO -> IO ()
r Point IO
p =
do let q :: EventQueue IO
q = Run IO -> EventQueue IO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run IO -> EventQueue IO) -> Run IO -> EventQueue IO
forall a b. (a -> b) -> a -> b
$ Point IO -> Run IO
forall (m :: * -> *). Point m -> Run m
pointRun Point IO
p
t :: IORef Double
t = EventQueue IO -> IORef Double
queueTime EventQueue IO
q
Double
t' <- IO Double -> IO Double
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> IO Double) -> IO Double -> IO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef IORef Double
t
if Point IO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point IO
p Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t'
then [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
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 IO -> Dynamics IO () -> IO ()
forall (m :: * -> *) a. Point m -> Dynamics m a -> m a
invokeDynamics Point IO
p Dynamics IO ()
m
m :: Dynamics IO ()
m = Bool -> Dynamics IO ()
processPendingEventsCore Bool
includingCurrentEvents
processEventsIncludingCurrent :: Dynamics IO ()
{-# INLINE processEventsIncludingCurrent #-}
processEventsIncludingCurrent :: Dynamics IO ()
processEventsIncludingCurrent = Bool -> Dynamics IO ()
processPendingEvents Bool
True
processEventsIncludingEarlier :: Dynamics IO ()
{-# INLINE processEventsIncludingEarlier #-}
processEventsIncludingEarlier :: Dynamics IO ()
processEventsIncludingEarlier = Bool -> Dynamics IO ()
processPendingEvents Bool
False
processEventsIncludingCurrentCore :: Dynamics IO ()
{-# INLINE processEventsIncludingCurrentCore #-}
processEventsIncludingCurrentCore :: Dynamics IO ()
processEventsIncludingCurrentCore = Bool -> Dynamics IO ()
processPendingEventsCore Bool
True
processEventsIncludingEarlierCore :: Dynamics IO ()
{-# INLINE processEventsIncludingEarlierCore #-}
processEventsIncludingEarlierCore :: Dynamics IO ()
processEventsIncludingEarlierCore = Bool -> Dynamics IO ()
processPendingEventsCore Bool
True
processEvents :: EventProcessing -> Dynamics IO ()
{-# INLINABLE processEvents #-}
processEvents :: EventProcessing -> Dynamics IO ()
processEvents EventProcessing
CurrentEvents = Dynamics IO ()
processEventsIncludingCurrent
processEvents EventProcessing
EarlierEvents = Dynamics IO ()
processEventsIncludingEarlier
processEvents EventProcessing
CurrentEventsOrFromPast = Dynamics IO ()
processEventsIncludingCurrentCore
processEvents EventProcessing
EarlierEventsOrFromPast = Dynamics IO ()
processEventsIncludingEarlierCore
instance EventIOQueueing IO where
{-# SPECIALISE instance EventIOQueueing IO #-}
enqueueEventIO :: Double -> Event IO () -> Event IO ()
enqueueEventIO = Double -> Event IO () -> Event IO ()
forall (m :: * -> *).
EventQueueing m =>
Double -> Event m () -> Event m ()
enqueueEvent