{-# LANGUAGE TypeFamilies #-}

-- |
-- Module     : Simulation.Aivika.Lattice.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 7.10.3
--
-- The module defines an event queue, where 'LIO' is an instance of 'EventQueueing'.
-- Also it defines basic functions for running nested computations within lattice nodes.
--
module Simulation.Aivika.Lattice.Internal.Event
       (estimateStrictRef,
        estimateLazyRef) where

import Data.IORef

import Control.Monad
import Control.Monad.Trans

import qualified Simulation.Aivika.PriorityQueue.EventQueue.Pure as PQ

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

import Simulation.Aivika.Lattice.Internal.LIO
import Simulation.Aivika.Lattice.Internal.Estimate
import qualified Simulation.Aivika.Lattice.Internal.Ref.Strict as R
import qualified Simulation.Aivika.Lattice.Internal.Ref.Lazy as LazyR

-- | An implementation of the 'EventQueueing' type class.
instance EventQueueing LIO where

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

  newEventQueue :: Specs LIO -> LIO (EventQueue LIO)
newEventQueue Specs LIO
specs =
    do IORef Bool
f  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef Bool
False
       Ref Double
t  <- forall a. a -> LIO (Ref a)
R.newRef0 (forall (m :: * -> *). Specs m -> Double
spcStartTime Specs LIO
specs)
       Ref (PriorityQueue (Point LIO -> LIO ()))
pq <- forall a. a -> LIO (Ref a)
R.newRef0 forall a. PriorityQueue a
PQ.emptyQueue
       forall (m :: * -> *) a. Monad m => a -> m a
return EventQueueLIO { queuePQ :: Ref (PriorityQueue (Point LIO -> LIO ()))
queuePQ   = Ref (PriorityQueue (Point LIO -> LIO ()))
pq,
                              queueBusy :: IORef Bool
queueBusy = IORef Bool
f,
                              queueTime :: Ref Double
queueTime = Ref Double
t }

  enqueueEventWithPriority :: Double -> Int -> Event LIO () -> Event LIO ()
enqueueEventWithPriority Double
t Int
priority (Event Point LIO -> LIO ()
m) =
    forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point LIO
p ->
    let pq :: Ref (PriorityQueue (Point LIO -> LIO ()))
pq = EventQueue LIO -> Ref (PriorityQueue (Point LIO -> LIO ()))
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 LIO
p
    in forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point LIO
p forall a b. (a -> b) -> a -> b
$
       forall a. Ref a -> (a -> a) -> Event LIO ()
R.modifyRef Ref (PriorityQueue (Point LIO -> LIO ()))
pq forall a b. (a -> b) -> a -> b
$ \PriorityQueue (Point LIO -> LIO ())
x -> forall a. PriorityQueue a -> Double -> Int -> a -> PriorityQueue a
PQ.enqueue PriorityQueue (Point LIO -> LIO ())
x Double
t Int
priority Point LIO -> LIO ()
m

  runEventWith :: forall a. EventProcessing -> Event LIO a -> Dynamics LIO a
runEventWith EventProcessing
processing (Event Point LIO -> LIO a
e) =
    forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics forall a b. (a -> b) -> a -> b
$ \Point LIO
p ->
    forall a. (LIOParams -> IO a) -> LIO a
LIO forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
    do forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
         forall (m :: * -> *) a. Point m -> Dynamics m a -> m a
invokeDynamics Point LIO
p forall a b. (a -> b) -> a -> b
$
         EventProcessing -> Dynamics LIO ()
processEvents EventProcessing
processing
       forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
         Point LIO -> LIO a
e Point LIO
p

  eventQueueCount :: Event LIO Int
eventQueueCount =
    forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point LIO
p ->
    let pq :: Ref (PriorityQueue (Point LIO -> LIO ()))
pq = EventQueue LIO -> Ref (PriorityQueue (Point LIO -> LIO ()))
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 LIO
p
    in forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point LIO
p forall a b. (a -> b) -> a -> b
$
       forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. PriorityQueue a -> Int
PQ.queueCount forall a b. (a -> b) -> a -> b
$ forall a. Ref a -> Event LIO a
R.readRef Ref (PriorityQueue (Point LIO -> LIO ()))
pq

-- | Process the pending events.
processPendingEventsCore :: Bool -> Dynamics LIO ()
processPendingEventsCore :: Bool -> Dynamics LIO ()
processPendingEventsCore Bool
includingCurrentEvents = forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics Point LIO -> LIO ()
r where
  r :: Point LIO -> LIO ()
r Point LIO
p =
    forall a. (LIOParams -> IO a) -> LIO a
LIO forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
    do let q :: EventQueue LIO
q = forall (m :: * -> *). Run m -> EventQueue m
runEventQueue forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Point m -> Run m
pointRun Point LIO
p
           f :: IORef Bool
f = EventQueue LIO -> IORef Bool
queueBusy EventQueue LIO
q
       Bool
f' <- forall a. IORef a -> IO a
readIORef IORef Bool
f
       if Bool
f'
         then forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
              [Char]
"Detected an event loop, which may indicate to " forall a. [a] -> [a] -> [a]
++
              [Char]
"a logical error in the model: processPendingEventsCore"
         else do forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
f Bool
True
                 forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
                   forall (m :: * -> *) a. Point m -> Dynamics m a -> m a
invokeDynamics Point LIO
p forall a b. (a -> b) -> a -> b
$
                   Bool -> Dynamics LIO ()
processPendingEventsUnsafe Bool
includingCurrentEvents
                 forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
f Bool
False

-- | Process the pending events in unsafe manner.
processPendingEventsUnsafe :: Bool -> Dynamics LIO ()
processPendingEventsUnsafe :: Bool -> Dynamics LIO ()
processPendingEventsUnsafe Bool
includingCurrentEvents = forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics Point LIO -> LIO ()
r where
  r :: Point LIO -> LIO ()
r Point LIO
p =
    forall a. (LIOParams -> IO a) -> LIO a
LIO forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
    let q :: EventQueue LIO
q = forall (m :: * -> *). Run m -> EventQueue m
runEventQueue forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Point m -> Run m
pointRun Point LIO
p
    in EventQueue LIO -> Point LIO -> LIOParams -> IO ()
call EventQueue LIO
q Point LIO
p LIOParams
ps
  call :: EventQueue LIO -> Point LIO -> LIOParams -> IO ()
call EventQueue LIO
q Point LIO
p LIOParams
ps =
    do let pq :: Ref (PriorityQueue (Point LIO -> LIO ()))
pq = EventQueue LIO -> Ref (PriorityQueue (Point LIO -> LIO ()))
queuePQ EventQueue LIO
q
           r :: Run LIO
r  = forall (m :: * -> *). Point m -> Run m
pointRun Point LIO
p
       Bool
f <- forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. PriorityQueue a -> Bool
PQ.queueNull forall a b. (a -> b) -> a -> b
$ forall a. Ref a -> LIO a
R.readRef0 Ref (PriorityQueue (Point LIO -> LIO ()))
pq
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f forall a b. (a -> b) -> a -> b
$
         do (Double
t2, Int
priority2, Point LIO -> LIO ()
c2) <- forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
                                   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. PriorityQueue a -> (Double, Int, a)
PQ.queueFront forall a b. (a -> b) -> a -> b
$ forall a. Ref a -> LIO a
R.readRef0 Ref (PriorityQueue (Point LIO -> LIO ()))
pq
            let t :: Ref Double
t = EventQueue LIO -> Ref Double
queueTime EventQueue LIO
q
            Double
t' <- forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
                  forall a. Ref a -> LIO a
R.readRef0 Ref 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 LIO
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 LIO
p))) forall a b. (a -> b) -> a -> b
$
              do let sc :: Specs LIO
