aivika 0.3 → 0.4

raw patch · 30 files changed

+1756/−149 lines, 30 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Simulation/Aivika/Dynamics.hs +10/−5
• Simulation/Aivika/Dynamics/Agent.hs +56/−5
• Simulation/Aivika/Dynamics/Buffer.hs +148/−0
• Simulation/Aivika/Dynamics/Cont.hs +4/−4
• Simulation/Aivika/Dynamics/EventQueue.hs +4/−9
• Simulation/Aivika/Dynamics/FIFO.hs +164/−0
• Simulation/Aivika/Dynamics/Internal/Cont.hs +243/−24
• Simulation/Aivika/Dynamics/Internal/Dynamics.hs +67/−11
• Simulation/Aivika/Dynamics/Internal/Process.hs +148/−14
• Simulation/Aivika/Dynamics/Internal/Signal.hs +287/−0
• Simulation/Aivika/Dynamics/LIFO.hs +152/−0
• Simulation/Aivika/Dynamics/Parameter.hs +13/−13
• Simulation/Aivika/Dynamics/Process.hs +10/−1
• Simulation/Aivika/Dynamics/Ref.hs +31/−7
• Simulation/Aivika/Dynamics/Resource.hs +85/−14
• Simulation/Aivika/Dynamics/Signal.hs +108/−0
• Simulation/Aivika/Dynamics/UVar.hs +44/−11
• Simulation/Aivika/Dynamics/Var.hs +44/−11
• Simulation/Aivika/UVector.hs +58/−0
• Simulation/Aivika/Vector.hs +55/−0
• aivika.cabal +9/−4
• examples/BassDiffusion.hs +2/−2
• examples/ChemicalReaction.hs +1/−1
• examples/FishBank.hs +1/−1
• examples/Furnace.hs +3/−3
• examples/MachRep1.hs +2/−2
• examples/MachRep1EventDriven.hs +2/−2
• examples/MachRep1TimeDriven.hs +1/−1
• examples/MachRep2.hs +2/−2
• examples/MachRep3.hs +2/−2

@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Dynamics--- Copyright  : Copyright (c) 2009-2011, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2012, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.0.3+-- Tested with: GHC 7.4.1 -- -- The module defines the 'Dynamics' monad representing an abstract dynamic  -- process, i.e. a time varying polymorphic function. @@ -13,8 +13,13 @@ module Simulation.Aivika.Dynamics         (Dynamics,         DynamicsLift(..),-        runDynamicsInStart,-        runDynamicsInFinal,-        runDynamics) where+        runDynamicsInStartTime,+        runDynamicsInStopTime,+        runDynamicsInIntegTimes,+        runDynamicsInTime,+        runDynamicsInTimes,+        catchDynamics,+        finallyDynamics,+        throwDynamics) where  import Simulation.Aivika.Dynamics.Internal.Dynamics

@@ -18,6 +18,8 @@         newSubstate,         agentQueue,         agentState,+        agentStateChanged,+        agentStateChanged_,         activateState,         initState,         stateAgent,@@ -33,6 +35,7 @@ import Simulation.Aivika.Dynamics.Internal.Simulation import Simulation.Aivika.Dynamics.Internal.Dynamics import Simulation.Aivika.Dynamics.EventQueue+import Simulation.Aivika.Dynamics.Internal.Signal  -- -- Agent-based Modeling@@ -41,8 +44,11 @@ -- | Represents an agent. data Agent = Agent { agentQueue :: EventQueue,                      -- ^ Return the bound event queue.+                     agentTimeRef :: IORef Double,                      agentModeRef :: IORef AgentMode,-                     agentStateRef :: IORef (Maybe AgentState) }+                     agentStateRef :: IORef (Maybe AgentState), +                     agentStateChangedSource :: SignalSource (Maybe AgentState), +                     agentStateUpdatedSource :: SignalSource (Maybe AgentState) }  -- | Represents the agent state. data AgentState = AgentState { stateAgent :: Agent,@@ -111,6 +117,8 @@                activate st p                when (st == target) $                  writeIORef (agentModeRef agent) ProcessingMode+          unless (null path1 && null path2) $+            triggerAgentStateChanged p agent  -- | Add to the state a timeout handler that will be actuated  -- in the specified time period, while the state remains active.@@ -120,9 +128,11 @@   do let q = agentQueue (stateAgent st)          Dynamics m0 = queueRun q      m0 p    -- ensure that the agent state is actual+     checkTime p (stateAgent st) "addTimeout"      v <- readIORef (stateVersionRef st)      let m1 = Dynamics $ \p ->-           do v' <- readIORef (stateVersionRef st)+           do -- checkTime p (stateAgent st) "addTimeout"+              v' <- readIORef (stateVersionRef st)               when (v == v') $ action p          Dynamics m2 = enqueue q (pointTime p + dt) m1      m2 p@@ -136,9 +146,11 @@   do let q = agentQueue (stateAgent st)          Dynamics m0 = queueRun q      m0 p    -- ensure that the agent state is actual+     checkTime p (stateAgent st) "addTimer"      v <- readIORef (stateVersionRef st)      let m1 = Dynamics $ \p ->-           do v' <- readIORef (stateVersionRef st)+           do -- checkTime p (stateAgent st) "addTimer"+              v' <- readIORef (stateVersionRef st)               when (v == v') $ do { m2 p; action p }          Dynamics m2 =             Dynamics $ \p ->@@ -178,11 +190,19 @@ newAgent :: EventQueue -> Simulation Agent newAgent queue =   Simulation $ \r ->-  do modeRef    <- newIORef CreationMode+  do timeRef    <- newIORef $ spcStartTime $ runSpecs r+     modeRef    <- newIORef CreationMode      stateRef   <- newIORef Nothing+     let Simulation m1 = newSignalSourceUnsafe+         Simulation m2 = newSignalSourceWithUpdate $ queueRun queue+     stateChangedSource <- m1 r+     stateUpdatedSource <- m2 r      return Agent { agentQueue = queue,+                    agentTimeRef = timeRef,                     agentModeRef = modeRef,-                    agentStateRef = stateRef }+                    agentStateRef = stateRef, +                    agentStateChangedSource = stateChangedSource, +                    agentStateUpdatedSource = stateUpdatedSource }  -- | Return the selected downmost active state. agentState :: Agent -> Dynamics (Maybe AgentState)@@ -190,6 +210,7 @@   Dynamics $ \p ->    do let Dynamics m = queueRun $ agentQueue agent       m p    -- ensure that the agent state is actual+     checkTime p agent "agentState"      readIORef (agentStateRef agent)                     -- | Select the next downmost active state.       @@ -199,6 +220,7 @@   do let agent = stateAgent st          Dynamics m = queueRun $ agentQueue agent       m p    -- ensure that the agent state is actual+     checkTime p agent "activateState"      mode <- readIORef (agentModeRef agent)      case mode of        CreationMode ->@@ -213,6 +235,7 @@                 Dynamics m <- readIORef (stateActivateRef st)                 m p                 writeIORef (agentModeRef agent) ProcessingMode+                triggerAgentStateChanged p agent        InitialMode ->          error $           "Use the initState function during " ++@@ -234,6 +257,7 @@   do let agent = stateAgent st          Dynamics m = queueRun $ agentQueue agent       m p    -- ensure that the agent state is actual+     checkTime p agent "initState"      mode <- readIORef (agentModeRef agent)      case mode of        CreationMode ->@@ -263,3 +287,30 @@   Simulation $ \r ->   writeIORef (stateDeactivateRef st) action   +-- | Trigger the signal when the agent state changes.+triggerAgentStateChanged :: Point -> Agent -> IO ()+triggerAgentStateChanged p agent =+  do st <- readIORef (agentStateRef agent)+     let Dynamics m = triggerSignal (agentStateChangedSource agent) st+     m p++-- | Return a signal that notifies about every change of the state.+agentStateChanged :: Agent -> Signal (Maybe AgentState)+agentStateChanged agent = merge2Signals m1 m2+  where m1 = publishSignal (agentStateChangedSource agent)+        m2 = publishSignal (agentStateUpdatedSource agent)+        +-- | Return a signal that notifies about every change of the state.+agentStateChanged_ :: Agent -> Signal ()+agentStateChanged_ agent =+  mapSignal (const ()) $ agentStateChanged agent+        +-- | Check that we don't request for the past data.+checkTime :: Point -> Agent -> String -> IO ()+{-# INLINE checkTime #-}+checkTime p agent name =+  do t <- readIORef (agentTimeRef agent)+     when (pointTime p < t) $+       error $ "You cannot request for past data: " ++ name+     when (pointTime p > t) $+       writeIORef (agentTimeRef agent) (pointTime p)

@@ -0,0 +1,148 @@++-- |+-- Module     : Simulation.Aivika.Dynamics.Buffer+-- Copyright  : Copyright (c) 2009-2012, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.4.1+--+-- This module defines the limited queue similar to 'LIFO' and 'FIFO' but where +-- the items are not represented. We know only of their number in the buffer and +-- how many items were lost.+--+module Simulation.Aivika.Dynamics.Buffer+       (Buffer,+        bufferQueue,+        bufferNull,+        bufferFull,+        bufferMaxCount,+        bufferCount,+        bufferLostCount,+        newBuffer,+        dequeueBuffer,+        tryDequeueBuffer,+        enqueueBuffer,+        tryEnqueueBuffer,+        enqueueBufferOrLost) where++import Data.IORef+import Data.Array+import Data.Array.IO++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Dynamics+import Simulation.Aivika.Dynamics.Simulation+import Simulation.Aivika.Dynamics.EventQueue+import Simulation.Aivika.Dynamics.Process+import Simulation.Aivika.Dynamics.Resource++import Simulation.Aivika.Dynamics.LIFO+import Simulation.Aivika.Dynamics.FIFO++-- | Represents the limited queue similar to 'LIFO' and 'FIFO' but where the items are not repsented.+-- So, there is no order of items but their number is strictly limited.+data Buffer =+  Buffer { bufferQueue :: EventQueue,  -- ^ Return the event queue.+           bufferMaxCount :: Int,      -- ^ The maximum available number of items.+           bufferReadRes  :: Resource,+           bufferWriteRes :: Resource,+           bufferCountRef :: IORef Int,+           bufferLostCountRef :: IORef Int }+  +-- | Create a new queue with the specified maximum available number of items.  +newBuffer :: EventQueue -> Int -> Simulation Buffer  +newBuffer q count =+  do i <- liftIO $ newIORef 0+     l <- liftIO $ newIORef 0+     r <- newResourceWithCount q count 0+     w <- newResourceWithCount q count count+     return Buffer { bufferQueue = q,+                     bufferMaxCount = count,+                     bufferReadRes  = r,+                     bufferWriteRes = w,+                     bufferCountRef = i,+                     bufferLostCountRef = l }+  +-- | Test whether the queue is empty.+bufferNull :: Buffer -> Dynamics Bool+bufferNull q =+  do a <- bufferCount q+     return (a == 0)++-- | Test whether the queue is full.+bufferFull :: Buffer -> Dynamics Bool+bufferFull q =+  do a <- bufferCount q+     return (a == bufferMaxCount q)++-- | Return the queue size.+bufferCount :: Buffer -> Dynamics Int+bufferCount q =+  liftIO $ readIORef (bufferCountRef q)+  +-- | Return the number of lost items.+bufferLostCount :: Buffer -> Dynamics Int+bufferLostCount q =+  liftIO $ readIORef (bufferLostCountRef q)+  +-- | Dequeue suspending the process if the buffer is empty.+dequeueBuffer :: Buffer -> Process ()+dequeueBuffer q =+  do requestResource (bufferReadRes q)+     liftIO $ dequeueImpl q+     releaseResource (bufferWriteRes q)+  +-- | Try to dequeue immediately.  +tryDequeueBuffer :: Buffer -> Dynamics Bool+tryDequeueBuffer q =+  do x <- tryRequestResourceInDynamics (bufferReadRes q)+     if x +       then do liftIO $ dequeueImpl q+               releaseResourceInDynamics (bufferWriteRes q)+               return True+       else return False++-- | Enqueue the item suspending the process +-- if the buffer is full.  +enqueueBuffer :: Buffer -> Process ()+enqueueBuffer q =+  do requestResource (bufferWriteRes q)+     liftIO $ enqueueImpl q+     releaseResource (bufferReadRes q)+     +-- | Try to enqueue the item immediately.  +tryEnqueueBuffer :: Buffer -> Dynamics Bool+tryEnqueueBuffer q =+  do x <- tryRequestResourceInDynamics (bufferWriteRes q)+     if x +       then do liftIO $ enqueueImpl q+               releaseResourceInDynamics (bufferReadRes q)+               return True+       else return False++-- | Try to enqueue the item. If the buffer is full+-- then the item will be lost.+enqueueBufferOrLost :: Buffer -> Dynamics ()+enqueueBufferOrLost q =+  do x <- tryRequestResourceInDynamics (bufferWriteRes q)+     if x+       then do liftIO $ enqueueImpl q+               releaseResourceInDynamics (bufferReadRes q)+       else liftIO $ modifyIORef (bufferLostCountRef q) $ (+) 1++-- | An implementation method.+dequeueImpl :: Buffer -> IO ()+dequeueImpl q =+  do i <- readIORef (bufferCountRef q)+     let i' = i - 1+     i' `seq` writeIORef (bufferCountRef q) i'++-- | An implementation method.+enqueueImpl :: Buffer -> IO ()+enqueueImpl q =+  do i <- readIORef (bufferCountRef q)+     let i' = i + 1+     i' `seq` writeIORef (bufferCountRef q) i'

