diff --git a/Simulation/Aivika/Dynamics.hs b/Simulation/Aivika/Dynamics.hs --- a/Simulation/Aivika/Dynamics.hs +++ b/Simulation/Aivika/Dynamics.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Dynamics --- Copyright : Copyright (c) 2009-2011, David Sorokin +-- Copyright : Copyright (c) 2009-2012, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Dynamics/Agent.hs b/Simulation/Aivika/Dynamics/Agent.hs --- a/Simulation/Aivika/Dynamics/Agent.hs +++ b/Simulation/Aivika/Dynamics/Agent.hs @@ -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) diff --git a/Simulation/Aivika/Dynamics/Buffer.hs b/Simulation/Aivika/Dynamics/Buffer.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Dynamics/Buffer.hs @@ -0,0 +1,148 @@ + +-- | +-- Module : Simulation.Aivika.Dynamics.Buffer +-- Copyright : Copyright (c) 2009-2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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' diff --git a/Simulation/Aivika/Dynamics/Cont.hs b/Simulation/Aivika/Dynamics/Cont.hs --- a/Simulation/Aivika/Dynamics/Cont.hs +++ b/Simulation/Aivika/Dynamics/Cont.hs @@ -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 diff --git a/Simulation/Aivika/Dynamics/EventQueue.hs b/Simulation/Aivika/Dynamics/EventQueue.hs --- a/Simulation/Aivika/Dynamics/EventQueue.hs +++ b/Simulation/Aivika/Dynamics/EventQueue.hs @@ -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 } diff --git a/Simulation/Aivika/Dynamics/FIFO.hs b/Simulation/Aivika/Dynamics/FIFO.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Dynamics/FIFO.hs @@ -0,0 +1,164 @@ + +-- | +-- Module : Simulation.Aivika.Dynamics.FIFO +-- Copyright : Copyright (c) 2009-2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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' diff --git a/Simulation/Aivika/Dynamics/Internal/Cont.hs b/Simulation/Aivika/Dynamics/Internal/Cont.hs --- a/Simulation/Aivika/Dynamics/Internal/Cont.hs +++ b/Simulation/Aivika/Dynamics/Internal/Cont.hs @@ -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 diff --git a/Simulation/Aivika/Dynamics/Internal/Dynamics.hs b/Simulation/Aivika/Dynamics/Internal/Dynamics.hs --- a/Simulation/Aivika/Dynamics/Internal/Dynamics.hs +++ b/Simulation/Aivika/Dynamics/Internal/Dynamics.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Dynamics.Internal.Dynamics --- Copyright : Copyright (c) 2009-2011, David Sorokin +-- Copyright : Copyright (c) 2009-2012, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Dynamics/Internal/Process.hs b/Simulation/Aivika/Dynamics/Internal/Process.hs --- a/Simulation/Aivika/Dynamics/Internal/Process.hs +++ b/Simulation/Aivika/Dynamics/Internal/Process.hs @@ -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 + diff --git a/Simulation/Aivika/Dynamics/Internal/Signal.hs b/Simulation/Aivika/Dynamics/Internal/Signal.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Dynamics/Internal/Signal.hs @@ -0,0 +1,287 @@ + +-- | +-- Module : Simulation.Aivika.Dynamics.Internal.Signal +-- Copyright : Copyright (c) 2009-2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/Dynamics/LIFO.hs b/Simulation/Aivika/Dynamics/LIFO.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Dynamics/LIFO.hs @@ -0,0 +1,152 @@ + +-- | +-- Module : Simulation.Aivika.Dynamics.LIFO +-- Copyright : Copyright (c) 2009-2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Dynamics/Parameter.hs b/Simulation/Aivika/Dynamics/Parameter.hs --- a/Simulation/Aivika/Dynamics/Parameter.hs +++ b/Simulation/Aivika/Dynamics/Parameter.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Dynamics.Parameter --- Copyright : Copyright (c) 2009-2011, David Sorokin +-- Copyright : Copyright (c) 2009-2012, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 } diff --git a/Simulation/Aivika/Dynamics/Process.hs b/Simulation/Aivika/Dynamics/Process.hs --- a/Simulation/Aivika/Dynamics/Process.hs +++ b/Simulation/Aivika/Dynamics/Process.hs @@ -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 diff --git a/Simulation/Aivika/Dynamics/Ref.hs b/Simulation/Aivika/Dynamics/Ref.hs --- a/Simulation/Aivika/Dynamics/Ref.hs +++ b/Simulation/Aivika/Dynamics/Ref.hs @@ -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 diff --git a/Simulation/Aivika/Dynamics/Resource.hs b/Simulation/Aivika/Dynamics/Resource.hs --- a/Simulation/Aivika/Dynamics/Resource.hs +++ b/Simulation/Aivika/Dynamics/Resource.hs @@ -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 diff --git a/Simulation/Aivika/Dynamics/Signal.hs b/Simulation/Aivika/Dynamics/Signal.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Dynamics/Signal.hs @@ -0,0 +1,108 @@ + +-- | +-- Module : Simulation.Aivika.Dynamics.Signal +-- Copyright : Copyright (c) 2009-2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) diff --git a/Simulation/Aivika/Dynamics/UVar.hs b/Simulation/Aivika/Dynamics/UVar.hs --- a/Simulation/Aivika/Dynamics/UVar.hs +++ b/Simulation/Aivika/Dynamics/UVar.hs @@ -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 diff --git a/Simulation/Aivika/Dynamics/Var.hs b/Simulation/Aivika/Dynamics/Var.hs --- a/Simulation/Aivika/Dynamics/Var.hs +++ b/Simulation/Aivika/Dynamics/Var.hs @@ -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 diff --git a/Simulation/Aivika/UVector.hs b/Simulation/Aivika/UVector.hs --- a/Simulation/Aivika/UVector.hs +++ b/Simulation/Aivika/UVector.hs @@ -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 diff --git a/Simulation/Aivika/Vector.hs b/Simulation/Aivika/Vector.hs --- a/Simulation/Aivika/Vector.hs +++ b/Simulation/Aivika/Vector.hs @@ -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 diff --git a/aivika.cabal b/aivika.cabal --- a/aivika.cabal +++ b/aivika.cabal @@ -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 . - 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 diff --git a/examples/BassDiffusion.hs b/examples/BassDiffusion.hs --- a/examples/BassDiffusion.hs +++ b/examples/BassDiffusion.hs @@ -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] diff --git a/examples/ChemicalReaction.hs b/examples/ChemicalReaction.hs --- a/examples/ChemicalReaction.hs +++ b/examples/ChemicalReaction.hs @@ -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 diff --git a/examples/FishBank.hs b/examples/FishBank.hs --- a/examples/FishBank.hs +++ b/examples/FishBank.hs @@ -53,6 +53,6 @@ integDiff shipsInteg shipBuildingRate integDiff totalProfitInteg annualProfit -- results -- - runDynamicsInFinal annualProfit + runDynamicsInStopTime annualProfit main = runSimulation model specs >>= print diff --git a/examples/Furnace.hs b/examples/Furnace.hs --- a/examples/Furnace.hs +++ b/examples/Furnace.hs @@ -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 diff --git a/examples/MachRep1.hs b/examples/MachRep1.hs --- a/examples/MachRep1.hs +++ b/examples/MachRep1.hs @@ -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) diff --git a/examples/MachRep1EventDriven.hs b/examples/MachRep1EventDriven.hs --- a/examples/MachRep1EventDriven.hs +++ b/examples/MachRep1EventDriven.hs @@ -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) diff --git a/examples/MachRep1TimeDriven.hs b/examples/MachRep1TimeDriven.hs --- a/examples/MachRep1TimeDriven.hs +++ b/examples/MachRep1TimeDriven.hs @@ -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 diff --git a/examples/MachRep2.hs b/examples/MachRep2.hs --- a/examples/MachRep2.hs +++ b/examples/MachRep2.hs @@ -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 diff --git a/examples/MachRep3.hs b/examples/MachRep3.hs --- a/examples/MachRep3.hs +++ b/examples/MachRep3.hs @@ -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)