{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}

-- |
-- Module     : Simulation.Aivika.IO.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
--
-- The module defines an event queue, where the 'IO' monad is an instance of
-- 'EventQueueing' and 'EventIOQueueing'.
--
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

-- | An implementation of the 'EventQueueing' type class.
instance EventQueueing IO where
-- instance (Monad m, MonadIO m, MonadEventQueueTemplate m) => EventQueueing m where

  {-# SPECIALISE instance EventQueueing IO #-}

  data EventQueue IO =
    EventQueue { EventQueue IO -> PriorityQueue (Point IO -> IO ())
queuePQ :: PQ.PriorityQueue (Point IO -> IO ()),
                 -- ^ the underlying priority queue
                 EventQueue IO -> IORef Bool
queueBusy :: IORef Bool,
                 -- ^ whether the queue is currently processing events
                 EventQueue IO -> IORef Double
queueTime :: IORef Double
                 -- ^ the actual time of the event queue
               }

  {-# 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

-- | Process the pending events.
processPendingEventsCore :: Bool -> Dynamics IO ()
-- processPendingEventsCore :: (MonadIO m, MonadEventQueueTemplate m) => Bool -> Dynamics m ()
{-# 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

-- | Process the pending events synchronously, i.e. without past.
processPendingEvents :: Bool -> Dynamics IO ()
-- processPendingEvents :: (MonadIO m, MonadEventQueueTemplate m) => Bool -> Dynamics m ()
{-# 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

-- | A memoized value.
processEventsIncludingCurrent :: Dynamics IO ()
-- processEventsIncludingCurrent :: (MonadIO m, MonadEventQueueTemplate m) => Dynamics m ()
{-# INLINE processEventsIncludingCurrent #-}
processEventsIncludingCurrent :: Dynamics IO ()
processEventsIncludingCurrent = Bool -> Dynamics IO ()
processPendingEvents Bool
True

-- | A memoized value.
processEventsIncludingEarlier :: Dynamics IO ()
-- processEventsIncludingEarlier :: (MonadIO m, MonadEventQueueTemplate m) => Dynamics m ()
{-# INLINE processEventsIncludingEarlier #-}
processEventsIncludingEarlier :: Dynamics IO ()
processEventsIncludingEarlier = Bool -> Dynamics IO ()
processPendingEvents Bool
False

-- | A memoized value.
processEventsIncludingCurrentCore :: Dynamics IO ()
-- processEventsIncludingCurrentCore :: (MonadIO m, MonadEventQueueTemplate m) => Dynamics m ()
{-# INLINE processEventsIncludingCurrentCore #-}
processEventsIncludingCurrentCore :: Dynamics IO ()
processEventsIncludingCurrentCore = Bool -> Dynamics IO ()
processPendingEventsCore Bool
True

-- | A memoized value.
processEventsIncludingEarlierCore :: Dynamics IO ()
-- processEventsIncludingEarlierCore :: (MonadIO m, MonadEventQueueTemplate m) => Dynamics m ()
{-# INLINE processEventsIncludingEarlierCore #-}
processEventsIncludingEarlierCore :: Dynamics IO ()
processEventsIncludingEarlierCore = Bool -> Dynamics IO ()
processPendingEventsCore Bool
True

-- | Process the events.
processEvents :: EventProcessing -> Dynamics IO ()
-- processEvents :: (MonadIO m, MonadEventQueueTemplate m) => EventProcessing -> Dynamics m ()
{-# 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

-- | An implementation of the 'EventIOQueueing' type class.
instance EventIOQueueing IO where
-- instance (Monad m, MonadIO m, MonadEventQueueTemplate m, MonadDES m) => EventIOQueueing m 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