@@ -7,12 +7,12 @@ -- Stability  : experimental -- Tested with: GHC 7.0.3 ----- The 'Cont' monad is a variation of the standard Cont monad, where--- the result of applying the continuation is a dynamic process.+-- The 'Cont' monad is a variation of the standard Cont monad +-- and F# async workflow, where the result of applying +-- the continuation is a dynamic process. -- module Simulation.Aivika.Dynamics.Cont-       (Cont,-        runCont) where+       (Cont) where  import Simulation.Aivika.Dynamics.Internal.Dynamics import Simulation.Aivika.Dynamics.Internal.Cont

@@ -15,7 +15,6 @@ module Simulation.Aivika.Dynamics.EventQueue        (EventQueue,         newQueue,-        enqueueCont,         enqueue,         queueRun) where @@ -28,7 +27,7 @@  -- | The 'EventQueue' type represents the event queue. data EventQueue = EventQueue { -  queuePQ   :: PQ.PriorityQueue (() -> Dynamics ()),+  queuePQ   :: PQ.PriorityQueue (Dynamics ()),   queueRun  :: Dynamics (),   -- ^ Run the event queue processing its events   queueBusy :: IORef Bool,   queueTime :: IORef Double }@@ -48,13 +47,9 @@      return q               -- | Enqueue the event which must be actuated at the specified time.-enqueueCont :: EventQueue -> Double -> (() -> Dynamics ()) -> Dynamics ()-enqueueCont q t c = Dynamics r where-  r p = let pq = queuePQ q in PQ.enqueue pq t c-    --- | Enqueue the event which must be actuated at the specified time. enqueue :: EventQueue -> Double -> Dynamics () -> Dynamics ()-enqueue q t m = enqueueCont q t (const m) +enqueue q t c = Dynamics r where+  r p = let pq = queuePQ q in PQ.enqueue pq t c      -- | Run the event queue processing its events. runQueue :: EventQueue -> Dynamics ()@@ -82,7 +77,7 @@                      t0  = spcStartTime sc                      dt  = spcDT sc                      n2  = fromInteger $ toInteger $ floor ((t2 - t0) / dt)-                     Dynamics k = c2 ()+                     Dynamics k = c2                  k $ p { pointTime = t2,                          pointIteration = n2,                          pointPhase = -1 }

@@ -0,0 +1,164 @@++-- |+-- Module     : Simulation.Aivika.Dynamics.FIFO+-- Copyright  : Copyright (c) 2009-2012, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.4.1+--+-- This module defines the FIFO queue.+--+module Simulation.Aivika.Dynamics.FIFO+       (FIFO,+        fifoQueue,+        fifoNull,+        fifoFull,+        fifoMaxCount,+        fifoCount,+        fifoLostCount,+        newFIFO,+        dequeueFIFO,+        tryDequeueFIFO,+        enqueueFIFO,+        tryEnqueueFIFO,+        enqueueFIFOOrLost) where++import Data.IORef+import Data.Array+import Data.Array.IO++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Dynamics+import Simulation.Aivika.Dynamics.Simulation+import Simulation.Aivika.Dynamics.EventQueue+import Simulation.Aivika.Dynamics.Process+import Simulation.Aivika.Dynamics.Resource++-- | Represents the FIFO queue with rule: first input - first output.+data FIFO a =+  FIFO { fifoQueue :: EventQueue,  -- ^ Return the event queue.+         fifoMaxCount :: Int,      -- ^ The maximum available number of items.+         fifoReadRes  :: Resource,+         fifoWriteRes :: Resource,+         fifoCountRef :: IORef Int,+         fifoLostCountRef :: IORef Int,+         fifoStartRef :: IORef Int,+         fifoEndRef   :: IORef Int,+         fifoArray :: IOArray Int a }+  +-- | Create a new FIFO queue with the specified maximum available number of items.  +newFIFO :: EventQueue -> Int -> Simulation (FIFO a)  +newFIFO q count =+  do i <- liftIO $ newIORef 0+     l <- liftIO $ newIORef 0+     s <- liftIO $ newIORef 0+     e <- liftIO $ newIORef 0+     a <- liftIO $ newArray_ (0, count - 1)+     r <- newResourceWithCount q count 0+     w <- newResourceWithCount q count count+     return FIFO { fifoQueue = q,+                   fifoMaxCount = count,+                   fifoReadRes  = r,+                   fifoWriteRes = w,+                   fifoCountRef = i,+                   fifoLostCountRef = l,+                   fifoStartRef = s,+                   fifoEndRef   = e,+                   fifoArray = a }+  +-- | Test whether the FIFO queue is empty.+fifoNull :: FIFO a -> Dynamics Bool+fifoNull fifo =+  do a <- fifoCount fifo+     return (a == 0)++-- | Test whether the FIFO queue is full.+fifoFull :: FIFO a -> Dynamics Bool+fifoFull fifo =+  do a <- fifoCount fifo+     return (a == fifoMaxCount fifo)++-- | Return the queue size.+fifoCount :: FIFO a -> Dynamics Int+fifoCount fifo =+  liftIO $ readIORef (fifoCountRef fifo)+  +-- | Return the number of lost items.+fifoLostCount :: FIFO a -> Dynamics Int+fifoLostCount fifo =+  liftIO $ readIORef (fifoLostCountRef fifo)+  +-- | Dequeue from the FIFO queue suspending the process if+-- the queue is empty.+dequeueFIFO :: FIFO a -> Process a  +dequeueFIFO fifo =+  do requestResource (fifoReadRes fifo)+     a <- liftIO $ dequeueImpl fifo+     releaseResource (fifoWriteRes fifo)+     return a+  +-- | Try to dequeue from the FIFO queue immediately.  +tryDequeueFIFO :: FIFO a -> Dynamics (Maybe a)+tryDequeueFIFO fifo =+  do x <- tryRequestResourceInDynamics (fifoReadRes fifo)+     if x +       then do a <- liftIO $ dequeueImpl fifo+               releaseResourceInDynamics (fifoWriteRes fifo)+               return $ Just a+       else return Nothing++-- | Enqueue the item in the FIFO queue suspending the process+-- if the queue is full.  +enqueueFIFO :: FIFO a -> a -> Process ()+enqueueFIFO fifo a =+  do requestResource (fifoWriteRes fifo)+     liftIO $ enqueueImpl fifo a+     releaseResource (fifoReadRes fifo)+     +-- | Try to enqueue the item in the FIFO queue. Return 'False' in+-- the monad if the queue is full.+tryEnqueueFIFO :: FIFO a -> a -> Dynamics Bool+tryEnqueueFIFO fifo a =+  do x <- tryRequestResourceInDynamics (fifoWriteRes fifo)+     if x +       then do liftIO $ enqueueImpl fifo a+               releaseResourceInDynamics (fifoReadRes fifo)+               return True+       else return False++-- | Try to enqueue the item in the FIFO queue. If the queue is full+-- then the item will be lost.+enqueueFIFOOrLost :: FIFO a -> a -> Dynamics ()+enqueueFIFOOrLost fifo a =+  do x <- tryRequestResourceInDynamics (fifoWriteRes fifo)+     if x+       then do liftIO $ enqueueImpl fifo a+               releaseResourceInDynamics (fifoReadRes fifo)+       else liftIO $ modifyIORef (fifoLostCountRef fifo) $ (+) 1++-- | An implementation method.+dequeueImpl :: FIFO a -> IO a+dequeueImpl fifo =+  do i <- readIORef (fifoCountRef fifo)+     s <- readIORef (fifoStartRef fifo)+     let i' = i - 1+         s' = (s + 1) `mod` fifoMaxCount fifo+     a <- readArray (fifoArray fifo) s+     writeArray (fifoArray fifo) s undefined+     i' `seq` writeIORef (fifoCountRef fifo) i'+     s' `seq` writeIORef (fifoStartRef fifo) s'+     return a++-- | An implementation method.+enqueueImpl :: FIFO a -> a -> IO ()+enqueueImpl fifo a =+  do i <- readIORef (fifoCountRef fifo)+     e <- readIORef (fifoEndRef fifo)+     let i' = i + 1+         e' = (e + 1) `mod` fifoMaxCount fifo+     a `seq` writeArray (fifoArray fifo) e a+     i' `seq` writeIORef (fifoCountRef fifo) i'+     e' `seq` writeIORef (fifoEndRef fifo) e'

