{-# LANGUAGE TypeFamilies, FlexibleInstances #-}

-- |
-- Module     : Simulation.Aivika.Branch.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 'BR' can be an instance of 'EventQueueing'.
-- Also it defines basic functions for branching computations.
--
module Simulation.Aivika.Branch.Event
       (branchEvent,
        futureEvent,
        futureEventWith) 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.Branch.Internal.BR

-- | An implementation of the 'EventQueueing' type class.
instance EventQueueing (BR IO) where

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

  newEventQueue :: Specs (BR IO) -> BR IO (EventQueue (BR IO))
newEventQueue Specs (BR IO)
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
       IORef Double
t  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef (forall (m :: * -> *). Specs m -> Double
spcStartTime Specs (BR IO)
specs)
       IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
pq <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a. PriorityQueue a
PQ.emptyQueue
       forall (m :: * -> *) a. Monad m => a -> m a
return EventQueue { queuePQ :: IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
queuePQ   = IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
pq,
                           queueBusy :: IORef Bool
queueBusy = IORef Bool
f,
                           queueTime :: IORef Double
queueTime = IORef Double
t }

  enqueueEventWithPriority :: Double -> Int -> Event (BR IO) () -> Event (BR IO) ()
enqueueEventWithPriority Double
t Int
priority (Event Point (BR IO) -> BR IO ()
m) =
    forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point (BR IO)
p ->
    forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
    let pq :: IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
pq = EventQueue (BR IO)
-> IORef (PriorityQueue (Point (BR IO) -> BR 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 (BR IO)
p
    in forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
pq forall a b. (a -> b) -> a -> b
$ \PriorityQueue (Point (BR IO) -> BR IO ())
x -> forall a. PriorityQueue a -> Double -> Int -> a -> PriorityQueue a
PQ.enqueue PriorityQueue (Point (BR IO) -> BR IO ())
x Double
t Int
priority Point (BR IO) -> BR IO ()
m

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

  eventQueueCount :: Event (BR IO) Int
eventQueueCount =
    forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point (BR IO)
p ->
    forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
    let pq :: IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
pq = EventQueue (BR IO)
-> IORef (PriorityQueue (Point (BR IO) -> BR 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 (BR IO)
p
    in 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. IORef a -> IO a
readIORef IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
pq

-- | Process the pending events.
processPendingEventsCore :: Bool -> Dynamics (BR IO) ()
processPendingEventsCore :: Bool -> Dynamics (BR IO) ()
processPendingEventsCore Bool
includingCurrentEvents = forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics Point (BR IO) -> BR IO ()
r where
  r :: Point (BR IO) -> BR IO ()
r Point (BR IO)
p =
    forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
    do let q :: EventQueue (BR IO)
q = forall (m :: * -> *). Run m -> EventQueue m
runEventQueue forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Point m -> Run m
pointRun Point (BR IO)
p
           f :: IORef Bool
f = EventQueue (BR IO) -> IORef Bool
queueBusy EventQueue (BR IO)
q
       Bool
f' <- 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 a. IORef a -> a -> IO ()
writeIORef IORef Bool
f Bool
True
            EventQueue (BR IO) -> Point (BR IO) -> BRParams -> IO ()
call EventQueue (BR IO)
q Point (BR IO)
p BRParams
ps
            forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
f Bool
False
  call :: EventQueue (BR IO) -> Point (BR IO) -> BRParams -> IO ()
call EventQueue (BR IO)
q Point (BR IO)
p BRParams
ps =
    do let pq :: IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
pq = EventQueue (BR IO)
-> IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
queuePQ EventQueue (BR IO)
q
           r :: Run (BR IO)
r  = forall (m :: * -> *). Point m -> Run m
pointRun Point (BR IO)
p
       Bool
f <- 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. IORef a -> IO a
readIORef IORef (PriorityQueue (Point (BR IO) -> BR 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 (BR IO) -> BR IO ()
c2) <- 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. IORef a -> IO a
readIORef IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
pq
            let t :: IORef Double
t = EventQueue (BR IO) -> IORef Double
queueTime EventQueue (BR IO)
q
            Double
t' <- 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 (BR 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 (BR IO)
p))) forall a b. (a -> b) -> a -> b
$
              do forall a. IORef a -> a -> IO ()
writeIORef IORef Double
t Double
t2
                 forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
pq forall a. PriorityQueue a -> PriorityQueue a
PQ.dequeue
                 let sc :: Specs (BR IO)
sc = forall (m :: * -> *). Point m -> Specs m
pointSpecs Point (BR IO)
p
                     t0 :: Double
t0 = forall (m :: * -> *). Specs m -> Double
spcStartTime Specs (BR IO)
sc
                     dt :: Double
dt = forall (m :: * -> *). Specs m -> Double
spcDT Specs (BR 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)
                 forall (m :: * -> *) a. BRParams -> BR m a -> m a
invokeBR BRParams
ps forall a b. (a -> b) -> a -> b
$
                   Point (BR IO) -> BR IO ()
c2 forall a b. (a -> b) -> a -> b
$ Point (BR IO)
p { pointTime :: Double
pointTime = Double
t2,
                            pointPriority :: Int
pointPriority = Int
priority2,
                            pointIteration :: Int
pointIteration = Int
n2,
                            pointPhase :: Int
pointPhase = -Int
1 }
                 EventQueue (BR IO) -> Point (BR IO) -> BRParams -> IO ()
call EventQueue (BR IO)
q Point (BR IO)
p BRParams
ps

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

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

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

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

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

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

-- | Branch a new computation and return its result leaving the current computation intact.
--
-- A new derivative branch with 'branchLevel' increased by 1 is created at the current modeling time.
-- Then the result of the specified computation for the derivative branch is returned.
--
-- The state of the current computation including its event queue and mutable references 'Ref'
-- remain intact. In some sense we copy the state of the model to the derivative branch and then
-- proceed with the derived simulation. The copying operation is relatively cheap.
branchEvent :: Event (BR IO) a -> Event (BR IO) a
branchEvent :: forall a. Event (BR IO) a -> Event (BR IO) a
branchEvent (Event Point (BR IO) -> BR IO a
m) =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point (BR IO)
p ->
  forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR forall a b. (a -> b) -> a -> b
$ \BRParams
ps->
  do Point (BR IO)
p2  <- Point (BR IO) -> IO (Point (BR IO))
clonePoint Point (BR IO)
p
     BRParams
ps2 <- BRParams -> IO BRParams
newBRParams BRParams
ps
     forall (m :: * -> *) a. BRParams -> BR m a -> m a
invokeBR BRParams
ps2 (Point (BR IO) -> BR IO a
m Point (BR IO)
p2)

-- | Branch a new computation and return its result at the desired time
-- in the future leaving the current computation intact.
--
-- A new derivative branch with 'branchLevel' increased by 1 is created at the current modeling time.
-- All pending events are processed till the specified time for that new branch. Then the result
-- of the specified computation for the derivative branch is returned.
--
-- The state of the current computation including its event queue and mutable references 'Ref'
-- remain intact. In some sense we copy the state of the model to the derivative branch and then
-- proceed with the derived simulation. The copying operation is relatively cheap.
futureEvent :: Double -> Event (BR IO) a -> Event (BR IO) a
futureEvent :: forall a. Double -> Event (BR IO) a -> Event (BR IO) a
futureEvent = forall a.
EventProcessing -> Double -> Event (BR IO) a -> Event (BR IO) a
futureEventWith EventProcessing
CurrentEvents

-- | Like 'futureEvent' but allows specifying how the pending events must be processed.
futureEventWith :: EventProcessing -> Double -> Event (BR IO) a -> Event (BR IO) a
futureEventWith :: forall a.
EventProcessing -> Double -> Event (BR IO) a -> Event (BR IO) a
futureEventWith EventProcessing
processing Double
t (Event Point (BR IO) -> BR IO a
m) =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point (BR IO)
p ->
  forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
  do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
t forall a. Ord a => a -> a -> Bool
< forall (m :: * -> *). Point m -> Double
pointTime Point (BR IO)
p) forall a b. (a -> b) -> a -> b
$
       forall a. HasCallStack => [Char] -> a
error [Char]
"The specified time is less than the current modeling time: futureEventWith"
     Point (BR IO)
p2  <- Point (BR IO) -> IO (Point (BR IO))
clonePoint Point (BR IO)
p
     BRParams
ps2 <- BRParams -> IO BRParams
newBRParams BRParams
ps
     let sc :: Specs (BR IO)
sc = forall (m :: * -> *). Point m -> Specs m
pointSpecs Point (BR IO)
p
         t0 :: Double
t0 = forall (m :: * -> *). Specs m -> Double
spcStartTime Specs (BR IO)
sc
         t' :: Double
t' = forall (m :: * -> *). Specs m -> Double
spcStopTime Specs (BR IO)
sc
         dt :: Double
dt = forall (m :: * -> *). Specs m -> Double
spcDT Specs (BR IO)
sc
         n :: Int
n  = 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
t forall a. Num a => a -> a -> a
- Double
t0) forall a. Fractional a => a -> a -> a
/ Double
dt)
         p' :: Point (BR IO)
