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

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

  runEventWith :: EventProcessing -> Event (BR IO) a -> Dynamics (BR IO) a
runEventWith EventProcessing
processing (Event Point (BR IO) -> BR IO a
e) =
    (Point (BR IO) -> BR IO a) -> Dynamics (BR IO) a
forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics ((Point (BR IO) -> BR IO a) -> Dynamics (BR IO) a)
-> (Point (BR IO) -> BR IO a) -> Dynamics (BR IO) a
forall a b. (a -> b) -> a -> b
$ \Point (BR IO)
p ->
    do Point (BR IO) -> Dynamics (BR IO) () -> BR IO ()
forall (m :: * -> *) a. Point m -> Dynamics m a -> m a
invokeDynamics Point (BR IO)
p (Dynamics (BR IO) () -> BR IO ())
-> Dynamics (BR IO) () -> BR IO ()
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 =
    (Point (BR IO) -> BR IO Int) -> Event (BR IO) Int
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point (BR IO) -> BR IO Int) -> Event (BR IO) Int)
-> (Point (BR IO) -> BR IO Int) -> Event (BR IO) Int
forall a b. (a -> b) -> a -> b
$ \Point (BR IO)
p ->
    (BRParams -> IO Int) -> BR IO Int
forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR ((BRParams -> IO Int) -> BR IO Int)
-> (BRParams -> IO Int) -> BR IO Int
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 (EventQueue (BR IO)
 -> IORef (PriorityQueue (Point (BR IO) -> BR IO ())))
-> EventQueue (BR IO)
-> IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
forall a b. (a -> b) -> a -> b
$ Run (BR IO) -> EventQueue (BR IO)
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run (BR IO) -> EventQueue (BR IO))
-> Run (BR IO) -> EventQueue (BR IO)
forall a b. (a -> b) -> a -> b
$ Point (BR IO) -> Run (BR IO)
forall (m :: * -> *). Point m -> Run m
pointRun Point (BR IO)
p
    in (PriorityQueue (Point (BR IO) -> BR IO ()) -> Int)
-> IO (PriorityQueue (Point (BR IO) -> BR IO ())) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PriorityQueue (Point (BR IO) -> BR IO ()) -> Int
forall a. PriorityQueue a -> Int
PQ.queueCount (IO (PriorityQueue (Point (BR IO) -> BR IO ())) -> IO Int)
-> IO (PriorityQueue (Point (BR IO) -> BR IO ())) -> IO Int
forall a b. (a -> b) -> a -> b
$ IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
-> IO (PriorityQueue (Point (BR IO) -> BR IO ()))
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 = (Point (BR IO) -> BR IO ()) -> Dynamics (BR IO) ()
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 =
    (BRParams -> IO ()) -> BR IO ()
forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR ((BRParams -> IO ()) -> BR IO ())
-> (BRParams -> IO ()) -> BR IO ()
forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
    do let q :: EventQueue (BR IO)
q = Run (BR IO) -> EventQueue (BR IO)
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run (BR IO) -> EventQueue (BR IO))
-> Run (BR IO) -> EventQueue (BR IO)
forall a b. (a -> b) -> a -> b
$ Point (BR IO) -> Run (BR IO)
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' <- 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 IORef Bool -> Bool -> IO ()
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
            IORef Bool -> Bool -> IO ()
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  = Point (BR IO) -> Run (BR IO)
forall (m :: * -> *). Point m -> Run m
pointRun Point (BR IO)
p
       Bool