@@ -7,23 +7,48 @@ -- Stability  : experimental -- Tested with: GHC 7.0.3 ----- The 'Cont' monad is a variation of the standard Cont monad, where--- the result of applying the continuation is a dynamic process.+-- The 'Cont' monad is a variation of the standard Cont monad +-- and F# async workflow, where the result of applying +-- the continuation is a dynamic process. -- module Simulation.Aivika.Dynamics.Internal.Cont        (Cont(..),-        runCont) where+        ContParams,+        runCont,+        catchCont,+        finallyCont,+        throwCont,+        resumeContByParams,+        contParamsCanceled) where +import Data.IORef++import qualified Control.Exception as C+import Control.Exception (IOException, throw)+ import Control.Monad import Control.Monad.Trans  import Simulation.Aivika.Dynamics.Internal.Simulation import Simulation.Aivika.Dynamics.Internal.Dynamics --- | The 'Cont' type is similar to the standard Cont monad but only--- the continuation uses a dynamic process as a result.-newtype Cont a = Cont ((a -> Dynamics ()) -> Dynamics ())+-- | The 'Cont' type is similar to the standard Cont monad +-- and F# async workflow but only the continuations return+-- a dynamic process as a result.+newtype Cont a = Cont (ContParams a -> Dynamics ()) +-- | The continuation parameters.+data ContParams a = +  ContParams { contCont :: a -> Dynamics (), +               contAux  :: ContParamsAux }++-- | The auxiliary continuation parameters.+data ContParamsAux =+  ContParamsAux { contECont :: IOException -> Dynamics (),+                  contCCont :: () -> Dynamics (),+                  contCancelRef :: IORef Bool, +                  contCatchFlag :: Bool }+ instance Monad Cont where   return  = returnC   m >>= k = bindC m k@@ -40,46 +65,240 @@ instance MonadIO Cont where   liftIO = liftIOC  +invokeC :: Cont a -> ContParams a -> Dynamics ()+{-# INLINE invokeC #-}+invokeC (Cont m) = m++invokeD :: Point -> Dynamics a -> IO a+{-# INLINE invokeD #-}+invokeD p (Dynamics m) = m p++cancelD :: Point -> ContParams a -> IO ()+{-# NOINLINE cancelD #-}+cancelD p c =+  do writeIORef (contCancelRef . contAux $ c) False+     invokeD p $ (contCCont . contAux $ c) ()+ returnC :: a -> Cont a {-# INLINE returnC #-}-returnC a = Cont $ \c -> c a+returnC a = +  Cont $ \c ->+  Dynamics $ \p ->+  do z <- readIORef $ (contCancelRef . contAux) c+     if z +       then cancelD p c+       else invokeD p $ contCont c a                           +-- bindC :: Cont a -> (a -> Cont b) -> Cont b+-- {-# INLINE bindC #-}+-- bindC m k = +--   Cont $ \c -> +--   if (contCatchFlag . contAux $ c) +--   then bindWithCatch m k c+--   else bindWithoutCatch m k c+   bindC :: Cont a -> (a -> Cont b) -> Cont b {-# INLINE bindC #-}-bindC (Cont m) k = Cont $ \c -> m (\a -> let Cont m' = k a in m' c)+bindC m k = +  Cont $ bindWithoutCatch m k  -- Another version is not tail recursive!+  +bindWithoutCatch :: Cont a -> (a -> Cont b) -> ContParams b -> Dynamics ()+{-# INLINE bindWithoutCatch #-}+bindWithoutCatch (Cont m) k c = +  Dynamics $ \p ->+  do z <- readIORef $ (contCancelRef . contAux) c+     if z +       then cancelD p c+       else invokeD p $ m $ +            let cont a = invokeC (k a) c+            in c { contCont = cont } --- | Run the 'Cont' computation.-runCont :: Cont a -> (a -> Dynamics ()) -> Dynamics ()-{-# INLINE runCont #-}-runCont (Cont m) = m+-- It is not tail recursive!+bindWithCatch :: Cont a -> (a -> Cont b) -> ContParams b -> Dynamics ()+{-# NOINLINE bindWithCatch #-}+bindWithCatch (Cont m) k c = +  Dynamics $ \p ->+  do z <- readIORef $ (contCancelRef . contAux) c+     if z +       then cancelD p c+       else invokeD p $ m $ +            let cont a = catchDynamics +                         (invokeC (k a) c)+                         (contECont . contAux $ c)+            in c { contCont = cont } +-- Like "bindWithoutCatch (return a) k"+callWithoutCatch :: (a -> Cont b) -> a -> ContParams b -> Dynamics ()+callWithoutCatch k a c =+  Dynamics $ \p ->+  do z <- readIORef $ (contCancelRef . contAux) c+     if z +       then cancelD p c+       else invokeD p $ invokeC (k a) c++-- Like "bindWithCatch (return a) k" but it is not tail recursive!+callWithCatch :: (a -> Cont b) -> a -> ContParams b -> Dynamics ()+callWithCatch k a c =+  Dynamics $ \p ->+  do z <- readIORef $ (contCancelRef . contAux) c+     if z +       then cancelD p c+       else invokeD p $ catchDynamics +            (invokeC (k a) c)+            (contECont . contAux $ c)++-- | Exception handling within 'Cont' computations.+catchCont :: Cont a -> (IOException -> Cont a) -> Cont a+catchCont m h = +  Cont $ \c -> +  if contCatchFlag . contAux $ c+  then catchWithCatch m h c+  else error $+       "To catch exceptions, the process must be created " +++       "with help of newProcessIDWithCatch: catchCont."+  +catchWithCatch :: Cont a -> (IOException -> Cont a) -> ContParams a -> Dynamics ()+catchWithCatch (Cont m) h c =+  Dynamics $ \p -> +  do z <- readIORef $ (contCancelRef . contAux) c+     if z +       then cancelD p c+       else invokeD p $ m $+            -- let econt e = callWithCatch h e c   -- not tail recursive!+            let econt e = callWithoutCatch h e c+            in c { contAux = (contAux c) { contECont = econt } }+               +-- | A computation with finalization part.+finallyCont :: Cont a -> Cont b -> Cont a+finallyCont m m' = +  Cont $ \c -> +  if contCatchFlag . contAux $ c+  then finallyWithCatch m m' c+  else error $+       "To finalize computation, the process must be created " +++       "with help of newProcessIDWithCatch: finallyCont."+  +finallyWithCatch :: Cont a -> Cont b -> ContParams a -> Dynamics ()               +finallyWithCatch (Cont m) (Cont m') c =+  Dynamics $ \p ->+  do z <- readIORef $ (contCancelRef . contAux) c+     if z +       then cancelD p c+       else invokeD p $ m $+            let cont a   = +                  Dynamics $ \p ->+                  invokeD p $ m' $+                  let cont b = contCont c a+                  in c { contCont = cont }+                econt e  =+                  Dynamics $ \p ->+                  invokeD p $ m' $+                  let cont b = (contECont . contAux $ c) e+                  in c { contCont = cont }+                ccont () = +                  Dynamics $ \p ->+                  invokeD p $ m' $+                  let cont b  = (contCCont . contAux $ c) ()+                      econt e = (contCCont . contAux $ c) ()+                  in c { contCont = cont,+                         contAux  = (contAux c) { contECont = econt } }+            in c { contCont = cont,+                   contAux  = (contAux c) { contECont = econt,+                                            contCCont = ccont } }++-- | Throw the exception with the further exception handling.+-- By some reasons, the standard 'throw' function per se is not handled +-- properly within 'Cont' computations, altough it will be still handled +-- if it will be hidden under the 'liftIO' function. The problem arises +-- namely with the @throw@ function, not 'IO' computations.+throwCont :: IOException -> Cont a+throwCont e = liftIO $ throw e++-- | Run the 'Cont' computation with the specified cancelation token +-- and flag indicating whether to catch exceptions.+runCont :: Cont a -> +           (a -> Dynamics ()) ->+           (IOError -> Dynamics ()) ->+           (() -> Dynamics ()) ->+           IORef Bool -> +           Bool -> +           Dynamics ()+runCont (Cont m) cont econt ccont cancelToken catchFlag = +  m ContParams { contCont = cont,+                 contAux  = +                   ContParamsAux { contECont = econt,+                                   contCCont = ccont,+                                   contCancelRef = cancelToken, +                                   contCatchFlag = catchFlag } }+ -- | Lift the 'Simulation' computation. liftSC :: Simulation a -> Cont a-{-# INLINE liftSC #-} liftSC (Simulation m) =    Cont $ \c ->   Dynamics $ \p ->-  do a <- m $ pointRun p-     let Dynamics m' = c a-     m' p+  if contCatchFlag . contAux $ c+  then liftIOWithCatch (m $ pointRun p) p c+  else liftIOWithoutCatch (m $ pointRun p) p c       -- | Lift the 'Dynamics' computation. liftDC :: Dynamics a -> Cont a-{-# INLINE liftDC #-} liftDC (Dynamics m) =   Cont $ \c ->   Dynamics $ \p ->-  do a <- m p-     let Dynamics m' = c a-     m' p+  if contCatchFlag . contAux $ c+  then liftIOWithCatch (m p) p c+  else liftIOWithoutCatch (m p) p c       -- | Lift the IO computation. liftIOC :: IO a -> Cont a-{-# INLINE liftIOC #-} liftIOC m =   Cont $ \c ->   Dynamics $ \p ->-  do a <- m-     let Dynamics m' = c a-     m' p+  if contCatchFlag . contAux $ c+  then liftIOWithCatch m p c+  else liftIOWithoutCatch m p c   +liftIOWithoutCatch :: IO a -> Point -> ContParams a -> IO ()+{-# INLINE liftIOWithoutCatch #-}+liftIOWithoutCatch m p c =+  do z <- readIORef $ (contCancelRef . contAux) c+     if z+       then cancelD p c+       else do a <- m+               invokeD p $ contCont c a++liftIOWithCatch :: IO a -> Point -> ContParams a -> IO ()+{-# NOINLINE liftIOWithCatch #-}+liftIOWithCatch m p c =+  do z <- readIORef $ (contCancelRef . contAux) c+     if z+       then cancelD p c+       else do aref <- newIORef undefined+               eref <- newIORef Nothing+               C.catch (m >>= writeIORef aref) +                 (writeIORef eref . Just)+               e <- readIORef eref+               case e of+                 Nothing -> +                   do a <- readIORef aref+                      -- tail recursive+                      invokeD p $ contCont c a+                 Just e ->+                   -- tail recursive+                   invokeD p $ (contECont . contAux) c e++-- | Resume the computation by the specified parameters.+resumeContByParams :: ContParams a -> a -> Dynamics ()+{-# INLINE resumeContByParams #-}+resumeContByParams c a = +  Dynamics $ \p ->+  do z <- readIORef $ (contCancelRef . contAux) c+     if z+       then cancelD p c+       else invokeD p $ contCont c a++-- | Test whether the computation is canceled+contParamsCanceled :: ContParams a -> IO Bool+{-# INLINE contParamsCanceled #-}+contParamsCanceled c = +  readIORef $ (contCancelRef . contAux) c