sc = forall (m :: * -> *). Point m -> Specs m
pointSpecs Point LIO
p
                     t0 :: Double
t0 = forall (m :: * -> *). Specs m -> Double
spcStartTime Specs LIO
sc
                     dt :: Double
dt = forall (m :: * -> *). Specs m -> Double
spcDT Specs LIO
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)
                     p2 :: Point LIO
p2 = Point LIO
p { pointTime :: Double
pointTime = Double
t2,
                              pointPriority :: Int
pointPriority = Int
priority2,
                              pointIteration :: Int
pointIteration = Int
n2,
                              pointPhase :: Int
pointPhase = -Int
1 }
                 forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
                   forall a. Ref a -> a -> LIO ()
R.writeRef0 Ref Double
t Double
t2
                 forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
                   forall a. Ref a -> LIO ()
R.defineTopRef0_ Ref (PriorityQueue (Point LIO -> LIO ()))
pq
                 forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
                   forall a. Ref a -> (a -> a) -> LIO ()
R.modifyRef0 Ref (PriorityQueue (Point LIO -> LIO ()))
pq forall a. PriorityQueue a -> PriorityQueue a
PQ.dequeue
                 forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
                   Point LIO -> LIO ()
c2 Point LIO
p2
                 EventQueue LIO -> Point LIO -> LIOParams -> IO ()
call EventQueue LIO
q Point LIO
p LIOParams
ps

-- | Process the pending events synchronously, i.e. without past.
processPendingEvents :: Bool -> Dynamics LIO ()
processPendingEvents :: Bool -> Dynamics LIO ()
processPendingEvents Bool
includingCurrentEvents = forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics Point LIO -> LIO ()
r where
  r :: Point LIO -> LIO ()
r Point LIO
p =
    forall a. (LIOParams -> IO a) -> LIO a
LIO forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
    do let q :: EventQueue LIO
q = forall (m :: * -> *). Run m -> EventQueue m
runEventQueue forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Point m -> Run m
pointRun Point LIO
p
           t :: Ref Double
t = EventQueue LIO -> Ref Double
queueTime EventQueue LIO
q
       Double
t' <- forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
             forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point LIO
p forall a b. (a -> b) -> a -> b
$
             forall a. Ref a -> Event LIO a
