{-# 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 =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    do IORef Bool
f <- forall a. a -> IO (IORef a)
newIORef Bool
False
       IORef Double
t <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Specs m -> Double
spcStartTime Specs IO
specs
       PriorityQueue (Point IO -> IO ())
pq <- forall a. IO (PriorityQueue a)
PQ.newQueue
       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) =
    forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point IO
p ->
    let pq :: PriorityQueue (Point IO -> IO ())
pq = EventQueue IO -> PriorityQueue (Point IO -> IO ())
queuePQ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Run m -> EventQueue m
runEventQueue forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Point m -> Run m
pointRun Point IO
p
    in forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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) =
    forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics forall a b. (a -> b) -> a -> b
$ \Point IO
p ->
    do forall (m :: * -> *) a. Point m -> Dynamics m a -> m a
invokeDynamics Point IO
p 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 =
    forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PriorityQueue a -> IO Int
PQ.queueCount forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventQueue IO -> PriorityQueue (Point IO -> IO ())
queuePQ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Run m -> EventQueue m
runEventQueue forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 = forall (m :: * -> *). Run m -> EventQueue m
runEventQueue forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Point m -> Run m
pointRun Point IO
p
           f :: IORef Bool
f = EventQueue IO -> IORef Bool
queueBusy EventQueue IO
q
       Bool
f' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
f Bool
True
            EventQueue IO -> Point IO -> IO ()
call EventQueue IO
q Point IO
p
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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  = forall (m :: * -> *). Point m -> Run m
pointRun Point IO
p
       Bool
f <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. PriorityQueue a -> IO Bool
PQ.queueNull PriorityQueue (Point IO -> 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 -> IO ()
c2) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 => [Char] -> a
error [Char]
"The time value is too small: processPendingEventsCore"
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Double
t2 forall a. Ord a => a -> a -> Bool
< forall (m :: * -> *). Point m -> Double
pointTime Point IO
p) Bool -> Bool -> Bool
||
                  (Bool
includingCurrentEvents Bool -> Bool -> Bool
&& (Double
t2 forall a. Eq a => a -> a -> Bool
== forall (m :: * -> *). Point m -> Double
pointTime Point IO
p))) forall a b. (a -> b) -> a -> b
$
              do forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef Double
t Double
t2
                 forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. PriorityQueue a -> IO ()
PQ.dequeue PriorityQueue (Point IO -> IO ())
pq
                 let sc :: Specs IO
sc = forall (m :: * -> *). Point m -> Specs m
pointSpecs Point IO
p
                     t0 :: Double
t0 = forall (m :: * -> *). Specs m -> Double
spcStartTime Specs IO
sc
                     dt :: Double
dt = forall (m :: * -> *). Specs m -> Double
spcDT Specs IO
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 -> IO ()
c2 forall a b. (a -> b) -> a -> b
$ Point IO
p { pointTime :: Double
pointTime = Double
t2,
                          pointIteration :: Int
pointIteration = Int
n2,
                          pointPriority :: Int
pointPriority = Int
priority2,
                          pointPhase :: Int
pointPhase = -Int
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 = 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 = forall (m :: * -> *). Run m -> EventQueue m
runEventQueue forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Point m -> Run m
pointRun Point IO
p
           t :: IORef Double
t = EventQueue IO -> IORef Double
queueTime EventQueue IO
q
       Double
t' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef Double
t
       if forall (m :: * -> *). Point m -> Double
pointTime Point IO
p forall a. Ord a => a -> a -> Bool
< Double
t'
         then forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
              [Char]
"The current time is less than " forall a. [a] -> [a] -> [a]
++
              [Char]
"the time in the queue: processPendingEvents"
         else 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 = forall (m :: * -> *).
EventQueueing m =>
Double -> Event m () -> Event m ()
enqueueEvent