@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Dynamics.Internal.Dynamics--- Copyright  : Copyright (c) 2009-2011, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2012, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.0.3+-- Tested with: GHC 7.4.1 -- -- The module defines the 'Dynamics' monad representing an abstract dynamic  -- process, i.e. a time varying polymorphic function. @@ -15,9 +15,15 @@         Dynamics(..),         DynamicsLift(..),         Point(..),-        runDynamicsInStart,-        runDynamicsInFinal,-        runDynamics,+        runDynamicsInStartTime,+        runDynamicsInStopTime,+        runDynamicsInIntegTimes,+        runDynamicsInTime,+        runDynamicsInTimes,+        -- * Error Handling+        catchDynamics,+        finallyDynamics,+        throwDynamics,         -- * Utilities         basicTime,         iterationBnds,@@ -27,6 +33,9 @@         phaseHiBnd,         phaseLoBnd) where +import qualified Control.Exception as C+import Control.Exception (IOException, throw, finally)+ import Control.Monad import Control.Monad.Trans @@ -133,8 +142,8 @@      m' p  -- | Run the dynamic process in the initial simulation point.-runDynamicsInStart :: Dynamics a -> Simulation a-runDynamicsInStart (Dynamics m) =+runDynamicsInStartTime :: Dynamics a -> Simulation a+runDynamicsInStartTime (Dynamics m) =   Simulation $ \r ->   do let sc = runSpecs r           n  = 0@@ -146,8 +155,8 @@                pointPhase = 0 }  -- | Run the dynamic process in the final simulation point.-runDynamicsInFinal :: Dynamics a -> Simulation a-runDynamicsInFinal (Dynamics m) =+runDynamicsInStopTime :: Dynamics a -> Simulation a+runDynamicsInStopTime (Dynamics m) =   Simulation $ \r ->   do let sc = runSpecs r           n  = iterationHiBnd sc@@ -159,8 +168,8 @@                pointPhase = 0 }  -- | Run the dynamic process in all integration time points-runDynamics :: Dynamics a -> Simulation [IO a]-runDynamics (Dynamics m) =+runDynamicsInIntegTimes :: Dynamics a -> Simulation [IO a]+runDynamicsInIntegTimes (Dynamics m) =   Simulation $ \r ->   do let sc = runSpecs r          (nl, nu) = iterationBnds sc@@ -171,6 +180,36 @@                            pointPhase = 0 }      return $ map (m . point) [nl .. nu] +-- | Run the dynamic process in the specified time point.+runDynamicsInTime :: Double -> Dynamics a -> Simulation a+runDynamicsInTime t (Dynamics m) =+  Simulation $ \r ->+  do let sc = runSpecs r+         t0 = spcStartTime sc+         dt = spcDT sc+         n  = fromInteger $ toInteger $ floor ((t - t0) / dt)+     m Point { pointSpecs = sc,+               pointRun = r,+               pointTime = t,+               pointIteration = n,+               pointPhase = -1 }++-- | Run the dynamic process in the specified time points.+runDynamicsInTimes :: [Double] -> Dynamics a -> Simulation [IO a]+runDynamicsInTimes ts (Dynamics m) =+  Simulation $ \r ->+  do let sc = runSpecs r+         t0 = spcStartTime sc+         dt = spcDT sc+         point t =+           let n = fromInteger $ toInteger $ floor ((t - t0) / dt)+           in Point { pointSpecs = sc,+                      pointRun = r,+                      pointTime = t,+                      pointIteration = n,+                      pointPhase = -1 }+     return $ map (m . point) ts+ instance Functor Dynamics where   fmap = liftMD @@ -239,3 +278,20 @@      -- | Lift the specified 'Dynamics' computation in another monad.   liftDynamics :: Dynamics a -> m a+  +-- | Exception handling within 'Dynamics' computations.+catchDynamics :: Dynamics a -> (IOException -> Dynamics a) -> Dynamics a+catchDynamics (Dynamics m) h =+  Dynamics $ \p -> +  C.catch (m p) $ \e ->+  let Dynamics m' = h e in m' p+                           +-- | A computation with finalization part like the 'finally' function.+finallyDynamics :: Dynamics a -> Dynamics b -> Dynamics a+finallyDynamics (Dynamics m) (Dynamics m') =+  Dynamics $ \p ->+  C.finally (m p) (m' p)++-- | Like the standard 'throw' function.+throwDynamics :: IOException -> Dynamics a+throwDynamics = throw

@@ -22,15 +22,25 @@         Process(..),         processQueue,         newProcessID,+        newProcessIDWithCatch,         holdProcess,+        interruptProcess,+        processInterrupted,         passivateProcess,         processPassive,         reactivateProcess,         processID,-        runProcess) where+        cancelProcess,+        processCanceled,+        runProcess,+        runProcessNow,+        catchProcess,+        finallyProcess,+        throwProcess) where  import Data.Maybe import Data.IORef+import Control.Exception (IOException, throw) import Control.Monad import Control.Monad.Trans @@ -43,7 +53,13 @@ data ProcessID =    ProcessID { processQueue   :: EventQueue,  -- ^ Return the event queue.               processStarted :: IORef Bool,-              processCont    :: IORef (Maybe (() -> Dynamics ())) }+              processCatchFlag     :: Bool,+              processReactCont     :: IORef (Maybe (ContParams ())), +              processCancelRef     :: IORef Bool, +              processCancelToken   :: IORef Bool,+              processInterruptRef  :: IORef Bool, +              processInterruptCont :: IORef (Maybe (ContParams ())), +              processInterruptVersion :: IORef Int }  -- | Specifies a discontinuous process that can suspend at any time -- and then resume later.@@ -55,16 +71,51 @@   Process $ \pid ->   Cont $ \c ->   Dynamics $ \p ->-  do let Dynamics m = enqueueCont (processQueue pid) (pointTime p + dt) c+  do let x = processInterruptCont pid+     writeIORef x $ Just c+     writeIORef (processInterruptRef pid) False+     v <- readIORef (processInterruptVersion pid)+     let Dynamics m = +           enqueue (processQueue pid) (pointTime p + dt) $+           Dynamics $ \p ->+           do v' <- readIORef (processInterruptVersion pid)+              when (v == v') $ +                do writeIORef x Nothing+                   let Dynamics m = resumeContByParams c ()+                   m p      m p +-- | Interrupt a process with the specified ID if the process+-- was held by computation 'holdProcess'.+interruptProcess :: ProcessID -> Dynamics ()+interruptProcess pid =+  Dynamics $ \p ->+  do let x = processInterruptCont pid+     a <- readIORef x+     case a of+       Nothing -> return ()+       Just c ->+         do writeIORef x Nothing+            writeIORef (processInterruptRef pid) True+            modifyIORef (processInterruptVersion pid) $ (+) 1+            let Dynamics m = +                  enqueue (processQueue pid) (pointTime p) $ +                  resumeContByParams c ()+            m p+            +-- | Test whether the process with the specified ID was interrupted.+processInterrupted :: ProcessID -> Dynamics Bool+processInterrupted pid =+  Dynamics $ \p ->+  readIORef (processInterruptRef pid)+ -- | Passivate the process. passivateProcess :: Process () passivateProcess =   Process $ \pid ->   Cont $ \c ->   Dynamics $ \p ->-  do let x = processCont pid+  do let x = processReactCont pid      a <- readIORef x      case a of        Nothing -> writeIORef x $ Just c@@ -76,7 +127,7 @@   Dynamics $ \p ->   do let Dynamics m = queueRun $ processQueue pid      m p-     let x = processCont pid+     let x = processReactCont pid      a <- readIORef x      return $ isJust a @@ -86,44 +137,105 @@   Dynamics $ \p ->   do let Dynamics m = queueRun $ processQueue pid      m p-     let x = processCont pid+     let x = processReactCont pid      a <- readIORef x      case a of        Nothing ->           return ()        Just c ->          do writeIORef x Nothing-            let Dynamics m  = enqueueCont (processQueue pid) (pointTime p) c+            let Dynamics m  = enqueue (processQueue pid) (pointTime p) $ +                              resumeContByParams c ()             m p  -- | Start the process with the specified ID at the desired time. runProcess :: Process () -> ProcessID -> Double -> Dynamics () runProcess (Process p) pid t =-  runCont m return-    where m = do y <- liftIO $ readIORef (processStarted pid)+  runCont m cont econt ccont (processCancelToken pid) (processCatchFlag pid)+    where cont  = return+          econt = throw+          ccont = return+          m = do y <- liftIO $ readIORef (processStarted pid)                  if y                     then error $                         "A process with such ID " ++                         "has been started already: runProc"                    else liftIO $ writeIORef (processStarted pid) True-                 Cont $ \c -> enqueueCont (processQueue pid) t c+                 Cont $ \c -> enqueue (processQueue pid) t $ +                              resumeContByParams c ()                  p pid +-- | Start the process with the specified ID at the current simulation time.+runProcessNow :: Process () -> ProcessID -> Dynamics ()+runProcessNow process pid =+  Dynamics $ \p ->+  do let Dynamics m = runProcess process pid (pointTime p)+     m p+ -- | Return the current process ID. processID :: Process ProcessID processID = Process $ \pid -> return pid --- | Create a new process ID.+-- | Create a new process ID without exception handling. newProcessID :: EventQueue -> Simulation ProcessID newProcessID q =   do x <- liftIO $ newIORef Nothing      y <- liftIO $ newIORef False+     c <- liftIO $ newIORef False+     t <- liftIO $ newIORef False+     i <- liftIO $ newIORef False+     z <- liftIO $ newIORef Nothing+     v <- liftIO $ newIORef 0      return ProcessID { processQueue   = q,                         processStarted = y,-                        processCont    = x }+                        processCatchFlag     = False,+                        processReactCont     = x, +                        processCancelRef     = c, +                        processCancelToken   = t,+                        processInterruptRef  = i,+                        processInterruptCont = z, +                        processInterruptVersion = v } +-- | Create a new process ID with capabilities of catching +-- the IOError exceptions and finalizing the computation. +-- The corresponded process will be slower than that one+-- which identifier is created with help of 'newProcessID'.+newProcessIDWithCatch :: EventQueue -> Simulation ProcessID+newProcessIDWithCatch q =+  do x <- liftIO $ newIORef Nothing+     y <- liftIO $ newIORef False+     c <- liftIO $ newIORef False+     t <- liftIO $ newIORef False+     i <- liftIO $ newIORef False+     z <- liftIO $ newIORef Nothing+     v <- liftIO $ newIORef 0+     return ProcessID { processQueue   = q,+                        processStarted = y,+                        processCatchFlag     = True,+                        processReactCont     = x, +                        processCancelRef     = c, +                        processCancelToken   = t,+                        processInterruptRef  = i,+                        processInterruptCont = z, +                        processInterruptVersion = v }++-- | Cancel a process with the specified ID.+cancelProcess :: ProcessID -> Dynamics ()+cancelProcess pid =+  Dynamics $ \p ->+  do z <- readIORef (processCancelRef pid) +     unless z $+       do writeIORef (processCancelRef pid) True+          writeIORef (processCancelToken pid) True++-- | Test whether the process with the specified ID is canceled.+processCanceled :: ProcessID -> Dynamics Bool+processCanceled pid =+  Dynamics $ \p ->+  readIORef (processCancelRef pid)+ instance Eq ProcessID where-  x == y = processCont x == processCont y    -- for the references are unique+  x == y = processReactCont x == processReactCont y    -- for the references are unique  instance Monad Process where   return  = returnP@@ -143,7 +255,7 @@    returnP :: a -> Process a {-# INLINE returnP #-}-returnP a = Process (\pid -> return a)+returnP a = Process $ \pid -> return a  bindP :: Process a -> (a -> Process b) -> Process b {-# INLINE bindP #-}@@ -164,3 +276,25 @@ liftIOP :: IO a -> Process a {-# INLINE liftIOP #-} liftIOP m = Process $ \pid -> liftIO m++-- | Exception handling within 'Process' computations.+catchProcess :: Process a -> (IOException -> Process a) -> Process a+catchProcess (Process m) h =+  Process $ \pid ->+  catchCont (m pid) $ \e ->+  let Process m' = h e in m' pid+                           +-- | A computation with finalization part.+finallyProcess :: Process a -> Process b -> Process a+finallyProcess (Process m) (Process m') =+  Process $ \pid ->+  finallyCont (m pid) (m' pid)++-- | Throw the exception with the further exception handling.+-- By some reasons, the standard 'throw' function per se is not handled +-- properly within 'Process' computations, although it will be still +-- handled if it will be hidden under the 'liftIO' function. The problem +-- arises namely with the @throw@ function, not 'IO' computations.+throwProcess :: IOException -> Process a+throwProcess = liftIO . throw+

@@ -0,0 +1,287 @@++-- |+-- Module     : Simulation.Aivika.Dynamics.Internal.Signal+-- Copyright  : Copyright (c) 2009-2012, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.4.1+--+-- This module defines the signal which we can subscribe handlers to. +-- These handlers can be disposed. The signal is triggered in the +-- current time point actuating the corresponded computations from +-- the handlers. +--++module Simulation.Aivika.Dynamics.Internal.Signal+       (Signal,+        SignalSource,+        newSignalSourceWithUpdate,+        newSignalSourceUnsafe,+        publishSignal,+        triggerSignal,+        handleSignal,+        handleSignal_,+        updateSignal,+        mapSignal,+        composeSignal,+        apSignal,+        filterSignal,+        merge2Signals,+        merge3Signals,+        merge4Signals,+        merge5Signals) where++import Data.IORef++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Dynamics.Internal.Dynamics+import Simulation.Aivika.Dynamics.Internal.Simulation++-- | The signal source that can publish its signal.+data SignalSource a =+  SignalSource { publishSignal :: Signal a,+                                  -- ^ Publish the signal.+                 triggerSignal :: a -> Dynamics ()+                                  -- ^ Trigger the signal actuating +                                  -- all its handlers at the current +                                  -- simulation time point.+               }+  +-- | The signal that can have disposable handlers.  +data Signal a =+  Signal { handleSignal :: (a -> Dynamics ()) -> +                           Simulation (Simulation ()),+           -- ^ Subscribe the handler to the specified +           -- signal and return a nested computation +           -- that, being applied, unsubscribes the +           -- handler from this signal.+           updateSignal :: Dynamics ()+           -- ^ Update the signal to its actual state.+         }+  +-- | The queue of signal handlers.+data SignalHandlerQueue a =+  SignalHandlerQueue { queueStart :: IORef (Maybe (SignalHandler a)),+                       queueEnd   :: IORef (Maybe (SignalHandler a)) }+  +-- | It contains the information about the disposable queue handler.+data SignalHandler a =+  SignalHandler { handlerComp :: a -> Dynamics (),+                  handlerPrev :: IORef (Maybe (SignalHandler a)),+                  handlerNext :: IORef (Maybe (SignalHandler a)) }++-- | Subscribe the handler to the specified signal.+-- To subscribe the disposable handlers, use function 'handleSignal'.+handleSignal_ :: Signal a -> (a -> Dynamics ()) -> Simulation ()+handleSignal_ signal h = +  do x <- handleSignal signal h+     return ()+     +-- | Create a new signal source with the specified update computation.+newSignalSourceWithUpdate :: Dynamics () -> Simulation (SignalSource a)+newSignalSourceWithUpdate update =+  Simulation $ \r ->+  do start <- newIORef Nothing+     end <- newIORef Nothing+     let queue  = SignalHandlerQueue { queueStart = start,+                                       queueEnd   = end }+         signal = Signal { handleSignal = handle, +                           updateSignal = update }+         source = SignalSource { publishSignal = signal, +                                 triggerSignal = trigger }+         handle h =+           Simulation $ \r ->+           do x <- enqueueSignalHandler queue h+              return $ liftIO $ dequeueSignalHandler queue x+         trigger a =+           Dynamics $ \p ->+           do let Dynamics m = update +              m p+              let h = queueStart queue+              triggerSignalHandlers h a p+     return source+     +-- | Create a new signal source that has no update computation.+newSignalSourceUnsafe :: Simulation (SignalSource a)+newSignalSourceUnsafe =+  Simulation $ \r ->+  do start <- newIORef Nothing+     end <- newIORef Nothing+     let queue  = SignalHandlerQueue { queueStart = start,+                                       queueEnd   = end }+         signal = Signal { handleSignal = handle, +                           updateSignal = update }+         source = SignalSource { publishSignal = signal, +                                 triggerSignal = trigger }+         handle h =+           Simulation $ \r ->+           do x <- enqueueSignalHandler queue h+              return $ liftIO $ dequeueSignalHandler queue x+         trigger a =+           Dynamics $ \p ->+           let h = queueStart queue+           in triggerSignalHandlers h a p+         update = return ()+     return source++-- | Trigger all next signal handlers.+triggerSignalHandlers :: IORef (Maybe (SignalHandler a)) -> a -> Point -> IO ()+{-# INLINE triggerSignalHandlers #-}+triggerSignalHandlers r a p =+  do x <- readIORef r+     case x of+       Nothing -> return ()+       Just h ->+         do let Dynamics m = handlerComp h a+            m p+            triggerSignalHandlers (handlerNext h) a p+            +-- | Enqueue the handler and return its representative in the queue.            +enqueueSignalHandler :: SignalHandlerQueue a -> (a -> Dynamics ()) -> IO (SignalHandler a)+enqueueSignalHandler q h = +  do tail <- readIORef (queueEnd q)+     case tail of+       Nothing ->+         do prev <- newIORef Nothing+            next <- newIORef Nothing+            let handler = SignalHandler { handlerComp = h,+                                          handlerPrev = prev,+                                          handlerNext = next }+            writeIORef (queueStart q) (Just handler)+            writeIORef (queueEnd q) (Just handler)+            return handler+       Just x ->+         do prev <- newIORef tail+            next <- newIORef Nothing+            let handler = SignalHandler { handlerComp = h,+                                          handlerPrev = prev,+                                          handlerNext = next }+            writeIORef (handlerNext x) (Just handler)+            writeIORef (queueEnd q) (Just handler)+            return handler++-- | Dequeue the handler representative.+dequeueSignalHandler :: SignalHandlerQueue a -> SignalHandler a -> IO ()+dequeueSignalHandler q h = +  do prev <- readIORef (handlerPrev h)+     case prev of+       Nothing ->+         do next <- readIORef (handlerNext h)+            case next of+              Nothing ->+                do writeIORef (queueStart q) Nothing+                   writeIORef (queueEnd q) Nothing+              Just y ->+                do writeIORef (handlerPrev y) Nothing+                   writeIORef (handlerNext h) Nothing+                   writeIORef (queueStart q) next+       Just x ->+         do next <- readIORef (handlerNext h)+            case next of+              Nothing ->+                do writeIORef (handlerPrev h) Nothing+                   writeIORef (handlerNext x) Nothing+                   writeIORef (queueEnd q) prev+              Just y ->+                do writeIORef (handlerPrev h) Nothing+                   writeIORef (handlerNext h) Nothing+                   writeIORef (handlerPrev y) prev+                   writeIORef (handlerNext x) next++-- | Map the signal according the specified function.+mapSignal :: (a -> b) -> Signal a -> Signal b+mapSignal f m =+  Signal { handleSignal = \h -> +            handleSignal m $ h . f, +           updateSignal = +             updateSignal m }++instance Functor Signal where+  fmap = mapSignal+  +-- | Filter only those signal values that satisfy to +-- the specified predicate.+filterSignal :: (a -> Bool) -> Signal a -> Signal a+filterSignal p m =+  Signal { handleSignal = \h ->+            handleSignal m $ \a ->+            when (p a) $ h a, +           updateSignal =+             updateSignal m }+  +-- | Merge two signals.+merge2Signals :: Signal a -> Signal a -> Signal a+merge2Signals m1 m2 =+  Signal { handleSignal = \h ->+            do x1 <- handleSignal m1 h+               x2 <- handleSignal m2 h+               return $ do { x1; x2 }, +           updateSignal =+             do updateSignal m1+                updateSignal m2 }++-- | Merge three signals.+merge3Signals :: Signal a -> Signal a -> Signal a -> Signal a+merge3Signals m1 m2 m3 =+  Signal { handleSignal = \h ->+            do x1 <- handleSignal m1 h+               x2 <- handleSignal m2 h+               x3 <- handleSignal m3 h+               return $ do { x1; x2; x3 },+           updateSignal =+             do updateSignal m1+                updateSignal m2 +                updateSignal m3 }++-- | Merge four signals.+merge4Signals :: Signal a -> Signal a -> Signal a -> +                 Signal a -> Signal a+merge4Signals m1 m2 m3 m4 =+  Signal { handleSignal = \h ->+            do x1 <- handleSignal m1 h+               x2 <- handleSignal m2 h+               x3 <- handleSignal m3 h+               x4 <- handleSignal m4 h+               return $ do { x1; x2; x3; x4 },+           updateSignal =+             do updateSignal m1+                updateSignal m2 +                updateSignal m3 +                updateSignal m4 }+           +-- | Merge five signals.+merge5Signals :: Signal a -> Signal a -> Signal a -> +                 Signal a -> Signal a -> Signal a+merge5Signals m1 m2 m3 m4 m5 =+  Signal { handleSignal = \h ->+            do x1 <- handleSignal m1 h+               x2 <- handleSignal m2 h+               x3 <- handleSignal m3 h+               x4 <- handleSignal m4 h+               x5 <- handleSignal m5 h+               return $ do { x1; x2; x3; x4; x5 },+           updateSignal =+             do updateSignal m1+                updateSignal m2 +                updateSignal m3 +                updateSignal m4+                updateSignal m5 }++-- | Compose the signal.+composeSignal :: (a -> Dynamics b) -> Signal a -> Signal b+composeSignal f m =+  Signal { handleSignal = \h ->+            handleSignal m (f >=> h),+           updateSignal = +             updateSignal m }+  +-- | Transform the signal.+apSignal :: Dynamics (a -> b) -> Signal a -> Signal b+apSignal f m =+  Signal { handleSignal = \h ->+            handleSignal m $ \a -> do { x <- f; h (x a) },+           updateSignal =+             updateSignal m }

@@ -0,0 +1,152 @@++-- |+-- Module     : Simulation.Aivika.Dynamics.LIFO+-- Copyright  : Copyright (c) 2009-2012, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.4.1+--+-- This module defines the LIFO queue.+--+module Simulation.Aivika.Dynamics.LIFO+       (LIFO,+        lifoQueue,+        lifoNull,+        lifoFull,+        lifoMaxCount,+        lifoCount,+        lifoLostCount,+        newLIFO,+        dequeueLIFO,+        tryDequeueLIFO,+        enqueueLIFO,+        tryEnqueueLIFO,+        enqueueLIFOOrLost) where++import Data.IORef+import Data.Array+import Data.Array.IO++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Dynamics+import Simulation.Aivika.Dynamics.Simulation+import Simulation.Aivika.Dynamics.EventQueue+import Simulation.Aivika.Dynamics.Process+import Simulation.Aivika.Dynamics.Resource++-- | Represents the LIFO queue with rule: last input - first output.+data LIFO a =+  LIFO { lifoQueue :: EventQueue,  -- ^ Return the event queue.+         lifoMaxCount :: Int,      -- ^ The maximum available number of items.+         lifoReadRes  :: Resource,+         lifoWriteRes :: Resource,+         lifoCountRef :: IORef Int,+         lifoLostCountRef :: IORef Int,+         lifoArray :: IOArray Int a }+  +-- | Create a new LIFO queue with the specified maximum available number of items.  +newLIFO :: EventQueue -> Int -> Simulation (LIFO a)  +newLIFO q count =+  do i <- liftIO $ newIORef 0+     l <- liftIO $ newIORef 0+     a <- liftIO $ newArray_ (0, count - 1)+     r <- newResourceWithCount q count 0+     w <- newResourceWithCount q count count+     return LIFO { lifoQueue = q,+                   lifoMaxCount = count,+                   lifoReadRes  = r,+                   lifoWriteRes = w,+                   lifoCountRef = i,+                   lifoLostCountRef = l,+                   lifoArray = a }+  +-- | Test whether the LIFO queue is empty.+lifoNull :: LIFO a -> Dynamics Bool+lifoNull lifo =+  do a <- lifoCount lifo+     return (a == 0)++-- | Test whether the LIFO queue is full.+lifoFull :: LIFO a -> Dynamics Bool+lifoFull lifo =+  do a <- lifoCount lifo+     return (a == lifoMaxCount lifo)++-- | Return the queue size.+lifoCount :: LIFO a -> Dynamics Int+lifoCount lifo =+  liftIO $ readIORef (lifoCountRef lifo)+  +-- | Return the number of lost items.+lifoLostCount :: LIFO a -> Dynamics Int+lifoLostCount lifo =+  liftIO $ readIORef (lifoLostCountRef lifo)+  +-- | Dequeue from the LIFO queue suspending the process if+-- the queue is empty.+dequeueLIFO :: LIFO a -> Process a  +dequeueLIFO lifo =+  do requestResource (lifoReadRes lifo)+     a <- liftIO $ dequeueImpl lifo+     releaseResource (lifoWriteRes lifo)+     return a+  +-- | Try to dequeue from the LIFO queue immediately.  +tryDequeueLIFO :: LIFO a -> Dynamics (Maybe a)+tryDequeueLIFO lifo =+  do x <- tryRequestResourceInDynamics (lifoReadRes lifo)+     if x +       then do a <- liftIO $ dequeueImpl lifo+               releaseResourceInDynamics (lifoWriteRes lifo)+               return $ Just a+       else return Nothing++-- | Enqueue the item in the LIFO queue suspending the process if+-- the queue is full.  +enqueueLIFO :: LIFO a -> a -> Process ()+enqueueLIFO lifo a =+  do requestResource (lifoWriteRes lifo)+     liftIO $ enqueueImpl lifo a+     releaseResource (lifoReadRes lifo)+     +-- | Try to enqueue the item in the LIFO queue. Return 'False' in+-- the monad if the queue is full.+tryEnqueueLIFO :: LIFO a -> a -> Dynamics Bool+tryEnqueueLIFO lifo a =+  do x <- tryRequestResourceInDynamics (lifoWriteRes lifo)+     if x +       then do liftIO $ enqueueImpl lifo a+               releaseResourceInDynamics (lifoReadRes lifo)+               return True+       else return False++-- | Try to enqueue the item in the LIFO queue. If the queue is full+-- then the item will be lost.+enqueueLIFOOrLost :: LIFO a -> a -> Dynamics ()+enqueueLIFOOrLost lifo a =+  do x <- tryRequestResourceInDynamics (lifoWriteRes lifo)+     if x+       then do liftIO $ enqueueImpl lifo a+               releaseResourceInDynamics (lifoReadRes lifo)+       else liftIO $ modifyIORef (lifoLostCountRef lifo) $ (+) 1++-- | An implementation method.+dequeueImpl :: LIFO a -> IO a+dequeueImpl lifo =+  do i <- readIORef (lifoCountRef lifo)+     let j = i - 1+     a <- j `seq` readArray (lifoArray lifo) j+     writeArray (lifoArray lifo) j undefined+     writeIORef (lifoCountRef lifo) j+     return a++-- | An implementation method.+enqueueImpl :: LIFO a -> a -> IO ()+enqueueImpl lifo a =+  do i <- readIORef (lifoCountRef lifo)+     let j = i + 1+     a `seq` writeArray (lifoArray lifo) i a+     j `seq` writeIORef (lifoCountRef lifo) j

@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Dynamics.Parameter--- Copyright  : Copyright (c) 2009-2011, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2012, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.0.3+-- Tested with: GHC 7.4.1 -- -- This module defines the parameters of simulation experiments. --@@ -25,35 +25,35 @@  -- | Create a thread-safe parameter that returns always the same value during the simulation run,  -- where the value is recalculated for each new run.-newParameter :: IO a -> IO (Dynamics a)+newParameter :: IO a -> IO (Simulation a) newParameter a = newIndexedParameter $ \_ -> a  -- | Create a thread-safe parameter that returns always the same value during the simulation run, -- where the value is taken consequently from the specified table based on the number of the  -- current run starting from zero. After all values from the table are used, it takes the first  -- value of the table, then the second one and so on.-newTableParameter :: Array Int a -> IO (Dynamics a)+newTableParameter :: Array Int a -> IO (Simulation a) newTableParameter t = newIndexedParameter (\i -> return $ t ! (((i - i1) `mod` n) + i1))   where (i1, i2) = bounds t         n = i2 - i1 + 1  -- | Create a thread-safe parameter that returns always the same value during the simulation run,  -- where the value depends on the number of this run starting from zero.-newIndexedParameter :: (Int -> IO a) -> IO (Dynamics a)+newIndexedParameter :: (Int -> IO a) -> IO (Simulation a) newIndexedParameter f =    do lock <- newMVar ()      dict <- newIORef M.empty-     return $ Dynamics $ \p ->-       do let i = runIndex $ pointRun p+     return $ Simulation $ \r ->+       do let i = runIndex r           m <- readIORef dict           if M.member i m             then do let Just v = M.lookup i m                     return v             else withMVar lock $                   \() -> do { m <- readIORef dict;-                            if M.member i m-                            then do let Just v = M.lookup i m-                                    return v-                            else do v <- f i-                                    writeIORef dict $ M.insert i v m-                                    return v }+                             if M.member i m+                             then do let Just v = M.lookup i m+                                     return v+                             else do v <- f i+                                     writeIORef dict $ M.insert i v m+                                     return v }

@@ -22,12 +22,21 @@         Process,         processQueue,         newProcessID,+        newProcessIDWithCatch,         holdProcess,+        interruptProcess,+        processInterrupted,         passivateProcess,         processPassive,         reactivateProcess,         processID,-        runProcess) where+        cancelProcess,+        processCanceled,+        runProcess,+        runProcessNow,+        catchProcess,+        finallyProcess,+        throwProcess) where  import Simulation.Aivika.Dynamics.Internal.Dynamics import Simulation.Aivika.Dynamics.Internal.Process