f <- (PriorityQueue (Point (BR IO) -> BR IO ()) -> Bool)
-> IO (PriorityQueue (Point (BR IO) -> BR IO ())) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PriorityQueue (Point (BR IO) -> BR IO ()) -> Bool
forall a. PriorityQueue a -> Bool
PQ.queueNull (IO (PriorityQueue (Point (BR IO) -> BR IO ())) -> IO Bool)
-> IO (PriorityQueue (Point (BR IO) -> BR IO ())) -> IO Bool
forall a b. (a -> b) -> a -> b
$ IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
-> IO (PriorityQueue (Point (BR IO) -> BR IO ()))
forall a. IORef a -> IO a
readIORef IORef (PriorityQueue (Point (BR IO) -> BR 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, Point (BR IO) -> BR IO ()
c2) <- (PriorityQueue (Point (BR IO) -> BR IO ())
 -> (Double, Point (BR IO) -> BR IO ()))
-> IO (PriorityQueue (Point (BR IO) -> BR IO ()))
-> IO (Double, Point (BR IO) -> BR IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PriorityQueue (Point (BR IO) -> BR IO ())
-> (Double, Point (BR IO) -> BR IO ())
forall a. PriorityQueue a -> (Double, a)
PQ.queueFront (IO (PriorityQueue (Point (BR IO) -> BR IO ()))
 -> IO (Double, Point (BR IO) -> BR IO ()))
-> IO (PriorityQueue (Point (BR IO) -> BR IO ()))
-> IO (Double, Point (BR IO) -> BR IO ())
forall a b. (a -> b) -> a -> b
$ IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
-> IO (PriorityQueue (Point (BR IO) -> BR IO ()))
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' <- 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 (BR IO) -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point (BR IO)
p) Bool -> Bool -> Bool
||
                  (Bool
includingCurrentEvents Bool -> Bool -> Bool
&& (Double
t2 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Point (BR IO) -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point (BR IO)
p))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              do IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Double
t Double
t2
                 IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
-> (PriorityQueue (Point (BR IO) -> BR IO ())
    -> PriorityQueue (Point (BR IO) -> BR IO ()))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
pq PriorityQueue (Point (BR IO) -> BR IO ())
-> PriorityQueue (Point (BR IO) -> BR IO ())
forall a. PriorityQueue a -> PriorityQueue a
PQ.dequeue
                 let sc :: Specs (BR IO)
sc = Point (BR IO) -> Specs (BR IO)
forall (m :: * -> *). Point m -> Specs m
pointSpecs Point (BR IO)
p
                     t0 :: Double
t0 = Specs (BR IO) -> Double
forall (m :: * -> *). Specs m -> Double
spcStartTime Specs (BR IO)
sc
                     dt :: Double
dt = Specs (BR IO) -> Double
forall (m :: * -> *). Specs m -> Double
spcDT Specs (BR 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 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)
                 BRParams -> BR IO () -> IO ()
forall (m :: * -> *) a. BRParams -> BR m a -> m a
invokeBR BRParams
ps (BR IO () -> IO ()) -> BR IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                   Point (BR IO) -> BR IO ()
c2 (Point (BR IO) -> BR IO ()) -> Point (BR IO) -> BR IO ()
forall a b. (a -> b) -> a -> b
$ Point (BR IO)
p { pointTime :: Double
pointTime = Double
t2,
                            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 = (Point (BR IO) -> BR IO ()) -> Dynamics (BR IO) ()
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 =
    (BRParams -> IO ()) -> BR IO ()
forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR ((BRParams -> IO ()) -> BR IO ())
-> (BRParams -> IO ()) -> BR IO ()
forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
    do let q :: EventQueue (BR IO)
q = Run (BR IO) -> EventQueue (BR IO)
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run (BR IO) -> EventQueue (BR IO))
-> Run (BR IO) -> EventQueue (BR IO)
forall a b. (a -> b) -> a -> b
$ Point (BR IO) -> Run (BR IO)
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' <- IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef IORef Double
t
       if Point (BR IO) -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point (BR 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 BRParams -> BR IO () -> IO ()
forall (m :: * -> *) a. BRParams -> BR m a -> m a
invokeBR BRParams
ps (BR IO () -> IO ()) -> BR IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              Point (BR IO) -> Dynamics (BR IO) () -> BR IO ()
forall (m :: * -> *) a. Point m -> Dynamics m a -> m a
invokeDynamics Point (BR IO)
p (Dynamics (BR IO) () -> BR IO ())
-> Dynamics (BR IO) () -> BR IO ()
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 :: Event (BR IO) a -> Event (BR IO) a
branchEvent (Event Point (BR IO) -> BR IO a
m) =
  (Point (BR IO) -> BR IO a) -> Event (BR IO) a
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point (BR IO) -> BR IO a) -> Event (BR IO) a)
-> (Point (BR IO) -> BR IO a) -> Event (BR IO) a
forall a b. (a -> b) -> a -> b
$ \Point (BR IO)
p ->
  (BRParams -> IO a) -> BR IO a
forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR ((BRParams -> IO a) -> BR IO a) -> (BRParams -> IO a) -> BR IO a
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
     BRParams -> BR IO a -> IO a
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 :: Double -> Event (BR IO) a -> Event (BR IO) a
futureEvent = EventProcessing -> Double -> Event (BR IO) a -> Event (BR IO) a
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 :: EventProcessing -> Double -> Event (BR IO) a -> Event (BR IO) a
futureEventWith EventProcessing
processing Double
t (Event Point (BR IO) -> BR IO a
m) =
  (Point (BR IO) -> BR IO a) -> Event (BR IO) a
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point (BR IO) -> BR IO a) -> Event (BR IO) a)
-> (Point (BR IO) -> BR IO a) -> Event (BR IO) a
forall a b. (a -> b) -> a -> b
$ \Point (BR IO)
p ->
  (BRParams -> IO a) -> BR IO a
forall (m :: * -> *) a. (BRParams -> m a) -> BR m a
BR ((BRParams -> IO a) -> BR IO a) -> (BRParams -> IO a) -> BR IO a
forall a b. (a -> b) -> a -> b
$ \BRParams
ps ->
  do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Point (BR IO) -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point (BR IO)
p) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
       [Char] -> IO ()
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 = Point (BR IO) -> Specs (BR IO)
forall (m :: * -> *). Point m -> Specs m
pointSpecs Point (BR IO)
p
         t0 :: Double
t0 = Specs (BR IO) -> Double
forall (m :: * -> *). Specs m -> Double
spcStartTime Specs (BR IO)
sc
         t' :: Double
t' = Specs (BR IO) -> Double
forall (m :: * -> *). Specs m -> Double
spcStopTime Specs (BR IO)
sc
         dt :: Double
dt = Specs (BR IO) -> Double
forall (m :: * -> *). Specs m -> Double
spcDT Specs (BR IO)
sc
         n :: Int
n  = 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 a b. (RealFrac a, Integral b) => a -> b
floor ((Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
t0) Double -> Double -> Double
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 }
     BRParams -> BR IO () -> IO ()
forall (m :: * -> *) a. BRParams -> BR m a -> m a
invokeBR BRParams
ps2 (BR IO () -> IO ()) -> BR IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
       Point (BR IO) -> Dynamics (BR IO) () -> BR IO ()
forall (m :: * -> *) a. Point m -> Dynamics m a -> m a
invokeDynamics Point (BR IO)
p' (Dynamics (BR IO) () -> BR IO ())
-> Dynamics (BR IO) () -> BR IO ()
forall a b. (a -> b) -> a -> b
$
       EventProcessing -> Dynamics (BR IO) ()
processEvents EventProcessing
processing
     BRParams -> BR IO a -> IO a
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 = Point (BR IO) -> Run (BR IO)
forall (m :: * -> *). Point m -> Run m
pointRun Point (BR IO)
p
         q :: EventQueue (BR IO)
q = Run (BR IO) -> EventQueue (BR IO)
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue Run (BR IO)
r
     PriorityQueue (Point (BR IO) -> BR IO ())
pq  <- IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
-> IO (PriorityQueue (Point (BR IO) -> BR IO ()))
forall a. IORef a -> IO a
readIORef (EventQueue (BR IO)
-> IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
queuePQ EventQueue (BR IO)
q)
     Double
t   <- IORef Double -> IO Double
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 <- PriorityQueue (Point (BR IO) -> BR IO ())
-> IO (IORef (PriorityQueue (Point (BR IO) -> BR IO ())))
forall a. a -> IO (IORef a)
newIORef PriorityQueue (Point (BR IO) -> BR IO ())
pq
     IORef Bool
f2  <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
     IORef Double
t2  <- Double -> IO (IORef Double)
forall a. a -> IO (IORef a)
newIORef Double
t
     let q2 :: EventQueue (BR IO)
q2 = EventQueue :: IORef (PriorityQueue (Point (BR IO) -> BR IO ()))
-> IORef Bool -> IORef Double -> EventQueue (BR IO)
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 }
     Point (BR IO) -> IO (Point (BR IO))
forall (m :: * -> *) a. Monad m => a -> m a
return Point (BR IO)
p2