p' = Point (BR IO)
p2 { pointTime :: Double
pointTime = Double
t,
                   pointIteration :: Int
pointIteration = Int
n,
                   pointPhase :: Int
pointPhase = -Int
1 }
     forall (m :: * -> *) a. BRParams -> BR m a -> m a
invokeBR BRParams
ps2 forall a b. (a -> b) -> a -> b
$
       forall (m :: * -> *) a. Point m -> Dynamics m a -> m a
invokeDynamics Point (BR IO)
p' forall a b. (a -> b) -> a -> b
$
       EventProcessing -> Dynamics (BR IO) ()
processEvents EventProcessing
processing
     forall (m :: * -> *) a. BRParams -> BR m a -> m a
invokeBR BRParams
ps2 (Point (BR IO) -> BR IO a
m Point (BR IO)
p')

-- | Clone the time point.
clonePoint :: Point (BR IO) -> IO (Point (BR IO))
clonePoint :: Point (BR IO) -> IO (Point (BR IO))
clonePoint Point (BR IO)
p =
  do let r :: Run (BR IO)
r = forall (m :: * -> *). Point m -> Run m
pointRun Point (BR IO)
p
         q :: EventQueue (BR IO)
q = forall (m :: * -> *). Run m -> EventQueue m
runEventQueue Run (BR IO)
r
     PriorityQueue (Point (BR IO) -> BR IO ())
pq  <- forall a. IORef a -> IO a
readIORef (EventQueue (BR IO)
-> IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
queuePQ EventQueue (BR IO)
q)
     Double
t   <- forall a. IORef a -> IO a
readIORef (EventQueue (BR IO) -> IORef Double
queueTime EventQueue (BR IO)
q)
     IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
pq2 <- forall a. a -> IO (IORef a)
newIORef PriorityQueue (Point (BR IO) -> BR IO ())
pq
     IORef Bool
f2  <- forall a. a -> IO (IORef a)
newIORef Bool
False
     IORef Double
t2  <- forall a. a -> IO (IORef a)
newIORef Double
t
     let q2 :: EventQueue (BR IO)
q2 = EventQueue { queuePQ :: IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
queuePQ   = IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
pq2,
                           queueBusy :: IORef Bool
queueBusy = IORef Bool
f2,
                           queueTime :: IORef Double
queueTime = IORef Double
t2 }
         r2 :: Run (BR IO)
r2 = Run (BR IO)
r { runEventQueue :: EventQueue (BR IO)
runEventQueue = EventQueue (BR IO)
q2 }
         p2 :: Point (BR IO)
p2 = Point (BR IO)
p { pointRun :: Run (BR IO)
pointRun = Run (BR IO)
r2 }
     forall (m :: * -> *) a. Monad m => a -> m a
return Point (BR IO)
p2