@@ -12,6 +12,8 @@ module Simulation.Aivika.Dynamics.Ref        (Ref,         refQueue,+        refChanged,+        refChanged_,         newRef,         readRef,         writeRef,@@ -24,6 +26,7 @@ import Simulation.Aivika.Dynamics.Internal.Simulation import Simulation.Aivika.Dynamics.Internal.Dynamics import Simulation.Aivika.Dynamics.EventQueue+import Simulation.Aivika.Dynamics.Internal.Signal  -- | The 'Ref' type represents a mutable variable similar to the 'IORef' variable  -- but only bound to some event queue, which makes the variable coordinated @@ -31,35 +34,56 @@ data Ref a =    Ref { refQueue :: EventQueue,  -- ^ Return the bound event queue.         refRun   :: Dynamics (),-        refValue :: IORef a }+        refValue :: IORef a, +        refChangedSource :: SignalSource a, +        refUpdatedSource :: SignalSource a }  -- | Create a new reference bound to the specified event queue. newRef :: EventQueue -> a -> Simulation (Ref a) newRef q a =   do x <- liftIO $ newIORef a+     s <- newSignalSourceUnsafe+     u <- newSignalSourceWithUpdate (queueRun q)      return Ref { refQueue = q,                   refRun   = queueRun q,-                  refValue = x }+                  refValue = x, +                  refChangedSource = s, +                  refUpdatedSource = u }       -- | Read the value of a reference, forcing the bound event queue to raise  -- the events in case of need. readRef :: Ref a -> Dynamics a readRef r = Dynamics $ \p -> -  do let Dynamics m = refRun r-     m p+  do invokeDynamics p $ refRun r      readIORef (refValue r)  -- | Write a new value into the reference. writeRef :: Ref a -> a -> Dynamics () writeRef r a = Dynamics $ \p -> -  a `seq` writeIORef (refValue r) a+  do a `seq` writeIORef (refValue r) a+     invokeDynamics p $ triggerSignal (refChangedSource r) a  -- | Mutate the contents of the reference, forcing the bound event queue to -- raise all pending events in case of need. modifyRef :: Ref a -> (a -> a) -> Dynamics () modifyRef r f = Dynamics $ \p -> -  do let Dynamics m = refRun r-     m p+  do invokeDynamics p $ refRun r      a <- readIORef (refValue r)      let b = f a      b `seq` writeIORef (refValue r) b+     invokeDynamics p $ triggerSignal (refChangedSource r) b++-- | Return a signal that notifies about every change of the reference state.+refChanged :: Ref a -> Signal a+refChanged r = merge2Signals m1 m2+  where+    m1 = publishSignal (refChangedSource r)+    m2 = publishSignal (refUpdatedSource r)++-- | Return a signal that notifies about every change of the reference state.+refChanged_ :: Ref a -> Signal ()+refChanged_ r = mapSignal (const ()) $ refChanged r++invokeDynamics :: Point -> Dynamics a -> IO a+{-# INLINE invokeDynamics #-}+invokeDynamics p (Dynamics m) = m p

@@ -13,14 +13,19 @@ module Simulation.Aivika.Dynamics.Resource        (Resource,         newResource,+        newResourceWithCount,         resourceQueue,         resourceInitCount,         resourceCount,         requestResource,-        releaseResource) where+        tryRequestResourceInDynamics,+        releaseResource,+        releaseResourceInDynamics,+        usingResource) where  import Data.IORef import Control.Monad+import Control.Monad.Trans  import Simulation.Aivika.Dynamics.Internal.Simulation import Simulation.Aivika.Dynamics.Internal.Dynamics@@ -36,7 +41,7 @@              resourceInitCount :: Int,              -- ^ Return the initial count of the resource.              resourceCountRef  :: IORef Int, -             resourceWaitQueue :: Q.Queue (() -> Dynamics ())}+             resourceWaitQueue :: Q.Queue (ContParams ())}  instance Eq Resource where   x == y = resourceCountRef x == resourceCountRef y  -- unique references@@ -52,12 +57,33 @@                        resourceCountRef  = countRef,                        resourceWaitQueue = waitQueue } +-- | Create a new resource with the specified initial count.+-- The third argument specifies how the resource is consumed +-- at the beginning, i.e. it defines the current count, which must be +-- non-negative and less or equal to the initial count.+newResourceWithCount :: EventQueue -> Int -> Int -> Simulation Resource+newResourceWithCount q initCount count = do+  when (count < 0) $+    error $+    "The resource count cannot be negative: " +++    "newResourceWithCount."+  when (count > initCount) $+    error $+    "The resource count cannot be greater than " +++    "its initial value: newResourceWithCount."+  Simulation $ \r ->+    do countRef  <- newIORef count+       waitQueue <- Q.newQueue+       return Resource { resourceQueue     = q,+                         resourceInitCount = initCount,+                         resourceCountRef  = countRef,+                         resourceWaitQueue = waitQueue }+ -- | Return the current count of the resource. resourceCount :: Resource -> Dynamics Int resourceCount r =   Dynamics $ \p ->-  do let Dynamics m = queueRun (resourceQueue r)-     m p+  do invokeDynamics p $ queueRun (resourceQueue r)      readIORef (resourceCountRef r)  -- | Request for the resource decreasing its count in case of success,@@ -65,7 +91,7 @@ -- process releases the resource. requestResource :: Resource -> Process () requestResource r =-  Process $ \_ ->+  Process $ \pid ->   Cont $ \c ->   Dynamics $ \p ->   do a <- readIORef (resourceCountRef r)@@ -73,28 +99,73 @@        then Q.enqueue (resourceWaitQueue r) c        else do let a' = a - 1                a' `seq` writeIORef (resourceCountRef r) a'-               let Dynamics m = c ()-               m p+               invokeDynamics p $ resumeContByParams c ()  -- | Release the resource increasing its count and resuming one of the -- previously suspended processes as possible. releaseResource :: Resource -> Process ()-releaseResource r =+releaseResource r =    Process $ \_ ->   Cont $ \c ->   Dynamics $ \p ->+  do invokeDynamics p $ releaseResourceUnsafe r+     invokeDynamics p $ resumeContByParams c ()++-- | Release the resource increasing its count and resuming one of the+-- previously suspended processes as possible.+releaseResourceInDynamics :: Resource -> Dynamics ()+releaseResourceInDynamics r =+  Dynamics $ \p ->+  do invokeDynamics p $ queueRun (resourceQueue r)+     invokeDynamics p $ releaseResourceUnsafe r++releaseResourceUnsafe :: Resource -> Dynamics ()+{-# INLINE releaseResourceUnsafe #-}+releaseResourceUnsafe r =+  Dynamics $ \p ->   do a <- readIORef (resourceCountRef r)      let a' = a + 1      when (a' > resourceInitCount r) $        error $        "The resource count cannot be greater than " ++-       "its initial value: releaseResource."+       "its initial value: releaseResourceUnsafe."      f <- Q.queueNull (resourceWaitQueue r)      if f         then a' `seq` writeIORef (resourceCountRef r) a'-       else do c2 <- Q.queueFront (resourceWaitQueue r)+       else do c <- Q.queueFront (resourceWaitQueue r)                Q.dequeue (resourceWaitQueue r)-               let Dynamics m = enqueueCont (resourceQueue r) (pointTime p) c2-               m p-     let Dynamics m' = c ()-     m' p+               invokeDynamics p $ enqueue (resourceQueue r) (pointTime p) $+                 Dynamics $ \p ->+                 do z <- contParamsCanceled c+                    if z+                      then do invokeDynamics p $ releaseResourceUnsafe r+                              invokeDynamics p $ resumeContByParams c ()+                      else invokeDynamics p $ resumeContByParams c ()++-- | Try to request for the resource decreasing its count in case of success+-- and returning 'True' in the 'Dynamics' monad; otherwise, returning 'False'.+tryRequestResourceInDynamics :: Resource -> Dynamics Bool+tryRequestResourceInDynamics r =+  Dynamics $ \p ->+  do invokeDynamics p $ queueRun (resourceQueue r)+     a <- readIORef (resourceCountRef r)+     if a == 0 +       then return False+       else do let a' = a - 1+               a' `seq` writeIORef (resourceCountRef r) a'+               return True+               +-- | Acquire the resource, perform some action and safely release the resource               +-- in the end, even if the 'IOException' was raised within the action. +-- The process identifier must be created with support of exception +-- handling, i.e. with help of function 'newProcessIDWithCatch'. Unfortunately,+-- such processes are slower than those that are created with help of+-- other function 'newProcessID'.+usingResource :: Resource -> Process a -> Process a+usingResource r m =+  do requestResource r+     finallyProcess m $ releaseResource r++invokeDynamics :: Point -> Dynamics a -> IO a+{-# INLINE invokeDynamics #-}+invokeDynamics p (Dynamics m) = m p 

@@ -0,0 +1,108 @@++-- |+-- Module     : Simulation.Aivika.Dynamics.Signal+-- Copyright  : Copyright (c) 2009-2012, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.4.1+--+-- This module defines the signal which we can subscribe handlers to. +-- These handlers can be disposed. The signal is triggered in the +-- current time point actuating the corresponded computations from +-- the handlers. +--+module Simulation.Aivika.Dynamics.Signal+       (Signal,+        SignalSource,+        newSignalSource,+        newSignalSourceWithUpdate,+        publishSignal,+        triggerSignal,+        handleSignal,+        handleSignal_,+        updateSignal,+        awaitSignal,+        mapSignal,+        composeSignal,+        apSignal,+        filterSignal,+        merge2Signals,+        merge3Signals,+        merge4Signals,+        merge5Signals,+        SignalHistory,+        signalHistorySignal,+        newSignalHistory,+        readSignalHistory) where++import Data.IORef+import Data.Array++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Dynamics.EventQueue+import Simulation.Aivika.Dynamics.Internal.Signal+import Simulation.Aivika.Dynamics.Internal.Simulation+import Simulation.Aivika.Dynamics.Internal.Dynamics+import Simulation.Aivika.Dynamics.Internal.Cont+import Simulation.Aivika.Dynamics.Internal.Process++import qualified Simulation.Aivika.Vector as V+import qualified Simulation.Aivika.UVector as UV++-- | Create a new signal source when the state depends on the event queue.+newSignalSource :: EventQueue -> Simulation (SignalSource a)+newSignalSource queue = +  newSignalSourceWithUpdate $ queueRun queue++-- | Await the signal.+awaitSignal :: Signal a -> Process a+awaitSignal signal =+  Process $ \pid ->+  Cont $ \c ->+  Dynamics $ \p ->+  do r <- newIORef Nothing+     let Simulation m = +           handleSignal signal $ +           \a -> Dynamics $ +                 \p -> do x <- readIORef r+                          case x of+                            Nothing ->+                              error "The signal was lost: awaitSignal."+                            Just x ->+                              do let Simulation m = x+                                 m $ pointRun p+                                 let Dynamics m = resumeContByParams c a+                                 m p+     h <- m $ pointRun p+     writeIORef r $ Just h+          +-- | Represents the history of the signal values.+data SignalHistory a =+  SignalHistory { signalHistorySignal :: Signal a,  +                  -- ^ The signal for which the history is created.+                  signalHistoryTimes  :: UV.UVector Double,+                  signalHistoryValues :: V.Vector a }++-- | Create a history of the signal values.+newSignalHistory :: Signal a -> Simulation (SignalHistory a)+newSignalHistory signal =+  do ts <- liftIO UV.newVector+     xs <- liftIO V.newVector+     handleSignal_ signal $ \a ->+       Dynamics $ \p ->+       do liftIO $ UV.appendVector ts (pointTime p)+          liftIO $ V.appendVector xs a+     return SignalHistory { signalHistorySignal = signal,+                            signalHistoryTimes  = ts,+                            signalHistoryValues = xs }+       +-- | Read the history of signal values.+readSignalHistory :: SignalHistory a -> Dynamics (Array Int Double, Array Int a)+readSignalHistory history =+  do updateSignal $ signalHistorySignal history+     xs <- liftIO $ UV.freezeVector (signalHistoryTimes history)+     ys <- liftIO $ V.freezeVector (signalHistoryValues history)+     return (xs, ys)     

@@ -15,6 +15,8 @@ module Simulation.Aivika.Dynamics.UVar        (UVar,         uvarQueue,+        uvarChanged,+        uvarChanged_,         newUVar,         readUVar,         writeUVar,@@ -29,6 +31,7 @@ import Simulation.Aivika.Dynamics.Internal.Simulation import Simulation.Aivika.Dynamics.Internal.Dynamics import Simulation.Aivika.Dynamics.EventQueue+import Simulation.Aivika.Dynamics.Internal.Signal  import qualified Simulation.Aivika.UVector as UV @@ -38,7 +41,9 @@   UVar { uvarQueue :: EventQueue, -- ^ Return the bound event queue.          uvarRun   :: Dynamics (),          uvarXS    :: UV.UVector Double, -         uvarYS    :: UV.UVector a}+         uvarYS    :: UV.UVector a,+         uvarChangedSource :: SignalSource a, +         uvarUpdatedSource :: SignalSource a }       -- | Create a new variable bound to the specified event queue. newUVar :: (MArray IOUArray a IO) => EventQueue -> a -> Simulation (UVar a)@@ -48,18 +53,21 @@      ys <- UV.newVector      UV.appendVector xs $ spcStartTime $ runSpecs r      UV.appendVector ys a+     s  <- invokeSimulation r newSignalSourceUnsafe+     u  <- invokeSimulation r $ newSignalSourceWithUpdate $ queueRun q      return UVar { uvarQueue = q,                    uvarRun   = queueRun q,                    uvarXS = xs,-                   uvarYS = ys }+                   uvarYS = ys, +                   uvarChangedSource = s, +                   uvarUpdatedSource = u }  -- | Read the value of a variable, forcing the bound event queue to raise  -- the events in case of need. readUVar :: (MArray IOUArray a IO) => UVar a -> Dynamics a readUVar v =   Dynamics $ \p ->-  do let Dynamics m = uvarRun v-     m p+  do invokeDynamics p $ uvarRun v      let xs = uvarXS v          ys = uvarYS v          t  = pointTime p@@ -80,6 +88,7 @@   do let xs = uvarXS v          ys = uvarYS v          t  = pointTime p+         s  = uvarChangedSource v      count <- UV.vectorCount xs      let i = count - 1      x <- UV.readVector xs i@@ -89,17 +98,18 @@             then UV.writeVector ys i $! a             else do UV.appendVector xs t                     UV.appendVector ys $! a+     invokeDynamics p $ triggerSignal s a  -- | Mutate the contents of the variable, forcing the bound event queue to -- raise all pending events in case of need. modifyUVar :: (MArray IOUArray a IO) => UVar a -> (a -> a) -> Dynamics () modifyUVar v f =   Dynamics $ \p ->-  do let Dynamics m = uvarRun v-     m p+  do invokeDynamics p $ uvarRun v      let xs = uvarXS v          ys = uvarYS v          t  = pointTime p+         s  = uvarChangedSource v      count <- UV.vectorCount xs      let i = count - 1      x <- UV.readVector xs i@@ -107,15 +117,21 @@        then error "Cannot update the past data: modifyUVar."        else if t == x             then do a <- UV.readVector ys i-                    UV.writeVector ys i $! f a+                    let b = f a+                    UV.writeVector ys i $! b+                    invokeDynamics p $ triggerSignal s b             else do i <- UV.vectorBinarySearch xs t                     if i >= 0                       then do a <- UV.readVector ys i+                              let b = f a                               UV.appendVector xs t-                              UV.appendVector ys $! f a+                              UV.appendVector ys $! b+                              invokeDynamics p $ triggerSignal s b                       else do a <- UV.readVector ys $ - (i + 1) - 1+                              let b = f a                               UV.appendVector xs t-                              UV.appendVector ys $! f a+                              UV.appendVector ys $! b+                              invokeDynamics p $ triggerSignal s b  -- | Freeze the variable and return in arrays the time points and corresponded  -- values when the variable had changed.@@ -123,8 +139,25 @@               UVar a -> Dynamics (Array Int Double, Array Int a) freezeUVar v =   Dynamics $ \p ->-  do let Dynamics m = uvarRun v-     m p+  do invokeDynamics p $ uvarRun v      xs <- UV.freezeVector (uvarXS v)      ys <- UV.freezeVector (uvarYS v)      return (xs, ys)+     +-- | Return a signal that notifies about every change of the variable state.+uvarChanged :: UVar a -> Signal a+uvarChanged v = merge2Signals m1 m2+  where m1 = publishSignal (uvarChangedSource v)+        m2 = publishSignal (uvarUpdatedSource v)++-- | Return a signal that notifies about every change of the variable state.+uvarChanged_ :: UVar a -> Signal ()+uvarChanged_ v = mapSignal (const ()) $ uvarChanged v          ++invokeDynamics :: Point -> Dynamics a -> IO a+{-# INLINE invokeDynamics #-}+invokeDynamics p (Dynamics m) = m p++invokeSimulation :: Run -> Simulation a -> IO a+{-# INLINE invokeSimulation #-}+invokeSimulation r (Simulation m) = m r

@@ -13,6 +13,8 @@ module Simulation.Aivika.Dynamics.Var        (Var,         varQueue,+        varChanged,+        varChanged_,         newVar,         readVar,         writeVar,@@ -26,6 +28,7 @@ import Simulation.Aivika.Dynamics.Internal.Simulation import Simulation.Aivika.Dynamics.Internal.Dynamics import Simulation.Aivika.Dynamics.EventQueue+import Simulation.Aivika.Dynamics.Internal.Signal  import qualified Simulation.Aivika.Vector as V import qualified Simulation.Aivika.UVector as UV@@ -38,7 +41,9 @@   Var { varQueue :: EventQueue,  -- ^ Return the bound event queue.         varRun   :: Dynamics (),         varXS    :: UV.UVector Double, -        varYS    :: V.Vector a}+        varYS    :: V.Vector a,+        varChangedSource :: SignalSource a, +        varUpdatedSource :: SignalSource a }       -- | Create a new variable bound to the specified event queue. newVar :: EventQueue -> a -> Simulation (Var a)@@ -48,18 +53,21 @@      ys <- V.newVector      UV.appendVector xs $ spcStartTime $ runSpecs r      V.appendVector ys a+     s  <- invokeSimulation r newSignalSourceUnsafe+     u  <- invokeSimulation r $ newSignalSourceWithUpdate $ queueRun q      return Var { varQueue = q,                   varRun   = queueRun q,                   varXS = xs,-                  varYS = ys }+                  varYS = ys, +                  varChangedSource = s, +                  varUpdatedSource = u }  -- | Read the value of a variable, forcing the bound event queue to raise  -- the events in case of need. readVar :: Var a -> Dynamics a readVar v =   Dynamics $ \p ->-  do let Dynamics m = varRun v-     m p+  do invokeDynamics p $ varRun v      let xs = varXS v          ys = varYS v          t  = pointTime p@@ -80,6 +88,7 @@   do let xs = varXS v          ys = varYS v          t  = pointTime p+         s  = varChangedSource v      count <- UV.vectorCount xs      let i = count - 1      x <- UV.readVector xs i@@ -89,17 +98,18 @@             then V.writeVector ys i $! a             else do UV.appendVector xs t                     V.appendVector ys $! a+     invokeDynamics p $ triggerSignal s a  -- | Mutate the contents of the variable, forcing the bound event queue to -- raise all pending events in case of need. modifyVar :: Var a -> (a -> a) -> Dynamics () modifyVar v f =   Dynamics $ \p ->-  do let Dynamics m = varRun v-     m p+  do invokeDynamics p $ varRun v      let xs = varXS v          ys = varYS v          t  = pointTime p+         s  = varChangedSource v      count <- UV.vectorCount xs      let i = count - 1      x <- UV.readVector xs i@@ -107,23 +117,46 @@        then error "Cannot update the past data: modifyVar."        else if t == x             then do a <- V.readVector ys i-                    V.writeVector ys i $! f a+                    let b = f a+                    V.writeVector ys i $! b+                    invokeDynamics p $ triggerSignal s b             else do i <- UV.vectorBinarySearch xs t                     if i >= 0                       then do a <- V.readVector ys i+                              let b = f a                               UV.appendVector xs t-                              V.appendVector ys $! f a+                              V.appendVector ys $! b+                              invokeDynamics p $ triggerSignal s b                       else do a <- V.readVector ys $ - (i + 1) - 1+                              let b = f a                               UV.appendVector xs t-                              V.appendVector ys $! f a+                              V.appendVector ys $! b+                              invokeDynamics p $ triggerSignal s b  -- | Freeze the variable and return in arrays the time points and corresponded  -- values when the variable had changed. freezeVar :: Var a -> Dynamics (Array Int Double, Array Int a) freezeVar v =   Dynamics $ \p ->-  do let Dynamics m = varRun v-     m p+  do invokeDynamics p $ varRun v      xs <- UV.freezeVector (varXS v)      ys <- V.freezeVector (varYS v)      return (xs, ys)+     +-- | Return a signal that notifies about every change of the variable state.+varChanged :: Var a -> Signal a+varChanged v = merge2Signals m1 m2+  where m1 = publishSignal (varChangedSource v)+        m2 = publishSignal (varUpdatedSource v)++-- | Return a signal that notifies about every change of the variable state.+varChanged_ :: Var a -> Signal ()+varChanged_ v = mapSignal (const ()) $ varChanged v     ++invokeDynamics :: Point -> Dynamics a -> IO a+{-# INLINE invokeDynamics #-}+invokeDynamics p (Dynamics m) = m p++invokeSimulation :: Run -> Simulation a -> IO a+{-# INLINE invokeSimulation #-}+invokeSimulation r (Simulation m) = m r

@@ -20,6 +20,9 @@         readVector,          writeVector,          vectorBinarySearch,+        vectorInsert,+        vectorDeleteAt,+        vectorIndex,         freezeVector) where   import Data.Array@@ -127,4 +130,59 @@   do vector' <- copyVector vector      array   <- readIORef (vectorArrayRef vector')      freeze array+     +     +-- | Insert the element in the vector at the specified index.+vectorInsert :: (MArray IOUArray a IO) => UVector a -> Int -> a -> IO ()          +vectorInsert vector index item =+  do count <- readIORef (vectorCountRef vector)+     when (index < 0) $+       error $+       "Index cannot be " +++       "negative: vectorInsert."+     when (index > count) $+       error $+       "Index cannot be greater " +++       "than the count: vectorInsert."+     vectorEnsureCapacity vector (count + 1)+     array <- readIORef (vectorArrayRef vector)+     forM_ [count, count - 1 .. index + 1] $ \i ->+       do x <- readArray array (i - 1)+          writeArray array i x+     writeArray array index item+     writeIORef (vectorCountRef vector) (count + 1)+     +-- | Delete the element at the specified index.+vectorDeleteAt :: (MArray IOUArray a IO) => UVector a -> Int -> IO ()+vectorDeleteAt vector index =+  do count <- readIORef (vectorCountRef vector)+     when (index < 0) $+       error $+       "Index cannot be " +++       "negative: vectorDeleteAt."+     when (index >= count) $+       error $+       "Index must be less " +++       "than the count: vectorDeleteAt."+     array <- readIORef (vectorArrayRef vector)+     forM_ [index, index + 1 .. count - 2] $ \i ->+       do x <- readArray array (i + 1)+          writeArray array i x+     writeArray array (count - 1) undefined+     writeIORef (vectorCountRef vector) (count - 1)+     +-- | Return the index of the item or -1.     +vectorIndex :: (MArray IOUArray a IO, Eq a) => +               UVector a -> a -> IO Int+vectorIndex vector item =+  do count <- readIORef (vectorCountRef vector)+     array <- readIORef (vectorArrayRef vector)+     let loop index =+           if index >= count+           then return $ -1+           else do x <- readArray array index+                   if item == x+                     then return index+                     else loop $ index + 1+     loop 0      