R.readRef Ref Double
t
       if forall (m :: * -> *). Point m -> Double
pointTime Point LIO
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 a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
              forall (m :: * -> *) a. Point m -> Dynamics m a -> m a
invokeDynamics Point LIO
p forall a b. (a -> b) -> a -> b
$
              Bool -> Dynamics LIO ()
processPendingEventsCore Bool
includingCurrentEvents

-- | A memoized value.
processEventsIncludingCurrent :: Dynamics LIO ()
processEventsIncludingCurrent :: Dynamics LIO ()
processEventsIncludingCurrent = Bool -> Dynamics LIO ()
processPendingEvents Bool
True

-- | A memoized value.
processEventsIncludingEarlier :: Dynamics LIO ()
processEventsIncludingEarlier :: Dynamics LIO ()
processEventsIncludingEarlier = Bool -> Dynamics LIO ()
processPendingEvents Bool
False

-- | A memoized value.
processEventsIncludingCurrentCore :: Dynamics LIO ()
processEventsIncludingCurrentCore :: Dynamics LIO ()
processEventsIncludingCurrentCore = Bool -> Dynamics LIO ()
processPendingEventsCore Bool
True

-- | A memoized value.
processEventsIncludingEarlierCore :: Dynamics LIO ()
processEventsIncludingEarlierCore :: Dynamics LIO ()
processEventsIncludingEarlierCore = Bool -> Dynamics LIO ()
processPendingEventsCore Bool
True

-- | Process the events.
processEvents :: EventProcessing -> Dynamics LIO ()
processEvents :: EventProcessing -> Dynamics LIO ()
processEvents EventProcessing
CurrentEvents = Dynamics LIO ()
processEventsIncludingCurrent
processEvents EventProcessing
EarlierEvents = Dynamics LIO ()
processEventsIncludingEarlier
processEvents EventProcessing
CurrentEventsOrFromPast = Dynamics LIO ()
processEventsIncludingCurrentCore
processEvents EventProcessing
EarlierEventsOrFromPast = Dynamics LIO ()
processEventsIncludingEarlierCore

-- | Initialize the event queue in the current lattice node if required.
initEventQueue :: Event LIO ()
initEventQueue :: Event LIO ()
initEventQueue =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point LIO
p ->
  forall a. (LIOParams -> IO a) -> LIO a
LIO forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
  do let pq :: Ref (PriorityQueue (Point LIO -> LIO ()))
pq = EventQueue LIO -> Ref (PriorityQueue (Point LIO -> LIO ()))
queuePQ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Run m -> EventQueue m
runEventQueue Run LIO
r
         r :: Run LIO
r  = forall (m :: * -> *). Point m -> Run m
pointRun Point LIO
p
     Bool
f <- forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
          forall a. Ref a -> LIO Bool
R.topRefDefined0 Ref (PriorityQueue (Point LIO -> LIO ()))
pq
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f forall a b. (a -> b) -> a -> b
$
       do case LIOParams -> Maybe LIOParams
parentLIOParams LIOParams
ps of
            Maybe LIOParams
Nothing  -> forall a. HasCallStack => [Char] -> a
error [Char]
"The root must be initialized: initEventQueue"
            Just LIOParams
ps' ->
              do Point LIO
p' <- forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps' forall a b. (a -> b) -> a -> b
$
                       forall (m :: * -> *) a. Run m -> Parameter m a -> m a
invokeParameter Run LIO
r
                       Parameter LIO (Point LIO)
latticePoint
                 forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps' forall a b. (a -> b) -> a -> b
$
                   forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point LIO
p'
                   Event LIO ()
initEventQueue
          forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
            forall a. Ref a -> LIO ()
R.defineTopRef0_ Ref (PriorityQueue (Point LIO -> LIO ()))
pq
          forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a. Point m -> Dynamics m a -> m a
invokeDynamics Point LIO
p forall a b. (a -> b) -> a -> b
$
            Bool -> Dynamics LIO ()
processPendingEventsUnsafe Bool
True

-- | Estimate the specified reference.
estimateStrictRef :: R.Ref a -> Estimate LIO a
estimateStrictRef :: forall a. Ref a -> Estimate LIO a
estimateStrictRef Ref a
r =
  forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate forall a b. (a -> b) -> a -> b
$ \Point LIO
p ->
  forall a. (LIOParams -> IO a) -> LIO a
LIO forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
  do forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
       forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point LIO
p
       Event LIO ()
initEventQueue
     forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
       forall a. Ref a -> LIO a
R.readRef0 Ref a
r

-- | Estimate the specified reference.
estimateLazyRef :: LazyR.Ref a -> Estimate LIO a
estimateLazyRef :: forall a. Ref a -> Estimate LIO a
estimateLazyRef Ref a
r =
  forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate forall a b. (a -> b) -> a -> b
$ \Point LIO
p ->
  forall a. (LIOParams -> IO a) -> LIO a
LIO forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
  do forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
       forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point LIO
p
       Event LIO ()
initEventQueue
     forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
       forall a. Ref a -> LIO a
LazyR.readRef0 Ref a
r