@@ -18,6 +18,9 @@         readVector,          writeVector,         vectorBinarySearch,+        vectorInsert,+        vectorDeleteAt,+        vectorIndex,         freezeVector) where   import Data.Array@@ -125,3 +128,55 @@      array   <- readIORef (vectorArrayRef vector')      freeze array      +-- | Insert the element in the vector at the specified index.+vectorInsert :: Vector a -> Int -> a -> IO ()          +vectorInsert vector index item =+  do count <- readIORef (vectorCountRef vector)+     when (index < 0) $+       error $+       "Index cannot be " +++       "negative: vectorInsert."+     when (index > count) $+       error $+       "Index cannot be greater " +++       "than the count: vectorInsert."+     vectorEnsureCapacity vector (count + 1)+     array <- readIORef (vectorArrayRef vector)+     forM_ [count, count - 1 .. index + 1] $ \i ->+       do x <- readArray array (i - 1)+          writeArray array i x+     writeArray array index item+     writeIORef (vectorCountRef vector) (count + 1)+     +-- | Delete the element at the specified index.+vectorDeleteAt :: Vector a -> Int -> IO ()+vectorDeleteAt vector index =+  do count <- readIORef (vectorCountRef vector)+     when (index < 0) $+       error $+       "Index cannot be " +++       "negative: vectorDeleteAt."+     when (index >= count) $+       error $+       "Index must be less " +++       "than the count: vectorDeleteAt."+     array <- readIORef (vectorArrayRef vector)+     forM_ [index, index + 1 .. count - 2] $ \i ->+       do x <- readArray array (i + 1)+          writeArray array i x+     writeArray array (count - 1) undefined+     writeIORef (vectorCountRef vector) (count - 1)+     +-- | Return the index of the item or -1.     +vectorIndex :: Eq a => Vector a -> a -> IO Int+vectorIndex vector item =+  do count <- readIORef (vectorCountRef vector)+     array <- readIORef (vectorArrayRef vector)+     let loop index =+           if index >= count+           then return $ -1+           else do x <- readArray array index+                   if item == x+                     then return index+                     else loop $ index + 1+     loop 0

@@ -1,5 +1,5 @@ name:            aivika-version:         0.3+version:         0.4 synopsis:        A multi-paradigm simulation library description:     Aivika is a small simulation library that covers many paradigms. @@ -27,8 +27,8 @@     .     The PDF documentation is available at      <https://github.com/dsorokin/aivika/blob/master/doc/aivika.pdf>.-    Please note that the documentation is obsolete and it corresponds to -    the previous version but it can still be helpful.+    Please note that the documentation is outdated and it corresponds to +    version 0.2 but it can still be helpful.     . category:        Simulation license:         BSD3@@ -39,7 +39,7 @@ homepage:        http://github.com/dsorokin/aivika cabal-version:   >= 1.2.0 build-type:      Simple-tested-with:     GHC == 7.0.4+tested-with:     GHC == 7.4.1  extra-source-files:  examples/BassDiffusion.hs                      examples/ChemicalReaction.hs@@ -69,6 +69,10 @@                      Simulation.Aivika.Dynamics.SystemDynamics                      Simulation.Aivika.Dynamics.UVar                      Simulation.Aivika.Dynamics.Var+                     Simulation.Aivika.Dynamics.FIFO+                     Simulation.Aivika.Dynamics.LIFO+                     Simulation.Aivika.Dynamics.Buffer+                     Simulation.Aivika.Dynamics.Signal                      Simulation.Aivika.Statistics                      Simulation.Aivika.PriorityQueue                      Simulation.Aivika.Queue@@ -81,6 +85,7 @@                      Simulation.Aivika.Dynamics.Internal.Memo                      Simulation.Aivika.Dynamics.Internal.Interpolate                      Simulation.Aivika.Dynamics.Internal.Fold+                     Simulation.Aivika.Dynamics.Internal.Signal                      Simulation.Aivika.Vector                      Simulation.Aivika.UVector                      

@@ -95,9 +95,9 @@      adopters <- newRef q 0      ps <- createPersons q      definePersons ps potentialAdopters adopters-     runDynamicsInStart $+     runDynamicsInStartTime $        activatePersons ps-     runDynamics $+     runDynamicsInIntegTimes $        do i1 <- readRef potentialAdopters           i2 <- readRef adopters           return [i1, i2]

@@ -21,6 +21,6 @@      integDiff integA (- ka * a)      integDiff integB (ka * a - kb * b)      integDiff integC (kb * b)-     runDynamicsInFinal $ sequence [a, b, c]+     runDynamicsInStopTime $ sequence [a, b, c]  main = runSimulation model specs >>= print

@@ -53,6 +53,6 @@      integDiff shipsInteg shipBuildingRate      integDiff totalProfitInteg annualProfit      -- results ---     runDynamicsInFinal annualProfit+     runDynamicsInStopTime annualProfit  main = runSimulation model specs >>= print

@@ -344,19 +344,19 @@      furnace <- newFurnace queue      pid <- newProcessID queue      -     runDynamicsInStart $+     runDynamicsInStartTime $        initializeFurnace furnace            -- get the furnace iterator      iterator <- iterateFurnace furnace            -- accept input ingots-     runDynamicsInStart $+     runDynamicsInStartTime $        do t0 <- starttime           runProcess (processFurnace furnace) pid t0            -- run the model in the final time point-     runDynamicsInFinal $+     runDynamicsInStopTime $        do iterator   --  iterate in each time point                     -- the ingots

@@ -59,12 +59,12 @@               holdProcess repairTime               machine          -     runDynamicsInStart $+     runDynamicsInStartTime $        do t0 <- starttime           runProcess machine pid1 t0           runProcess machine pid2 t0      -     runDynamicsInFinal $+     runDynamicsInStopTime $        do x <- readRef totalUpTime           y <- stoptime           return $ x / (2 * y)

@@ -63,14 +63,14 @@               let t = startUpTime + upTime               enqueue queue t $ machineBroken startUpTime      -     runDynamicsInStart $+     runDynamicsInStartTime $        do t0 <- starttime           -- start the first machine           enqueue queue t0 machineRepaired           -- start the second machine           enqueue queue t0 machineRepaired           -     runDynamicsInFinal $+     runDynamicsInStopTime $        do x <- readRef totalUpTime           y <- stoptime           return $ x / (2 * y)

@@ -105,7 +105,7 @@      c1 <- iterateDynamics m1      c2 <- iterateDynamics m2      -     runDynamicsInFinal $+     runDynamicsInStopTime $        do c1    -- involve in the simulation           c2    -- involve in the simulation           x <- readRef totalUpTime

@@ -83,12 +83,12 @@                              machine          -     runDynamicsInStart $+     runDynamicsInStartTime $        do t0 <- starttime           runProcess machine pid1 t0           runProcess machine pid2 t0           -     runDynamicsInFinal $+     runDynamicsInStopTime $        do x <- readRef totalUpTime           y <- stoptime           n <- readRef nRep

@@ -79,12 +79,12 @@                              machine pid -     runDynamicsInStart $+     runDynamicsInStartTime $        do t0 <- starttime           runProcess (machine pid2) pid1 t0           runProcess (machine pid1) pid2 t0      -     runDynamicsInFinal $+     runDynamicsInStopTime $        do x <- readRef totalUpTime           y <- stoptime           return $ x / (2 * y)