diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009, 2010, 2011, 2012, 2013 David Sorokin +Copyright (c) 2009, 2010, 2011, 2012, 2013, 2014 David Sorokin All rights reserved. diff --git a/Simulation/Aivika.hs b/Simulation/Aivika.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika.hs @@ -0,0 +1,66 @@ + +-- | +-- Module : Simulation.Aivika +-- Copyright : Copyright (c) 2009-2013, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- This module re-exports the most part of the library functionality. +-- But there are modules that must be imported explicitly. +-- +module Simulation.Aivika + (-- * Modules + module Simulation.Aivika.Agent, + module Simulation.Aivika.Cont, + module Simulation.Aivika.Dynamics, + module Simulation.Aivika.Dynamics.Interpolate, + module Simulation.Aivika.Dynamics.Memo.Unboxed, + module Simulation.Aivika.Dynamics.Random, + module Simulation.Aivika.Event, + module Simulation.Aivika.Generator, + module Simulation.Aivika.Parameter, + module Simulation.Aivika.Parameter.Random, + module Simulation.Aivika.Process, + module Simulation.Aivika.Processor, + module Simulation.Aivika.Processor.RoundRobbin, + module Simulation.Aivika.QueueStrategy, + module Simulation.Aivika.Ref, + module Simulation.Aivika.Resource, + module Simulation.Aivika.Server, + module Simulation.Aivika.Signal, + module Simulation.Aivika.Simulation, + module Simulation.Aivika.Specs, + module Simulation.Aivika.Statistics, + module Simulation.Aivika.Stream, + module Simulation.Aivika.Stream.Random, + module Simulation.Aivika.Task, + module Simulation.Aivika.Var.Unboxed) where + +import Simulation.Aivika.Agent +import Simulation.Aivika.Cont +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Dynamics.Interpolate +import Simulation.Aivika.Dynamics.Memo.Unboxed +import Simulation.Aivika.Dynamics.Random +import Simulation.Aivika.Event +import Simulation.Aivika.Generator +import Simulation.Aivika.Parameter +import Simulation.Aivika.Parameter.Random +import Simulation.Aivika.Process +import Simulation.Aivika.Processor +import Simulation.Aivika.Processor.RoundRobbin +import Simulation.Aivika.QueueStrategy +import Simulation.Aivika.Ref +import Simulation.Aivika.Resource +import Simulation.Aivika.Server +import Simulation.Aivika.Signal +import Simulation.Aivika.Simulation +import Simulation.Aivika.Specs +import Simulation.Aivika.Statistics +import Simulation.Aivika.Stream +import Simulation.Aivika.Stream.Random +import Simulation.Aivika.Task +import Simulation.Aivika.Var.Unboxed + diff --git a/Simulation/Aivika/Agent.hs b/Simulation/Aivika/Agent.hs --- a/Simulation/Aivika/Agent.hs +++ b/Simulation/Aivika/Agent.hs @@ -15,10 +15,10 @@ newAgent, newState, newSubstate, - agentState, - agentStateChanged, - agentStateChanged_, - activateState, + selectedState, + selectedStateChanged, + selectedStateChanged_, + selectState, stateAgent, stateParent, addTimeout, @@ -190,15 +190,15 @@ agentStateRef = stateRef, agentStateChangedSource = stateChangedSource } --- | Return the selected downmost active state. -agentState :: Agent -> Event (Maybe AgentState) -agentState agent = +-- | Return the selected active state. +selectedState :: Agent -> Event (Maybe AgentState) +selectedState agent = Event $ \p -> readIORef (agentStateRef agent) --- | Select the next downmost active state. The activation is repeated while +-- | Select the state. The activation and selection are repeated while -- there is the transition state defined by 'setStateTransition'. -activateState :: AgentState -> Event () -activateState st = +selectState :: AgentState -> Event () +selectState st = Event $ \p -> do let agent = stateAgent st mode <- readIORef (agentModeRef agent) @@ -227,8 +227,8 @@ writeIORef (stateDeactivateRef st) action -- | Set the transition state which will be next and which is used only --- when activating the state directly with help of 'activateState'. --- If the state was activated intermediately, when activating directly +-- when selecting the state directly with help of 'selectState'. +-- If the state was activated intermediately, when selecting -- another state, then this computation is not used. setStateTransition :: AgentState -> Event (Maybe AgentState) -> Simulation () setStateTransition st action = @@ -241,12 +241,12 @@ do st <- readIORef (agentStateRef agent) invokeEvent p $ triggerSignal (agentStateChangedSource agent) st --- | Return a signal that notifies about every change of the state. -agentStateChanged :: Agent -> Signal (Maybe AgentState) -agentStateChanged agent = +-- | Return a signal that notifies about every change of the selected state. +selectedStateChanged :: Agent -> Signal (Maybe AgentState) +selectedStateChanged agent = publishSignal (agentStateChangedSource agent) --- | Return a signal that notifies about every change of the state. -agentStateChanged_ :: Agent -> Signal () -agentStateChanged_ agent = - mapSignal (const ()) $ agentStateChanged agent +-- | Return a signal that notifies about every change of the selected state. +selectedStateChanged_ :: Agent -> Signal () +selectedStateChanged_ agent = + mapSignal (const ()) $ selectedStateChanged agent diff --git a/Simulation/Aivika/Cont.hs b/Simulation/Aivika/Cont.hs --- a/Simulation/Aivika/Cont.hs +++ b/Simulation/Aivika/Cont.hs @@ -12,7 +12,8 @@ -- the continuations is the 'Event' computation. -- module Simulation.Aivika.Cont - (Cont) where + (ContCancellation(..), + Cont) where import Simulation.Aivika.Internal.Event import Simulation.Aivika.Internal.Cont diff --git a/Simulation/Aivika/Dynamics.hs b/Simulation/Aivika/Dynamics.hs --- a/Simulation/Aivika/Dynamics.hs +++ b/Simulation/Aivika/Dynamics.hs @@ -22,10 +22,7 @@ catchDynamics, finallyDynamics, throwDynamics, - -- * Time parameters - starttime, - stoptime, - dt, + -- * Simulation Time time, isTimeInteg, integIteration, diff --git a/Simulation/Aivika/Dynamics/Interpolate.hs b/Simulation/Aivika/Dynamics/Interpolate.hs --- a/Simulation/Aivika/Dynamics/Interpolate.hs +++ b/Simulation/Aivika/Dynamics/Interpolate.hs @@ -8,31 +8,15 @@ -- Tested with: GHC 7.6.3 -- -- This module defines interpolation functions. --- These functions complement the memoization, possibly except for --- the 'initDynamics' function which is useful to get an initial --- value of any dynamic process. +-- These functions complement the memoization. -- module Simulation.Aivika.Dynamics.Interpolate - (initDynamics, - discreteDynamics, + (discreteDynamics, interpolateDynamics) where import Simulation.Aivika.Internal.Specs import Simulation.Aivika.Internal.Dynamics - --- | Return the initial value. -initDynamics :: Dynamics a -> Dynamics a -{-# INLINE initDynamics #-} -initDynamics (Dynamics m) = - Dynamics $ \p -> - if pointIteration p == 0 && pointPhase p == 0 then - m p - else - let sc = pointSpecs p - in m $ p { pointTime = basicTime sc 0 0, - pointIteration = 0, - pointPhase = 0 } -- | Discretize the computation in the integration time points. discreteDynamics :: Dynamics a -> Dynamics a diff --git a/Simulation/Aivika/Dynamics/Random.hs b/Simulation/Aivika/Dynamics/Random.hs --- a/Simulation/Aivika/Dynamics/Random.hs +++ b/Simulation/Aivika/Dynamics/Random.hs @@ -7,38 +7,103 @@ -- Stability : experimental -- Tested with: GHC 7.6.3 -- --- Below are defined random functions that return the 'Dynamics' computations. --- The values are initially defined in the integration time points and then --- they are passed in to the 'memo0Dynamics' function to memoize and then interpolate. +-- This module defines the random parameters of simulation experiments. -- -module Simulation.Aivika.Dynamics.Random - (newRandomDynamics, newNormalDynamics) where +module Simulation.Aivika.Dynamics.Random + (memoRandomUniformDynamics, + memoRandomNormalDynamics, + memoRandomExponentialDynamics, + memoRandomErlangDynamics, + memoRandomPoissonDynamics, + memoRandomBinomialDynamics) where import System.Random -import Data.IORef + import Control.Monad.Trans -import Simulation.Aivika.Simulation -import Simulation.Aivika.Random -import Simulation.Aivika.Dynamics +import Simulation.Aivika.Generator +import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Parameter +import Simulation.Aivika.Internal.Simulation +import Simulation.Aivika.Internal.Dynamics import Simulation.Aivika.Dynamics.Memo.Unboxed --- | Return the uniform random numbers in the integration time points. -newRandomDynamics :: Dynamics Double -- ^ minimum - -> Dynamics Double -- ^ maximum - -> Simulation (Dynamics Double) -newRandomDynamics min max = - memo0Dynamics $ do - x <- liftIO $ getStdRandom random - min + return x * (max - min) - --- | Return the normal random numbers in the integration time points. -newNormalDynamics :: Dynamics Double -- ^ mean - -> Dynamics Double -- ^ variance - -> Simulation (Dynamics Double) -newNormalDynamics mu nu = - do g <- liftIO newNormalGen - memo0Dynamics $ do - x <- liftIO g - mu + return x * nu +-- | Computation that generates random numbers distributed uniformly and +-- memoizes them in the integration time points. +memoRandomUniformDynamics :: Dynamics Double -- ^ minimum + -> Dynamics Double -- ^ maximum + -> Simulation (Dynamics Double) +memoRandomUniformDynamics min max = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + min' <- invokeDynamics p min + max' <- invokeDynamics p max + generatorUniform g min' max' + +-- | Computation that generates random numbers distributed normally and +-- memoizes them in the integration time points. +memoRandomNormalDynamics :: Dynamics Double -- ^ mean + -> Dynamics Double -- ^ deviation + -> Simulation (Dynamics Double) +memoRandomNormalDynamics mu nu = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + mu' <- invokeDynamics p mu + nu' <- invokeDynamics p nu + generatorNormal g mu' nu' + +-- | Computation that generates exponential random numbers with the specified mean +-- (the reciprocal of the rate) and memoizes them in the integration time points. +memoRandomExponentialDynamics :: Dynamics Double + -- ^ the mean (the reciprocal of the rate) + -> Simulation (Dynamics Double) +memoRandomExponentialDynamics mu = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + mu' <- invokeDynamics p mu + generatorExponential g mu' + +-- | Computation that generates the Erlang random numbers with the specified scale +-- (the reciprocal of the rate) and integer shape but memoizes them in the integration +-- time points. +memoRandomErlangDynamics :: Dynamics Double + -- ^ the scale (the reciprocal of the rate) + -> Dynamics Int + -- ^ the shape + -> Simulation (Dynamics Double) +memoRandomErlangDynamics beta m = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + beta' <- invokeDynamics p beta + m' <- invokeDynamics p m + generatorErlang g beta' m' + +-- | Computation that generats the Poisson random numbers with the specified mean +-- and memoizes them in the integration time points. +memoRandomPoissonDynamics :: Dynamics Double + -- ^ the mean + -> Simulation (Dynamics Int) +memoRandomPoissonDynamics mu = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + mu' <- invokeDynamics p mu + generatorPoisson g mu' + +-- | Computation that generates binomial random numbers with the specified +-- probability and trials but memoizes them in the integration time points. +memoRandomBinomialDynamics :: Dynamics Double -- ^ the probability + -> Dynamics Int -- ^ the number of trials + -> Simulation (Dynamics Int) +memoRandomBinomialDynamics prob trials = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + prob' <- invokeDynamics p prob + trials' <- invokeDynamics p trials + generatorBinomial g prob' trials' diff --git a/Simulation/Aivika/Event.hs b/Simulation/Aivika/Event.hs --- a/Simulation/Aivika/Event.hs +++ b/Simulation/Aivika/Event.hs @@ -15,7 +15,6 @@ Event, EventLift(..), EventProcessing(..), - EventCancellation(..), runEvent, runEventInStartTime, runEventInStopTime, @@ -24,13 +23,17 @@ enqueueEventWithCancellation, enqueueEventWithTimes, enqueueEventWithIntegTimes, - enqueueEventWithStartTime, - enqueueEventWithStopTime, - enqueueEventWithCurrentTime, eventQueueCount, + -- * Cancelling Event + EventCancellation, + cancelEvent, + eventCancelled, + eventFinished, -- * Error Handling catchEvent, finallyEvent, - throwEvent) where + throwEvent, + -- * Memoization + memoEvent) where import Simulation.Aivika.Internal.Event diff --git a/Simulation/Aivika/Generator.hs b/Simulation/Aivika/Generator.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Generator.hs @@ -0,0 +1,191 @@ + +-- | +-- Module : Simulation.Aivika.Generator +-- Copyright : Copyright (c) 2009-2013, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- Below is defined a type class of the random number generator. +-- +module Simulation.Aivika.Generator + (Generator(..), + GeneratorType(..), + newGenerator, + newRandomGenerator) where + +import System.Random +import Data.IORef + +-- | Defines a random number generator. +data Generator = + Generator { generatorUniform :: Double -> Double -> IO Double, + -- ^ Generate an uniform random number + -- with the specified minimum and maximum. + generatorNormal :: Double -> Double -> IO Double, + -- ^ Generate the normal random number + -- with the specified mean and deviation. + generatorExponential :: Double -> IO Double, + -- ^ Generate the random number distributed exponentially + -- with the specified mean (the reciprocal of the rate). + generatorErlang :: Double -> Int -> IO Double, + -- ^ Generate the Erlang random number + -- with the specified scale (the reciprocal of the rate) and integer shape. + generatorPoisson :: Double -> IO Int, + -- ^ Generate the Poisson random number + -- with the specified mean. + generatorBinomial :: Double -> Int -> IO Int + -- ^ Generate the binomial random number + -- with the specified probability and number of trials. + } + +-- | Generate the uniform random number with the specified minimum and maximum. +generateUniform :: IO Double + -- ^ the generator + -> Double + -- ^ minimum + -> Double + -- ^ maximum + -> IO Double +generateUniform g min max = + do x <- g + return $ min + x * (max - min) + +-- | Create a normal random number generator with mean 0 and variance 1 +-- by the specified generator of uniform random numbers from 0 to 1. +newNormalGenerator :: IO Double + -- ^ the generator + -> IO (IO Double) +newNormalGenerator g = + do nextRef <- newIORef 0.0 + flagRef <- newIORef False + xi1Ref <- newIORef 0.0 + xi2Ref <- newIORef 0.0 + psiRef <- newIORef 0.0 + let loop = + do psi <- readIORef psiRef + if (psi >= 1.0) || (psi == 0.0) + then do g1 <- g + g2 <- g + let xi1 = 2.0 * g1 - 1.0 + xi2 = 2.0 * g2 - 1.0 + psi = xi1 * xi1 + xi2 * xi2 + writeIORef xi1Ref xi1 + writeIORef xi2Ref xi2 + writeIORef psiRef psi + loop + else writeIORef psiRef $ sqrt (- 2.0 * log psi / psi) + return $ + do flag <- readIORef flagRef + if flag + then do writeIORef flagRef False + readIORef nextRef + else do writeIORef xi1Ref 0.0 + writeIORef xi2Ref 0.0 + writeIORef psiRef 0.0 + loop + xi1 <- readIORef xi1Ref + xi2 <- readIORef xi2Ref + psi <- readIORef psiRef + writeIORef flagRef True + writeIORef nextRef $ xi2 * psi + return $ xi1 * psi + +-- | Return the exponential random number with the specified mean. +generateExponential :: IO Double + -- ^ the generator + -> Double + -- ^ the mean + -> IO Double +generateExponential g mu = + do x <- g + return (- log x * mu) + +-- | Return the Erlang random number. +generateErlang :: IO Double + -- ^ the generator + -> Double + -- ^ the scale + -> Int + -- ^ the shape + -> IO Double +generateErlang g beta m = + do x <- loop m 1 + return (- log x * beta) + where loop m acc + | m < 0 = error "Negative shape: generateErlang." + | m == 0 = return acc + | otherwise = do x <- g + loop (m - 1) (x * acc) + +-- | Generate the Poisson random number with the specified mean. +generatePoisson :: IO Double + -- ^ the generator + -> Double + -- ^ the mean + -> IO Int +generatePoisson g mu = + do prob0 <- g + let loop prob prod acc + | prob <= prod = return acc + | otherwise = loop + (prob - prod) + (prod * mu / fromIntegral (acc + 1)) + (acc + 1) + loop prob0 (exp (- mu)) 0 + +-- | Generate a binomial random number with the specified probability and number of trials. +generateBinomial :: IO Double + -- ^ the generator + -> Double + -- ^ the probability + -> Int + -- ^ the number of trials + -> IO Int +generateBinomial g prob trials = loop trials 0 where + loop n acc + | n < 0 = error "Negative number of trials: generateBinomial." + | n == 0 = return acc + | otherwise = do x <- g + if x <= prob + then loop (n - 1) (acc + 1) + else loop (n - 1) acc + +-- | Defines a type of the random number generator. +data GeneratorType = SimpleGenerator + -- ^ The simple random number generator. + | SimpleGeneratorWithSeed Int + -- ^ The simple random number generator with the specified seed. + | CustomGenerator (IO Generator) + -- ^ The custom random number generator. + +-- | Create a new random number generator by the specified type. +newGenerator :: GeneratorType -> IO Generator +newGenerator tp = + case tp of + SimpleGenerator -> + newStdGen >>= newRandomGenerator + SimpleGeneratorWithSeed x -> + newRandomGenerator $ mkStdGen x + CustomGenerator g -> + g + +-- | Create a new random generator by the specified standard generator. +newRandomGenerator :: RandomGen g => g -> IO Generator +newRandomGenerator g = + do r <- newIORef g + let g1 = do g <- readIORef r + let (x, g') = random g + writeIORef r g' + return x + g2 <- newNormalGenerator g1 + let g3 mu nu = + do x <- g2 + return $ mu + nu * x + return Generator { generatorUniform = generateUniform g1, + generatorNormal = g3, + generatorExponential = generateExponential g1, + generatorErlang = generateErlang g1, + generatorPoisson = generatePoisson g1, + generatorBinomial = generateBinomial g1 } diff --git a/Simulation/Aivika/Internal/Cont.hs b/Simulation/Aivika/Internal/Cont.hs --- a/Simulation/Aivika/Internal/Cont.hs +++ b/Simulation/Aivika/Internal/Cont.hs @@ -12,17 +12,35 @@ -- the continuations is the 'Event' computation. -- module Simulation.Aivika.Internal.Cont - (Cont(..), + (ContCancellation(..), + ContCancellationSource, + Cont(..), ContParams, + newContCancellationSource, + contCancellationInitiated, + contCancellationInitiate, + contCancellationInitiating, + contCancellationBind, + contCancellationConnect, invokeCont, runCont, + rerunCont, + spawnCont, + contParallel, + contParallel_, catchCont, finallyCont, throwCont, resumeCont, - contCanceled) where + resumeECont, + contCanceled, + contFreeze, + contAwait) where import Data.IORef +import Data.Array +import Data.Array.IO.Safe +import Data.Monoid import qualified Control.Exception as C import Control.Exception (IOException, throw) @@ -31,10 +49,117 @@ import Control.Monad.Trans import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Parameter import Simulation.Aivika.Internal.Simulation import Simulation.Aivika.Internal.Dynamics import Simulation.Aivika.Internal.Event +import Simulation.Aivika.Internal.Signal +-- | It defines how the parent and child computations should be cancelled. +data ContCancellation = CancelTogether + -- ^ Cancel the both computations together. + | CancelChildAfterParent + -- ^ Cancel the child if its parent is cancelled. + | CancelParentAfterChild + -- ^ Cancel the parent if its child is cancelled. + | CancelInIsolation + -- ^ Cancel the computations in isolation. + +-- | It manages the cancellation process. +data ContCancellationSource = + ContCancellationSource { contCancellationInitiatedRef :: IORef Bool, + contCancellationActivatedRef :: IORef Bool, + contCancellationInitiatingSource :: SignalSource () + } + +-- | Create the cancellation source. +newContCancellationSource :: Simulation ContCancellationSource +newContCancellationSource = + Simulation $ \r -> + do r1 <- newIORef False + r2 <- newIORef False + s <- invokeSimulation r newSignalSource + return ContCancellationSource { contCancellationInitiatedRef = r1, + contCancellationActivatedRef = r2, + contCancellationInitiatingSource = s + } + +-- | Signal when the cancellation is intiating. +contCancellationInitiating :: ContCancellationSource -> Signal () +contCancellationInitiating = + publishSignal . contCancellationInitiatingSource + +-- | Whether the cancellation was initiated. +contCancellationInitiated :: ContCancellationSource -> Event Bool +contCancellationInitiated x = + Event $ \p -> readIORef (contCancellationInitiatedRef x) + +-- | Whether the cancellation was activated. +contCancellationActivated :: ContCancellationSource -> IO Bool +contCancellationActivated = + readIORef . contCancellationActivatedRef + +-- | Deactivate the cancellation. +contCancellationDeactivate :: ContCancellationSource -> IO () +contCancellationDeactivate x = + writeIORef (contCancellationActivatedRef x) False + +-- | If the main computation is cancelled then all the nested ones will be cancelled too. +contCancellationBind :: ContCancellationSource -> [ContCancellationSource] -> Event (Event ()) +contCancellationBind x ys = + Event $ \p -> + do hs1 <- forM ys $ \y -> + invokeEvent p $ + handleSignal (contCancellationInitiating x) $ \_ -> + contCancellationInitiate y + hs2 <- forM ys $ \y -> + invokeEvent p $ + handleSignal (contCancellationInitiating y) $ \_ -> + contCancellationInitiate x + return $ do sequence_ hs1 + sequence_ hs2 + +-- | Connect the parent computation to the child one. +contCancellationConnect :: ContCancellationSource + -- ^ the parent + -> ContCancellation + -- ^ how to connect + -> ContCancellationSource + -- ^ the child + -> Event (Event ()) + -- ^ computation of the disposable handler +contCancellationConnect parent cancellation child = + Event $ \p -> + do let m1 = + handleSignal (contCancellationInitiating parent) $ \_ -> + contCancellationInitiate child + m2 = + handleSignal (contCancellationInitiating child) $ \_ -> + contCancellationInitiate parent + h1 <- + case cancellation of + CancelTogether -> invokeEvent p m1 + CancelChildAfterParent -> invokeEvent p m1 + CancelParentAfterChild -> return $ return () + CancelInIsolation -> return $ return () + h2 <- + case cancellation of + CancelTogether -> invokeEvent p m2 + CancelChildAfterParent -> return $ return () + CancelParentAfterChild -> invokeEvent p m2 + CancelInIsolation -> return $ return () + return $ h1 >> h2 + +-- | Initiate the cancellation. +contCancellationInitiate :: ContCancellationSource -> Event () +contCancellationInitiate x = + Event $ \p -> + do f <- readIORef (contCancellationInitiatedRef x) + unless f $ + do writeIORef (contCancellationInitiatedRef x) True + writeIORef (contCancellationActivatedRef x) True + invokeEvent p $ triggerSignal (contCancellationInitiatingSource x) () + -- | The 'Cont' type is similar to the standard Cont monad -- and F# async workflow but only the result of applying -- the continuations return the 'Event' computation. @@ -49,13 +174,17 @@ data ContParamsAux = ContParamsAux { contECont :: IOException -> Event (), contCCont :: () -> Event (), - contCancelToken :: IORef Bool, - contCatchFlag :: Bool } + contCancelSource :: ContCancellationSource, + contCancelFlag :: IO Bool, + contCatchFlag :: Bool } instance Monad Cont where return = returnC m >>= k = bindC m k +instance ParameterLift Cont where + liftParameter = liftPC + instance SimulationLift Cont where liftSimulation = liftSC @@ -78,7 +207,7 @@ cancelCont :: Point -> ContParams a -> IO () {-# NOINLINE cancelCont #-} cancelCont p c = - do writeIORef (contCancelToken $ contAux c) False + do contCancellationDeactivate (contCancelSource $ contAux c) invokeEvent p $ (contCCont $ contAux c) () returnC :: a -> Cont a @@ -115,19 +244,19 @@ let cont a = invokeCont c (k a) in c { contCont = cont } --- It is not tail recursive! -bindWithCatch :: Cont a -> (a -> Cont b) -> ContParams b -> Event () -{-# NOINLINE bindWithCatch #-} -bindWithCatch (Cont m) k c = - Event $ \p -> - do z <- contCanceled c - if z - then cancelCont p c - else invokeEvent p $ m $ - let cont a = catchEvent - (invokeCont c (k a)) - (contECont $ contAux c) - in c { contCont = cont } +-- -- It is not tail recursive! +-- bindWithCatch :: Cont a -> (a -> Cont b) -> ContParams b -> Event () +-- {-# NOINLINE bindWithCatch #-} +-- bindWithCatch (Cont m) k c = +-- Event $ \p -> +-- do z <- contCanceled c +-- if z +-- then cancelCont p c +-- else invokeEvent p $ m $ +-- let cont a = catchEvent +-- (invokeCont c (k a)) +-- (contECont $ contAux c) +-- in c { contCont = cont } -- Like "bindWithoutCatch (return a) k" callWithoutCatch :: (a -> Cont b) -> a -> ContParams b -> Event () @@ -138,26 +267,22 @@ then cancelCont p c else invokeEvent p $ invokeCont c (k a) --- Like "bindWithCatch (return a) k" but it is not tail recursive! -callWithCatch :: (a -> Cont b) -> a -> ContParams b -> Event () -callWithCatch k a c = - Event $ \p -> - do z <- contCanceled c - if z - then cancelCont p c - else invokeEvent p $ catchEvent - (invokeCont c (k a)) - (contECont $ contAux c) +-- -- Like "bindWithCatch (return a) k" but it is not tail recursive! +-- callWithCatch :: (a -> Cont b) -> a -> ContParams b -> Event () +-- callWithCatch k a c = +-- Event $ \p -> +-- do z <- contCanceled c +-- if z +-- then cancelCont p c +-- else invokeEvent p $ catchEvent +-- (invokeCont c (k a)) +-- (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." + Cont $ \c -> + catchWithCatch m h (c { contAux = (contAux c) { contCatchFlag = True } }) catchWithCatch :: Cont a -> (IOException -> Cont a) -> ContParams a -> Event () catchWithCatch (Cont m) h c = @@ -174,11 +299,7 @@ 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 m m' (c { contAux = (contAux c) { contCatchFlag = True } }) finallyWithCatch :: Cont a -> Cont b -> ContParams a -> Event () finallyWithCatch (Cont m) (Cont m') c = @@ -216,8 +337,8 @@ 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. +-- | Run the 'Cont' computation with the specified cancelation source +-- and flag indicating whether to catch exceptions from the beginning. runCont :: Cont a -- ^ the computation to run -> (a -> Event ()) @@ -226,19 +347,29 @@ -- ^ the branch for handing exceptions -> (() -> Event ()) -- ^ the branch for cancellation - -> IORef Bool - -- ^ the cancellation token + -> ContCancellationSource + -- ^ the cancellation source -> Bool - -- ^ whether to support the exception catching + -- ^ whether to support the exception handling from the beginning -> Event () -runCont (Cont m) cont econt ccont cancelToken catchFlag = +runCont (Cont m) cont econt ccont cancelSource catchFlag = m ContParams { contCont = cont, contAux = ContParamsAux { contECont = econt, contCCont = ccont, - contCancelToken = cancelToken, - contCatchFlag = catchFlag } } + contCancelSource = cancelSource, + contCancelFlag = contCancellationActivated cancelSource, + contCatchFlag = catchFlag } } +-- | Lift the 'Parameter' computation. +liftPC :: Parameter a -> Cont a +liftPC (Parameter m) = + Cont $ \c -> + Event $ \p -> + if contCatchFlag . contAux $ c + then liftIOWithCatch (m $ pointRun p) p c + else liftIOWithoutCatch (m $ pointRun p) p c + -- | Lift the 'Simulation' computation. liftSC :: Simulation a -> Cont a liftSC (Simulation m) = @@ -314,7 +445,262 @@ then cancelCont p c else invokeEvent p $ contCont c a +-- | Resume the exception handling by the specified parameters. +resumeECont :: ContParams a -> IOException -> Event () +{-# INLINE resumeECont #-} +resumeECont c e = + Event $ \p -> + do z <- contCanceled c + if z + then cancelCont p c + else invokeEvent p $ (contECont $ contAux c) e + -- | Test whether the computation is canceled. contCanceled :: ContParams a -> IO Bool {-# INLINE contCanceled #-} -contCanceled c = readIORef $ contCancelToken $ contAux c +contCanceled c = contCancelFlag $ contAux c + +-- | Execute the specified computations in parallel within +-- the current computation and return their results. The cancellation +-- of any of the nested computations affects the current computation. +-- The exception raised in any of the nested computations is propogated +-- to the current computation as well (if the exception handling is +-- supported). +-- +-- Here word @parallel@ literally means that the computations are +-- actually executed on a single operating system thread but +-- they are processed simultaneously by the event queue. +contParallel :: [(Cont a, ContCancellationSource)] + -- ^ the list of: + -- the nested computation, + -- the cancellation source + -> Cont [a] +contParallel xs = + Cont $ \c -> + Event $ \p -> + do let n = length xs + worker = + do results <- newArray_ (1, n) :: IO (IOArray Int a) + counter <- newIORef 0 + catchRef <- newIORef Nothing + hs <- invokeEvent p $ + contCancellationBind (contCancelSource $ contAux c) $ + map snd xs + let propagate = + Event $ \p -> + do n' <- readIORef counter + when (n' == n) $ + do invokeEvent p hs -- unbind the cancellation sources + f1 <- contCanceled c + f2 <- readIORef catchRef + case (f1, f2) of + (False, Nothing) -> + do rs <- getElems results + invokeEvent p $ resumeCont c rs + (False, Just e) -> + invokeEvent p $ resumeECont c e + (True, _) -> + cancelCont p c + cont i a = + Event $ \p -> + do modifyIORef counter (+ 1) + writeArray results i a + invokeEvent p propagate + econt e = + Event $ \p -> + do modifyIORef counter (+ 1) + r <- readIORef catchRef + case r of + Nothing -> writeIORef catchRef $ Just e + Just e' -> return () -- ignore the next error + invokeEvent p propagate + ccont e = + Event $ \p -> + do modifyIORef counter (+ 1) + -- the main computation was automatically canceled + invokeEvent p propagate + forM_ (zip [1..n] xs) $ \(i, (x, cancelSource)) -> + invokeEvent p $ + runCont x (cont i) econt ccont cancelSource (contCatchFlag $ contAux c) + z <- contCanceled c + if z + then cancelCont p c + else if n == 0 + then invokeEvent p $ contCont c [] + else worker + +-- | A partial case of 'contParallel' when we are not interested in +-- the results but we are interested in the actions to be peformed by +-- the nested computations. +contParallel_ :: [(Cont a, ContCancellationSource)] + -- ^ the list of: + -- the nested computation, + -- the cancellation source + -> Cont () +contParallel_ xs = + Cont $ \c -> + Event $ \p -> + do let n = length xs + worker = + do counter <- newIORef 0 + catchRef <- newIORef Nothing + hs <- invokeEvent p $ + contCancellationBind (contCancelSource $ contAux c) $ + map snd xs + let propagate = + Event $ \p -> + do n' <- readIORef counter + when (n' == n) $ + do invokeEvent p hs -- unbind the cancellation sources + f1 <- contCanceled c + f2 <- readIORef catchRef + case (f1, f2) of + (False, Nothing) -> + invokeEvent p $ resumeCont c () + (False, Just e) -> + invokeEvent p $ resumeECont c e + (True, _) -> + cancelCont p c + cont i a = + Event $ \p -> + do modifyIORef counter (+ 1) + -- ignore the result + invokeEvent p propagate + econt e = + Event $ \p -> + do modifyIORef counter (+ 1) + r <- readIORef catchRef + case r of + Nothing -> writeIORef catchRef $ Just e + Just e' -> return () -- ignore the next error + invokeEvent p propagate + ccont e = + Event $ \p -> + do modifyIORef counter (+ 1) + -- the main computation was automatically canceled + invokeEvent p propagate + forM_ (zip [1..n] xs) $ \(i, (x, cancelSource)) -> + invokeEvent p $ + runCont x (cont i) econt ccont cancelSource (contCatchFlag $ contAux c) + z <- contCanceled c + if z + then cancelCont p c + else if n == 0 + then invokeEvent p $ contCont c () + else worker + +-- | Rerun the 'Cont' computation with the specified cancellation source. +rerunCont :: Cont a -> ContCancellationSource -> Cont a +rerunCont x cancelSource = + Cont $ \c -> + Event $ \p -> + do let worker = + do hs <- invokeEvent p $ + contCancellationBind (contCancelSource $ contAux c) [cancelSource] + let cont a = + Event $ \p -> + do invokeEvent p hs -- unbind the cancellation source + invokeEvent p $ resumeCont c a + econt e = + Event $ \p -> + do invokeEvent p hs -- unbind the cancellation source + invokeEvent p $ resumeECont c e + ccont e = + Event $ \p -> + do invokeEvent p hs -- unbind the cancellation source + cancelCont p c + invokeEvent p $ + runCont x cont econt ccont cancelSource (contCatchFlag $ contAux c) + z <- contCanceled c + if z + then cancelCont p c + else worker + +-- | Run the 'Cont' computation in parallel but connect the cancellation sources. +spawnCont :: ContCancellation -> Cont () -> ContCancellationSource -> Cont () +spawnCont cancellation x cancelSource = + Cont $ \c -> + Event $ \p -> + do let worker = + do hs <- invokeEvent p $ + contCancellationConnect + (contCancelSource $ contAux c) cancellation cancelSource + let cont a = + Event $ \p -> + do invokeEvent p hs -- unbind the cancellation source + -- do nothing and it will finish the computation + econt e = + Event $ \p -> + do invokeEvent p hs -- unbind the cancellation source + invokeEvent p $ throwEvent e -- this is all we can do + ccont e = + Event $ \p -> + do invokeEvent p hs -- unbind the cancellation source + -- do nothing and it will finish the computation + invokeEvent p $ + enqueueEvent (pointTime p) $ + runCont x cont econt ccont cancelSource False + invokeEvent p $ + resumeCont c () + z <- contCanceled c + if z + then cancelCont p c + else worker + +-- | Freeze the computation parameters temporarily. +contFreeze :: ContParams a -> Event (Event (Maybe (ContParams a))) +contFreeze c = + Event $ \p -> + do rh <- newIORef Nothing + rc <- newIORef $ Just c + h <- invokeEvent p $ + handleSignal (contCancellationInitiating $ + contCancelSource $ + contAux c) $ \a -> + Event $ \p -> + do h <- readIORef rh + case h of + Nothing -> + error "The handler was lost: contFreeze." + Just h -> + do invokeEvent p h + c <- readIORef rc + case c of + Nothing -> return () + Just c -> + do writeIORef rc Nothing + invokeEvent p $ + enqueueEvent (pointTime p) $ + Event $ \p -> + do z <- contCanceled c + when z $ cancelCont p c + writeIORef rh (Just h) + return $ + Event $ \p -> + do invokeEvent p h + c <- readIORef rc + writeIORef rc Nothing + return c + +-- | Await the signal. +contAwait :: Signal a -> Cont a +contAwait signal = + Cont $ \c -> + Event $ \p -> + do c <- invokeEvent p $ contFreeze c + r <- newIORef Nothing + h <- invokeEvent p $ + handleSignal signal $ + \a -> Event $ + \p -> do x <- readIORef r + case x of + Nothing -> + error "The signal was lost: awaitSignal." + Just x -> + do invokeEvent p x + c <- invokeEvent p c + case c of + Nothing -> return () + Just c -> + invokeEvent p $ resumeCont c a + writeIORef r $ Just h diff --git a/Simulation/Aivika/Internal/Dynamics.hs b/Simulation/Aivika/Internal/Dynamics.hs --- a/Simulation/Aivika/Internal/Dynamics.hs +++ b/Simulation/Aivika/Internal/Dynamics.hs @@ -25,10 +25,7 @@ catchDynamics, finallyDynamics, throwDynamics, - -- * Time parameters - starttime, - stoptime, - dt, + -- * Simulation Time time, isTimeInteg, integIteration, @@ -42,6 +39,7 @@ import Control.Monad.Fix import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Parameter import Simulation.Aivika.Internal.Simulation -- | A value in the 'Dynamics' monad represents a polymorphic time varying function. @@ -143,18 +141,26 @@ instance MonadIO Dynamics where liftIO m = Dynamics $ const m +instance ParameterLift Dynamics where + liftParameter = liftDP + instance SimulationLift Dynamics where liftSimulation = liftDS +liftDP :: Parameter a -> Dynamics a +{-# INLINE liftDP #-} +liftDP (Parameter m) = + Dynamics $ \p -> m $ pointRun p + liftDS :: Simulation a -> Dynamics a {-# INLINE liftDS #-} liftDS (Simulation m) = Dynamics $ \p -> m $ pointRun p --- | A type class to lift the 'Dynamics' computations to other monads. -class Monad m => DynamicsLift m where +-- | A type class to lift the 'Dynamics' computations to other computations. +class DynamicsLift m where - -- | Lift the specified 'Dynamics' computation to another monad. + -- | Lift the specified 'Dynamics' computation to another computation. liftDynamics :: Dynamics a -> m a instance DynamicsLift Dynamics where @@ -187,19 +193,7 @@ Dynamics $ \p -> do { rec { a <- invokeDynamics p (f a) }; return a } --- | Return the start simulation time. -starttime :: Dynamics Double -starttime = Dynamics $ return . spcStartTime . pointSpecs - --- | Return the stop simulation time. -stoptime :: Dynamics Double -stoptime = Dynamics $ return . spcStopTime . pointSpecs - --- | Return the integration time step. -dt :: Dynamics Double -dt = Dynamics $ return . spcDT . pointSpecs - --- | Return the current simulation time. +-- | Computation that returns the current simulation time. time :: Dynamics Double time = Dynamics $ return . pointTime diff --git a/Simulation/Aivika/Internal/Event.hs b/Simulation/Aivika/Internal/Event.hs --- a/Simulation/Aivika/Internal/Event.hs +++ b/Simulation/Aivika/Internal/Event.hs @@ -17,7 +17,6 @@ Event(..), EventLift(..), EventProcessing(..), - EventCancellation(..), invokeEvent, runEvent, runEventInStartTime, @@ -28,14 +27,18 @@ enqueueEventWithTimes, enqueueEventWithPoints, enqueueEventWithIntegTimes, - enqueueEventWithStartTime, - enqueueEventWithStopTime, - enqueueEventWithCurrentTime, eventQueueCount, + -- * Cancelling Event + EventCancellation, + cancelEvent, + eventCancelled, + eventFinished, -- * Error Handling catchEvent, finallyEvent, - throwEvent) where + throwEvent, + -- * Memoization + memoEvent) where import Data.IORef @@ -49,6 +52,7 @@ import qualified Simulation.Aivika.PriorityQueue as PQ import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Parameter import Simulation.Aivika.Internal.Simulation import Simulation.Aivika.Internal.Dynamics @@ -83,12 +87,20 @@ instance MonadIO Event where liftIO m = Event $ const m +instance ParameterLift Event where + liftParameter = liftPS + instance SimulationLift Event where liftSimulation = liftES instance DynamicsLift Event where liftDynamics = liftDS +liftPS :: Parameter a -> Event a +{-# INLINE liftPS #-} +liftPS (Parameter m) = + Event $ \p -> m $ pointRun p + liftES :: Simulation a -> Event a {-# INLINE liftES #-} liftES (Simulation m) = @@ -99,10 +111,10 @@ liftDS (Dynamics m) = Event m --- | A type class to lift the 'Event' computation to other monads. -class Monad m => EventLift m where +-- | A type class to lift the 'Event' computation to other computations. +class EventLift m where - -- | Lift the specified 'Event' computation to another monad. + -- | Lift the specified 'Event' computation to another computation. liftEvent :: Event a -> m a instance EventLift Event where @@ -287,35 +299,12 @@ let points = integPoints $ pointRun p in invokeEvent p $ enqueueEventWithPoints points e --- | Actuate the event handler in the start time. -enqueueEventWithStartTime :: Event () -> Event () -enqueueEventWithStartTime e = - Event $ \p -> - let point = integStartPoint $ pointRun p - in invokeEvent p $ enqueueEventWithPoints [point] e - --- | Actuate the event handler in the stop time. -enqueueEventWithStopTime :: Event () -> Event () -enqueueEventWithStopTime e = - Event $ \p -> - let point = integStopPoint $ pointRun p - in invokeEvent p $ enqueueEventWithPoints [point] e - --- | Actuate the event handler in the current time but --- through the event queue, which allows continuing the --- current tasks and then calling the handler after the --- tasks are finished. The simulation time will be the same. -enqueueEventWithCurrentTime :: Event () -> Event () -enqueueEventWithCurrentTime e = - Event $ \p -> - invokeEvent p $ enqueueEvent (pointTime p) e - -- | It allows cancelling the event. data EventCancellation = EventCancellation { cancelEvent :: Event (), -- ^ Cancel the event. - eventCanceled :: Event Bool, - -- ^ Test whether the event was canceled. + eventCancelled :: Event Bool, + -- ^ Test whether the event was cancelled. eventFinished :: Event Bool -- ^ Test whether the event was processed and finished. } @@ -324,26 +313,40 @@ enqueueEventWithCancellation :: Double -> Event () -> Event EventCancellation enqueueEventWithCancellation t e = Event $ \p -> - do canceledRef <- newIORef False + do cancelledRef <- newIORef False cancellableRef <- newIORef True finishedRef <- newIORef False let cancel = Event $ \p -> do x <- readIORef cancellableRef when x $ - writeIORef canceledRef True - canceled = - Event $ \p -> readIORef canceledRef + writeIORef cancelledRef True + cancelled = + Event $ \p -> readIORef cancelledRef finished = Event $ \p -> readIORef finishedRef invokeEvent p $ enqueueEvent t $ Event $ \p -> do writeIORef cancellableRef False - x <- readIORef canceledRef + x <- readIORef cancelledRef unless x $ do invokeEvent p e writeIORef finishedRef True return EventCancellation { cancelEvent = cancel, - eventCanceled = canceled, + eventCancelled = cancelled, eventFinished = finished } + +-- | Memoize the 'Event' computation, always returning the same value +-- within a simulation run. +memoEvent :: Event a -> Simulation (Event a) +memoEvent m = + do ref <- liftIO $ newIORef Nothing + return $ Event $ \p -> + do x <- readIORef ref + case x of + Just v -> return v + Nothing -> + do v <- invokeEvent p m + writeIORef ref (Just v) + return v diff --git a/Simulation/Aivika/Internal/Parameter.hs b/Simulation/Aivika/Internal/Parameter.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Internal/Parameter.hs @@ -0,0 +1,251 @@ + +{-# LANGUAGE RecursiveDo #-} + +-- | +-- Module : Simulation.Aivika.Internal.Parameter +-- Copyright : Copyright (c) 2009-2013, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- The module defines the 'Parameter' monad that allows representing the model +-- parameters. For example, they can be used when running the Monte-Carlo simulation. +-- +module Simulation.Aivika.Internal.Parameter + (-- * Parameter + Parameter(..), + ParameterLift(..), + invokeParameter, + runParameter, + runParameters, + -- * Error Handling + catchParameter, + finallyParameter, + throwParameter, + -- * Predefined Parameters + simulationIndex, + simulationCount, + simulationSpecs, + starttime, + stoptime, + dt, + generatorParameter, + -- * Memoization + memoParameter, + -- * Utilities + tableParameter) where + +import qualified Control.Exception as C +import Control.Exception (IOException, throw, finally) +import Control.Concurrent.MVar + +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Fix + +import Data.IORef +import qualified Data.Map as M +import Data.Array + +import Simulation.Aivika.Generator +import Simulation.Aivika.Internal.Specs + +-- | The 'Parameter' monad that allows specifying the model parameters. +-- For example, they can be used when running the Monte-Carlo simulation. +newtype Parameter a = Parameter (Run -> IO a) + +instance Monad Parameter where + return = returnP + m >>= k = bindP m k + +returnP :: a -> Parameter a +{-# INLINE returnP #-} +returnP a = Parameter (\r -> return a) + +bindP :: Parameter a -> (a -> Parameter b) -> Parameter b +{-# INLINE bindP #-} +bindP (Parameter m) k = + Parameter $ \r -> + do a <- m r + let Parameter m' = k a + m' r + +-- | Run the parameter using the specified specs. +runParameter :: Parameter a -> Specs -> IO a +runParameter (Parameter m) sc = + do q <- newEventQueue sc + g <- newGenerator $ spcGeneratorType sc + m Run { runSpecs = sc, + runIndex = 1, + runCount = 1, + runEventQueue = q, + runGenerator = g } + +-- | Run the given number of parameters using the specified specs, +-- where each parameter is distinguished by its index 'parameterIndex'. +runParameters :: Parameter a -> Specs -> Int -> [IO a] +runParameters (Parameter m) sc runs = map f [1 .. runs] + where f i = do q <- newEventQueue sc + g <- newGenerator $ spcGeneratorType sc + m Run { runSpecs = sc, + runIndex = i, + runCount = runs, + runEventQueue = q, + runGenerator = g } + +-- | Return the run index for the current simulation. +simulationIndex :: Parameter Int +simulationIndex = Parameter $ return . runIndex + +-- | Return the number of simulations currently run. +simulationCount :: Parameter Int +simulationCount = Parameter $ return . runCount + +-- | Return the simulation specs. +simulationSpecs :: Parameter Specs +simulationSpecs = Parameter $ return . runSpecs + +-- | Return the random number generator for the simulation run. +generatorParameter :: Parameter Generator +generatorParameter = Parameter $ return . runGenerator + +instance Functor Parameter where + fmap = liftMP + +instance Eq (Parameter a) where + x == y = error "Can't compare parameters." + +instance Show (Parameter a) where + showsPrec _ x = showString "<< Parameter >>" + +liftMP :: (a -> b) -> Parameter a -> Parameter b +{-# INLINE liftMP #-} +liftMP f (Parameter x) = + Parameter $ \r -> do { a <- x r; return $ f a } + +liftM2P :: (a -> b -> c) -> Parameter a -> Parameter b -> Parameter c +{-# INLINE liftM2P #-} +liftM2P f (Parameter x) (Parameter y) = + Parameter $ \r -> do { a <- x r; b <- y r; return $ f a b } + +instance (Num a) => Num (Parameter a) where + x + y = liftM2P (+) x y + x - y = liftM2P (-) x y + x * y = liftM2P (*) x y + negate = liftMP negate + abs = liftMP abs + signum = liftMP signum + fromInteger i = return $ fromInteger i + +instance (Fractional a) => Fractional (Parameter a) where + x / y = liftM2P (/) x y + recip = liftMP recip + fromRational t = return $ fromRational t + +instance (Floating a) => Floating (Parameter a) where + pi = return pi + exp = liftMP exp + log = liftMP log + sqrt = liftMP sqrt + x ** y = liftM2P (**) x y + sin = liftMP sin + cos = liftMP cos + tan = liftMP tan + asin = liftMP asin + acos = liftMP acos + atan = liftMP atan + sinh = liftMP sinh + cosh = liftMP cosh + tanh = liftMP tanh + asinh = liftMP asinh + acosh = liftMP acosh + atanh = liftMP atanh + +instance MonadIO Parameter where + liftIO m = Parameter $ const m + +-- | A type class to lift the parameters to other computations. +class ParameterLift m where + + -- | Lift the specified 'Parameter' computation to another computation. + liftParameter :: Parameter a -> m a + +instance ParameterLift Parameter where + liftParameter = id + +-- | Exception handling within 'Parameter' computations. +catchParameter :: Parameter a -> (IOException -> Parameter a) -> Parameter a +catchParameter (Parameter m) h = + Parameter $ \r -> + C.catch (m r) $ \e -> + let Parameter m' = h e in m' r + +-- | A computation with finalization part like the 'finally' function. +finallyParameter :: Parameter a -> Parameter b -> Parameter a +finallyParameter (Parameter m) (Parameter m') = + Parameter $ \r -> + C.finally (m r) (m' r) + +-- | Like the standard 'throw' function. +throwParameter :: IOException -> Parameter a +throwParameter = throw + +-- | Invoke the 'Parameter' computation. +invokeParameter :: Run -> Parameter a -> IO a +{-# INLINE invokeParameter #-} +invokeParameter r (Parameter m) = m r + +instance MonadFix Parameter where + mfix f = + Parameter $ \r -> + do { rec { a <- invokeParameter r (f a) }; return a } + +-- | Memoize the 'Parameter' computation, always returning the same value +-- within a simulation run. However, the value will be recalculated for other +-- simulation runs. Also it is thread-safe when different simulation runs +-- are executed in parallel on physically different operating system threads. +memoParameter :: Parameter a -> IO (Parameter a) +memoParameter x = + do lock <- newMVar () + dict <- newIORef M.empty + return $ Parameter $ \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 <- invokeParameter r x + writeIORef dict $ M.insert i v m + return v } + +-- | Return a parameter which value is taken consequently from the specified table +-- based on the run index of the current simulation starting from zero. After all +-- values from the table are used, it takes again the first value of the table, +-- then the second one and so on. +tableParameter :: Array Int a -> Parameter a +tableParameter t = + do i <- simulationIndex + return $ t ! (((i - i1) `mod` n) + i1) + where (i1, i2) = bounds t + n = i2 - i1 + 1 + +-- | Computation that returns the start simulation time. +starttime :: Parameter Double +starttime = + Parameter $ return . spcStartTime . runSpecs + +-- | Computation that returns the final simulation time. +stoptime :: Parameter Double +stoptime = + Parameter $ return . spcStopTime . runSpecs + +-- | Computation that returns the integration time step. +dt :: Parameter Double +dt = + Parameter $ return . spcDT . runSpecs diff --git a/Simulation/Aivika/Internal/Process.hs b/Simulation/Aivika/Internal/Process.hs --- a/Simulation/Aivika/Internal/Process.hs +++ b/Simulation/Aivika/Internal/Process.hs @@ -18,29 +18,58 @@ -- A value of the 'ProcessId' type is just an identifier of such a process. -- module Simulation.Aivika.Internal.Process - (ProcessId, + (-- * Process Monad + ProcessId, Process(..), + ProcessLift(..), invokeProcess, + -- * Running Process runProcess, + runProcessUsingId, runProcessInStartTime, + runProcessInStartTimeUsingId, runProcessInStopTime, + runProcessInStopTimeUsingId, + -- * Spawning Processes + spawnProcess, + spawnProcessUsingId, + -- * Enqueuing Process enqueueProcess, - enqueueProcessWithStartTime, - enqueueProcessWithStopTime, + enqueueProcessUsingId, + -- * Creating Process Identifier newProcessId, - newProcessIdWithCatch, + processId, + processUsingId, + -- * Holding, Interrupting, Passivating and Canceling Process holdProcess, interruptProcess, processInterrupted, passivateProcess, processPassive, reactivateProcess, - processId, + cancelProcessUsingId, cancelProcess, - processCanceled, + processCancelled, + -- * Awaiting Signal + processAwait, + -- * Process Timeout + timeoutProcess, + timeoutProcessUsingId, + -- * Parallelizing Processes + processParallel, + processParallelUsingIds, + processParallel_, + processParallelUsingIds_, + -- * Exception Handling catchProcess, finallyProcess, - throwProcess) where + throwProcess, + -- * Utilities + zipProcessParallel, + zip3ProcessParallel, + unzipProcess, + -- * Memoizing Process + memoProcess) where import Data.Maybe import Data.IORef @@ -49,18 +78,18 @@ import Control.Monad.Trans import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Parameter import Simulation.Aivika.Internal.Simulation import Simulation.Aivika.Internal.Dynamics import Simulation.Aivika.Internal.Event import Simulation.Aivika.Internal.Cont +import Simulation.Aivika.Internal.Signal -- | Represents a process identifier. data ProcessId = ProcessId { processStarted :: IORef Bool, - processCatchFlag :: Bool, processReactCont :: IORef (Maybe (ContParams ())), - processCancelRef :: IORef Bool, - processCancelToken :: IORef Bool, + processCancelSource :: ContCancellationSource, processInterruptRef :: IORef Bool, processInterruptCont :: IORef (Maybe (ContParams ())), processInterruptVersion :: IORef Int } @@ -69,6 +98,15 @@ -- and then resume later. newtype Process a = Process (ProcessId -> Cont a) +-- | A type class to lift the 'Process' computation to other computations. +class ProcessLift m where + + -- | Lift the specified 'Process' computation to another computation. + liftProcess :: Process a -> m a + +instance ProcessLift Process where + liftProcess = id + -- | Invoke the process computation. invokeProcess :: ProcessId -> Process a -> Cont a {-# INLINE invokeProcess #-} @@ -123,7 +161,7 @@ a <- readIORef x case a of Nothing -> writeIORef x $ Just c - Just _ -> error "Cannot passivate the process twice: passivate" + Just _ -> error "Cannot passivate the process twice: passivateProcess" -- | Test whether the process with the specified identifier is passivated. processPassive :: ProcessId -> Event Bool @@ -146,111 +184,113 @@ do writeIORef x Nothing invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c () --- | Start immediately the process with the specified identifier. +-- | Prepare the processes identifier for running. +processIdPrepare :: ProcessId -> Event () +processIdPrepare pid = + Event $ \p -> + do y <- readIORef (processStarted pid) + if y + then error $ + "Another process with the specified identifier " ++ + "has been started already: processIdPrepare" + else writeIORef (processStarted pid) True + let signal = (contCancellationInitiating $ processCancelSource pid) + invokeEvent p $ + handleSignal_ signal $ \_ -> + do interruptProcess pid + reactivateProcess pid + +-- | Run immediately the process. A new 'ProcessId' identifier will be +-- assigned to the process. -- -- To run the process at the specified time, you can use -- the 'enqueueProcess' function. -runProcess :: ProcessId -> Process () -> Event () -runProcess pid p = - runCont m cont econt ccont (processCancelToken pid) (processCatchFlag pid) - where cont = return - econt = throwEvent - ccont = return - m = do y <- liftIO $ readIORef (processStarted pid) - if y - then error $ - "Another process with this identifier " ++ - "has been started already: runProcess" - else liftIO $ writeIORef (processStarted pid) True - invokeProcess pid p +runProcess :: Process () -> Event () +runProcess p = + do pid <- liftSimulation newProcessId + runProcessUsingId pid p + +-- | Run immediately the process with the specified identifier. +-- It will be more efficient than as you would specify the process identifier +-- with help of the 'processUsingId' combinator and then would call 'runProcess'. +-- +-- To run the process at the specified time, you can use +-- the 'enqueueProcessUsingId' function. +runProcessUsingId :: ProcessId -> Process () -> Event () +runProcessUsingId pid p = + do processIdPrepare pid + runCont m cont econt ccont (processCancelSource pid) False + where cont = return + econt = throwEvent + ccont = return + m = invokeProcess pid p --- | Start the process in the start time immediately. -runProcessInStartTime :: EventProcessing -> ProcessId -> Process () -> Simulation () -runProcessInStartTime processing pid p = - runEventInStartTime processing $ runProcess pid p +-- | Run the process in the start time immediately. +runProcessInStartTime :: EventProcessing -> Process () -> Simulation () +runProcessInStartTime processing p = + runEventInStartTime processing $ runProcess p --- | Start the process in the stop time immediately. -runProcessInStopTime :: EventProcessing -> ProcessId -> Process () -> Simulation () -runProcessInStopTime processing pid p = - runEventInStopTime processing $ runProcess pid p +-- | Run the process in the start time immediately using the specified identifier. +runProcessInStartTimeUsingId :: EventProcessing -> ProcessId -> Process () -> Simulation () +runProcessInStartTimeUsingId processing pid p = + runEventInStartTime processing $ runProcessUsingId pid p --- | Enqueue the process that will be then started at the specified time --- from the event queue. -enqueueProcess :: Double -> ProcessId -> Process () -> Event () -enqueueProcess t pid p = - enqueueEvent t $ runProcess pid p +-- | Run the process in the final simulation time immediately. +runProcessInStopTime :: EventProcessing -> Process () -> Simulation () +runProcessInStopTime processing p = + runEventInStopTime processing $ runProcess p --- | Enqueue the process that will be then started in the start time +-- | Run the process in the final simulation time immediately using the specified identifier. +runProcessInStopTimeUsingId :: EventProcessing -> ProcessId -> Process () -> Simulation () +runProcessInStopTimeUsingId processing pid p = + runEventInStopTime processing $ runProcessUsingId pid p + +-- | Enqueue the process that will be then started at the specified time -- from the event queue. -enqueueProcessWithStartTime :: ProcessId -> Process () -> Event () -enqueueProcessWithStartTime pid p = - enqueueEventWithStartTime $ runProcess pid p +enqueueProcess :: Double -> Process () -> Event () +enqueueProcess t p = + enqueueEvent t $ runProcess p --- | Enqueue the process that will be then started in the stop time +-- | Enqueue the process that will be then started at the specified time -- from the event queue. -enqueueProcessWithStopTime :: ProcessId -> Process () -> Event () -enqueueProcessWithStopTime pid p = - enqueueEventWithStopTime $ runProcess pid p +enqueueProcessUsingId :: Double -> ProcessId -> Process () -> Event () +enqueueProcessUsingId t pid p = + enqueueEvent t $ runProcessUsingId pid p -- | Return the current process identifier. processId :: Process ProcessId processId = Process return --- | Create a new process identifier without exception handling. +-- | Create a new process identifier. newProcessId :: Simulation ProcessId newProcessId = do x <- liftIO $ newIORef Nothing y <- liftIO $ newIORef False - c <- liftIO $ newIORef False - t <- liftIO $ newIORef False + c <- newContCancellationSource i <- liftIO $ newIORef False z <- liftIO $ newIORef Nothing v <- liftIO $ newIORef 0 return ProcessId { processStarted = y, - processCatchFlag = False, processReactCont = x, - processCancelRef = c, - processCancelToken = t, + processCancelSource = c, processInterruptRef = i, processInterruptCont = z, processInterruptVersion = v } --- | Create a new process identifier 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 :: Simulation ProcessId -newProcessIdWithCatch = - 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 { processStarted = y, - processCatchFlag = True, - processReactCont = x, - processCancelRef = c, - processCancelToken = t, - processInterruptRef = i, - processInterruptCont = z, - processInterruptVersion = v } +-- | Cancel a process with the specified identifier, interrupting it if needed. +cancelProcessUsingId :: ProcessId -> Event () +cancelProcessUsingId pid = contCancellationInitiate (processCancelSource pid) --- | Cancel a process with the specified identifier. -cancelProcess :: ProcessId -> Event () -cancelProcess pid = - Event $ \p -> - do z <- readIORef (processCancelRef pid) - unless z $ - do writeIORef (processCancelRef pid) True - writeIORef (processCancelToken pid) True +-- | The process cancels itself. +cancelProcess :: Process a +cancelProcess = + do pid <- processId + liftEvent $ cancelProcessUsingId pid + throwProcess $ error "The process must be cancelled already: cancelProcessItself." --- | Test whether the process with the specified identifier was canceled. -processCanceled :: ProcessId -> Event Bool -processCanceled pid = - Event $ \p -> - readIORef (processCancelRef pid) +-- | Test whether the process with the specified identifier was cancelled. +processCancelled :: ProcessId -> Event Bool +processCancelled pid = contCancellationInitiated (processCancelSource pid) instance Eq ProcessId where x == y = processReactCont x == processReactCont y -- for the references are unique @@ -262,6 +302,9 @@ instance Functor Process where fmap = liftM +instance ParameterLift Process where + liftParameter = liftPP + instance SimulationLift Process where liftSimulation = liftSP @@ -286,6 +329,10 @@ let Process m' = k a m' pid +liftPP :: Parameter a -> Process a +{-# INLINE liftPP #-} +liftPP m = Process $ \pid -> liftParameter m + liftSP :: Simulation a -> Process a {-# INLINE liftSP #-} liftSP m = Process $ \pid -> liftSimulation m @@ -323,3 +370,208 @@ throwProcess :: IOException -> Process a throwProcess = liftIO . throw +-- | Execute the specified computations in parallel within +-- the current computation and return their results. The cancellation +-- of any of the nested computations affects the current computation. +-- The exception raised in any of the nested computations is propogated +-- to the current computation as well. +-- +-- Here word @parallel@ literally means that the computations are +-- actually executed on a single operating system thread but +-- they are processed simultaneously by the event queue. +-- +-- New 'ProcessId' identifiers will be assigned to the started processes. +processParallel :: [Process a] -> Process [a] +processParallel xs = + liftSimulation (processParallelCreateIds xs) >>= processParallelUsingIds + +-- | Like 'processParallel' but allows specifying the process identifiers. +-- It will be more efficient than as you would specify the process identifiers +-- with help of the 'processUsingId' combinator and then would call 'processParallel'. +processParallelUsingIds :: [(ProcessId, Process a)] -> Process [a] +processParallelUsingIds xs = + Process $ \pid -> + do liftEvent $ processParallelPrepare xs + contParallel $ + flip map xs $ \(pid, m) -> + (invokeProcess pid m, processCancelSource pid) + +-- | Like 'processParallel' but ignores the result. +processParallel_ :: [Process a] -> Process () +processParallel_ xs = + liftSimulation (processParallelCreateIds xs) >>= processParallelUsingIds_ + +-- | Like 'processParallelUsingIds' but ignores the result. +processParallelUsingIds_ :: [(ProcessId, Process a)] -> Process () +processParallelUsingIds_ xs = + Process $ \pid -> + do liftEvent $ processParallelPrepare xs + contParallel_ $ + flip map xs $ \(pid, m) -> + (invokeProcess pid m, processCancelSource pid) + +-- | Create the new process identifiers. +processParallelCreateIds :: [Process a] -> Simulation [(ProcessId, Process a)] +processParallelCreateIds xs = + do pids <- liftSimulation $ forM xs $ const newProcessId + return $ zip pids xs + +-- | Prepare the processes for parallel execution. +processParallelPrepare :: [(ProcessId, Process a)] -> Event () +processParallelPrepare xs = + Event $ \p -> + forM_ xs $ invokeEvent p . processIdPrepare . fst + +-- | Allow calling the process with the specified identifier. +-- It creates a nested process when canceling any of two, or raising an +-- @IO@ exception in any of the both, affects the 'Process' computation. +-- +-- At the same time, the interruption has no such effect as it requires +-- explicit specifying the 'ProcessId' identifier of the nested process itself, +-- that is the nested process cannot be interrupted using only the parent +-- process identifier. +processUsingId :: ProcessId -> Process a -> Process a +processUsingId pid x = + Process $ \pid' -> + do liftEvent $ processIdPrepare pid + rerunCont (invokeProcess pid x) (processCancelSource pid) + +-- | Spawn the child process specifying how the child and parent processes +-- should be cancelled in case of need. +spawnProcess :: ContCancellation -> Process () -> Process () +spawnProcess cancellation x = + do pid <- liftSimulation $ newProcessId + spawnProcessUsingId cancellation pid x + +-- | Spawn the child process specifying how the child and parent processes +-- should be cancelled in case of need. +spawnProcessUsingId :: ContCancellation -> ProcessId -> Process () -> Process () +spawnProcessUsingId cancellation pid x = + Process $ \pid' -> + do liftEvent $ processIdPrepare pid + spawnCont cancellation (invokeProcess pid x) (processCancelSource pid) + +-- | Await the signal. +processAwait :: Signal a -> Process a +processAwait signal = + Process $ \pid -> contAwait signal + +-- | The result of memoization. +data MemoResult a = MemoComputed a + | MemoError IOException + | MemoCancelled + +-- | Memoize the process so that it would always return the same value +-- within the simulation run. +memoProcess :: Process a -> Simulation (Process a) +memoProcess x = + do started <- liftIO $ newIORef False + computed <- newSignalSource + value <- liftIO $ newIORef Nothing + let result = + do Just x <- liftIO $ readIORef value + case x of + MemoComputed a -> return a + MemoError e -> throwProcess e + MemoCancelled -> cancelProcess + return $ + do v <- liftIO $ readIORef value + case v of + Just _ -> result + Nothing -> + do f <- liftIO $ readIORef started + case f of + True -> + do processAwait $ publishSignal computed + result + False -> + do liftIO $ writeIORef started True + r <- liftIO $ newIORef MemoCancelled + finallyProcess + (catchProcess + (do a <- x -- compute only once! + liftIO $ writeIORef r (MemoComputed a)) + (\e -> + liftIO $ writeIORef r (MemoError e))) + (liftEvent $ + do liftIO $ + do x <- readIORef r + writeIORef value (Just x) + triggerSignal computed ()) + result + +-- | Zip two parallel processes waiting for the both. +zipProcessParallel :: Process a -> Process b -> Process (a, b) +zipProcessParallel x y = + do [Left a, Right b] <- processParallel [fmap Left x, fmap Right y] + return (a, b) + +-- | Zip three parallel processes waiting for their results. +zip3ProcessParallel :: Process a -> Process b -> Process c -> Process (a, b, c) +zip3ProcessParallel x y z = + do [Left a, + Right (Left b), + Right (Right c)] <- + processParallel [fmap Left x, + fmap (Right . Left) y, + fmap (Right . Right) z] + return (a, b, c) + +-- | Unzip the process using memoization so that the both returned +-- processes could be applied independently, although they will refer +-- to the same pair of values. +unzipProcess :: Process (a, b) -> Simulation (Process a, Process b) +unzipProcess xy = + do xy' <- memoProcess xy + return (fmap fst xy', fmap snd xy') + +-- | Try to run the child process within the specified timeout. +-- If the process will finish successfully within this time interval then +-- the result wrapped in 'Just' will be returned; otherwise, the child process +-- will be cancelled and 'Nothing' will be returned. +-- +-- If an exception is raised in the child process then it is propagated to +-- the parent computation as well. +-- +-- A cancellation of the child process doesn't lead to cancelling the parent process. +-- Then 'Nothing' is returned within the computation. +timeoutProcess :: Double -> Process a -> Process (Maybe a) +timeoutProcess timeout p = + do pid <- liftSimulation newProcessId + timeoutProcessUsingId timeout pid p + +-- | Try to run the child process with the given identifier within the specified timeout. +-- If the process will finish successfully within this time interval then +-- the result wrapped in 'Just' will be returned; otherwise, the child process +-- will be cancelled and 'Nothing' will be returned. +-- +-- If an exception is raised in the child process then it is propagated to +-- the parent computation as well. +-- +-- A cancellation of the child process doesn't lead to cancelling the parent process. +-- Then 'Nothing' is returned within the computation. +timeoutProcessUsingId :: Double -> ProcessId -> Process a -> Process (Maybe a) +timeoutProcessUsingId timeout pid p = + do s <- liftSimulation newSignalSource + timeoutPid <- liftSimulation newProcessId + spawnProcessUsingId CancelChildAfterParent timeoutPid $ + finallyProcess + (holdProcess timeout) + (liftEvent $ + cancelProcessUsingId pid) + spawnProcessUsingId CancelChildAfterParent pid $ + do r <- liftIO $ newIORef Nothing + finallyProcess + (catchProcess + (do a <- p + liftIO $ writeIORef r $ Just (Right a)) + (\e -> + liftIO $ writeIORef r $ Just (Left e))) + (liftEvent $ + do x <- liftIO $ readIORef r + triggerSignal s x) + x <- processAwait $ publishSignal s + case x of + Nothing -> return Nothing + Just (Right a) -> return (Just a) + Just (Left e) -> throwProcess e diff --git a/Simulation/Aivika/Internal/Signal.hs b/Simulation/Aivika/Internal/Signal.hs --- a/Simulation/Aivika/Internal/Signal.hs +++ b/Simulation/Aivika/Internal/Signal.hs @@ -14,10 +14,14 @@ -- module Simulation.Aivika.Internal.Signal - (Signal(..), - SignalSource(..), - newSignalSource, + (-- * Handling and Triggering Signal + Signal(..), handleSignal_, + SignalSource, + newSignalSource, + publishSignal, + triggerSignal, + -- * Useful Combinators mapSignal, mapSignalM, apSignal, @@ -27,18 +31,39 @@ merge2Signals, merge3Signals, merge4Signals, - merge5Signals) where + merge5Signals, + -- * Creating Signal in Time Points + newSignalInTimes, + newSignalInIntegTimes, + newSignalInStartTime, + newSignalInStopTime, + -- * Signal History + SignalHistory, + signalHistorySignal, + newSignalHistory, + readSignalHistory, + -- * Signalable Computations + Signalable(..), + signalableChanged, + emptySignalable, + appendSignalable) where import Data.IORef import Data.Monoid +import Data.List +import Data.Array import Control.Monad import Control.Monad.Trans import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Parameter import Simulation.Aivika.Internal.Simulation import Simulation.Aivika.Internal.Event +import qualified Simulation.Aivika.Vector as V +import qualified Simulation.Aivika.Vector.Unboxed as UV + -- | The signal source that can publish its signal. data SignalSource a = SignalSource { publishSignal :: Signal a, @@ -60,15 +85,16 @@ -- | The queue of signal handlers. data SignalHandlerQueue a = - SignalHandlerQueue { queueStart :: IORef (Maybe (SignalHandler a)), - queueEnd :: IORef (Maybe (SignalHandler a)) } + SignalHandlerQueue { queueList :: IORef [SignalHandler a] } -- | It contains the information about the disposable queue handler. data SignalHandler a = SignalHandler { handlerComp :: a -> Event (), - handlerPrev :: IORef (Maybe (SignalHandler a)), - handlerNext :: IORef (Maybe (SignalHandler a)) } + handlerRef :: IORef () } +instance Eq (SignalHandler a) where + x == y = (handlerRef x) == (handlerRef y) + -- | Subscribe the handler to the specified signal. -- To subscribe the disposable handlers, use function 'handleSignal'. handleSignal_ :: Signal a -> (a -> Event ()) -> Event () @@ -80,10 +106,8 @@ newSignalSource :: Simulation (SignalSource a) newSignalSource = Simulation $ \r -> - do start <- newIORef Nothing - end <- newIORef Nothing - let queue = SignalHandlerQueue { queueStart = start, - queueEnd = end } + do list <- newIORef [] + let queue = SignalHandlerQueue { queueList = list } signal = Signal { handleSignal = handle } source = SignalSource { publishSignal = signal, triggerSignal = trigger } @@ -93,73 +117,32 @@ return $ Event $ \p -> dequeueSignalHandler queue x trigger a = - Event $ \p -> - let h = queueStart queue - in triggerSignalHandlers h a p + Event $ \p -> triggerSignalHandlers queue a p return source -- | Trigger all next signal handlers. -triggerSignalHandlers :: IORef (Maybe (SignalHandler a)) -> a -> Point -> IO () +triggerSignalHandlers :: SignalHandlerQueue a -> a -> Point -> IO () {-# INLINE triggerSignalHandlers #-} -triggerSignalHandlers r a p = - do x <- readIORef r - case x of - Nothing -> return () - Just h -> - do invokeEvent p $ handlerComp h a - triggerSignalHandlers (handlerNext h) a p +triggerSignalHandlers q a p = + do hs <- readIORef (queueList q) + forM_ hs $ \h -> + invokeEvent p $ handlerComp h a -- | Enqueue the handler and return its representative in the queue. enqueueSignalHandler :: SignalHandlerQueue a -> (a -> Event ()) -> IO (SignalHandler a) +{-# INLINE enqueueSignalHandler #-} 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 + do r <- newIORef () + let handler = SignalHandler { handlerComp = h, + handlerRef = r } + modifyIORef (queueList q) (handler :) + return handler -- | Dequeue the handler representative. dequeueSignalHandler :: SignalHandlerQueue a -> SignalHandler a -> IO () +{-# INLINE dequeueSignalHandler #-} 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 + modifyIORef (queueList q) (delete h) instance Functor Signal where fmap = mapSignal @@ -258,3 +241,100 @@ emptySignal :: Signal a emptySignal = Signal { handleSignal = \h -> return $ return () } + +-- | Represents the history of the signal values. +data SignalHistory a = + SignalHistory { signalHistorySignal :: Signal a, + -- ^ The signal for which the history is created. + signalHistoryTimes :: UV.Vector Double, + signalHistoryValues :: V.Vector a } + +-- | Create a history of the signal values. +newSignalHistory :: Signal a -> Event (SignalHistory a) +newSignalHistory signal = + do ts <- liftIO UV.newVector + xs <- liftIO V.newVector + handleSignal_ signal $ \a -> + Event $ \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 -> Event (Array Int Double, Array Int a) +readSignalHistory history = + do xs <- liftIO $ UV.freezeVector (signalHistoryTimes history) + ys <- liftIO $ V.freezeVector (signalHistoryValues history) + return (xs, ys) + +-- | Trigger the signal with the current time. +triggerSignalWithCurrentTime :: SignalSource Double -> Event () +triggerSignalWithCurrentTime s = + Event $ \p -> invokeEvent p $ triggerSignal s (pointTime p) + +-- | Return a signal that is triggered in the specified time points. +newSignalInTimes :: [Double] -> Event (Signal Double) +newSignalInTimes xs = + do s <- liftSimulation newSignalSource + enqueueEventWithTimes xs $ triggerSignalWithCurrentTime s + return $ publishSignal s + +-- | Return a signal that is triggered in the integration time points. +-- It should be called with help of 'runEventInStartTime'. +newSignalInIntegTimes :: Event (Signal Double) +newSignalInIntegTimes = + do s <- liftSimulation newSignalSource + enqueueEventWithIntegTimes $ triggerSignalWithCurrentTime s + return $ publishSignal s + +-- | Return a signal that is triggered in the start time. +-- It should be called with help of 'runEventInStartTime'. +newSignalInStartTime :: Event (Signal Double) +newSignalInStartTime = + do s <- liftSimulation newSignalSource + t <- liftParameter starttime + enqueueEvent t $ triggerSignalWithCurrentTime s + return $ publishSignal s + +-- | Return a signal that is triggered in the final time. +newSignalInStopTime :: Event (Signal Double) +newSignalInStopTime = + do s <- liftSimulation newSignalSource + t <- liftParameter stoptime + enqueueEvent t $ triggerSignalWithCurrentTime s + return $ publishSignal s + +-- | Describes a computation that also signals when changing its value. +data Signalable a = + Signalable { readSignalable :: Event a, + -- ^ Return a computation of the value. + signalableChanged_ :: Signal () + -- ^ Return a signal notifying that the value has changed + -- but without providing the information about the changed value. + } + +-- | Return a signal notifying that the value has changed. +signalableChanged :: Signalable a -> Signal a +signalableChanged x = mapSignalM (const $ readSignalable x) $ signalableChanged_ x + +instance Functor Signalable where + fmap f x = x { readSignalable = fmap f (readSignalable x) } + +instance Monoid a => Monoid (Signalable a) where + + mempty = emptySignalable + mappend = appendSignalable + +-- | Return an identity. +emptySignalable :: Monoid a => Signalable a +emptySignalable = + Signalable { readSignalable = return mempty, + signalableChanged_ = mempty } + +-- | An associative operation. +appendSignalable :: Monoid a => Signalable a -> Signalable a -> Signalable a +appendSignalable m1 m2 = + Signalable { readSignalable = liftM2 (<>) (readSignalable m1) (readSignalable m2), + signalableChanged_ = (signalableChanged_ m1) <> (signalableChanged_ m2) } diff --git a/Simulation/Aivika/Internal/Simulation.hs b/Simulation/Aivika/Internal/Simulation.hs --- a/Simulation/Aivika/Internal/Simulation.hs +++ b/Simulation/Aivika/Internal/Simulation.hs @@ -9,7 +9,8 @@ -- Stability : experimental -- Tested with: GHC 7.6.3 -- --- The module defines the 'Simulation' monad that represents a simulation run. +-- The module defines the 'Simulation' monad that represents a computation +-- within the simulation run. -- module Simulation.Aivika.Internal.Simulation (-- * Simulation @@ -23,10 +24,9 @@ finallySimulation, throwSimulation, -- * Utilities - simulationIndex, - simulationCount, - simulationSpecs, - simulationEventQueue) where + simulationEventQueue, + -- * Memoization + memoSimulation) where import qualified Control.Exception as C import Control.Exception (IOException, throw, finally) @@ -35,19 +35,14 @@ import Control.Monad.Trans import Control.Monad.Fix +import Data.IORef + +import Simulation.Aivika.Generator import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Parameter --- | A value in the 'Simulation' monad represents something that --- doesn't change within the simulation run but may change for --- other runs. --- --- This monad is ideal for representing the external --- parameters for the model, when the Monte-Carlo simulation --- is used. Also this monad is useful for defining some --- actions that should occur only once within the simulation run, --- for example, setting of the integral with help of recursive --- equations. --- +-- | A value in the 'Simulation' monad represents a computation +-- within the simulation run. newtype Simulation a = Simulation (Run -> IO a) instance Monad Simulation where @@ -70,32 +65,24 @@ runSimulation :: Simulation a -> Specs -> IO a runSimulation (Simulation m) sc = do q <- newEventQueue sc + g <- newGenerator $ spcGeneratorType sc m Run { runSpecs = sc, runIndex = 1, runCount = 1, - runEventQueue = q } + runEventQueue = q, + runGenerator = g } -- | Run the given number of simulations using the specified specs, -- where each simulation is distinguished by its index 'simulationIndex'. runSimulations :: Simulation a -> Specs -> Int -> [IO a] runSimulations (Simulation m) sc runs = map f [1 .. runs] where f i = do q <- newEventQueue sc + g <- newGenerator $ spcGeneratorType sc m Run { runSpecs = sc, runIndex = i, runCount = runs, - runEventQueue = q } - --- | Return the run index for the current simulation. -simulationIndex :: Simulation Int -simulationIndex = Simulation $ return . runIndex - --- | Return the number of simulations currently run. -simulationCount :: Simulation Int -simulationCount = Simulation $ return . runCount - --- | Return the simulation specs. -simulationSpecs :: Simulation Specs -simulationSpecs = Simulation $ return . runSpecs + runEventQueue = q, + runGenerator = g } -- | Return the event queue. simulationEventQueue :: Simulation EventQueue @@ -104,66 +91,30 @@ instance Functor Simulation where fmap = liftMS -instance Eq (Simulation a) where - x == y = error "Can't compare simulation runs." - -instance Show (Simulation a) where - showsPrec _ x = showString "<< Simulation >>" - liftMS :: (a -> b) -> Simulation a -> Simulation b {-# INLINE liftMS #-} liftMS f (Simulation x) = Simulation $ \r -> do { a <- x r; return $ f a } -liftM2S :: (a -> b -> c) -> Simulation a -> Simulation b -> Simulation c -{-# INLINE liftM2S #-} -liftM2S f (Simulation x) (Simulation y) = - Simulation $ \r -> do { a <- x r; b <- y r; return $ f a b } - -instance (Num a) => Num (Simulation a) where - x + y = liftM2S (+) x y - x - y = liftM2S (-) x y - x * y = liftM2S (*) x y - negate = liftMS negate - abs = liftMS abs - signum = liftMS signum - fromInteger i = return $ fromInteger i - -instance (Fractional a) => Fractional (Simulation a) where - x / y = liftM2S (/) x y - recip = liftMS recip - fromRational t = return $ fromRational t - -instance (Floating a) => Floating (Simulation a) where - pi = return pi - exp = liftMS exp - log = liftMS log - sqrt = liftMS sqrt - x ** y = liftM2S (**) x y - sin = liftMS sin - cos = liftMS cos - tan = liftMS tan - asin = liftMS asin - acos = liftMS acos - atan = liftMS atan - sinh = liftMS sinh - cosh = liftMS cosh - tanh = liftMS tanh - asinh = liftMS asinh - acosh = liftMS acosh - atanh = liftMS atanh - instance MonadIO Simulation where liftIO m = Simulation $ const m --- | A type class to lift the simulation computations to other monads. -class Monad m => SimulationLift m where +-- | A type class to lift the simulation computations to other computations. +class SimulationLift m where - -- | Lift the specified 'Simulation' computation to another monad. + -- | Lift the specified 'Simulation' computation to another computation. liftSimulation :: Simulation a -> m a instance SimulationLift Simulation where liftSimulation = id + +instance ParameterLift Simulation where + liftParameter = liftPS + +liftPS :: Parameter a -> Simulation a +{-# INLINE liftPS #-} +liftPS (Parameter x) = + Simulation x -- | Exception handling within 'Simulation' computations. catchSimulation :: Simulation a -> (IOException -> Simulation a) -> Simulation a @@ -191,3 +142,17 @@ mfix f = Simulation $ \r -> do { rec { a <- invokeSimulation r (f a) }; return a } + +-- | Memoize the 'Simulation' computation, always returning the same value +-- within a simulation run. +memoSimulation :: Simulation a -> Simulation (Simulation a) +memoSimulation m = + do ref <- liftIO $ newIORef Nothing + return $ Simulation $ \r -> + do x <- readIORef ref + case x of + Just v -> return v + Nothing -> + do v <- invokeSimulation r m + writeIORef ref (Just v) + return v diff --git a/Simulation/Aivika/Internal/Specs.hs b/Simulation/Aivika/Internal/Specs.hs --- a/Simulation/Aivika/Internal/Specs.hs +++ b/Simulation/Aivika/Internal/Specs.hs @@ -30,14 +30,17 @@ import Data.IORef +import Simulation.Aivika.Generator import qualified Simulation.Aivika.PriorityQueue as PQ -- | It defines the simulation specs. data Specs = Specs { spcStartTime :: Double, -- ^ the start time spcStopTime :: Double, -- ^ the stop time spcDT :: Double, -- ^ the integration time step - spcMethod :: Method -- ^ the integration method - } deriving (Eq, Ord, Show) + spcMethod :: Method, -- ^ the integration method + spcGeneratorType :: GeneratorType + -- ^ the type of the random number generator + } -- | It defines the integration method. data Method = Euler -- ^ Euler's method @@ -49,7 +52,8 @@ data Run = Run { runSpecs :: Specs, -- ^ the simulation specs runIndex :: Int, -- ^ the current simulation run index runCount :: Int, -- ^ the total number of runs in this experiment - runEventQueue :: EventQueue -- ^ the event queue + runEventQueue :: EventQueue, -- ^ the event queue + runGenerator :: Generator -- ^ the random number generator } -- | It defines the simulation point appended with the additional information. diff --git a/Simulation/Aivika/Parameter.hs b/Simulation/Aivika/Parameter.hs --- a/Simulation/Aivika/Parameter.hs +++ b/Simulation/Aivika/Parameter.hs @@ -1,4 +1,3 @@ - -- | -- Module : Simulation.Aivika.Parameter -- Copyright : Copyright (c) 2009-2013, David Sorokin @@ -7,53 +6,30 @@ -- Stability : experimental -- Tested with: GHC 7.6.3 -- --- This module defines the parameters of simulation experiments. --- - +-- The module defines the 'Parameter' monad that allows representing the model +-- parameters. For example, they can be used when running the Monte-Carlo simulation. +-- module Simulation.Aivika.Parameter - (newParameter, - newTableParameter, - newIndexedParameter) where - -import Data.Array -import Data.IORef -import qualified Data.Map as M -import Control.Concurrent.MVar - -import Simulation.Aivika.Internal.Specs -import Simulation.Aivika.Internal.Simulation - --- | Create a thread-safe parameter that returns always the same value within the simulation run, --- where the value is recalculated for each new run. -newParameter :: IO a -> IO (Simulation a) -newParameter a = newIndexedParameter $ \_ -> a - --- | Create a thread-safe parameter that returns always the same value within 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 (Simulation a) -newTableParameter t = newIndexedParameter (\i -> return $ t ! (((i - i1) `mod` n) + i1)) - where (i1, i2) = bounds t - n = i2 - i1 + 1 + (-- * Parameter + Parameter, + ParameterLift(..), + runParameter, + runParameters, + -- * Error Handling + catchParameter, + finallyParameter, + throwParameter, + -- * Predefined Parameters + simulationIndex, + simulationCount, + simulationSpecs, + generatorParameter, + starttime, + stoptime, + dt, + -- * Memoization + memoParameter, + -- * Utilities + tableParameter) where --- | Create a thread-safe parameter that returns always the same value within the simulation run, --- where the value depends on the number of this run starting from zero. -newIndexedParameter :: (Int -> IO a) -> IO (Simulation a) -newIndexedParameter f = - do lock <- newMVar () - dict <- newIORef M.empty - 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 } +import Simulation.Aivika.Internal.Parameter diff --git a/Simulation/Aivika/Parameter/Random.hs b/Simulation/Aivika/Parameter/Random.hs --- a/Simulation/Aivika/Parameter/Random.hs +++ b/Simulation/Aivika/Parameter/Random.hs @@ -11,31 +11,130 @@ -- module Simulation.Aivika.Parameter.Random - (newRandomParameter, - newNormalParameter) where + (randomUniform, + randomNormal, + randomExponential, + randomErlang, + randomPoisson, + randomBinomial) where import System.Random -import Simulation.Aivika.Simulation -import Simulation.Aivika.Random -import Simulation.Aivika.Parameter +import Control.Monad.Trans --- | Create a new random parameter distributed uniformly. --- The value doesn't change within the simulation run but --- then the value is recalculated for each new run. -newRandomParameter :: Simulation Double -- ^ minimum - -> Simulation Double -- ^ maximum - -> IO (Simulation Double) -newRandomParameter min max = - do x <- newParameter $ getStdRandom random - return $ min + x * (max - min) +import Simulation.Aivika.Generator +import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Parameter --- | Create a new random parameter distributed normally. --- The value doesn't change within the simulation run but --- then the value is recalculated for each new run. -newNormalParameter :: Simulation Double -- ^ mean - -> Simulation Double -- ^ variance - -> IO (Simulation Double) -newNormalParameter mu nu = - do x <- newNormalGen >>= newParameter - return $ mu + x * nu +-- | Computation that generates a new random number distributed uniformly. +-- +-- To create a parameter that would return the same value within the simulation run, +-- you should memoize the computation, which is important for the Monte-Carlo simulation. +-- +-- To create a random function that would return the same values in the integration +-- time points within the simulation run, you should either lift the computation to +-- the @Dynamics@ computation and then memoize it too but using the corresponded +-- function for that computation, or just take the predefined function that does +-- namely this. +randomUniform :: Double -- ^ minimum + -> Double -- ^ maximum + -> Parameter Double +randomUniform min max = + Parameter $ \r -> + let g = runGenerator r + in generatorUniform g min max + +-- | Computation that generates a new random number distributed normally. +-- +-- To create a parameter that would return the same value within the simulation run, +-- you should memoize the computation, which is important for the Monte-Carlo simulation. +-- +-- To create a random function that would return the same values in the integration +-- time points within the simulation run, you should either lift the computation to +-- the @Dynamics@ computation and then memoize it too but using the corresponded +-- function for that computation, or just take the predefined function that does +-- namely this. +randomNormal :: Double -- ^ mean + -> Double -- ^ deviation + -> Parameter Double +randomNormal mu nu = + Parameter $ \r -> + let g = runGenerator r + in generatorNormal g mu nu + +-- | Computation that returns a new exponential random number with the specified mean +-- (the reciprocal of the rate). +-- +-- To create a parameter that would return the same value within the simulation run, +-- you should memoize the computation, which is important for the Monte-Carlo simulation. +-- +-- To create a random function that would return the same values in the integration +-- time points within the simulation run, you should either lift the computation to +-- the @Dynamics@ computation and then memoize it too but using the corresponded +-- function for that computation, or just take the predefined function that does +-- namely this. +randomExponential :: Double + -- ^ the mean (the reciprocal of the rate) + -> Parameter Double +randomExponential mu = + Parameter $ \r -> + let g = runGenerator r + in generatorExponential g mu + +-- | Computation that returns a new Erlang random number with the specified scale +-- (the reciprocal of the rate) and integer shape. +-- +-- To create a parameter that would return the same value within the simulation run, +-- you should memoize the computation, which is important for the Monte-Carlo simulation. +-- +-- To create a random function that would return the same values in the integration +-- time points within the simulation run, you should either lift the computation to +-- the @Dynamics@ computation and then memoize it too but using the corresponded +-- function for that computation, or just take the predefined function that does +-- namely this. +randomErlang :: Double + -- ^ the scale (the reciprocal of the rate) + -> Int + -- ^ the shape + -> Parameter Double +randomErlang beta m = + Parameter $ \r -> + let g = runGenerator r + in generatorErlang g beta m + +-- | Computation that returns a new Poisson random number with the specified mean. +-- +-- To create a parameter that would return the same value within the simulation run, +-- you should memoize the computation, which is important for the Monte-Carlo simulation. +-- +-- To create a random function that would return the same values in the integration +-- time points within the simulation run, you should either lift the computation to +-- the @Dynamics@ computation and then memoize it too but using the corresponded +-- function for that computation, or just take the predefined function that does +-- namely this. +randomPoisson :: Double + -- ^ the mean + -> Parameter Int +randomPoisson mu = + Parameter $ \r -> + let g = runGenerator r + in generatorPoisson g mu + +-- | Computation that returns a new binomial random number with the specified +-- probability and trials. +-- +-- To create a parameter that would return the same value within the simulation run, +-- you should memoize the computation, which is important for the Monte-Carlo simulation. +-- +-- To create a random function that would return the same values in the integration +-- time points within the simulation run, you should either lift the computation to +-- the @Dynamics@ computation and then memoize it too but using the corresponded +-- function for that computation, or just take the predefined function that does +-- namely this. +randomBinomial :: Double -- ^ the probability + -> Int -- ^ the number of trials + -> Parameter Int +randomBinomial prob trials = + Parameter $ \r -> + let g = runGenerator r + in generatorBinomial g prob trials diff --git a/Simulation/Aivika/PriorityQueue.hs b/Simulation/Aivika/PriorityQueue.hs --- a/Simulation/Aivika/PriorityQueue.hs +++ b/Simulation/Aivika/PriorityQueue.hs diff --git a/Simulation/Aivika/Process.hs b/Simulation/Aivika/Process.hs --- a/Simulation/Aivika/Process.hs +++ b/Simulation/Aivika/Process.hs @@ -17,31 +17,60 @@ -- -- A value of the 'ProcessId' type is just an identifier of such a process. -- +-- The characteristic property of the @Process@ type is function 'holdProcess' +-- that suspends the current process for the specified time interval. +-- module Simulation.Aivika.Process - (ProcessId, + (-- * Process Monad + ProcessId, Process, + ProcessLift(..), + -- * Running Process runProcess, + runProcessUsingId, runProcessInStartTime, + runProcessInStartTimeUsingId, runProcessInStopTime, + runProcessInStopTimeUsingId, + -- * Spawning Processes + spawnProcess, + spawnProcessUsingId, + -- * Enqueuing Process enqueueProcess, - enqueueProcessWithStartTime, - enqueueProcessWithStopTime, + enqueueProcessUsingId, + -- * Creating Process Identifier newProcessId, - newProcessIdWithCatch, processId, + processUsingId, + -- * Holding, Interrupting, Passivating and Canceling Process holdProcess, interruptProcess, processInterrupted, passivateProcess, processPassive, reactivateProcess, + cancelProcessUsingId, cancelProcess, - processCanceled, + processCancelled, + -- * Awaiting Signal + processAwait, + -- * Process Timeout + timeoutProcess, + timeoutProcessUsingId, + -- * Parallelizing Processes + processParallel, + processParallelUsingIds, + processParallel_, + processParallelUsingIds_, + -- * Exception Handling catchProcess, finallyProcess, - throwProcess) where + throwProcess, + -- * Utilities + zipProcessParallel, + zip3ProcessParallel, + unzipProcess, + -- * Memoizing Process + memoProcess) where -import Simulation.Aivika.Internal.Simulation -import Simulation.Aivika.Internal.Dynamics -import Simulation.Aivika.Internal.Event import Simulation.Aivika.Internal.Process diff --git a/Simulation/Aivika/Processor.hs b/Simulation/Aivika/Processor.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Processor.hs @@ -0,0 +1,414 @@ + +-- | +-- Module : Simulation.Aivika.Processor +-- Copyright : Copyright (c) 2009-2013, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- The processor of simulation data. +-- +module Simulation.Aivika.Processor + (-- * Processor Type + Processor(..), + -- * Creating Simple Processor + simpleProcessor, + statefulProcessor, + -- * Specifying Identifier + processorUsingId, + -- * Buffer Processor + bufferProcessor, + bufferProcessorLoop, + -- * Processing Queues + queueProcessor, + queueProcessorLoopMerging, + queueProcessorLoopSeq, + queueProcessorLoopParallel, + -- * Parallelizing Processors + processorParallel, + processorQueuedParallel, + processorPrioritisingOutputParallel, + processorPrioritisingInputParallel, + processorPrioritisingInputOutputParallel) where + +import qualified Control.Category as C +import Control.Arrow + +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Event +import Simulation.Aivika.Cont +import Simulation.Aivika.Process +import Simulation.Aivika.Stream +import Simulation.Aivika.QueueStrategy + +-- | Represents a processor of simulation data. +newtype Processor a b = + Processor { runProcessor :: Stream a -> Stream b + -- ^ Run the processor. + } + +instance C.Category Processor where + + id = Processor id + + Processor x . Processor y = Processor (x . y) + +-- The implementation is based on article +-- A New Notation for Arrows by Ross Paterson, +-- although my streams are different and they +-- already depend on the Process monad, +-- while the pure streams were considered in the +-- mentioned article. +instance Arrow Processor where + + arr = Processor . mapStream + + first (Processor f) = + Processor $ \xys -> + Cons $ + do (xs, ys) <- liftSimulation $ unzipStream xys + runStream $ zipStreamSeq (f xs) ys + + second (Processor f) = + Processor $ \xys -> + Cons $ + do (xs, ys) <- liftSimulation $ unzipStream xys + runStream $ zipStreamSeq xs (f ys) + + Processor f *** Processor g = + Processor $ \xys -> + Cons $ + do (xs, ys) <- liftSimulation $ unzipStream xys + runStream $ zipStreamSeq (f xs) (g ys) + +-- N.B. +-- Very probably, Processor is not ArrowLoop, +-- which would be natural as Process is not MonadFix, +-- for the discontinuous process is not irreversible +-- and the time flows in one direction only. +-- +-- -- The implementation is based on article +-- -- A New Notation for Arrows by Ross Paterson, +-- -- although my streams are different and they +-- -- already depend on the Process monad, +-- -- while the pure streams were considered in the +-- -- mentioned article. +-- instance ArrowLoop Processor where +-- +-- loop (Processor f) = +-- Processor $ \xs -> +-- Cons $ +-- do Cons zs <- liftSimulation $ +-- simulationLoop (\(xs, ys) -> +-- unzipStream $ f $ zipStreamSeq xs ys) xs +-- zs +-- +-- simulationLoop :: ((b, d) -> Simulation (c, d)) -> b -> Simulation c +-- simulationLoop f b = +-- mdo (c, d) <- f (b, d) +-- return c + +-- The implementation is based on article +-- A New Notation for Arrows by Ross Paterson, +-- although my streams are different and they +-- already depend on the Process monad, +-- while the pure streams were considered in the +-- mentioned article. +instance ArrowChoice Processor where + + left (Processor f) = + Processor $ \xs -> + Cons $ + do ys <- liftSimulation $ memoStream xs + runStream $ replaceLeftStream ys (f $ leftStream ys) + + right (Processor f) = + Processor $ \xs -> + Cons $ + do ys <- liftSimulation $ memoStream xs + runStream $ replaceRightStream ys (f $ rightStream ys) + +instance ArrowZero Processor where + + zeroArrow = Processor $ const emptyStream + +instance ArrowPlus Processor where + + (Processor f) <+> (Processor g) = + Processor $ \xs -> + Cons $ + do [xs1, xs2] <- liftSimulation $ splitStream 2 xs + runStream $ mergeStreams (f xs1) (g xs2) + +-- These instances are meaningless: +-- +-- instance SimulationLift (Processor a) where +-- liftSimulation = Processor . mapStreamM . const . liftSimulation +-- +-- instance DynamicsLift (Processor a) where +-- liftDynamics = Processor . mapStreamM . const . liftDynamics +-- +-- instance EventLift (Processor a) where +-- liftEvent = Processor . mapStreamM . const . liftEvent +-- +-- instance ProcessLift (Processor a) where +-- liftProcess = Processor . mapStreamM . const -- data first! + +-- | Create a simple processor by the specified handling function +-- that runs the discontinuous process for each input value to get the output. +simpleProcessor :: (a -> Process b) -> Processor a b +simpleProcessor = Processor . mapStreamM + +-- | Like 'simpleProcessor' but allows creating a processor that has a state +-- which is passed in to every new iteration. +statefulProcessor :: s -> ((s, a) -> Process (s, b)) -> Processor a b +statefulProcessor s f = + Processor $ \xs -> Cons $ loop s xs where + loop s xs = + do (a, xs') <- runStream xs + (s', b) <- f (s, a) + return (b, Cons $ loop s' xs') + +-- | Create a processor that will use the specified process identifier. +-- It can be useful to refer to the underlying 'Process' computation which +-- can be passivated, interrupted, canceled and so on. See also the +-- 'processUsingId' function for more details. +processorUsingId :: ProcessId -> Processor a b -> Processor a b +processorUsingId pid (Processor f) = + Processor $ Cons . processUsingId pid . runStream . f + +-- | Launches the specified processors in parallel consuming the same input +-- stream and producing a combined output stream. +-- +-- If you don't know what the enqueue strategies to apply, then +-- you will probably need 'FCFS' for the both parameters, or +-- function 'processorParallel' that does namely this. +processorQueuedParallel :: (EnqueueStrategy si qi, + EnqueueStrategy so qo) + => si + -- ^ the strategy applied for enqueuing the input data + -> so + -- ^ the strategy applied for enqueuing the output data + -> [Processor a b] + -- ^ the processors to parallelize + -> Processor a b + -- ^ the parallelized processor +processorQueuedParallel si so ps = + Processor $ \xs -> + Cons $ + do let n = length ps + input <- liftSimulation $ splitStreamQueuing si n xs + let results = flip map (zip input ps) $ \(input, p) -> + runProcessor p input + output = concatQueuedStreams so results + runStream output + +-- | Launches the specified processors in parallel using priorities for combining the output. +processorPrioritisingOutputParallel :: (EnqueueStrategy si qi, + PriorityQueueStrategy so qo po) + => si + -- ^ the strategy applied for enqueuing the input data + -> so + -- ^ the strategy applied for enqueuing the output data + -> [Processor a (po, b)] + -- ^ the processors to parallelize + -> Processor a b + -- ^ the parallelized processor +processorPrioritisingOutputParallel si so ps = + Processor $ \xs -> + Cons $ + do let n = length ps + input <- liftSimulation $ splitStreamQueuing si n xs + let results = flip map (zip input ps) $ \(input, p) -> + runProcessor p input + output = concatPriorityStreams so results + runStream output + +-- | Launches the specified processors in parallel using priorities for consuming the intput. +processorPrioritisingInputParallel :: (PriorityQueueStrategy si qi pi, + EnqueueStrategy so qo) + => si + -- ^ the strategy applied for enqueuing the input data + -> so + -- ^ the strategy applied for enqueuing the output data + -> [(Stream pi, Processor a b)] + -- ^ the streams of input priorities and the processors + -- to parallelize + -> Processor a b + -- ^ the parallelized processor +processorPrioritisingInputParallel si so ps = + Processor $ \xs -> + Cons $ + do input <- liftSimulation $ splitStreamPrioritising si (map fst ps) xs + let results = flip map (zip input ps) $ \(input, (_, p)) -> + runProcessor p input + output = concatQueuedStreams so results + runStream output + +-- | Launches the specified processors in parallel using priorities for consuming +-- the input and combining the output. +processorPrioritisingInputOutputParallel :: (PriorityQueueStrategy si qi pi, + PriorityQueueStrategy so qo po) + => si + -- ^ the strategy applied for enqueuing the input data + -> so + -- ^ the strategy applied for enqueuing the output data + -> [(Stream pi, Processor a (po, b))] + -- ^ the streams of input priorities and the processors + -- to parallelize + -> Processor a b + -- ^ the parallelized processor +processorPrioritisingInputOutputParallel si so ps = + Processor $ \xs -> + Cons $ + do input <- liftSimulation $ splitStreamPrioritising si (map fst ps) xs + let results = flip map (zip input ps) $ \(input, (_, p)) -> + runProcessor p input + output = concatPriorityStreams so results + runStream output + +-- | Launches the processors in parallel consuming the same input stream and producing +-- a combined output stream. This version applies the 'FCFS' strategy both for input +-- and output, which suits the most part of uses cases. +processorParallel :: [Processor a b] -> Processor a b +processorParallel = processorQueuedParallel FCFS FCFS + +-- | Create a buffer processor, where the process from the first argument +-- consumes the input stream but the stream passed in as the second argument +-- and produced usually by some other process is returned as an output. +-- This kind of processor is very useful for modeling the queues. +bufferProcessor :: (Stream a -> Process ()) + -- ^ a separate process to consume the input + -> Stream b + -- ^ the resulting stream of data + -> Processor a b +bufferProcessor consume output = + Processor $ \xs -> + Cons $ + do spawnProcess CancelTogether (consume xs) + runStream output + +-- | Like 'bufferProcessor' but allows creating a loop when some items +-- can be returned for processing them again. It is very useful for +-- modeling the processors with queues and loop-backs. +bufferProcessorLoop :: (Stream a -> Stream c -> Process ()) + -- ^ consume two streams: the input values of type @a@ + -- and the values of type @c@ returned by the loop + -> Stream d + -- ^ the stream of data that may become results + -> Processor d (Either c b) + -- ^ process and then decide what values of type @c@ + -- should be processed again + -> Processor a b +bufferProcessorLoop consume preoutput filter = + Processor $ \xs -> + Cons $ + do (reverted, output) <- + liftSimulation $ + partitionEitherStream $ + runProcessor filter preoutput + spawnProcess CancelTogether (consume xs reverted) + runStream output + +-- | Return a processor with help of which we can model the queue. +-- +-- Although the function doesn't refer to the queue directly, its main use case +-- is namely a processing of the queue. The first argument should be the enqueueing +-- operation, while the second argument should be the opposite dequeueing operation. +-- +-- The reason is as follows. There are many possible combinations how the queues +-- can be modeled. There is no sense to enumerate all them creating a separate function +-- for each case. We can just use combinators to define exactly what we need. +-- +-- So, the queue can lose the input items if the queue is full, or the input process +-- can suspend while the queue is full, or we can use priorities for enqueueing, +-- storing and dequeueing the items in different combinations. There are so many use +-- cases! +-- +-- There is a hope that this function along with other similar functions from this +-- module is sufficient to cover the most important cases. Even if it is not sufficient +-- then you can use a more generic function 'bufferProcessor' which this function is +-- based on. In case of need, you can even write your own function from scratch. It is +-- quite easy actually. +queueProcessor :: (a -> Process ()) + -- ^ enqueue the input item and wait + -- while the queue is full if required + -- so that there was no hanging items + -> Process b + -- ^ dequeue an output item + -> Processor a b + -- ^ the buffering processor +queueProcessor enqueue dequeue = + bufferProcessor + (consumeStream enqueue) + (repeatProcess dequeue) + +-- | Like 'queueProcessor' creates a queue processor but allows creating +-- a loop when some items can be returned and added to the queue again. +-- Also it allows specifying how two input streams of data can be merged. +queueProcessorLoopMerging :: (Stream a -> Stream d -> Stream e) + -- ^ merge two streams: the input values of type @a@ + -- and the values of type @d@ returned by the loop + -> (e -> Process ()) + -- ^ enqueue the input item and wait + -- while the queue is full if required + -- so that there was no hanging items + -> Process c + -- ^ dequeue an item for the further processing + -> Processor c (Either d b) + -- ^ process and then decide what values of type @d@ + -- should be processed again + -> Processor a b + -- ^ the buffering processor +queueProcessorLoopMerging merge enqueue dequeue = + bufferProcessorLoop + (\bs cs -> + consumeStream enqueue $ + merge bs cs) + (repeatProcess dequeue) + +-- | Like 'queueProcessorLoopMerging' creates a queue processor and allows +-- creating a loop when some items can be returned and added to the queue again. +-- Only it sequentially merges two input streams of data: one stream +-- that come from the external source and another stream of data returned +-- by the loop. The first stream has a priority over the second one. +queueProcessorLoopSeq :: (a -> Process ()) + -- ^ enqueue the input item and wait + -- while the queue is full if required + -- so that there was no hanging items + -> Process c + -- ^ dequeue an item for the further processing + -> Processor c (Either a b) + -- ^ process and then decide what values of type @a@ + -- should be processed again + -> Processor a b + -- ^ the buffering processor +queueProcessorLoopSeq = + queueProcessorLoopMerging mergeStreams + +-- | Like 'queueProcessorLoopMerging' creates a queue processor and allows +-- creating a loop when some items can be returned and added to the queue again. +-- Only it runs two simultaneous processes to enqueue the input streams of data: +-- one stream that come from the external source and another stream of data returned +-- by the loop. +queueProcessorLoopParallel :: (a -> Process ()) + -- ^ enqueue the input item and wait + -- while the queue is full if required + -- so that there was no hanging items + -> Process c + -- ^ dequeue an item for the further processing + -> Processor c (Either a b) + -- ^ process and then decide what values of type @a@ + -- should be processed again + -> Processor a b + -- ^ the buffering processor +queueProcessorLoopParallel enqueue dequeue = + bufferProcessorLoop + (\bs cs -> + do spawnProcess CancelTogether $ + consumeStream enqueue bs + spawnProcess CancelTogether $ + consumeStream enqueue cs) + (repeatProcess dequeue) diff --git a/Simulation/Aivika/Processor/RoundRobbin.hs b/Simulation/Aivika/Processor/RoundRobbin.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Processor/RoundRobbin.hs @@ -0,0 +1,58 @@ + +-- | +-- Module : Simulation.Aivika.Processor.RoundRobbin +-- Copyright : Copyright (c) 2009-2013, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- The module defines the Round-Robbin processor. +-- +module Simulation.Aivika.Processor.RoundRobbin + (roundRobbinProcessor, + roundRobbinProcessorUsingIds) where + +import Control.Monad + +import Simulation.Aivika.Simulation +import Simulation.Aivika.Event +import Simulation.Aivika.Process +import Simulation.Aivika.Processor +import Simulation.Aivika.Stream +import Simulation.Aivika.Queue.Infinite + +-- | Represents the Round-Robbin processor that tries to perform the task within +-- the specified timeout. If the task times out, then it is canceled and returned +-- to the processor again; otherwise, the successful result is redirected to output. +roundRobbinProcessor :: Processor (Process Double, Process a) a +roundRobbinProcessor = + Processor $ + runProcessor roundRobbinProcessorUsingIds . mapStreamM f where + f (timeout, p) = + let x = do timeout' <- timeout + pid <- liftSimulation newProcessId + return (timeout', pid) + in return (x, p) + +-- | Like 'roundRobbinProcessor' but allows specifying the process identifiers which +-- must be unique for every new attemp to perform the task even if the task is the same. +roundRobbinProcessorUsingIds :: Processor (Process (Double, ProcessId), Process a) a +roundRobbinProcessorUsingIds = + Processor $ \xs -> + Cons $ + do q <- liftSimulation newFCFSQueue + let process = + do t@(x, p) <- dequeue q + (timeout, pid) <- x + result <- timeoutProcessUsingId timeout pid p + case result of + Just a -> return a + Nothing -> + do liftEvent $ enqueue q t + process + processor = + bufferProcessor + (consumeStream $ liftEvent . enqueue q) + (repeatProcess process) + runStream $ runProcessor processor xs diff --git a/Simulation/Aivika/Queue.hs b/Simulation/Aivika/Queue.hs --- a/Simulation/Aivika/Queue.hs +++ b/Simulation/Aivika/Queue.hs @@ -9,44 +9,140 @@ -- -- This module defines a queue that can use the specified strategies. So, having only -- the 'FCFS', 'LCFS', 'SIRO' and 'StaticPriorities' strategies, you can build --- 4 x 3 x 4 = 48 different types of the queue, each of them will have its own --- behavior (below @StaticPriorities@ can be used for input and output only). +-- 4 x 4 x 4 = 64 different types of the queue, each of them will have its own +-- behaviour. -- module Simulation.Aivika.Queue - (Queue, + (-- * Queue Types + FCFSQueue, + LCFSQueue, + SIROQueue, + PriorityQueue, + Queue, + -- * Creating Queue + newFCFSQueue, + newLCFSQueue, + newSIROQueue, + newPriorityQueue, + newQueue, + -- * Queue Properties and Activities + queueInputStrategy, + queueStoringStrategy, + queueOutputStrategy, queueNull, queueFull, queueMaxCount, queueCount, queueLostCount, - enqueued, - dequeued, - enqueuedButLost, - newQueue, + queueInputCount, + queueStoreCount, + queueOutputRequestCount, + queueOutputCount, + queueLoadFactor, + queueInputRate, + queueStoreRate, + queueOutputRequestRate, + queueOutputRate, + queueWaitTime, + queueTotalWaitTime, + queueInputWaitTime, + queueOutputWaitTime, + -- * Dequeuing and Enqueuing dequeue, - dequeueWithPriority, - dequeueWithDynamicPriority, + dequeueWithOutputPriority, tryDequeue, enqueue, - enqueueWithPriority, - enqueueWithDynamicPriority, + enqueueWithInputPriority, + enqueueWithStoringPriority, + enqueueWithInputStoringPriorities, tryEnqueue, + tryEnqueueWithStoringPriority, enqueueOrLost, - enqueueOrLost_) where + enqueueOrLost_, + enqueueWithStoringPriorityOrLost, + enqueueWithStoringPriorityOrLost_, + -- * Awaiting + waitWhileFullQueue, + -- * Summary + queueSummary, + -- * Derived Signals for Properties + queueNullChanged, + queueNullChanged_, + queueFullChanged, + queueFullChanged_, + queueCountChanged, + queueCountChanged_, + queueLostCountChanged, + queueLostCountChanged_, + queueInputCountChanged, + queueInputCountChanged_, + queueStoreCountChanged, + queueStoreCountChanged_, + queueOutputRequestCountChanged, + queueOutputRequestCountChanged_, + queueOutputCountChanged, + queueOutputCountChanged_, + queueLoadFactorChanged, + queueLoadFactorChanged_, + queueWaitTimeChanged, + queueWaitTimeChanged_, + queueTotalWaitTimeChanged, + queueTotalWaitTimeChanged_, + queueInputWaitTimeChanged, + queueInputWaitTimeChanged_, + queueOutputWaitTimeChanged, + queueOutputWaitTimeChanged_, + -- * Basic Signals + enqueueInitiated, + enqueueStored, + enqueueLost, + dequeueRequested, + dequeueExtracted, + -- * Overall Signal + queueChanged_) where import Data.IORef +import Data.Monoid import Control.Monad import Control.Monad.Trans +import Simulation.Aivika.Internal.Specs import Simulation.Aivika.Internal.Simulation +import Simulation.Aivika.Internal.Dynamics import Simulation.Aivika.Internal.Event import Simulation.Aivika.Internal.Process import Simulation.Aivika.Internal.Signal import Simulation.Aivika.Signal import Simulation.Aivika.Resource import Simulation.Aivika.QueueStrategy +import Simulation.Aivika.Statistics +import Simulation.Aivika.Stream +import Simulation.Aivika.Processor +import qualified Simulation.Aivika.DoubleLinkedList as DLL +import qualified Simulation.Aivika.Vector as V +import qualified Simulation.Aivika.PriorityQueue as PQ + +-- | A type synonym for the ordinary FIFO queue also known as the FCFS +-- (First Come - First Serviced) queue. +type FCFSQueue a = + Queue FCFS DLL.DoubleLinkedList FCFS DLL.DoubleLinkedList FCFS DLL.DoubleLinkedList a + +-- | A type synonym for the ordinary LIFO queue also known as the LCFS +-- (Last Come - First Serviced) queue. +type LCFSQueue a = + Queue FCFS DLL.DoubleLinkedList LCFS DLL.DoubleLinkedList FCFS DLL.DoubleLinkedList a + +-- | A type synonym for the SIRO (Serviced in Random Order) queue. +type SIROQueue a = + Queue FCFS DLL.DoubleLinkedList SIRO V.Vector FCFS DLL.DoubleLinkedList a + +-- | A type synonym for the queue with static priorities applied when +-- storing the elements in the queue. +type PriorityQueue a = + Queue FCFS DLL.DoubleLinkedList StaticPriorities PQ.PriorityQueue FCFS DLL.DoubleLinkedList a + -- | Represents the queue using the specified strategies for input @si@, -- internal storing (in memory) @sm@ and output @so@, where @a@ denotes -- the type of items stored in the queue. Types @qi@, @qm@ and @qo@ are @@ -54,20 +150,61 @@ -- are dependent types. data Queue si qi sm qm so qo a = Queue { queueMaxCount :: Int, - -- ^ The maximum available number of items. + -- ^ The queue capacity. queueInputStrategy :: si, - queueMemoryStrategy :: sm, + -- ^ The strategy applied to the input (enqueuing) process. + queueStoringStrategy :: sm, + -- ^ The strategy applied when storing (in memory) items in the queue. queueOutputStrategy :: so, + -- ^ The strategy applied to the output (dequeuing) process. queueInputRes :: Resource si qi, - queueMemory :: qm a, + queueStore :: qm (QueueItem a), queueOutputRes :: Resource so qo, queueCountRef :: IORef Int, queueLostCountRef :: IORef Int, - enqueuedSource :: SignalSource a, - enqueuedButLostSource :: SignalSource a, - dequeuedSource :: SignalSource a } + queueInputCountRef :: IORef Int, + queueStoreCountRef :: IORef Int, + queueOutputRequestCountRef :: IORef Int, + queueOutputCountRef :: IORef Int, + queueWaitTimeRef :: IORef (SamplingStats Double), + queueTotalWaitTimeRef :: IORef (SamplingStats Double), + queueInputWaitTimeRef :: IORef (SamplingStats Double), + queueOutputWaitTimeRef :: IORef (SamplingStats Double), + enqueueInitiatedSource :: SignalSource a, + enqueueLostSource :: SignalSource a, + enqueueStoredSource :: SignalSource a, + dequeueRequestedSource :: SignalSource (), + dequeueExtractedSource :: SignalSource a } + +-- | Stores the item and a time of its enqueuing. +data QueueItem a = + QueueItem { itemValue :: a, + -- ^ Return the item value. + itemInputTime :: Double, + -- ^ Return the time of enqueuing the item. + itemStoringTime :: Double + -- ^ Return the time of storing in the queue, or + -- @itemInputTime@ before the actual storing when + -- the item was just enqueued. + } --- | Create a new queue with the specified strategies and maximum available number of items. +-- | Create a new FCFS queue with the specified capacity. +newFCFSQueue :: Int -> Simulation (FCFSQueue a) +newFCFSQueue = newQueue FCFS FCFS FCFS + +-- | Create a new LCFS queue with the specified capacity. +newLCFSQueue :: Int -> Simulation (LCFSQueue a) +newLCFSQueue = newQueue FCFS LCFS FCFS + +-- | Create a new SIRO queue with the specified capacity. +newSIROQueue :: Int -> Simulation (SIROQueue a) +newSIROQueue = newQueue FCFS SIRO FCFS + +-- | Create a new priority queue with the specified capacity. +newPriorityQueue :: Int -> Simulation (PriorityQueue a) +newPriorityQueue = newQueue FCFS StaticPriorities FCFS + +-- | Create a new queue with the specified strategies and capacity. newQueue :: (QueueStrategy si qi, QueueStrategy sm qm, QueueStrategy so qo) => @@ -78,54 +215,327 @@ -> so -- ^ the strategy applied to the output (dequeuing) process -> Int - -- ^ the maximum available number of items + -- ^ the queue capacity -> Simulation (Queue si qi sm qm so qo a) newQueue si sm so count = do i <- liftIO $ newIORef 0 l <- liftIO $ newIORef 0 - ri <- newResourceWithCount si count count + ci <- liftIO $ newIORef 0 + cm <- liftIO $ newIORef 0 + cr <- liftIO $ newIORef 0 + co <- liftIO $ newIORef 0 + ri <- newResourceWithMaxCount si count (Just count) qm <- newStrategyQueue sm - ro <- newResourceWithCount so count 0 + ro <- newResourceWithMaxCount so 0 (Just count) + w <- liftIO $ newIORef mempty + wt <- liftIO $ newIORef mempty + wi <- liftIO $ newIORef mempty + wo <- liftIO $ newIORef mempty s1 <- newSignalSource s2 <- newSignalSource s3 <- newSignalSource + s4 <- newSignalSource + s5 <- newSignalSource return Queue { queueMaxCount = count, queueInputStrategy = si, - queueMemoryStrategy = sm, + queueStoringStrategy = sm, queueOutputStrategy = so, queueInputRes = ri, - queueMemory = qm, + queueStore = qm, queueOutputRes = ro, queueCountRef = i, queueLostCountRef = l, - enqueuedSource = s1, - enqueuedButLostSource = s2, - dequeuedSource = s3 } + queueInputCountRef = ci, + queueStoreCountRef = cm, + queueOutputRequestCountRef = cr, + queueOutputCountRef = co, + queueWaitTimeRef = w, + queueTotalWaitTimeRef = wt, + queueInputWaitTimeRef = wi, + queueOutputWaitTimeRef = wo, + enqueueInitiatedSource = s1, + enqueueLostSource = s2, + enqueueStoredSource = s3, + dequeueRequestedSource = s4, + dequeueExtractedSource = s5 } -- | Test whether the queue is empty. +-- +-- See also 'queueNullChanged' and 'queueNullChanged_'. queueNull :: Queue si qi sm qm so qo a -> Event Bool queueNull q = Event $ \p -> do n <- readIORef (queueCountRef q) return (n == 0) + +-- | Signal when the 'queueNull' property value has changed. +queueNullChanged :: Queue si qi sm qm so qo a -> Signal Bool +queueNullChanged q = + mapSignalM (const $ queueNull q) (queueNullChanged_ q) + +-- | Signal when the 'queueNull' property value has changed. +queueNullChanged_ :: Queue si qi sm qm so qo a -> Signal () +queueNullChanged_ = queueCountChanged_ -- | Test whether the queue is full. +-- +-- See also 'queueFullChanged' and 'queueFullChanged_'. queueFull :: Queue si qi sm qm so qo a -> Event Bool queueFull q = Event $ \p -> do n <- readIORef (queueCountRef q) return (n == queueMaxCount q) + +-- | Signal when the 'queueFull' property value has changed. +queueFullChanged :: Queue si qi sm qm so qo a -> Signal Bool +queueFullChanged q = + mapSignalM (const $ queueFull q) (queueFullChanged_ q) + +-- | Signal when the 'queueFull' property value has changed. +queueFullChanged_ :: Queue si qi sm qm so qo a -> Signal () +queueFullChanged_ = queueCountChanged_ -- | Return the queue size. +-- +-- See also 'queueCountChanged' and 'queueCountChanged_'. queueCount :: Queue si qi sm qm so qo a -> Event Int queueCount q = Event $ \p -> readIORef (queueCountRef q) +-- | Signal when the 'queueCount' property value has changed. +queueCountChanged :: Queue si qi sm qm so qo a -> Signal Int +queueCountChanged q = + mapSignalM (const $ queueCount q) (queueCountChanged_ q) + +-- | Signal when the 'queueCount' property value has changed. +queueCountChanged_ :: Queue si qi sm qm so qo a -> Signal () +queueCountChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (dequeueExtracted q) + -- | Return the number of lost items. +-- +-- See also 'queueLostCountChanged' and 'queueLostCountChanged_'. queueLostCount :: Queue si qi sm qm so qo a -> Event Int queueLostCount q = Event $ \p -> readIORef (queueLostCountRef q) +-- | Signal when the 'queueLostCount' property value has changed. +queueLostCountChanged :: Queue si qi sm qm so qo a -> Signal Int +queueLostCountChanged q = + mapSignalM (const $ queueLostCount q) (queueLostCountChanged_ q) + +-- | Signal when the 'queueLostCount' property value has changed. +queueLostCountChanged_ :: Queue si qi sm qm so qo a -> Signal () +queueLostCountChanged_ q = + mapSignal (const ()) (enqueueLost q) + +-- | Return the total number of input items that were enqueued. +-- +-- See also 'queueInputCountChanged' and 'queueInputCountChanged_'. +queueInputCount :: Queue si qi sm qm so qo a -> Event Int +queueInputCount q = + Event $ \p -> readIORef (queueInputCountRef q) + +-- | Signal when the 'queueInputCount' property value has changed. +queueInputCountChanged :: Queue si qi sm qm so qo a -> Signal Int +queueInputCountChanged q = + mapSignalM (const $ queueInputCount q) (queueInputCountChanged_ q) + +-- | Signal when the 'queueInputCount' property value has changed. +queueInputCountChanged_ :: Queue si qi sm qm so qo a -> Signal () +queueInputCountChanged_ q = + mapSignal (const ()) (enqueueInitiated q) + +-- | Return the total number of input items that were stored. +-- +-- See also 'queueStoreCountChanged' and 'queueStoreCountChanged_'. +queueStoreCount :: Queue si qi sm qm so qo a -> Event Int +queueStoreCount q = + Event $ \p -> readIORef (queueStoreCountRef q) + +-- | Signal when the 'queueStoreCount' property value has changed. +queueStoreCountChanged :: Queue si qi sm qm so qo a -> Signal Int +queueStoreCountChanged q = + mapSignalM (const $ queueStoreCount q) (queueStoreCountChanged_ q) + +-- | Signal when the 'queueStoreCount' property value has changed. +queueStoreCountChanged_ :: Queue si qi sm qm so qo a -> Signal () +queueStoreCountChanged_ q = + mapSignal (const ()) (enqueueStored q) + +-- | Return the total number of requests for dequeueing the items, +-- not taking into account the attempts to dequeue immediately +-- without suspension. +-- +-- See also 'queueOutputRequestCountChanged' and 'queueOutputRequestCountChanged_'. +queueOutputRequestCount :: Queue si qi sm qm so qo a -> Event Int +queueOutputRequestCount q = + Event $ \p -> readIORef (queueOutputRequestCountRef q) + +-- | Signal when the 'queueOutputRequestCount' property value has changed. +queueOutputRequestCountChanged :: Queue si qi sm qm so qo a -> Signal Int +queueOutputRequestCountChanged q = + mapSignalM (const $ queueOutputRequestCount q) (queueOutputRequestCountChanged_ q) + +-- | Signal when the 'queueOutputRequestCount' property value has changed. +queueOutputRequestCountChanged_ :: Queue si qi sm qm so qo a -> Signal () +queueOutputRequestCountChanged_ q = + mapSignal (const ()) (dequeueRequested q) + +-- | Return the total number of output items that were dequeued. +-- +-- See also 'queueOutputCountChanged' and 'queueOutputCountChanged_'. +queueOutputCount :: Queue si qi sm qm so qo a -> Event Int +queueOutputCount q = + Event $ \p -> readIORef (queueOutputCountRef q) + +-- | Signal when the 'queueOutputCount' property value has changed. +queueOutputCountChanged :: Queue si qi sm qm so qo a -> Signal Int +queueOutputCountChanged q = + mapSignalM (const $ queueOutputCount q) (queueOutputCountChanged_ q) + +-- | Signal when the 'queueOutputCount' property value has changed. +queueOutputCountChanged_ :: Queue si qi sm qm so qo a -> Signal () +queueOutputCountChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the load factor: the queue size divided by its maximum size. +-- +-- See also 'queueLoadFactorChanged' and 'queueLoadFactorChanged_'. +queueLoadFactor :: Queue si qi sm qm so qo a -> Event Double +queueLoadFactor q = + Event $ \p -> + do x <- readIORef (queueCountRef q) + let y = queueMaxCount q + return (fromIntegral x / fromIntegral y) + +-- | Signal when the 'queueLoadFactor' property value has changed. +queueLoadFactorChanged :: Queue si qi sm qm so qo a -> Signal Double +queueLoadFactorChanged q = + mapSignalM (const $ queueLoadFactor q) (queueLoadFactorChanged_ q) + +-- | Signal when the 'queueLoadFactor' property value has changed. +queueLoadFactorChanged_ :: Queue si qi sm qm so qo a -> Signal () +queueLoadFactorChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the rate of the input items that were enqueued: how many items +-- per time. +queueInputRate :: Queue si qi sm qm so qo a -> Event Double +queueInputRate q = + Event $ \p -> + do x <- readIORef (queueInputCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the rate of the items that were stored: how many items +-- per time. +queueStoreRate :: Queue si qi sm qm so qo a -> Event Double +queueStoreRate q = + Event $ \p -> + do x <- readIORef (queueStoreCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the rate of the requests for dequeueing the items: how many requests +-- per time. It does not include the attempts to dequeue immediately +-- without suspension. +queueOutputRequestRate :: Queue si qi sm qm so qo a -> Event Double +queueOutputRequestRate q = + Event $ \p -> + do x <- readIORef (queueOutputRequestCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the rate of the output items that were dequeued: how many items +-- per time. +queueOutputRate :: Queue si qi sm qm so qo a -> Event Double +queueOutputRate q = + Event $ \p -> + do x <- readIORef (queueOutputCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the wait time from the time at which the item was stored in the queue to +-- the time at which it was dequeued. +-- +-- See also 'queueWaitTimeChanged' and 'queueWaitTimeChanged_'. +queueWaitTime :: Queue si qi sm qm so qo a -> Event (SamplingStats Double) +queueWaitTime q = + Event $ \p -> readIORef (queueWaitTimeRef q) + +-- | Signal when the 'queueWaitTime' property value has changed. +queueWaitTimeChanged :: Queue si qi sm qm so qo a -> Signal (SamplingStats Double) +queueWaitTimeChanged q = + mapSignalM (const $ queueWaitTime q) (queueWaitTimeChanged_ q) + +-- | Signal when the 'queueWaitTime' property value has changed. +queueWaitTimeChanged_ :: Queue si qi sm qm so qo a -> Signal () +queueWaitTimeChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the total wait time from the time at which the enqueueing operation +-- was initiated to the time at which the item was dequeued. +-- +-- In some sense, @queueTotalWaitTime == queueInputWaitTime + queueWaitTime@. +-- +-- See also 'queueTotalWaitTimeChanged' and 'queueTotalWaitTimeChanged_'. +queueTotalWaitTime :: Queue si qi sm qm so qo a -> Event (SamplingStats Double) +queueTotalWaitTime q = + Event $ \p -> readIORef (queueTotalWaitTimeRef q) + +-- | Signal when the 'queueTotalWaitTime' property value has changed. +queueTotalWaitTimeChanged :: Queue si qi sm qm so qo a -> Signal (SamplingStats Double) +queueTotalWaitTimeChanged q = + mapSignalM (const $ queueTotalWaitTime q) (queueTotalWaitTimeChanged_ q) + +-- | Signal when the 'queueTotalWaitTime' property value has changed. +queueTotalWaitTimeChanged_ :: Queue si qi sm qm so qo a -> Signal () +queueTotalWaitTimeChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the input wait time from the time at which the enqueueing operation +-- was initiated to the time at which the item was stored in the queue. +-- +-- See also 'queueInputWaitTimeChanged' and 'queueInputWaitTimeChanged_'. +queueInputWaitTime :: Queue si qi sm qm so qo a -> Event (SamplingStats Double) +queueInputWaitTime q = + Event $ \p -> readIORef (queueInputWaitTimeRef q) + +-- | Signal when the 'queueInputWaitTime' property value has changed. +queueInputWaitTimeChanged :: Queue si qi sm qm so qo a -> Signal (SamplingStats Double) +queueInputWaitTimeChanged q = + mapSignalM (const $ queueInputWaitTime q) (queueInputWaitTimeChanged_ q) + +-- | Signal when the 'queueInputWaitTime' property value has changed. +queueInputWaitTimeChanged_ :: Queue si qi sm qm so qo a -> Signal () +queueInputWaitTimeChanged_ q = + mapSignal (const ()) (enqueueStored q) + +-- | Return the output wait time from the time at which the item was requested +-- for dequeueing to the time at which it was actually dequeued. +-- +-- See also 'queueOutputWaitTimeChanged' and 'queueOutputWaitTimeChanged_'. +queueOutputWaitTime :: Queue si qi sm qm so qo a -> Event (SamplingStats Double) +queueOutputWaitTime q = + Event $ \p -> readIORef (queueOutputWaitTimeRef q) + +-- | Signal when the 'queueOutputWaitTime' property value has changed. +queueOutputWaitTimeChanged :: Queue si qi sm qm so qo a -> Signal (SamplingStats Double) +queueOutputWaitTimeChanged q = + mapSignalM (const $ queueOutputWaitTime q) (queueOutputWaitTimeChanged_ q) + +-- | Signal when the 'queueOutputWaitTime' property value has changed. +queueOutputWaitTimeChanged_ :: Queue si qi sm qm so qo a -> Signal () +queueOutputWaitTimeChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + -- | Dequeue suspending the process if the queue is empty. dequeue :: (DequeueStrategy si qi, DequeueStrategy sm qm, @@ -135,53 +545,26 @@ -> Process a -- ^ the dequeued value dequeue q = - do requestResource (queueOutputRes q) - a <- liftEvent $ - strategyDequeue (queueMemoryStrategy q) (queueMemory q) - releaseResource (queueInputRes q) - liftEvent $ - triggerSignal (dequeuedSource q) a - return a - --- | Dequeue with the priority suspending the process if the queue is empty. -dequeueWithPriority :: (DequeueStrategy si qi, - DequeueStrategy sm qm, - PriorityQueueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> Double - -- ^ the priority - -> Process a - -- ^ the dequeued value -dequeueWithPriority q priority = - do requestResourceWithPriority (queueOutputRes q) priority - a <- liftEvent $ - strategyDequeue (queueMemoryStrategy q) (queueMemory q) - releaseResource (queueInputRes q) - liftEvent $ - triggerSignal (dequeuedSource q) a - return a + do t <- liftEvent $ dequeueRequest q + requestResource (queueOutputRes q) + liftEvent $ dequeueExtract q t --- | Dequeue with the dynamic priority suspending the process if the queue is empty. -dequeueWithDynamicPriority :: (DequeueStrategy si qi, - DequeueStrategy sm qm, - DynamicPriorityQueueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> Event Double - -- ^ the dynamic priority - -> Process a - -- ^ the dequeued value -dequeueWithDynamicPriority q priority = - do requestResourceWithDynamicPriority (queueOutputRes q) priority - a <- liftEvent $ - strategyDequeue (queueMemoryStrategy q) (queueMemory q) - releaseResource (queueInputRes q) - liftEvent $ - triggerSignal (dequeuedSource q) a - return a +-- | Dequeue with the output priority suspending the process if the queue is empty. +dequeueWithOutputPriority :: (DequeueStrategy si qi, + DequeueStrategy sm qm, + PriorityQueueStrategy so qo po) + => Queue si qi sm qm so qo a + -- ^ the queue + -> po + -- ^ the priority for output + -> Process a + -- ^ the dequeued value +dequeueWithOutputPriority q po = + do t <- liftEvent $ dequeueRequest q + requestResourceWithPriority (queueOutputRes q) po + liftEvent $ dequeueExtract q t --- | Try to dequeue from the queue immediately. +-- | Try to dequeue immediately. tryDequeue :: (DequeueStrategy si qi, DequeueStrategy sm qm) => Queue si qi sm qm so qo a @@ -191,10 +574,8 @@ tryDequeue q = do x <- tryRequestResourceWithinEvent (queueOutputRes q) if x - then do a <- strategyDequeue (queueMemoryStrategy q) (queueMemory q) - releaseResourceWithinEvent (queueInputRes q) - triggerSignal (dequeuedSource q) a - return $ Just a + then do t <- dequeueRequest q + fmap Just $ dequeueExtract q t else return Nothing -- | Enqueue the item suspending the process if the queue is full. @@ -207,51 +588,60 @@ -- ^ the item to enqueue -> Process () enqueue q a = - do requestResource (queueInputRes q) - liftEvent $ - strategyEnqueue (queueMemoryStrategy q) (queueMemory q) a - releaseResource (queueOutputRes q) - liftEvent $ - triggerSignal (enqueuedSource q) a + do i <- liftEvent $ enqueueInitiate q a + requestResource (queueInputRes q) + liftEvent $ enqueueStore q i --- | Enqueue with the priority the item suspending the process if the queue is full. -enqueueWithPriority :: (PriorityQueueStrategy si qi, - EnqueueStrategy sm qm, - DequeueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> Double - -- ^ the priority - -> a - -- ^ the item to enqueue - -> Process () -enqueueWithPriority q priority a = - do requestResourceWithPriority (queueInputRes q) priority - liftEvent $ - strategyEnqueue (queueMemoryStrategy q) (queueMemory q) a - releaseResource (queueOutputRes q) - liftEvent $ - triggerSignal (enqueuedSource q) a +-- | Enqueue with the input priority the item suspending the process if the queue is full. +enqueueWithInputPriority :: (PriorityQueueStrategy si qi pi, + EnqueueStrategy sm qm, + DequeueStrategy so qo) + => Queue si qi sm qm so qo a + -- ^ the queue + -> pi + -- ^ the priority for input + -> a + -- ^ the item to enqueue + -> Process () +enqueueWithInputPriority q pi a = + do i <- liftEvent $ enqueueInitiate q a + requestResourceWithPriority (queueInputRes q) pi + liftEvent $ enqueueStore q i --- | Enqueue with the dynamic priority the item suspending the process if the queue is full. -enqueueWithDynamicPriority :: (DynamicPriorityQueueStrategy si qi, - EnqueueStrategy sm qm, +-- | Enqueue with the storing priority the item suspending the process if the queue is full. +enqueueWithStoringPriority :: (EnqueueStrategy si qi, + PriorityQueueStrategy sm qm pm, DequeueStrategy so qo) => Queue si qi sm qm so qo a -- ^ the queue - -> Event Double - -- ^ the dynamic priority + -> pm + -- ^ the priority for storing -> a -- ^ the item to enqueue -> Process () -enqueueWithDynamicPriority q priority a = - do requestResourceWithDynamicPriority (queueInputRes q) priority - liftEvent $ - strategyEnqueue (queueMemoryStrategy q) (queueMemory q) a - releaseResource (queueOutputRes q) - liftEvent $ - triggerSignal (enqueuedSource q) a +enqueueWithStoringPriority q pm a = + do i <- liftEvent $ enqueueInitiate q a + requestResource (queueInputRes q) + liftEvent $ enqueueStoreWithPriority q pm i +-- | Enqueue with the input and storing priorities the item suspending the process if the queue is full. +enqueueWithInputStoringPriorities :: (PriorityQueueStrategy si qi pi, + PriorityQueueStrategy sm qm pm, + DequeueStrategy so qo) + => Queue si qi sm qm so qo a + -- ^ the queue + -> pi + -- ^ the priority for input + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to enqueue + -> Process () +enqueueWithInputStoringPriorities q pi pm a = + do i <- liftEvent $ enqueueInitiate q a + requestResourceWithPriority (queueInputRes q) pi + liftEvent $ enqueueStoreWithPriority q pm i + -- | Try to enqueue the item. Return 'False' in the monad if the queue is full. tryEnqueue :: (EnqueueStrategy sm qm, DequeueStrategy so qo) @@ -263,12 +653,28 @@ tryEnqueue q a = do x <- tryRequestResourceWithinEvent (queueInputRes q) if x - then do strategyEnqueue (queueMemoryStrategy q) (queueMemory q) a - releaseResourceWithinEvent (queueOutputRes q) - triggerSignal (enqueuedSource q) a + then do enqueueInitiate q a >>= enqueueStore q return True else return False +-- | Try to enqueue with the storing priority the item. Return 'False' in +-- the monad if the queue is full. +tryEnqueueWithStoringPriority :: (PriorityQueueStrategy sm qm pm, + DequeueStrategy so qo) + => Queue si qi sm qm so qo a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item which we try to enqueue + -> Event Bool +tryEnqueueWithStoringPriority q pm a = + do x <- tryRequestResourceWithinEvent (queueInputRes q) + if x + then do enqueueInitiate q a >>= enqueueStoreWithPriority q pm + return True + else return False + -- | Try to enqueue the item. If the queue is full then the item will be lost -- and 'False' will be returned. enqueueOrLost :: (EnqueueStrategy sm qm, @@ -281,14 +687,30 @@ enqueueOrLost q a = do x <- tryRequestResourceWithinEvent (queueInputRes q) if x - then do strategyEnqueue (queueMemoryStrategy q) (queueMemory q) a - releaseResourceWithinEvent (queueOutputRes q) - triggerSignal (enqueuedSource q) a + then do enqueueInitiate q a >>= enqueueStore q return True - else do liftIO $ modifyIORef (queueLostCountRef q) $ (+) 1 - triggerSignal (enqueuedButLostSource q) a + else do enqueueDeny q a return False +-- | Try to enqueue with the storing priority the item. If the queue is full +-- then the item will be lost and 'False' will be returned. +enqueueWithStoringPriorityOrLost :: (PriorityQueueStrategy sm qm pm, + DequeueStrategy so qo) + => Queue si qi sm qm so qo a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item which we try to enqueue + -> Event Bool +enqueueWithStoringPriorityOrLost q pm a = + do x <- tryRequestResourceWithinEvent (queueInputRes q) + if x + then do enqueueInitiate q a >>= enqueueStoreWithPriority q pm + return True + else do enqueueDeny q a + return False + -- | Try to enqueue the item. If the queue is full then the item will be lost. enqueueOrLost_ :: (EnqueueStrategy sm qm, DequeueStrategy so qo) @@ -301,16 +723,328 @@ do x <- enqueueOrLost q a return () --- | Return a signal that notifies when any item is enqueued. -enqueued :: Queue si qi sm qm so qo a -> Signal a -enqueued q = publishSignal (enqueuedSource q) +-- | Try to enqueue with the storing priority the item. If the queue is full +-- then the item will be lost. +enqueueWithStoringPriorityOrLost_ :: (PriorityQueueStrategy sm qm pm, + DequeueStrategy so qo) + => Queue si qi sm qm so qo a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item which we try to enqueue + -> Event () +enqueueWithStoringPriorityOrLost_ q pm a = + do x <- enqueueWithStoringPriorityOrLost q pm a + return () +-- | Return a signal that notifies when the enqueuing operation is initiated. +enqueueInitiated :: Queue si qi sm qm so qo a -> Signal a +enqueueInitiated q = publishSignal (enqueueInitiatedSource q) + +-- | Return a signal that notifies when the enqueuing operation is completed +-- and the item is stored in the internal memory of the queue. +enqueueStored :: Queue si qi sm qm so qo a -> Signal a +enqueueStored q = publishSignal (enqueueStoredSource q) + -- | Return a signal which notifies that the item was lost when -- attempting to add it to the full queue with help of --- 'enqueueOrLost' or 'enqueueOrLost_'. -enqueuedButLost :: Queue si qi sm qm so qo a -> Signal a -enqueuedButLost q = publishSignal (enqueuedButLostSource q) +-- 'enqueueOrLost', 'enqueueOrLost_' or similar functions that imply +-- that the element can be lost. All their names are ending with @OrLost@ +-- or @OrLost_@. +-- +-- In other cases the enqueued items are not lost but the corresponded process +-- can suspend until the internal queue storage is freed. Although there is one +-- exception from this rule. If the process trying to enqueue a new element was +-- suspended but then canceled through 'cancelProcess' from the outside then +-- the item will not be added. +enqueueLost :: Queue si qi sm qm so qo a -> Signal a +enqueueLost q = publishSignal (enqueueLostSource q) --- | Return a signal that notifies when any item is dequeued. -dequeued :: Queue si qi sm qm so qo a -> Signal a -dequeued q = publishSignal (dequeuedSource q) +-- | Return a signal that notifies when the dequeuing operation was requested. +dequeueRequested :: Queue si qi sm qm so qo a -> Signal () +dequeueRequested q = publishSignal (dequeueRequestedSource q) + +-- | Return a signal that notifies when the item was extracted from the internal +-- storage of the queue and prepared for immediate receiving by the dequeuing process. +dequeueExtracted :: Queue si qi sm qm so qo a -> Signal a +dequeueExtracted q = publishSignal (dequeueExtractedSource q) + +-- | Initiate the process of enqueuing the item. +enqueueInitiate :: Queue si qi sm qm so qo a + -- ^ the queue + -> a + -- ^ the item to be enqueued + -> Event (QueueItem a) +enqueueInitiate q a = + Event $ \p -> + do let t = pointTime p + modifyIORef (queueInputCountRef q) (+ 1) + invokeEvent p $ + triggerSignal (enqueueInitiatedSource q) a + return QueueItem { itemValue = a, + itemInputTime = t, + itemStoringTime = t -- it will be updated soon + } + +-- | Store the item. +enqueueStore :: (EnqueueStrategy sm qm, + DequeueStrategy so qo) + => Queue si qi sm qm so qo a + -- ^ the queue + -> QueueItem a + -- ^ the item to be stored + -> Event () +enqueueStore q i = + Event $ \p -> + do let i' = i { itemStoringTime = pointTime p } -- now we have the actual time of storing + invokeEvent p $ + strategyEnqueue (queueStoringStrategy q) (queueStore q) i' + modifyIORef (queueCountRef q) (+ 1) + modifyIORef (queueStoreCountRef q) (+ 1) + invokeEvent p $ + enqueueStat q i' + invokeEvent p $ + releaseResourceWithinEvent (queueOutputRes q) + invokeEvent p $ + triggerSignal (enqueueStoredSource q) (itemValue i') + +-- | Store with the priority the item. +enqueueStoreWithPriority :: (PriorityQueueStrategy sm qm pm, + DequeueStrategy so qo) + => Queue si qi sm qm so qo a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> QueueItem a + -- ^ the item to be enqueued + -> Event () +enqueueStoreWithPriority q pm i = + Event $ \p -> + do let i' = i { itemStoringTime = pointTime p } -- now we have the actual time of storing + invokeEvent p $ + strategyEnqueueWithPriority (queueStoringStrategy q) (queueStore q) pm i' + modifyIORef (queueCountRef q) (+ 1) + modifyIORef (queueStoreCountRef q) (+ 1) + invokeEvent p $ + enqueueStat q i' + invokeEvent p $ + releaseResourceWithinEvent (queueOutputRes q) + invokeEvent p $ + triggerSignal (enqueueStoredSource q) (itemValue i') + +-- | Deny the enqueuing. +enqueueDeny :: Queue si qi sm qm so qo a + -- ^ the queue + -> a + -- ^ the item to be denied + -> Event () +enqueueDeny q a = + Event $ \p -> + do modifyIORef (queueLostCountRef q) $ (+) 1 + invokeEvent p $ + triggerSignal (enqueueLostSource q) a + +-- | Update the statistics for the input wait time of the enqueuing operation. +enqueueStat :: Queue si qi sm qm so qo a + -- ^ the queue + -> QueueItem a + -- ^ the item and its input time + -> Event () + -- ^ the action of updating the statistics +enqueueStat q i = + Event $ \p -> + do let t0 = itemInputTime i + t1 = itemStoringTime i + modifyIORef (queueInputWaitTimeRef q) $ + addSamplingStats (t1 - t0) + +-- | Accept the dequeuing request and return the current simulation time. +dequeueRequest :: Queue si qi sm qm so qo a + -- ^ the queue + -> Event Double + -- ^ the current time +dequeueRequest q = + Event $ \p -> + do modifyIORef (queueOutputRequestCountRef q) (+ 1) + invokeEvent p $ + triggerSignal (dequeueRequestedSource q) () + return $ pointTime p + +-- | Extract an item for the dequeuing request. +dequeueExtract :: (DequeueStrategy si qi, + DequeueStrategy sm qm) + => Queue si qi sm qm so qo a + -- ^ the queue + -> Double + -- ^ the time of the dequeuing request + -> Event a + -- ^ the dequeued value +dequeueExtract q t' = + Event $ \p -> + do i <- invokeEvent p $ + strategyDequeue (queueStoringStrategy q) (queueStore q) + modifyIORef (queueCountRef q) (+ (- 1)) + modifyIORef (queueOutputCountRef q) (+ 1) + invokeEvent p $ + dequeueStat q t' i + invokeEvent p $ + releaseResourceWithinEvent (queueInputRes q) + invokeEvent p $ + triggerSignal (dequeueExtractedSource q) (itemValue i) + return $ itemValue i + +-- | Update the statistics for the output wait time of the dequeuing operation +-- and the wait time of storing in the queue. +dequeueStat :: Queue si qi sm qm so qo a + -- ^ the queue + -> Double + -- ^ the time of the dequeuing request + -> QueueItem a + -- ^ the item and its input time + -> Event () + -- ^ the action of updating the statistics +dequeueStat q t' i = + Event $ \p -> + do let t0 = itemInputTime i + t1 = itemStoringTime i + t = pointTime p + modifyIORef (queueOutputWaitTimeRef q) $ + addSamplingStats (t - t') + modifyIORef (queueTotalWaitTimeRef q) $ + addSamplingStats (t - t0) + modifyIORef (queueWaitTimeRef q) $ + addSamplingStats (t - t1) + +-- | Wait while the queue is full. +waitWhileFullQueue :: Queue si qi sm qm so qo a -> Process () +waitWhileFullQueue q = + do x <- liftEvent (queueFull q) + when x $ + do processAwait (dequeueExtracted q) + waitWhileFullQueue q + +-- | Signal whenever any property of the queue changes. +-- +-- The property must have the corresponded signal. There are also characteristics +-- similar to the properties but that have no signals. As a rule, such characteristics +-- already depend on the simulation time and therefore they may change at any +-- time point. +queueChanged_ :: Queue si qi sm qm so qo a -> Signal () +queueChanged_ q = + mapSignal (const ()) (enqueueInitiated q) <> + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (enqueueLost q) <> + dequeueRequested q <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the summary for the queue with desciption of its +-- properties and activities using the specified indent. +queueSummary :: (Show si, Show sm, Show so) => Queue si qi sm qm so qo a -> Int -> Event ShowS +queueSummary q indent = + do let si = queueInputStrategy q + sm = queueStoringStrategy q + so = queueOutputStrategy q + null <- queueNull q + full <- queueFull q + let maxCount = queueMaxCount q + count <- queueCount q + lostCount <- queueLostCount q + inputCount <- queueInputCount q + storeCount <- queueStoreCount q + outputRequestCount <- queueOutputRequestCount q + outputCount <- queueOutputCount q + loadFactor <- queueLoadFactor q + inputRate <- queueInputRate q + storeRate <- queueStoreRate q + outputRequestRate <- queueOutputRequestRate q + outputRate <- queueOutputRate q + waitTime <- queueWaitTime q + totalWaitTime <- queueTotalWaitTime q + inputWaitTime <- queueInputWaitTime q + outputWaitTime <- queueOutputWaitTime q + let tab = replicate indent ' ' + return $ + showString tab . + showString "the input (enqueueing) strategy = " . + shows si . + showString "\n" . + showString tab . + showString "the storing (memory) strategy = " . + shows sm . + showString "\n" . + showString tab . + showString "the output (dequeueing) strategy = " . + shows so . + showString "\n" . + showString tab . + showString "empty? = " . + shows null . + showString "\n" . + showString tab . + showString "full? = " . + shows full . + showString "\n" . + showString tab . + showString "max. capacity = " . + shows maxCount . + showString "\n" . + showString tab . + showString "size = " . + shows count . + showString "\n" . + showString tab . + showString "the lost count (number of the lost items) = " . + shows lostCount . + showString "\n" . + showString tab . + showString "the input count (number of the input items that were enqueued) = " . + shows inputCount . + showString "\n" . + showString tab . + showString "the store count (number of the input items that were stored) = " . + shows storeCount . + showString "\n" . + showString tab . + showString "the output request count (number of requests for dequeueing an item) = " . + shows outputRequestCount . + showString "\n" . + showString tab . + showString "the output count (number of the output items that were dequeued) = " . + shows outputCount . + showString "\n" . + showString tab . + showString "the load factor (size / max. capacity) = " . + shows loadFactor . + showString "\n" . + showString tab . + showString "the input rate (how many input items were enqueued per time) = " . + shows inputRate . + showString "\n" . + showString tab . + showString "the store rate (how many input items were stored per time) = " . + shows storeRate . + showString "\n" . + showString tab . + showString "the output request rate (how many requests for dequeueing per time) = " . + shows outputRequestRate . + showString "\n" . + showString tab . + showString "the output rate (how many output items were dequeued per time) = " . + shows outputRate . + showString "\n" . + showString tab . + showString "the wait time (when was stored -> when was dequeued) = \n\n" . + samplingStatsSummary waitTime (2 + indent) . + showString "\n\n" . + showString tab . + showString "the total wait time (when the enqueueing was initiated -> when was dequeued) = \n\n" . + samplingStatsSummary totalWaitTime (2 + indent) . + showString "\n\n" . + showString tab . + showString "the input wait time (when the enqueueing was initiated -> when was stored) = \n\n" . + samplingStatsSummary inputWaitTime (2 + indent) . + showString "\n\n" . + showString tab . + showString "the output wait time (when was requested for dequeueing -> when was dequeued) = \n\n" . + samplingStatsSummary outputWaitTime (2 + indent) diff --git a/Simulation/Aivika/Queue/Infinite.hs b/Simulation/Aivika/Queue/Infinite.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Queue/Infinite.hs @@ -0,0 +1,592 @@ + +-- | +-- Module : Simulation.Aivika.Queue.Infinite +-- Copyright : Copyright (c) 2009-2013, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- This module defines an infinite queue that can use the specified strategies. +-- +module Simulation.Aivika.Queue.Infinite + (-- * Queue Types + FCFSQueue, + LCFSQueue, + SIROQueue, + PriorityQueue, + Queue, + -- * Creating Queue + newFCFSQueue, + newLCFSQueue, + newSIROQueue, + newPriorityQueue, + newQueue, + -- * Queue Properties and Activities + queueStoringStrategy, + queueOutputStrategy, + queueNull, + queueCount, + queueStoreCount, + queueOutputRequestCount, + queueOutputCount, + queueStoreRate, + queueOutputRequestRate, + queueOutputRate, + queueWaitTime, + queueOutputWaitTime, + -- * Dequeuing and Enqueuing + dequeue, + dequeueWithOutputPriority, + tryDequeue, + enqueue, + enqueueWithStoringPriority, + -- * Summary + queueSummary, + -- * Derived Signals for Properties + queueNullChanged, + queueNullChanged_, + queueCountChanged, + queueCountChanged_, + queueStoreCountChanged, + queueStoreCountChanged_, + queueOutputRequestCountChanged, + queueOutputRequestCountChanged_, + queueOutputCountChanged, + queueOutputCountChanged_, + queueWaitTimeChanged, + queueWaitTimeChanged_, + queueOutputWaitTimeChanged, + queueOutputWaitTimeChanged_, + -- * Basic Signals + enqueueStored, + dequeueRequested, + dequeueExtracted, + -- * Overall Signal + queueChanged_) where + +import Data.IORef +import Data.Monoid + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Simulation +import Simulation.Aivika.Internal.Dynamics +import Simulation.Aivika.Internal.Event +import Simulation.Aivika.Internal.Process +import Simulation.Aivika.Internal.Signal +import Simulation.Aivika.Signal +import Simulation.Aivika.Resource +import Simulation.Aivika.QueueStrategy +import Simulation.Aivika.Statistics +import Simulation.Aivika.Stream +import Simulation.Aivika.Processor + +import qualified Simulation.Aivika.DoubleLinkedList as DLL +import qualified Simulation.Aivika.Vector as V +import qualified Simulation.Aivika.PriorityQueue as PQ + +-- | A type synonym for the ordinary FIFO queue also known as the FCFS +-- (First Come - First Serviced) queue. +type FCFSQueue a = + Queue FCFS DLL.DoubleLinkedList FCFS DLL.DoubleLinkedList a + +-- | A type synonym for the ordinary LIFO queue also known as the LCFS +-- (Last Come - First Serviced) queue. +type LCFSQueue a = + Queue LCFS DLL.DoubleLinkedList FCFS DLL.DoubleLinkedList a + +-- | A type synonym for the SIRO (Serviced in Random Order) queue. +type SIROQueue a = + Queue SIRO V.Vector FCFS DLL.DoubleLinkedList a + +-- | A type synonym for the queue with static priorities applied when +-- storing the elements in the queue. +type PriorityQueue a = + Queue StaticPriorities PQ.PriorityQueue FCFS DLL.DoubleLinkedList a + +-- | Represents the infinite queue using the specified strategies for +-- internal storing (in memory) @sm@ and output @so@, where @a@ denotes +-- the type of items stored in the queue. Types @qm@ and @qo@ are +-- determined automatically and you should not care about them - they +-- are dependent types. +data Queue sm qm so qo a = + Queue { queueStoringStrategy :: sm, + -- ^ The strategy applied when storing (in memory) items in the queue. + queueOutputStrategy :: so, + -- ^ The strategy applied to the output (dequeuing) process. + queueStore :: qm (QueueItem a), + queueOutputRes :: Resource so qo, + queueCountRef :: IORef Int, + queueStoreCountRef :: IORef Int, + queueOutputRequestCountRef :: IORef Int, + queueOutputCountRef :: IORef Int, + queueWaitTimeRef :: IORef (SamplingStats Double), + queueOutputWaitTimeRef :: IORef (SamplingStats Double), + enqueueStoredSource :: SignalSource a, + dequeueRequestedSource :: SignalSource (), + dequeueExtractedSource :: SignalSource a } + +-- | Stores the item and a time of its enqueuing. +data QueueItem a = + QueueItem { itemValue :: a, + -- ^ Return the item value. + itemStoringTime :: Double + -- ^ Return the time of storing in the queue. + } + +-- | Create a new infinite FCFS queue. +newFCFSQueue :: Simulation (FCFSQueue a) +newFCFSQueue = newQueue FCFS FCFS + +-- | Create a new infinite LCFS queue. +newLCFSQueue :: Simulation (LCFSQueue a) +newLCFSQueue = newQueue LCFS FCFS + +-- | Create a new infinite SIRO queue. +newSIROQueue :: Simulation (SIROQueue a) +newSIROQueue = newQueue SIRO FCFS + +-- | Create a new infinite priority queue. +newPriorityQueue :: Simulation (PriorityQueue a) +newPriorityQueue = newQueue StaticPriorities FCFS + +-- | Create a new infinite queue with the specified strategies. +newQueue :: (QueueStrategy sm qm, + QueueStrategy so qo) => + sm + -- ^ the strategy applied when storing items in the queue + -> so + -- ^ the strategy applied to the output (dequeuing) process + -> Simulation (Queue sm qm so qo a) +newQueue sm so = + do i <- liftIO $ newIORef 0 + cm <- liftIO $ newIORef 0 + cr <- liftIO $ newIORef 0 + co <- liftIO $ newIORef 0 + qm <- newStrategyQueue sm + ro <- newResourceWithMaxCount so 0 Nothing + w <- liftIO $ newIORef mempty + wo <- liftIO $ newIORef mempty + s3 <- newSignalSource + s4 <- newSignalSource + s5 <- newSignalSource + return Queue { queueStoringStrategy = sm, + queueOutputStrategy = so, + queueStore = qm, + queueOutputRes = ro, + queueCountRef = i, + queueStoreCountRef = cm, + queueOutputRequestCountRef = cr, + queueOutputCountRef = co, + queueWaitTimeRef = w, + queueOutputWaitTimeRef = wo, + enqueueStoredSource = s3, + dequeueRequestedSource = s4, + dequeueExtractedSource = s5 } + +-- | Test whether the queue is empty. +-- +-- See also 'queueNullChanged' and 'queueNullChanged_'. +queueNull :: Queue sm qm so qo a -> Event Bool +queueNull q = + Event $ \p -> + do n <- readIORef (queueCountRef q) + return (n == 0) + +-- | Signal when the 'queueNull' property value has changed. +queueNullChanged :: Queue sm qm so qo a -> Signal Bool +queueNullChanged q = + mapSignalM (const $ queueNull q) (queueNullChanged_ q) + +-- | Signal when the 'queueNull' property value has changed. +queueNullChanged_ :: Queue sm qm so qo a -> Signal () +queueNullChanged_ = queueCountChanged_ + +-- | Return the queue size. +-- +-- See also 'queueCountChanged' and 'queueCountChanged_'. +queueCount :: Queue sm qm so qo a -> Event Int +queueCount q = + Event $ \p -> readIORef (queueCountRef q) + +-- | Signal when the 'queueCount' property value has changed. +queueCountChanged :: Queue sm qm so qo a -> Signal Int +queueCountChanged q = + mapSignalM (const $ queueCount q) (queueCountChanged_ q) + +-- | Signal when the 'queueCount' property value has changed. +queueCountChanged_ :: Queue sm qm so qo a -> Signal () +queueCountChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the total number of input items that were stored. +-- +-- See also 'queueStoreCountChanged' and 'queueStoreCountChanged_'. +queueStoreCount :: Queue sm qm so qo a -> Event Int +queueStoreCount q = + Event $ \p -> readIORef (queueStoreCountRef q) + +-- | Signal when the 'queueStoreCount' property value has changed. +queueStoreCountChanged :: Queue sm qm so qo a -> Signal Int +queueStoreCountChanged q = + mapSignalM (const $ queueStoreCount q) (queueStoreCountChanged_ q) + +-- | Signal when the 'queueStoreCount' property value has changed. +queueStoreCountChanged_ :: Queue sm qm so qo a -> Signal () +queueStoreCountChanged_ q = + mapSignal (const ()) (enqueueStored q) + +-- | Return the total number of requests for dequeueing the items, +-- not taking into account the attempts to dequeue immediately +-- without suspension. +-- +-- See also 'queueOutputRequestCountChanged' and 'queueOutputRequestCountChanged_'. +queueOutputRequestCount :: Queue sm qm so qo a -> Event Int +queueOutputRequestCount q = + Event $ \p -> readIORef (queueOutputRequestCountRef q) + +-- | Signal when the 'queueOutputRequestCount' property value has changed. +queueOutputRequestCountChanged :: Queue sm qm so qo a -> Signal Int +queueOutputRequestCountChanged q = + mapSignalM (const $ queueOutputRequestCount q) (queueOutputRequestCountChanged_ q) + +-- | Signal when the 'queueOutputRequestCount' property value has changed. +queueOutputRequestCountChanged_ :: Queue sm qm so qo a -> Signal () +queueOutputRequestCountChanged_ q = + mapSignal (const ()) (dequeueRequested q) + +-- | Return the total number of output items that were dequeued. +-- +-- See also 'queueOutputCountChanged' and 'queueOutputCountChanged_'. +queueOutputCount :: Queue sm qm so qo a -> Event Int +queueOutputCount q = + Event $ \p -> readIORef (queueOutputCountRef q) + +-- | Signal when the 'queueOutputCount' property value has changed. +queueOutputCountChanged :: Queue sm qm so qo a -> Signal Int +queueOutputCountChanged q = + mapSignalM (const $ queueOutputCount q) (queueOutputCountChanged_ q) + +-- | Signal when the 'queueOutputCount' property value has changed. +queueOutputCountChanged_ :: Queue sm qm so qo a -> Signal () +queueOutputCountChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the rate of the items that were stored: how many items +-- per time. +queueStoreRate :: Queue sm qm so qo a -> Event Double +queueStoreRate q = + Event $ \p -> + do x <- readIORef (queueStoreCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the rate of the requests for dequeueing the items: how many requests +-- per time. It does not include the attempts to dequeue immediately +-- without suspension. +queueOutputRequestRate :: Queue sm qm so qo a -> Event Double +queueOutputRequestRate q = + Event $ \p -> + do x <- readIORef (queueOutputRequestCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the rate of the output items that were dequeued: how many items +-- per time. +queueOutputRate :: Queue sm qm so qo a -> Event Double +queueOutputRate q = + Event $ \p -> + do x <- readIORef (queueOutputCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the wait time from the time at which the item was stored in the queue to +-- the time at which it was dequeued. +-- +-- See also 'queueWaitTimeChanged' and 'queueWaitTimeChanged_'. +queueWaitTime :: Queue sm qm so qo a -> Event (SamplingStats Double) +queueWaitTime q = + Event $ \p -> readIORef (queueWaitTimeRef q) + +-- | Signal when the 'queueWaitTime' property value has changed. +queueWaitTimeChanged :: Queue sm qm so qo a -> Signal (SamplingStats Double) +queueWaitTimeChanged q = + mapSignalM (const $ queueWaitTime q) (queueWaitTimeChanged_ q) + +-- | Signal when the 'queueWaitTime' property value has changed. +queueWaitTimeChanged_ :: Queue sm qm so qo a -> Signal () +queueWaitTimeChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the output wait time from the time at which the item was requested +-- for dequeueing to the time at which it was actually dequeued. +-- +-- See also 'queueOutputWaitTimeChanged' and 'queueOutputWaitTimeChanged_'. +queueOutputWaitTime :: Queue sm qm so qo a -> Event (SamplingStats Double) +queueOutputWaitTime q = + Event $ \p -> readIORef (queueOutputWaitTimeRef q) + +-- | Signal when the 'queueOutputWaitTime' property value has changed. +queueOutputWaitTimeChanged :: Queue sm qm so qo a -> Signal (SamplingStats Double) +queueOutputWaitTimeChanged q = + mapSignalM (const $ queueOutputWaitTime q) (queueOutputWaitTimeChanged_ q) + +-- | Signal when the 'queueOutputWaitTime' property value has changed. +queueOutputWaitTimeChanged_ :: Queue sm qm so qo a -> Signal () +queueOutputWaitTimeChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Dequeue suspending the process if the queue is empty. +dequeue :: (DequeueStrategy sm qm, + EnqueueStrategy so qo) + => Queue sm qm so qo a + -- ^ the queue + -> Process a + -- ^ the dequeued value +dequeue q = + do t <- liftEvent $ dequeueRequest q + requestResource (queueOutputRes q) + liftEvent $ dequeueExtract q t + +-- | Dequeue with the output priority suspending the process if the queue is empty. +dequeueWithOutputPriority :: (DequeueStrategy sm qm, + PriorityQueueStrategy so qo po) + => Queue sm qm so qo a + -- ^ the queue + -> po + -- ^ the priority for output + -> Process a + -- ^ the dequeued value +dequeueWithOutputPriority q po = + do t <- liftEvent $ dequeueRequest q + requestResourceWithPriority (queueOutputRes q) po + liftEvent $ dequeueExtract q t + +-- | Try to dequeue immediately. +tryDequeue :: DequeueStrategy sm qm + => Queue sm qm so qo a + -- ^ the queue + -> Event (Maybe a) + -- ^ the dequeued value of 'Nothing' +tryDequeue q = + do x <- tryRequestResourceWithinEvent (queueOutputRes q) + if x + then do t <- dequeueRequest q + fmap Just $ dequeueExtract q t + else return Nothing + +-- | Enqueue the item. +enqueue :: (EnqueueStrategy sm qm, + DequeueStrategy so qo) + => Queue sm qm so qo a + -- ^ the queue + -> a + -- ^ the item to enqueue + -> Event () +enqueue = enqueueStore + +-- | Enqueue with the storing priority the item. +enqueueWithStoringPriority :: (PriorityQueueStrategy sm qm pm, + DequeueStrategy so qo) + => Queue sm qm so qo a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to enqueue + -> Event () +enqueueWithStoringPriority = enqueueStoreWithPriority + +-- | Return a signal that notifies when the enqueued item +-- is stored in the internal memory of the queue. +enqueueStored :: Queue sm qm so qo a -> Signal a +enqueueStored q = publishSignal (enqueueStoredSource q) + +-- | Return a signal that notifies when the dequeuing operation was requested. +dequeueRequested :: Queue sm qm so qo a -> Signal () +dequeueRequested q = publishSignal (dequeueRequestedSource q) + +-- | Return a signal that notifies when the item was extracted from the internal +-- storage of the queue and prepared for immediate receiving by the dequeuing process. +dequeueExtracted :: Queue sm qm so qo a -> Signal a +dequeueExtracted q = publishSignal (dequeueExtractedSource q) + +-- | Store the item. +enqueueStore :: (EnqueueStrategy sm qm, + DequeueStrategy so qo) + => Queue sm qm so qo a + -- ^ the queue + -> a + -- ^ the item to be stored + -> Event () +enqueueStore q a = + Event $ \p -> + do let i = QueueItem { itemValue = a, + itemStoringTime = pointTime p } + invokeEvent p $ + strategyEnqueue (queueStoringStrategy q) (queueStore q) i + modifyIORef (queueCountRef q) (+ 1) + modifyIORef (queueStoreCountRef q) (+ 1) + invokeEvent p $ + releaseResourceWithinEvent (queueOutputRes q) + invokeEvent p $ + triggerSignal (enqueueStoredSource q) (itemValue i) + +-- | Store with the priority the item. +enqueueStoreWithPriority :: (PriorityQueueStrategy sm qm pm, + DequeueStrategy so qo) + => Queue sm qm so qo a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to be enqueued + -> Event () +enqueueStoreWithPriority q pm a = + Event $ \p -> + do let i = QueueItem { itemValue = a, + itemStoringTime = pointTime p } + invokeEvent p $ + strategyEnqueueWithPriority (queueStoringStrategy q) (queueStore q) pm i + modifyIORef (queueCountRef q) (+ 1) + modifyIORef (queueStoreCountRef q) (+ 1) + invokeEvent p $ + releaseResourceWithinEvent (queueOutputRes q) + invokeEvent p $ + triggerSignal (enqueueStoredSource q) (itemValue i) + +-- | Accept the dequeuing request and return the current simulation time. +dequeueRequest :: Queue sm qm so qo a + -- ^ the queue + -> Event Double + -- ^ the current time +dequeueRequest q = + Event $ \p -> + do modifyIORef (queueOutputRequestCountRef q) (+ 1) + invokeEvent p $ + triggerSignal (dequeueRequestedSource q) () + return $ pointTime p + +-- | Extract an item for the dequeuing request. +dequeueExtract :: DequeueStrategy sm qm + => Queue sm qm so qo a + -- ^ the queue + -> Double + -- ^ the time of the dequeuing request + -> Event a + -- ^ the dequeued value +dequeueExtract q t' = + Event $ \p -> + do i <- invokeEvent p $ + strategyDequeue (queueStoringStrategy q) (queueStore q) + modifyIORef (queueCountRef q) (+ (- 1)) + modifyIORef (queueOutputCountRef q) (+ 1) + invokeEvent p $ + dequeueStat q t' i + invokeEvent p $ + triggerSignal (dequeueExtractedSource q) (itemValue i) + return $ itemValue i + +-- | Update the statistics for the output wait time of the dequeuing operation +-- and the wait time of storing in the queue. +dequeueStat :: Queue sm qm so qo a + -- ^ the queue + -> Double + -- ^ the time of the dequeuing request + -> QueueItem a + -- ^ the item and its input time + -> Event () + -- ^ the action of updating the statistics +dequeueStat q t' i = + Event $ \p -> + do let t1 = itemStoringTime i + t = pointTime p + modifyIORef (queueOutputWaitTimeRef q) $ + addSamplingStats (t - t') + modifyIORef (queueWaitTimeRef q) $ + addSamplingStats (t - t1) + +-- | Signal whenever any property of the queue changes. +-- +-- The property must have the corresponded signal. There are also characteristics +-- similar to the properties but that have no signals. As a rule, such characteristics +-- already depend on the simulation time and therefore they may change at any +-- time point. +queueChanged_ :: Queue sm qm so qo a -> Signal () +queueChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + dequeueRequested q <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the summary for the queue with desciption of its +-- properties and activities using the specified indent. +queueSummary :: (Show sm, Show so) => Queue sm qm so qo a -> Int -> Event ShowS +queueSummary q indent = + do let sm = queueStoringStrategy q + so = queueOutputStrategy q + null <- queueNull q + count <- queueCount q + storeCount <- queueStoreCount q + outputRequestCount <- queueOutputRequestCount q + outputCount <- queueOutputCount q + storeRate <- queueStoreRate q + outputRequestRate <- queueOutputRequestRate q + outputRate <- queueOutputRate q + waitTime <- queueWaitTime q + outputWaitTime <- queueOutputWaitTime q + let tab = replicate indent ' ' + return $ + showString tab . + showString "the storing (memory) strategy = " . + shows sm . + showString "\n" . + showString tab . + showString "the output (dequeueing) strategy = " . + shows so . + showString "\n" . + showString tab . + showString "empty? = " . + shows null . + showString "\n" . + showString tab . + showString "size = " . + shows count . + showString "\n" . + showString tab . + showString "the store count (number of the input items that were stored) = " . + shows storeCount . + showString "\n" . + showString tab . + showString "the output request count (number of requests for dequeueing an item) = " . + shows outputRequestCount . + showString "\n" . + showString tab . + showString "the output count (number of the output items that were dequeued) = " . + shows outputCount . + showString "\n" . + showString tab . + showString "the store rate (how many input items were stored per time) = " . + shows storeRate . + showString "\n" . + showString tab . + showString "the output request rate (how many requests for dequeueing per time) = " . + shows outputRequestRate . + showString "\n" . + showString tab . + showString "the output rate (how many output items were dequeued per time) = " . + shows outputRate . + showString "\n" . + showString tab . + showString "the wait time (when was stored -> when was dequeued) = \n\n" . + samplingStatsSummary waitTime (2 + indent) . + showString "\n\n" . + showString tab . + showString "the output wait time (when was requested for dequeueing -> when was dequeued) = \n\n" . + samplingStatsSummary outputWaitTime (2 + indent) diff --git a/Simulation/Aivika/QueueStrategy.hs b/Simulation/Aivika/QueueStrategy.hs --- a/Simulation/Aivika/QueueStrategy.hs +++ b/Simulation/Aivika/QueueStrategy.hs @@ -12,11 +12,12 @@ -- This module defines the queue strategies. -- module Simulation.Aivika.QueueStrategy - (QueueStrategy(..), + (-- * Strategy Classes + QueueStrategy(..), DequeueStrategy(..), EnqueueStrategy(..), PriorityQueueStrategy(..), - DynamicPriorityQueueStrategy(..), + -- * Strategy Instances FCFS(..), LCFS(..), SIRO(..), @@ -35,46 +36,69 @@ class QueueStrategy s q | s -> q where -- | Create a new queue by the specified strategy. - newStrategyQueue :: s -> Simulation (q i) + newStrategyQueue :: s + -- ^ the strategy + -> Simulation (q i) + -- ^ a new queue -- | Test whether the queue is empty. - strategyQueueNull :: s -> q i -> Event Bool + strategyQueueNull :: s + -- ^ the strategy + -> q i + -- ^ the queue + -> Event Bool + -- ^ the result of the test -- | Defines a strategy with support of the dequeuing operation. class QueueStrategy s q => DequeueStrategy s q | s -> q where -- | Dequeue the front element and return it. - strategyDequeue :: s -> q i -> Event i + strategyDequeue :: s + -- ^ the strategy + -> q i + -- ^ the queue + -> Event i + -- ^ the dequeued element -- | It defines a strategy when we can enqueue a single element. class DequeueStrategy s q => EnqueueStrategy s q | s -> q where -- | Enqueue an element. - strategyEnqueue :: s -> q i -> i -> Event () + strategyEnqueue :: s + -- ^ the strategy + -> q i + -- ^ the queue + -> i + -- ^ the element to be enqueued + -> Event () + -- ^ the action of enqueuing -- | It defines a strategy when we can enqueue an element with the specified priority. -class DequeueStrategy s q => PriorityQueueStrategy s q | s -> q where - - -- | Enqueue an element with the specified priority. - strategyEnqueueWithPriority :: s -> q i -> Double -> i -> Event () - --- | It defines a strategy when we can enqueue an element with the dynamic priority. -class DequeueStrategy s q => DynamicPriorityQueueStrategy s q | s -> q where +class DequeueStrategy s q => PriorityQueueStrategy s q p | s -> q, s -> p where -- | Enqueue an element with the specified priority. - strategyEnqueueWithDynamicPriority :: s -> q i -> Event Double -> i -> Event () + strategyEnqueueWithPriority :: s + -- ^ the strategy + -> q i + -- ^ the queue + -> p + -- ^ the priority + -> i + -- ^ the element to be enqueued + -> Event () + -- ^ the action of enqueuing -- | Strategy: First Come - First Served (FCFS). -data FCFS = FCFS +data FCFS = FCFS deriving (Eq, Ord, Show) -- | Strategy: Last Come - First Served (LCFS) -data LCFS = LCFS +data LCFS = LCFS deriving (Eq, Ord, Show) -- | Strategy: Service in Random Order (SIRO). -data SIRO = SIRO +data SIRO = SIRO deriving (Eq, Ord, Show) -- | Strategy: Static Priorities. It uses the priority queue. -data StaticPriorities = StaticPriorities +data StaticPriorities = StaticPriorities deriving (Eq, Ord, Show) instance QueueStrategy FCFS DoubleLinkedList where @@ -126,7 +150,7 @@ PQ.dequeue q return i -instance PriorityQueueStrategy StaticPriorities PQ.PriorityQueue where +instance PriorityQueueStrategy StaticPriorities PQ.PriorityQueue Double where strategyEnqueueWithPriority s q p i = liftIO $ PQ.enqueue q p i diff --git a/Simulation/Aivika/Random.hs b/Simulation/Aivika/Random.hs deleted file mode 100644 --- a/Simulation/Aivika/Random.hs +++ /dev/null @@ -1,53 +0,0 @@ - --- | --- Module : Simulation.Aivika.Random --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- Below are defined some random functions. --- -module Simulation.Aivika.Random - (newNormalGen) where - -import System.Random -import Data.IORef - --- | Createa a normal random number generator with mean 0 and variance 1. -newNormalGen :: IO (IO Double) -newNormalGen = - do nextRef <- newIORef 0.0 - flagRef <- newIORef False - xi1Ref <- newIORef 0.0 - xi2Ref <- newIORef 0.0 - psiRef <- newIORef 0.0 - let loop = - do psi <- readIORef psiRef - if (psi >= 1.0) || (psi == 0.0) - then do g1 <- getStdRandom random - g2 <- getStdRandom random - let xi1 = 2.0 * g1 - 1.0 - xi2 = 2.0 * g2 - 1.0 - psi = xi1 * xi1 + xi2 * xi2 - writeIORef xi1Ref xi1 - writeIORef xi2Ref xi2 - writeIORef psiRef psi - loop - else writeIORef psiRef $ sqrt (- 2.0 * log psi / psi) - return $ - do flag <- readIORef flagRef - if flag - then do writeIORef flagRef False - readIORef nextRef - else do writeIORef xi1Ref 0.0 - writeIORef xi2Ref 0.0 - writeIORef psiRef 0.0 - loop - xi1 <- readIORef xi1Ref - xi2 <- readIORef xi2Ref - psi <- readIORef psiRef - writeIORef flagRef True - writeIORef nextRef $ xi2 * psi - return $ xi1 * psi diff --git a/Simulation/Aivika/Resource.hs b/Simulation/Aivika/Resource.hs --- a/Simulation/Aivika/Resource.hs +++ b/Simulation/Aivika/Resource.hs @@ -7,89 +7,199 @@ -- Stability : experimental -- Tested with: GHC 7.6.3 -- --- This module defines a limited resource which can be acquired and +-- This module defines the resource which can be acquired and -- then released by the discontinuous process 'Process'. +-- The resource can be either limited by the upper bound +-- (run-time check), or it can have no upper bound. The latter +-- is useful for modeling the infinite queue, for example. -- module Simulation.Aivika.Resource - (Resource, + (-- * Resource Types + FCFSResource, + LCFSResource, + SIROResource, + PriorityResource, + Resource, + -- * Creating Resource + newFCFSResource, + newFCFSResourceWithMaxCount, + newLCFSResource, + newLCFSResourceWithMaxCount, + newSIROResource, + newSIROResourceWithMaxCount, + newPriorityResource, + newPriorityResourceWithMaxCount, newResource, - newResourceWithCount, + newResourceWithMaxCount, + -- * Resource Properties + resourceStrategy, resourceMaxCount, resourceCount, + -- * Requesting for and Releasing Resource requestResource, requestResourceWithPriority, - requestResourceWithDynamicPriority, tryRequestResourceWithinEvent, releaseResource, releaseResourceWithinEvent, usingResource, - usingResourceWithPriority, - usingResourceWithDynamicPriority) where + usingResourceWithPriority) where import Data.IORef import Control.Monad import Control.Monad.Trans +import Control.Exception import Simulation.Aivika.Internal.Specs import Simulation.Aivika.Internal.Simulation import Simulation.Aivika.Internal.Event import Simulation.Aivika.Internal.Cont import Simulation.Aivika.Internal.Process - import Simulation.Aivika.QueueStrategy --- | Represents a limited resource. +import qualified Simulation.Aivika.DoubleLinkedList as DLL +import qualified Simulation.Aivika.Vector as V +import qualified Simulation.Aivika.PriorityQueue as PQ + +-- | The ordinary FCFS (First Come - First Serviced) resource. +type FCFSResource = Resource FCFS DLL.DoubleLinkedList + +-- | The ordinary LCFS (Last Come - First Serviced) resource. +type LCFSResource = Resource LCFS DLL.DoubleLinkedList + +-- | The SIRO (Serviced in Random Order) resource. +type SIROResource = Resource SIRO V.Vector + +-- | The resource with static priorities. +type PriorityResource = Resource StaticPriorities PQ.PriorityQueue + +-- | Represents the resource with strategy @s@ applied for queuing the requests. +-- The @q@ type is dependent and it is usually derived automatically. data Resource s q = Resource { resourceStrategy :: s, - resourceMaxCount :: Int, - -- ^ Return the maximum count of the resource. + -- ^ Return the strategy applied for queuing the requests. + resourceMaxCount :: Maybe Int, + -- ^ Return the maximum count of the resource, where 'Nothing' + -- means that the resource has no upper bound. resourceCountRef :: IORef Int, - resourceWaitList :: q (ContParams ())} + resourceWaitList :: q (Event (Maybe (ContParams ()))) } instance Eq (Resource s q) where x == y = resourceCountRef x == resourceCountRef y -- unique references --- | Create a new resource with the specified queue strategy and maximum count. +-- | Create a new FCFS resource with the specified initial count which value becomes +-- the upper bound as well. +newFCFSResource :: Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation FCFSResource +newFCFSResource = newResource FCFS + +-- | Create a new FCFS resource with the specified initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newFCFSResourceWithMaxCount :: Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation FCFSResource +newFCFSResourceWithMaxCount = newResourceWithMaxCount FCFS + +-- | Create a new LCFS resource with the specified initial count which value becomes +-- the upper bound as well. +newLCFSResource :: Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation LCFSResource +newLCFSResource = newResource LCFS + +-- | Create a new LCFS resource with the specified initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newLCFSResourceWithMaxCount :: Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation LCFSResource +newLCFSResourceWithMaxCount = newResourceWithMaxCount LCFS + +-- | Create a new SIRO resource with the specified initial count which value becomes +-- the upper bound as well. +newSIROResource :: Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation SIROResource +newSIROResource = newResource SIRO + +-- | Create a new SIRO resource with the specified initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newSIROResourceWithMaxCount :: Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation SIROResource +newSIROResourceWithMaxCount = newResourceWithMaxCount SIRO + +-- | Create a new priority resource with the specified initial count which value becomes +-- the upper bound as well. +newPriorityResource :: Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation PriorityResource +newPriorityResource = newResource StaticPriorities + +-- | Create a new priority resource with the specified initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newPriorityResourceWithMaxCount :: Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation PriorityResource +newPriorityResourceWithMaxCount = newResourceWithMaxCount StaticPriorities + +-- | Create a new resource with the specified queue strategy and initial count. +-- The last value becomes the upper bound as well. newResource :: QueueStrategy s q => s -- ^ the strategy for managing the queuing requests -> Int - -- ^ the maximum count of the resource + -- ^ the initial count (and maximal count too) of the resource -> Simulation (Resource s q) -newResource s maxCount = +newResource s count = Simulation $ \r -> - do countRef <- newIORef maxCount + do when (count < 0) $ + error $ + "The resource count cannot be negative: " ++ + "newResource." + countRef <- newIORef count waitList <- invokeSimulation r $ newStrategyQueue s return Resource { resourceStrategy = s, - resourceMaxCount = maxCount, + resourceMaxCount = Just count, resourceCountRef = countRef, resourceWaitList = waitList } --- | Create a new resource with the specified queue strategy, maximum and initial count. -newResourceWithCount :: QueueStrategy s q - => s - -- ^ the strategy for managing the queuing requests - -> Int - -- ^ the maximum count of the resource - -> Int - -- ^ the initial count of the resource - -> Simulation (Resource s q) -newResourceWithCount s maxCount count = do - when (count < 0) $ - error $ - "The resource count cannot be negative: " ++ - "newResourceWithCount." - when (count > maxCount) $ - error $ - "The resource count cannot be greater than " ++ - "its maximum value: newResourceWithCount." +-- | Create a new resource with the specified queue strategy, initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newResourceWithMaxCount :: QueueStrategy s q + => s + -- ^ the strategy for managing the queuing requests + -> Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation (Resource s q) +newResourceWithMaxCount s count maxCount = Simulation $ \r -> - do countRef <- newIORef count - waitList <- invokeSimulation r $ newStrategyQueue s - return Resource { resourceStrategy = s, - resourceMaxCount = maxCount, - resourceCountRef = countRef, - resourceWaitList = waitList } + do when (count < 0) $ + error $ + "The resource count cannot be negative: " ++ + "newResourceWithMaxCount." + case maxCount of + Just maxCount | count > maxCount -> + error $ + "The resource count cannot be greater than " ++ + "its maximum value: newResourceWithMaxCount." + _ -> + return () + countRef <- newIORef count + waitList <- invokeSimulation r $ newStrategyQueue s + return Resource { resourceStrategy = s, + resourceMaxCount = maxCount, + resourceCountRef = countRef, + resourceWaitList = waitList } -- | Return the current count of the resource. resourceCount :: Resource s q -> Event Int @@ -109,8 +219,9 @@ Event $ \p -> do a <- readIORef (resourceCountRef r) if a == 0 - then invokeEvent p $ - strategyEnqueue (resourceStrategy r) (resourceWaitList r) c + then do c <- invokeEvent p $ contFreeze c + invokeEvent p $ + strategyEnqueue (resourceStrategy r) (resourceWaitList r) c else do let a' = a - 1 a' `seq` writeIORef (resourceCountRef r) a' invokeEvent p $ resumeCont c () @@ -118,10 +229,10 @@ -- | Request with the priority for the resource decreasing its count -- in case of success, otherwise suspending the discontinuous process -- until some other process releases the resource. -requestResourceWithPriority :: PriorityQueueStrategy s q +requestResourceWithPriority :: PriorityQueueStrategy s q p => Resource s q -- ^ the requested resource - -> Double + -> p -- ^ the priority -> Process () requestResourceWithPriority r priority = @@ -130,29 +241,9 @@ Event $ \p -> do a <- readIORef (resourceCountRef r) if a == 0 - then invokeEvent p $ - strategyEnqueueWithPriority (resourceStrategy r) (resourceWaitList r) priority c - else do let a' = a - 1 - a' `seq` writeIORef (resourceCountRef r) a' - invokeEvent p $ resumeCont c () - --- | Request with the dynamic priority for the resource decreasing its count --- in case of success, otherwise suspending the discontinuous process --- until some other process releases the resource. -requestResourceWithDynamicPriority :: DynamicPriorityQueueStrategy s q - => Resource s q - -- ^ the requested resource - -> Event Double - -- ^ the dynamic priority - -> Process () -requestResourceWithDynamicPriority r priority = - Process $ \pid -> - Cont $ \c -> - Event $ \p -> - do a <- readIORef (resourceCountRef r) - if a == 0 - then invokeEvent p $ - strategyEnqueueWithDynamicPriority (resourceStrategy r) (resourceWaitList r) priority c + then do c <- invokeEvent p $ contFreeze c + invokeEvent p $ + strategyEnqueueWithPriority (resourceStrategy r) (resourceWaitList r) priority c else do let a' = a - 1 a' `seq` writeIORef (resourceCountRef r) a' invokeEvent p $ resumeCont c () @@ -180,23 +271,25 @@ Event $ \p -> do a <- readIORef (resourceCountRef r) let a' = a + 1 - when (a' > resourceMaxCount r) $ - error $ - "The resource count cannot be greater than " ++ - "its maximum value: releaseResourceWithinEvent." + case resourceMaxCount r of + Just maxCount | a' > maxCount -> + error $ + "The resource count cannot be greater than " ++ + "its maximum value: releaseResourceWithinEvent." + _ -> + return () f <- invokeEvent p $ strategyQueueNull (resourceStrategy r) (resourceWaitList r) if f then a' `seq` writeIORef (resourceCountRef r) a' else do c <- invokeEvent p $ strategyDequeue (resourceStrategy r) (resourceWaitList r) - invokeEvent p $ enqueueEvent (pointTime p) $ - Event $ \p -> - do z <- contCanceled c - if z - then do invokeEvent p $ releaseResourceWithinEvent r - invokeEvent p $ resumeCont c () - else invokeEvent p $ resumeCont c () + c <- invokeEvent p c + case c of + Nothing -> + invokeEvent p $ releaseResourceWithinEvent r + Just c -> + invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c () -- | Try to request for the resource decreasing its count in case of success -- and returning 'True' in the 'Event' monad; otherwise, returning 'False'. @@ -214,10 +307,6 @@ -- | 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 :: EnqueueStrategy s q => Resource s q -- ^ the resource we are going to request for and then release in the end @@ -231,15 +320,12 @@ -- | Acquire the resource with the specified priority, 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'. -usingResourceWithPriority :: PriorityQueueStrategy s q +-- within the action. +usingResourceWithPriority :: PriorityQueueStrategy s q p => Resource s q -- ^ the resource we are going to request for and then -- release in the end - -> Double + -> p -- ^ the priority -> Process a -- ^ the action we are going to apply having the resource @@ -247,24 +333,4 @@ -- ^ the result of the action usingResourceWithPriority r priority m = do requestResourceWithPriority r priority - finallyProcess m $ releaseResource r - --- | Acquire the resource with the dynamic priority, 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'. -usingResourceWithDynamicPriority :: DynamicPriorityQueueStrategy s q - => Resource s q - -- ^ the resource we are going to request for and then - -- release in the end - -> Event Double - -- ^ the dynamic priority - -> Process a - -- ^ the action we are going to apply having the resource - -> Process a - -- ^ the result of the action -usingResourceWithDynamicPriority r priority m = - do requestResourceWithDynamicPriority r priority finallyProcess m $ releaseResource r diff --git a/Simulation/Aivika/Server.hs b/Simulation/Aivika/Server.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Server.hs @@ -0,0 +1,492 @@ + +-- | +-- Module : Simulation.Aivika.Server +-- Copyright : Copyright (c) 2009-2013, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- It models the server that prodives a service. +module Simulation.Aivika.Server + (-- * Server + Server, + newServer, + newServerWithState, + -- * Processing + serverProcessor, + -- * Server Properties and Activities + serverInitState, + serverState, + serverTotalInputTime, + serverTotalProcessingTime, + serverTotalOutputTime, + serverInputTime, + serverProcessingTime, + serverOutputTime, + serverInputTimeFactor, + serverProcessingTimeFactor, + serverOutputTimeFactor, + -- * Summary + serverSummary, + -- * Derived Signals for Properties + serverStateChanged, + serverStateChanged_, + serverTotalInputTimeChanged, + serverTotalInputTimeChanged_, + serverTotalProcessingTimeChanged, + serverTotalProcessingTimeChanged_, + serverTotalOutputTimeChanged, + serverTotalOutputTimeChanged_, + serverInputTimeChanged, + serverInputTimeChanged_, + serverProcessingTimeChanged, + serverProcessingTimeChanged_, + serverOutputTimeChanged, + serverOutputTimeChanged_, + serverInputTimeFactorChanged, + serverInputTimeFactorChanged_, + serverProcessingTimeFactorChanged, + serverProcessingTimeFactorChanged_, + serverOutputTimeFactorChanged, + serverOutputTimeFactorChanged_, + -- * Basic Signals + serverInputReceived, + serverTaskProcessed, + serverOutputProvided, + -- * Overall Signal + serverChanged_) where + +import Data.IORef +import Data.Monoid +import Control.Monad.Trans + +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Internal.Event +import Simulation.Aivika.Internal.Signal +import Simulation.Aivika.Resource +import Simulation.Aivika.Cont +import Simulation.Aivika.Process +import Simulation.Aivika.Processor +import Simulation.Aivika.Stream +import Simulation.Aivika.Statistics + +-- | It models a server that takes @a@ and provides @b@ having state @s@. +data Server s a b = + Server { serverInitState :: s, + -- ^ The initial state of the server. + serverStateRef :: IORef s, + -- ^ The current state of the server. + serverProcess :: (s, a) -> Process (s, b), + -- ^ Provide @b@ by specified @a@. + serverTotalInputTimeRef :: IORef Double, + -- ^ The counted total time spent in awating the input. + serverTotalProcessingTimeRef :: IORef Double, + -- ^ The counted total time spent to process the input and prepare the output. + serverTotalOutputTimeRef :: IORef Double, + -- ^ The counted total time spent for delivering the output. + serverInputTimeRef :: IORef (SamplingStats Double), + -- ^ The statistics for the time spent in awaiting the input. + serverProcessingTimeRef :: IORef (SamplingStats Double), + -- ^ The statistics for the time spent to process the input and prepare the output. + serverOutputTimeRef :: IORef (SamplingStats Double), + -- ^ The statistics for the time spent for delivering the output. + serverInputReceivedSource :: SignalSource a, + -- ^ A signal raised when the server recieves a new input to process. + serverTaskProcessedSource :: SignalSource (a, b), + -- ^ A signal raised when the input is processed and + -- the output is prepared for deliverying. + serverOutputProvidedSource :: SignalSource (a, b) + -- ^ A signal raised when the server has supplied the output. + } + +-- | Create a new server that can provide output @b@ by input @a@. +-- Also it returns the corresponded processor that being applied +-- updates the server state. +newServer :: (a -> Process b) + -- ^ provide an output by the specified input + -> Simulation (Server () a b) +newServer provide = + newServerWithState () $ \(s, a) -> + do b <- provide a + return (s, b) + +-- | Create a new server that can provide output @b@ by input @a@ +-- starting from state @s@. Also it returns the corresponded processor +-- that being applied updates the server state. +newServerWithState :: s + -- ^ the initial state + -> ((s, a) -> Process (s, b)) + -- ^ provide an output by the specified input + -- and update the state + -> Simulation (Server s a b) +newServerWithState state provide = + do r0 <- liftIO $ newIORef state + r1 <- liftIO $ newIORef 0 + r2 <- liftIO $ newIORef 0 + r3 <- liftIO $ newIORef 0 + r4 <- liftIO $ newIORef emptySamplingStats + r5 <- liftIO $ newIORef emptySamplingStats + r6 <- liftIO $ newIORef emptySamplingStats + s1 <- newSignalSource + s2 <- newSignalSource + s3 <- newSignalSource + let server = Server { serverInitState = state, + serverStateRef = r0, + serverProcess = provide, + serverTotalInputTimeRef = r1, + serverTotalProcessingTimeRef = r2, + serverTotalOutputTimeRef = r3, + serverInputTimeRef = r4, + serverProcessingTimeRef = r5, + serverOutputTimeRef = r6, + serverInputReceivedSource = s1, + serverTaskProcessedSource = s2, + serverOutputProvidedSource = s3 } + return server + +-- | Return a processor for the specified server. +-- +-- The processor updates the internal state of the server. The usual case is when +-- the processor is applied only once in a chain of data processing. Otherwise; +-- every time the processor is used, the state of the server changes. +serverProcessor :: Server s a b -> Processor a b +serverProcessor server = + Processor $ \xs -> loop (serverInitState server) Nothing xs + where + loop s r xs = + Cons $ + do t0 <- liftDynamics time + liftEvent $ + case r of + Nothing -> return () + Just (t', a', b') -> + do liftIO $ + do modifyIORef (serverTotalOutputTimeRef server) (+ (t0 - t')) + modifyIORef (serverOutputTimeRef server) $ + addSamplingStats (t0 - t') + triggerSignal (serverOutputProvidedSource server) (a', b') + -- get input + (a, xs') <- runStream xs + t1 <- liftDynamics time + liftEvent $ + do liftIO $ + do modifyIORef (serverTotalInputTimeRef server) (+ (t1 - t0)) + modifyIORef (serverInputTimeRef server) $ + addSamplingStats (t1 - t0) + triggerSignal (serverInputReceivedSource server) a + -- provide the service + (s', b) <- serverProcess server (s, a) + t2 <- liftDynamics time + liftEvent $ + do liftIO $ + do writeIORef (serverStateRef server) s' + modifyIORef (serverTotalProcessingTimeRef server) (+ (t2 - t1)) + modifyIORef (serverProcessingTimeRef server) $ + addSamplingStats (t2 - t1) + triggerSignal (serverTaskProcessedSource server) (a, b) + return (b, loop s' (Just $ (t2, a, b)) xs') + +-- | Return the current state of the server. +-- +-- See also 'serverStateChanged' and 'serverStateChanged_'. +serverState :: Server s a b -> Event s +serverState server = + Event $ \p -> readIORef (serverStateRef server) + +-- | Signal when the 'serverState' property value has changed. +serverStateChanged :: Server s a b -> Signal s +serverStateChanged server = + mapSignalM (const $ serverState server) (serverStateChanged_ server) + +-- | Signal when the 'serverState' property value has changed. +serverStateChanged_ :: Server s a b -> Signal () +serverStateChanged_ server = + mapSignal (const ()) (serverTaskProcessed server) + +-- | Return the counted total time spent by the server in awaiting the input. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverTotalInputTimeChanged' and 'serverTotalInputTimeChanged_'. +serverTotalInputTime :: Server s a b -> Event Double +serverTotalInputTime server = + Event $ \p -> readIORef (serverTotalInputTimeRef server) + +-- | Signal when the 'serverTotalInputTime' property value has changed. +serverTotalInputTimeChanged :: Server s a b -> Signal Double +serverTotalInputTimeChanged server = + mapSignalM (const $ serverTotalInputTime server) (serverTotalInputTimeChanged_ server) + +-- | Signal when the 'serverTotalInputTime' property value has changed. +serverTotalInputTimeChanged_ :: Server s a b -> Signal () +serverTotalInputTimeChanged_ server = + mapSignal (const ()) (serverInputReceived server) + +-- | Return the counted total time spent by the server to process all tasks. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverTotalProcessingTimeChanged' and 'serverTotalProcessingTimeChanged_'. +serverTotalProcessingTime :: Server s a b -> Event Double +serverTotalProcessingTime server = + Event $ \p -> readIORef (serverTotalProcessingTimeRef server) + +-- | Signal when the 'serverTotalProcessingTime' property value has changed. +serverTotalProcessingTimeChanged :: Server s a b -> Signal Double +serverTotalProcessingTimeChanged server = + mapSignalM (const $ serverTotalProcessingTime server) (serverTotalProcessingTimeChanged_ server) + +-- | Signal when the 'serverTotalProcessingTime' property value has changed. +serverTotalProcessingTimeChanged_ :: Server s a b -> Signal () +serverTotalProcessingTimeChanged_ server = + mapSignal (const ()) (serverTaskProcessed server) + +-- | Return the counted total time when the server was in the lock state trying +-- to deliver the output. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverTotalOutputTimeChanged' and 'serverTotalOutputTimeChanged_'. +serverTotalOutputTime :: Server s a b -> Event Double +serverTotalOutputTime server = + Event $ \p -> readIORef (serverTotalOutputTimeRef server) + +-- | Signal when the 'serverTotalOutputTime' property value has changed. +serverTotalOutputTimeChanged :: Server s a b -> Signal Double +serverTotalOutputTimeChanged server = + mapSignalM (const $ serverTotalOutputTime server) (serverTotalOutputTimeChanged_ server) + +-- | Signal when the 'serverTotalOutputTime' property value has changed. +serverTotalOutputTimeChanged_ :: Server s a b -> Signal () +serverTotalOutputTimeChanged_ server = + mapSignal (const ()) (serverOutputProvided server) + +-- | Return the statistics of the time spent by the server in awaiting the input. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverInputTimeChanged' and 'serverInputTimeChanged_'. +serverInputTime :: Server s a b -> Event (SamplingStats Double) +serverInputTime server = + Event $ \p -> readIORef (serverInputTimeRef server) + +-- | Signal when the 'serverInputTime' property value has changed. +serverInputTimeChanged :: Server s a b -> Signal (SamplingStats Double) +serverInputTimeChanged server = + mapSignalM (const $ serverInputTime server) (serverInputTimeChanged_ server) + +-- | Signal when the 'serverInputTime' property value has changed. +serverInputTimeChanged_ :: Server s a b -> Signal () +serverInputTimeChanged_ server = + mapSignal (const ()) (serverInputReceived server) + +-- | Return the statistics of the time spent by the server to process the tasks. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverProcessingTimeChanged' and 'serverProcessingTimeChanged_'. +serverProcessingTime :: Server s a b -> Event (SamplingStats Double) +serverProcessingTime server = + Event $ \p -> readIORef (serverProcessingTimeRef server) + +-- | Signal when the 'serverProcessingTime' property value has changed. +serverProcessingTimeChanged :: Server s a b -> Signal (SamplingStats Double) +serverProcessingTimeChanged server = + mapSignalM (const $ serverProcessingTime server) (serverProcessingTimeChanged_ server) + +-- | Signal when the 'serverProcessingTime' property value has changed. +serverProcessingTimeChanged_ :: Server s a b -> Signal () +serverProcessingTimeChanged_ server = + mapSignal (const ()) (serverTaskProcessed server) + +-- | Return the statistics of the time when the server was in the lock state trying +-- to deliver the output. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverOutputTimeChanged' and 'serverOutputTimeChanged_'. +serverOutputTime :: Server s a b -> Event (SamplingStats Double) +serverOutputTime server = + Event $ \p -> readIORef (serverOutputTimeRef server) + +-- | Signal when the 'serverOutputTime' property value has changed. +serverOutputTimeChanged :: Server s a b -> Signal (SamplingStats Double) +serverOutputTimeChanged server = + mapSignalM (const $ serverOutputTime server) (serverOutputTimeChanged_ server) + +-- | Signal when the 'serverOutputTime' property value has changed. +serverOutputTimeChanged_ :: Server s a b -> Signal () +serverOutputTimeChanged_ server = + mapSignal (const ()) (serverOutputProvided server) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the server was awaiting for the next input task. +-- +-- This factor is calculated as +-- +-- @ +-- totalInputTime \/ (totalInputTime + totalProcessingTime + totalOutputTime) +-- @ +-- +-- As before in this module, the value returned changes discretely and +-- it is usually delayed relative to the current simulation time. +-- +-- See also 'serverInputTimeFactorChanged' and 'serverInputTimeFactorChanged_'. +serverInputTimeFactor :: Server s a b -> Event Double +serverInputTimeFactor server = + Event $ \p -> + do x1 <- readIORef (serverTotalInputTimeRef server) + x2 <- readIORef (serverTotalProcessingTimeRef server) + x3 <- readIORef (serverTotalOutputTimeRef server) + return (x1 / (x1 + x2 + x3)) + +-- | Signal when the 'serverInputTimeFactor' property value has changed. +serverInputTimeFactorChanged :: Server s a b -> Signal Double +serverInputTimeFactorChanged server = + mapSignalM (const $ serverInputTimeFactor server) (serverInputTimeFactorChanged_ server) + +-- | Signal when the 'serverInputTimeFactor' property value has changed. +serverInputTimeFactorChanged_ :: Server s a b -> Signal () +serverInputTimeFactorChanged_ server = + mapSignal (const ()) (serverInputReceived server) <> + mapSignal (const ()) (serverTaskProcessed server) <> + mapSignal (const ()) (serverOutputProvided server) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the server was busy with direct processing its tasks. +-- +-- This factor is calculated as +-- +-- @ +-- totalProcessingTime \/ (totalInputTime + totalProcessingTime + totalOutputTime) +-- @ +-- +-- As before in this module, the value returned changes discretely and +-- it is usually delayed relative to the current simulation time. +-- +-- See also 'serverProcessingTimeFactorChanged' and 'serverProcessingTimeFactorChanged_'. +serverProcessingTimeFactor :: Server s a b -> Event Double +serverProcessingTimeFactor server = + Event $ \p -> + do x1 <- readIORef (serverTotalInputTimeRef server) + x2 <- readIORef (serverTotalProcessingTimeRef server) + x3 <- readIORef (serverTotalOutputTimeRef server) + return (x2 / (x1 + x2 + x3)) + +-- | Signal when the 'serverProcessingTimeFactor' property value has changed. +serverProcessingTimeFactorChanged :: Server s a b -> Signal Double +serverProcessingTimeFactorChanged server = + mapSignalM (const $ serverProcessingTimeFactor server) (serverProcessingTimeFactorChanged_ server) + +-- | Signal when the 'serverProcessingTimeFactor' property value has changed. +serverProcessingTimeFactorChanged_ :: Server s a b -> Signal () +serverProcessingTimeFactorChanged_ server = + mapSignal (const ()) (serverInputReceived server) <> + mapSignal (const ()) (serverTaskProcessed server) <> + mapSignal (const ()) (serverOutputProvided server) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the server was locked trying to deliver the output after the task is finished. +-- +-- This factor is calculated as +-- +-- @ +-- totalOutputTime \/ (totalInputTime + totalProcessingTime + totalOutputTime) +-- @ +-- +-- As before in this module, the value returned changes discretely and +-- it is usually delayed relative to the current simulation time. +-- +-- See also 'serverOutputTimeFactorChanged' and 'serverOutputTimeFactorChanged_'. +serverOutputTimeFactor :: Server s a b -> Event Double +serverOutputTimeFactor server = + Event $ \p -> + do x1 <- readIORef (serverTotalInputTimeRef server) + x2 <- readIORef (serverTotalProcessingTimeRef server) + x3 <- readIORef (serverTotalOutputTimeRef server) + return (x3 / (x1 + x2 + x3)) + +-- | Signal when the 'serverOutputTimeFactor' property value has changed. +serverOutputTimeFactorChanged :: Server s a b -> Signal Double +serverOutputTimeFactorChanged server = + mapSignalM (const $ serverOutputTimeFactor server) (serverOutputTimeFactorChanged_ server) + +-- | Signal when the 'serverOutputTimeFactor' property value has changed. +serverOutputTimeFactorChanged_ :: Server s a b -> Signal () +serverOutputTimeFactorChanged_ server = + mapSignal (const ()) (serverInputReceived server) <> + mapSignal (const ()) (serverTaskProcessed server) <> + mapSignal (const ()) (serverOutputProvided server) + +-- | Raised when the server receives a new input task. +serverInputReceived :: Server s a b -> Signal a +serverInputReceived = publishSignal . serverInputReceivedSource + +-- | Raised when the server has just processed the task. +serverTaskProcessed :: Server s a b -> Signal (a, b) +serverTaskProcessed = publishSignal . serverTaskProcessedSource + +-- | Raised when the server has just delivered the output. +serverOutputProvided :: Server s a b -> Signal (a, b) +serverOutputProvided = publishSignal . serverOutputProvidedSource + +-- | Signal whenever any property of the server changes. +serverChanged_ :: Server s a b -> Signal () +serverChanged_ server = + mapSignal (const ()) (serverInputReceived server) <> + mapSignal (const ()) (serverTaskProcessed server) <> + mapSignal (const ()) (serverOutputProvided server) + +-- | Return the summary for the server with desciption of its +-- properties and activities using the specified indent. +serverSummary :: Server s a b -> Int -> Event ShowS +serverSummary server indent = + Event $ \p -> + do tx1 <- readIORef (serverTotalInputTimeRef server) + tx2 <- readIORef (serverTotalProcessingTimeRef server) + tx3 <- readIORef (serverTotalOutputTimeRef server) + let xf1 = tx1 / (tx1 + tx2 + tx3) + xf2 = tx2 / (tx1 + tx2 + tx3) + xf3 = tx3 / (tx1 + tx2 + tx3) + xs1 <- readIORef (serverInputTimeRef server) + xs2 <- readIORef (serverProcessingTimeRef server) + xs3 <- readIORef (serverOutputTimeRef server) + let tab = replicate indent ' ' + return $ + showString tab . + showString "total input time (in awaiting the input) = " . shows tx1 . + showString "\n" . + showString tab . + showString "total processing time = " . shows tx2 . + showString "\n" . + showString tab . + showString "total output time (to deliver the output) = " . shows tx3 . + showString "\n\n" . + showString tab . + showString "input time factor (from 0 to 1) = " . shows xf1 . + showString "\n" . + showString tab . + showString "processing time factor (from 0 to 1) = " . shows xf2 . + showString "\n" . + showString tab . + showString "output time factor (from 0 to 1) = " . shows xf3 . + showString "\n\n" . + showString tab . + showString "input time:\n\n" . + samplingStatsSummary xs1 (2 + indent) . + showString "\n\n" . + showString tab . + showString "processing time:\n\n" . + samplingStatsSummary xs2 (2 + indent) . + showString "\n\n" . + showString tab . + showString "output time:\n\n" . + samplingStatsSummary xs3 (2 + indent) diff --git a/Simulation/Aivika/Signal.hs b/Simulation/Aivika/Signal.hs --- a/Simulation/Aivika/Signal.hs +++ b/Simulation/Aivika/Signal.hs @@ -13,13 +13,14 @@ -- the handlers. -- module Simulation.Aivika.Signal - (Signal(..), + (-- * Handling and Triggering Signal + Signal(..), handleSignal_, SignalSource, newSignalSource, publishSignal, triggerSignal, - awaitSignal, + -- * Useful Combinators mapSignal, mapSignalM, apSignal, @@ -30,108 +31,20 @@ merge3Signals, merge4Signals, merge5Signals, + -- * Creating Signal in Time Points newSignalInTimes, newSignalInIntegTimes, newSignalInStartTime, newSignalInStopTime, + -- * Signal History SignalHistory, signalHistorySignal, newSignalHistory, - readSignalHistory) where - -import Data.IORef -import Data.Array - -import Control.Monad -import Control.Monad.Trans + readSignalHistory, + -- * Signalable Computations + Signalable(..), + signalableChanged, + emptySignalable, + appendSignalable) where -import Simulation.Aivika.Internal.Specs import Simulation.Aivika.Internal.Signal -import Simulation.Aivika.Internal.Simulation -import Simulation.Aivika.Internal.Event -import Simulation.Aivika.Internal.Cont -import Simulation.Aivika.Internal.Process - -import qualified Simulation.Aivika.Vector as V -import qualified Simulation.Aivika.Vector.Unboxed as UV - --- | Await the signal. -awaitSignal :: Signal a -> Process a -awaitSignal signal = - Process $ \pid -> - Cont $ \c -> - Event $ \p -> - do r <- newIORef Nothing - h <- invokeEvent p $ - handleSignal signal $ - \a -> Event $ - \p -> do x <- readIORef r - case x of - Nothing -> - error "The signal was lost: awaitSignal." - Just x -> - do invokeEvent p x - invokeEvent p $ resumeCont c a - 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.Vector Double, - signalHistoryValues :: V.Vector a } - --- | Create a history of the signal values. -newSignalHistory :: Signal a -> Event (SignalHistory a) -newSignalHistory signal = - do ts <- liftIO UV.newVector - xs <- liftIO V.newVector - handleSignal_ signal $ \a -> - Event $ \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 -> Event (Array Int Double, Array Int a) -readSignalHistory history = - do xs <- liftIO $ UV.freezeVector (signalHistoryTimes history) - ys <- liftIO $ V.freezeVector (signalHistoryValues history) - return (xs, ys) - --- | Trigger the signal with the current time. -triggerSignalWithCurrentTime :: SignalSource Double -> Event () -triggerSignalWithCurrentTime s = - Event $ \p -> invokeEvent p $ triggerSignal s (pointTime p) - --- | Return a signal that is triggered in the specified time points. -newSignalInTimes :: [Double] -> Event (Signal Double) -newSignalInTimes xs = - do s <- liftSimulation newSignalSource - enqueueEventWithTimes xs $ triggerSignalWithCurrentTime s - return $ publishSignal s - --- | Return a signal that is triggered in the integration time points. --- It should be called with help of 'runEventInStartTime'. -newSignalInIntegTimes :: Event (Signal Double) -newSignalInIntegTimes = - do s <- liftSimulation newSignalSource - enqueueEventWithIntegTimes $ triggerSignalWithCurrentTime s - return $ publishSignal s - --- | Return a signal that is triggered in the start time. --- It should be called with help of 'runEventInStartTime'. -newSignalInStartTime :: Event (Signal Double) -newSignalInStartTime = - do s <- liftSimulation newSignalSource - enqueueEventWithStartTime $ triggerSignalWithCurrentTime s - return $ publishSignal s - --- | Return a signal that is triggered in the stop time. -newSignalInStopTime :: Event (Signal Double) -newSignalInStopTime = - do s <- liftSimulation newSignalSource - enqueueEventWithStopTime $ triggerSignalWithCurrentTime s - return $ publishSignal s diff --git a/Simulation/Aivika/Simulation.hs b/Simulation/Aivika/Simulation.hs --- a/Simulation/Aivika/Simulation.hs +++ b/Simulation/Aivika/Simulation.hs @@ -19,9 +19,7 @@ catchSimulation, finallySimulation, throwSimulation, - -- * Utilities - simulationIndex, - simulationCount, - simulationSpecs) where + -- * Memoization + memoSimulation) where import Simulation.Aivika.Internal.Simulation diff --git a/Simulation/Aivika/Statistics.hs b/Simulation/Aivika/Statistics.hs --- a/Simulation/Aivika/Statistics.hs +++ b/Simulation/Aivika/Statistics.hs @@ -11,20 +11,22 @@ -- module Simulation.Aivika.Statistics - (SamplingStats(..), + (-- * Simple Statistics + SamplingStats(..), SamplingData(..), samplingStatsVariance, samplingStatsDeviation, + samplingStatsSummary, returnSamplingStats, listSamplingStats, fromIntSamplingStats, - showSamplingStats, + -- * Timing Statistics TimingStats(..), TimingData(..), timingStatsDeviation, + timingStatsSummary, returnTimingStats, - fromIntTimingStats, - showTimingStats) where + fromIntTimingStats) where import Data.Monoid @@ -54,7 +56,7 @@ samplingStatsMean2 :: !Double -- ^ The average square value. } - deriving (Eq, Ord, Show) + deriving (Eq, Ord) -- | Specifies data type from which values we can gather the statistics. class SamplingData a where @@ -182,24 +184,36 @@ stats { samplingStatsMin = fromIntegral $ samplingStatsMin stats, samplingStatsMax = fromIntegral $ samplingStatsMax stats } --- | Show the summary of the statistics with the specified indent. -showSamplingStats :: (Show a) => SamplingStats a -> Int -> ShowS -showSamplingStats stats indent = +-- | Show the summary of the statistics. +showSamplingStats :: (Show a) => SamplingStats a -> ShowS +showSamplingStats stats = + showString "count = " . shows (samplingStatsCount stats) . + showString ", mean = " . shows (samplingStatsMean stats) . + showString ", std = " . shows (samplingStatsDeviation stats) . + showString ", min = " . shows (samplingStatsMin stats) . + showString ", max = " . shows (samplingStatsMax stats) + +instance Show a => Show (SamplingStats a) where + showsPrec prec = showSamplingStats + +-- | Show the summary of the statistics using the specified indent. +samplingStatsSummary :: (Show a) => SamplingStats a -> Int -> ShowS +samplingStatsSummary stats indent = let tab = replicate indent ' ' in showString tab . - showString "count = " . shows (samplingStatsCount stats) . - showString "\n" . + showString "count = " . shows (samplingStatsCount stats) . + showString "\n" . showString tab . - showString "mean = " . shows (samplingStatsMean stats) . - showString "\n" . + showString "mean = " . shows (samplingStatsMean stats) . + showString "\n" . showString tab . - showString "deviation = " . shows (samplingStatsDeviation stats) . + showString "std = " . shows (samplingStatsDeviation stats) . showString "\n" . showString tab . - showString "minimum = " . shows (samplingStatsMin stats) . + showString "min = " . shows (samplingStatsMin stats) . showString "\n" . showString tab . - showString "maximum = " . shows (samplingStatsMax stats) + showString "max = " . shows (samplingStatsMax stats) -- | This is the timing statistics where data are bound to the time. data TimingStats a = @@ -221,7 +235,7 @@ -- ^ Return the sum of values. timingStatsSum2 :: !Double -- ^ Return the sum of square values. - } deriving (Eq, Ord, Show) + } deriving (Eq, Ord) -- | Defines the data type from which values we can gather the timing statistics. class TimingData a where @@ -248,8 +262,8 @@ timingStatsMaxTime = (-1) / 0, timingStatsStartTime = 1 / 0, timingStatsLastTime = (-1) / 0, - timingStatsSum = 0, - timingStatsSum2 = 0 } + timingStatsSum = 0 / 0, + timingStatsSum2 = 0 / 0 } addTimingStats = addTimingStatsGeneric timingStatsMean = timingStatsMeanGeneric @@ -265,8 +279,8 @@ timingStatsMaxTime = (-1) / 0, timingStatsStartTime = 1 / 0, timingStatsLastTime = (-1) / 0, - timingStatsSum = 0, - timingStatsSum2 = 0 } + timingStatsSum = 0 / 0, + timingStatsSum2 = 0 / 0 } addTimingStats = addTimingStatsGeneric timingStatsMean = timingStatsMeanGeneric @@ -312,22 +326,26 @@ sumX2 = sumX2' + (t - t') * x * x timingStatsMeanGeneric :: ConvertableToDouble a => TimingStats a -> Double -timingStatsMeanGeneric stats - | t1 > t0 = sumX / (t1 - t0) - | otherwise = minX - where t0 = timingStatsStartTime stats - t1 = timingStatsLastTime stats - sumX = timingStatsSum stats - minX = convertToDouble $ timingStatsMin stats +timingStatsMeanGeneric stats + | count == 0 = 0 / 0 + | t1 > t0 = sumX / (t1 - t0) + | otherwise = minX + where t0 = timingStatsStartTime stats + t1 = timingStatsLastTime stats + sumX = timingStatsSum stats + minX = convertToDouble $ timingStatsMin stats + count = timingStatsCount stats timingStatsMean2Generic :: ConvertableToDouble a => TimingStats a -> Double timingStatsMean2Generic stats - | t1 > t0 = sumX2 / (t1 - t0) - | otherwise = minX * minX + | count == 0 = 0 / 0 + | t1 > t0 = sumX2 / (t1 - t0) + | otherwise = minX * minX where t0 = timingStatsStartTime stats t1 = timingStatsLastTime stats sumX2 = timingStatsSum2 stats minX = convertToDouble $ timingStatsMin stats + count = timingStatsCount stats timingStatsVarianceGeneric :: ConvertableToDouble a => TimingStats a -> Double timingStatsVarianceGeneric stats = ex2 - ex * ex @@ -348,27 +366,44 @@ stats { timingStatsMin = fromIntegral $ timingStatsMin stats, timingStatsMax = fromIntegral $ timingStatsMax stats } --- | Show the summary of the statistics with the specified indent. -showTimingStats :: (Show a, TimingData a) => TimingStats a -> Int -> ShowS -showTimingStats stats indent = +-- | Show the summary of the statistics. +showTimingStats :: (Show a, TimingData a) => TimingStats a -> ShowS +showTimingStats stats = + showString "count = " . shows (timingStatsCount stats) . + showString ", mean = " . shows (timingStatsMean stats) . + showString ", std = " . shows (timingStatsDeviation stats) . + showString ", min = " . shows (timingStatsMin stats) . + showString " (t = " . shows (timingStatsMinTime stats) . + showString "), max = " . shows (timingStatsMax stats) . + showString " (t = " . shows (timingStatsMaxTime stats) . + showString "), t in [" . shows (timingStatsStartTime stats) . + showString ", " . shows (timingStatsLastTime stats) . + showString "]" + +instance (Show a, TimingData a) => Show (TimingStats a) where + showsPrec prec = showTimingStats + +-- | Show the summary of the statistics using the specified indent. +timingStatsSummary :: (Show a, TimingData a) => TimingStats a -> Int -> ShowS +timingStatsSummary stats indent = let tab = replicate indent ' ' in showString tab . - showString "count = " . shows (timingStatsCount stats) . - showString "\n" . - showString tab . - showString "mean = " . shows (timingStatsMean stats) . - showString "\n" . - showString tab . - showString "deviation = " . shows (timingStatsDeviation stats) . + showString "count = " . shows (timingStatsCount stats) . showString "\n" . showString tab . - showString "minimum = " . shows (timingStatsMin stats) . - showString " at t = " . shows (timingStatsMinTime stats) . + showString "mean = " . shows (timingStatsMean stats) . showString "\n" . showString tab . - showString "maximum = " . shows (timingStatsMax stats) . - showString " at t = " . shows (timingStatsMaxTime stats) . + showString "std = " . shows (timingStatsDeviation stats) . showString "\n" . + showString tab . + showString "min = " . shows (timingStatsMin stats) . + showString " (t = " . shows (timingStatsMinTime stats) . + showString ")\n" . + showString tab . + showString "max = " . shows (timingStatsMax stats) . + showString " (t = " . shows (timingStatsMaxTime stats) . + showString ")\n" . showString tab . showString "t in [" . shows (timingStatsStartTime stats) . showString ", " . shows (timingStatsLastTime stats) . diff --git a/Simulation/Aivika/Stream.hs b/Simulation/Aivika/Stream.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Stream.hs @@ -0,0 +1,438 @@ + +-- | +-- Module : Simulation.Aivika.Stream +-- Copyright : Copyright (c) 2009-2013, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- The infinite stream of data in time. +-- +module Simulation.Aivika.Stream + (-- * Stream Type + Stream(..), + -- * Merging and Splitting Stream + emptyStream, + mergeStreams, + mergeQueuedStreams, + mergePriorityStreams, + concatStreams, + concatQueuedStreams, + concatPriorityStreams, + splitStream, + splitStreamQueuing, + splitStreamPrioritising, + -- * Specifying Identifier + streamUsingId, + -- * Memoizing, Zipping and Uzipping Stream + memoStream, + zipStreamSeq, + zipStreamParallel, + zip3StreamSeq, + zip3StreamParallel, + unzipStream, + streamSeq, + streamParallel, + -- * Consuming and Sinking Stream + consumeStream, + sinkStream, + -- * Useful Combinators + repeatProcess, + mapStream, + mapStreamM, + apStreamDataFirst, + apStreamDataLater, + apStreamParallel, + filterStream, + filterStreamM, + -- * Utilities + leftStream, + rightStream, + replaceLeftStream, + replaceRightStream, + partitionEitherStream) where + +import Data.IORef +import Data.Maybe +import Data.Monoid + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Simulation +import Simulation.Aivika.Cont +import Simulation.Aivika.Process +import Simulation.Aivika.Resource +import Simulation.Aivika.QueueStrategy + +-- | Represents an infinite stream of data in time, +-- some kind of the cons cell. +newtype Stream a = Cons { runStream :: Process (a, Stream a) + -- ^ Run the stream. + } + +instance Functor Stream where + + fmap f (Cons s) = Cons y where + y = do ~(x, xs) <- s + return (f x, fmap f xs) + +instance Monoid (Stream a) where + + mempty = emptyStream + + mappend = mergeStreams + + mconcat = concatStreams + +-- | Create a stream that will use the specified process identifier. +-- It can be useful to refer to the underlying 'Process' computation which +-- can be passivated, interrupted, canceled and so on. See also the +-- 'processUsingId' function for more details. +streamUsingId :: ProcessId -> Stream a -> Stream a +streamUsingId pid (Cons s) = + Cons $ processUsingId pid s + +-- | Memoize the stream so that it would always return the same data +-- within the simulation run. +memoStream :: Stream a -> Simulation (Stream a) +memoStream (Cons s) = + do p <- memoProcess $ + do ~(x, xs) <- s + xs' <- liftSimulation $ memoStream xs + return (x, xs') + return (Cons p) + +-- | Zip two streams trying to get data sequentially. +zipStreamSeq :: Stream a -> Stream b -> Stream (a, b) +zipStreamSeq (Cons sa) (Cons sb) = Cons y where + y = do ~(x, xs) <- sa + ~(y, ys) <- sb + return ((x, y), zipStreamSeq xs ys) + +-- | Zip two streams trying to get data as soon as possible, +-- launching the sub-processes in parallel. +zipStreamParallel :: Stream a -> Stream b -> Stream (a, b) +zipStreamParallel (Cons sa) (Cons sb) = Cons y where + y = do ~((x, xs), (y, ys)) <- zipProcessParallel sa sb + return ((x, y), zipStreamParallel xs ys) + +-- | Zip three streams trying to get data sequentially. +zip3StreamSeq :: Stream a -> Stream b -> Stream c -> Stream (a, b, c) +zip3StreamSeq (Cons sa) (Cons sb) (Cons sc) = Cons y where + y = do ~(x, xs) <- sa + ~(y, ys) <- sb + ~(z, zs) <- sc + return ((x, y, z), zip3StreamSeq xs ys zs) + +-- | Zip three streams trying to get data as soon as possible, +-- launching the sub-processes in parallel. +zip3StreamParallel :: Stream a -> Stream b -> Stream c -> Stream (a, b, c) +zip3StreamParallel (Cons sa) (Cons sb) (Cons sc) = Cons y where + y = do ~((x, xs), (y, ys), (z, zs)) <- zip3ProcessParallel sa sb sc + return ((x, y, z), zip3StreamParallel xs ys zs) + +-- | Unzip the stream. +unzipStream :: Stream (a, b) -> Simulation (Stream a, Stream b) +unzipStream s = + do s' <- memoStream s + let sa = mapStream fst s' + sb = mapStream snd s' + return (sa, sb) + +-- | To form each new portion of data for the output stream, +-- read data sequentially from the input streams. +-- +-- This is a generalization of 'zipStreamSeq'. +streamSeq :: [Stream a] -> Stream [a] +streamSeq xs = Cons y where + y = do ps <- forM xs $ runStream + return (map fst ps, streamSeq $ map snd ps) + +-- | To form each new portion of data for the output stream, +-- read data from the input streams in parallel. +-- +-- This is a generalization of 'zipStreamParallel'. +streamParallel :: [Stream a] -> Stream [a] +streamParallel xs = Cons y where + y = do ps <- processParallel $ map runStream xs + return (map fst ps, streamParallel $ map snd ps) + +-- | Return a stream of values generated by the specified process. +repeatProcess :: Process a -> Stream a +repeatProcess p = Cons y where + y = do a <- p + return (a, repeatProcess p) + +-- | Map the stream according the specified function. +mapStream :: (a -> b) -> Stream a -> Stream b +mapStream = fmap + +-- | Compose the stream. +mapStreamM :: (a -> Process b) -> Stream a -> Stream b +mapStreamM f (Cons s) = Cons y where + y = do (a, xs) <- s + b <- f a + return (b, mapStreamM f xs) + +-- | Transform the stream getting the transformation function after data have come. +apStreamDataFirst :: Process (a -> b) -> Stream a -> Stream b +apStreamDataFirst f (Cons s) = Cons y where + y = do ~(a, xs) <- s + g <- f + return (g a, apStreamDataFirst f xs) + +-- | Transform the stream getting the transformation function before requesting for data. +apStreamDataLater :: Process (a -> b) -> Stream a -> Stream b +apStreamDataLater f (Cons s) = Cons y where + y = do g <- f + ~(a, xs) <- s + return (g a, apStreamDataLater f xs) + +-- | Transform the stream trying to get the transformation function as soon as possible +-- at the same time when requesting for the next portion of data. +apStreamParallel :: Process (a -> b) -> Stream a -> Stream b +apStreamParallel f (Cons s) = Cons y where + y = do ~(g, (a, xs)) <- zipProcessParallel f s + return (g a, apStreamParallel f xs) + +-- | Filter only those data values that satisfy to the specified predicate. +filterStream :: (a -> Bool) -> Stream a -> Stream a +filterStream p (Cons s) = Cons y where + y = do (a, xs) <- s + if p a + then return (a, filterStream p xs) + else let Cons z = filterStream p xs in z + +-- | Filter only those data values that satisfy to the specified predicate. +filterStreamM :: (a -> Process Bool) -> Stream a -> Stream a +filterStreamM p (Cons s) = Cons y where + y = do (a, xs) <- s + b <- p a + if b + then return (a, filterStreamM p xs) + else let Cons z = filterStreamM p xs in z + +-- | The stream of 'Left' values. +leftStream :: Stream (Either a b) -> Stream a +leftStream (Cons s) = Cons y where + y = do (a, xs) <- s + case a of + Left a -> return (a, leftStream xs) + Right _ -> let Cons z = leftStream xs in z + +-- | The stream of 'Right' values. +rightStream :: Stream (Either a b) -> Stream b +rightStream (Cons s) = Cons y where + y = do (a, xs) <- s + case a of + Left _ -> let Cons z = rightStream xs in z + Right a -> return (a, rightStream xs) + +-- | Replace the 'Left' values. +replaceLeftStream :: Stream (Either a b) -> Stream c -> Stream (Either c b) +replaceLeftStream (Cons sab) (ys0 @ (Cons sc)) = Cons z where + z = do (a, xs) <- sab + case a of + Left _ -> + do (b, ys) <- sc + return (Left b, replaceLeftStream xs ys) + Right a -> + return (Right a, replaceLeftStream xs ys0) + +-- | Replace the 'Right' values. +replaceRightStream :: Stream (Either a b) -> Stream c -> Stream (Either a c) +replaceRightStream (Cons sab) (ys0 @ (Cons sc)) = Cons z where + z = do (a, xs) <- sab + case a of + Right _ -> + do (b, ys) <- sc + return (Right b, replaceRightStream xs ys) + Left a -> + return (Left a, replaceRightStream xs ys0) + +-- | Partition the stream of 'Either' values into two streams. +partitionEitherStream :: Stream (Either a b) -> Simulation (Stream a, Stream b) +partitionEitherStream s = + do s' <- memoStream s + return (leftStream s', rightStream s') + +-- | Split the input stream into the specified number of output streams +-- after applying the 'FCFS' strategy for enqueuing the output requests. +splitStream :: Int -> Stream a -> Simulation [Stream a] +splitStream = splitStreamQueuing FCFS + +-- | Split the input stream into the specified number of output streams. +-- +-- If you don't know what the strategy to apply, then you probably +-- need the 'FCFS' strategy, or function 'splitStream' that +-- does namely this. +splitStreamQueuing :: EnqueueStrategy s q + => s + -- ^ the strategy applied for enqueuing the output requests + -> Int + -- ^ the number of output streams + -> Stream a + -- ^ the input stream + -> Simulation [Stream a] + -- ^ the splitted output streams +splitStreamQueuing s n x = + do ref <- liftIO $ newIORef x + res <- newResource s 1 + let reader = + usingResource res $ + do p <- liftIO $ readIORef ref + (a, xs) <- runStream p + liftIO $ writeIORef ref xs + return a + return $ map (\i -> repeatProcess reader) [1..n] + +-- | Split the input stream into a list of output streams +-- using the specified priorities. +splitStreamPrioritising :: PriorityQueueStrategy s q p + => s + -- ^ the strategy applied for enqueuing the output requests + -> [Stream p] + -- ^ the streams of priorities + -> Stream a + -- ^ the input stream + -> Simulation [Stream a] + -- ^ the splitted output streams +splitStreamPrioritising s ps x = + do ref <- liftIO $ newIORef x + res <- newResource s 1 + let stream (Cons p) = Cons z where + z = do (p', ps) <- p + a <- usingResourceWithPriority res p' $ + do p <- liftIO $ readIORef ref + (a, xs) <- runStream p + liftIO $ writeIORef ref xs + return a + return (a, stream ps) + return $ map stream ps + +-- | Concatenate the input streams applying the 'FCFS' strategy and +-- producing one output stream. +concatStreams :: [Stream a] -> Stream a +concatStreams = concatQueuedStreams FCFS + +-- | Concatenate the input streams producing one output stream. +-- +-- If you don't know what the strategy to apply, then you probably +-- need the 'FCFS' strategy, or function 'concatStreams' that +-- does namely this. +concatQueuedStreams :: EnqueueStrategy s q + => s + -- ^ the strategy applied for enqueuing the input data + -> [Stream a] + -- ^ the input stream + -> Stream a + -- ^ the combined output stream +concatQueuedStreams s streams = Cons z where + z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + writing <- liftSimulation $ newResourceWithMaxCount s 1 (Just 1) + ref <- liftIO $ newIORef Nothing + let writer p = + do (a, xs) <- runStream p + requestResource writing + liftIO $ writeIORef ref (Just a) + releaseResource reading + writer xs + reader = + do requestResource reading + Just a <- liftIO $ readIORef ref + liftIO $ writeIORef ref Nothing + releaseResource writing + return a + forM_ streams $ spawnProcess CancelTogether . writer + runStream $ repeatProcess reader + +-- | Concatenate the input priority streams producing one output stream. +concatPriorityStreams :: PriorityQueueStrategy s q p + => s + -- ^ the strategy applied for enqueuing the input data + -> [Stream (p, a)] + -- ^ the input stream + -> Stream a + -- ^ the combined output stream +concatPriorityStreams s streams = Cons z where + z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + writing <- liftSimulation $ newResourceWithMaxCount s 1 (Just 1) + ref <- liftIO $ newIORef Nothing + let writer p = + do ((priority, a), xs) <- runStream p + requestResourceWithPriority writing priority + liftIO $ writeIORef ref (Just a) + releaseResource reading + writer xs + reader = + do requestResource reading + Just a <- liftIO $ readIORef ref + liftIO $ writeIORef ref Nothing + releaseResource writing + return a + forM_ streams $ spawnProcess CancelTogether . writer + runStream $ repeatProcess reader + +-- | Merge two streams applying the 'FCFS' strategy for enqueuing the input data. +mergeStreams :: Stream a -> Stream a -> Stream a +mergeStreams = mergeQueuedStreams FCFS + +-- | Merge two streams. +-- +-- If you don't know what the strategy to apply, then you probably +-- need the 'FCFS' strategy, or function 'mergeStreams' that +-- does namely this. +mergeQueuedStreams :: EnqueueStrategy s q + => s + -- ^ the strategy applied for enqueuing the input data + -> Stream a + -- ^ the fist input stream + -> Stream a + -- ^ the second input stream + -> Stream a + -- ^ the output combined stream +mergeQueuedStreams s x y = concatQueuedStreams s [x, y] + +-- | Merge two priority streams. +mergePriorityStreams :: PriorityQueueStrategy s q p + => s + -- ^ the strategy applied for enqueuing the input data + -> Stream (p, a) + -- ^ the fist input stream + -> Stream (p, a) + -- ^ the second input stream + -> Stream a + -- ^ the output combined stream +mergePriorityStreams s x y = concatPriorityStreams s [x, y] + +-- | An empty stream that never returns data. +emptyStream :: Stream a +emptyStream = Cons z where + z = do pid <- liftSimulation newProcessId + -- use the generated identifier so that + -- nobody could reactivate the process, + -- although it can be still canceled + processUsingId pid passivateProcess + error "It should never happen: emptyStream." + +-- | Consume the stream. It returns a process that infinitely reads data +-- from the stream and then redirects them to the provided function. +-- It is useful for modeling the process of enqueuing data in the queue +-- from the input stream. +consumeStream :: (a -> Process ()) -> Stream a -> Process () +consumeStream f s = p s where + p (Cons s) = do (a, xs) <- s + f a + p xs + +-- | Sink the stream. It returns a process that infinitely reads data +-- from the stream. The resulting computation can be a moving force +-- to simulate the whole system of the interconnected streams and +-- processors. +sinkStream :: Stream a -> Process () +sinkStream s = p s where + p (Cons s) = do (a, xs) <- s + p xs + diff --git a/Simulation/Aivika/Stream/Random.hs b/Simulation/Aivika/Stream/Random.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Stream/Random.hs @@ -0,0 +1,89 @@ + +-- | +-- Module : Simulation.Aivika.Stream.Random +-- Copyright : Copyright (c) 2009-2013, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- This module defines random streams of data, which are useful +-- for describing the input of the model. +-- + +module Simulation.Aivika.Stream.Random + (randomUniformStream, + randomNormalStream, + randomExponentialStream, + randomErlangStream, + randomPoissonStream, + randomBinomialStream) where + +import System.Random + +import Control.Monad.Trans + +import Simulation.Aivika.Parameter +import Simulation.Aivika.Parameter.Random +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Process +import Simulation.Aivika.Stream + +-- | Create a new stream with delays distributed uniformly. +randomUniformStream :: Double -- ^ the minimum delay + -> Double -- ^ the maximum delay + -> Stream Double -- ^ the stream of delays +randomUniformStream min max = Cons z where + z = do delay <- liftParameter $ randomUniform min max + holdProcess delay + return (delay, randomUniformStream min max) + +-- | Create a new stream with delays distributed normally. +randomNormalStream :: Double -- ^ the mean delay + -> Double -- ^ the delay deviation + -> Stream Double -- ^ the stream of delays +randomNormalStream mu nu = Cons z where + z = do delay <- liftParameter $ randomNormal mu nu + holdProcess delay + return (delay, randomNormalStream mu nu) + +-- | Return a new stream with delays distibuted exponentially with the specified mean +-- (the reciprocal of the rate). +randomExponentialStream :: Double + -- ^ the mean delay (the reciprocal of the rate) + -> Stream Double + -- ^ the stream of delays +randomExponentialStream mu = Cons z where + z = do delay <- liftParameter $ randomExponential mu + holdProcess delay + return (delay, randomExponentialStream mu) + +-- | Return a new stream with delays having the Erlang distribution with the specified +-- scale (the reciprocal of the rate) and shape parameters. +randomErlangStream :: Double -- ^ the scale (the reciprocal of the rate) + -> Int -- ^ the shape + -> Stream Double -- ^ the stream of delays +randomErlangStream beta m = Cons z where + z = do delay <- liftParameter $ randomErlang beta m + holdProcess delay + return (delay, randomErlangStream beta m) + +-- | Return a new stream with delays having the Poisson distribution with +-- the specified mean. +randomPoissonStream :: Double -- ^ the mean delay + -> Stream Int -- ^ the stream of delays +randomPoissonStream mu = Cons z where + z = do delay <- liftParameter $ randomPoisson mu + holdProcess $ fromIntegral delay + return (delay, randomPoissonStream mu) + +-- | Return a new stream with delays having the binomial distribution with the specified +-- probability and trials. +randomBinomialStream :: Double -- ^ the probability + -> Int -- ^ the number of trials + -> Stream Int -- ^ the stream of delays +randomBinomialStream prob trials = Cons z where + z = do delay <- liftParameter $ randomBinomial prob trials + holdProcess $ fromIntegral delay + return (delay, randomBinomialStream prob trials) diff --git a/Simulation/Aivika/SystemDynamics.hs b/Simulation/Aivika/SystemDynamics.hs --- a/Simulation/Aivika/SystemDynamics.hs +++ b/Simulation/Aivika/SystemDynamics.hs @@ -40,12 +40,17 @@ forecast, trend, -- * Difference Equations - sumDynamics, + diffsum, -- * Table Functions lookupDynamics, lookupStepwiseDynamics, -- * Discrete Functions delay, + delayI, + step, + pulse, + pulseP, + ramp, -- * Financial Functions npv, npve) where @@ -57,12 +62,16 @@ import Control.Monad.Trans import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Parameter import Simulation.Aivika.Internal.Simulation import Simulation.Aivika.Internal.Dynamics import Simulation.Aivika.Dynamics.Interpolate -import Simulation.Aivika.Dynamics.Memo.Unboxed import Simulation.Aivika.Unboxed +import Simulation.Aivika.Table +import qualified Simulation.Aivika.Dynamics.Memo as M +import qualified Simulation.Aivika.Dynamics.Memo.Unboxed as MU + -- -- Equality and Ordering -- @@ -246,7 +255,7 @@ -> Dynamics Double -- ^ the initial value -> Simulation (Dynamics Double) -- ^ the integral integ diff i = - mdo y <- memoDynamics z + mdo y <- MU.memoDynamics z z <- Simulation $ \r -> case spcMethod (runSpecs r) of Euler -> return $ Dynamics $ integEuler diff i y @@ -460,14 +469,14 @@ -- the difference is used instead of derivative. -- -- As usual, to create a loopback, you should use the recursive do-notation. -sumDynamics :: (Num a, Unboxed a) - => Dynamics a -- ^ the difference - -> Dynamics a -- ^ the initial value - -> Simulation (Dynamics a) -- ^ the sum -sumDynamics (Dynamics diff) (Dynamics i) = - mdo y <- memoDynamics z - z <- Simulation $ \r -> - return $ Dynamics $ \p -> +diffsum :: (Num a, Unboxed a) + => Dynamics a -- ^ the difference + -> Dynamics a -- ^ the initial value + -> Simulation (Dynamics a) -- ^ the sum +diffsum (Dynamics diff) (Dynamics i) = + mdo y <- + MU.memo0Dynamics $ + Dynamics $ \p -> case pointIteration p of 0 -> i p n -> do @@ -490,67 +499,26 @@ -- | Lookup @x@ in a table of pairs @(x, y)@ using linear interpolation. lookupDynamics :: Dynamics Double -> Array Int (Double, Double) -> Dynamics Double lookupDynamics (Dynamics m) tbl = - Dynamics (\p -> do a <- m p; return $ find first last a) where - (first, last) = bounds tbl - find left right x = - if left > right then - error "Incorrect index: table" - else - let index = (left + 1 + right) `div` 2 - x1 = fst $ tbl ! index - in if x1 <= x then - let y | index < right = find index right x - | right == last = snd $ tbl ! right - | otherwise = - let x2 = fst $ tbl ! (index + 1) - y1 = snd $ tbl ! index - y2 = snd $ tbl ! (index + 1) - in y1 + (y2 - y1) * (x - x1) / (x2 - x1) - in y - else - let y | left < index = find left (index - 1) x - | left == first = snd $ tbl ! left - | otherwise = error "Incorrect index: table" - in y + Dynamics $ \p -> + do a <- m p + return $ tableLookup a tbl -- | Lookup @x@ in a table of pairs @(x, y)@ using stepwise function. -lookupStepwiseDynamics :: Dynamics Double - -> Array Int (Double, Double) - -> Dynamics Double +lookupStepwiseDynamics :: Dynamics Double -> Array Int (Double, Double) -> Dynamics Double lookupStepwiseDynamics (Dynamics m) tbl = - Dynamics (\p -> do a <- m p; return $ find first last a) where - (first, last) = bounds tbl - find left right x = - if left > right then - error "Incorrect index: table" - else - let index = (left + 1 + right) `div` 2 - x1 = fst $ tbl ! index - in if x1 <= x then - let y | index < right = find index right x - | right == last = snd $ tbl ! right - | otherwise = snd $ tbl ! right - in y - else - let y | left < index = find left (index - 1) x - | left == first = snd $ tbl ! left - | otherwise = error "Incorrect index: table" - in y + Dynamics $ \p -> + do a <- m p + return $ tableLookupStepwise a tbl -- -- Discrete Functions -- --- | Return the delayed value. --- --- If you want to apply the result recursively in some loopback then you --- should use one of the memoization functions such as 'memoDynamics' --- and 'memo0Dynamics'. +-- | Return the delayed value using the specified lag time. delay :: Dynamics a -- ^ the value to delay -> Dynamics Double -- ^ the lag time - -> Dynamics a -- ^ the initial value -> Dynamics a -- ^ the delayed value -delay (Dynamics x) (Dynamics d) (Dynamics i) = Dynamics r +delay (Dynamics x) (Dynamics d) = discreteDynamics $ Dynamics r where r p = do let t = pointTime p @@ -559,6 +527,35 @@ a <- d p let t' = t - a n' = fromIntegral $ floor $ (t' - spcStartTime sc) / spcDT sc + y | n' < 0 = x $ p { pointTime = spcStartTime sc, + pointIteration = 0, + pointPhase = 0 } + | n' < n = x $ p { pointTime = t', + pointIteration = n', + pointPhase = -1 } + | n' > n = error $ + "Cannot return the future data: delay. " ++ + "The lag time cannot be negative." + | otherwise = error $ + "Cannot return the current data: delay. " ++ + "The lag time is too small." + y + +-- | Return the delayed value using the specified lag time and initial value. +-- Because of the latter, it allows creating a loop back. +delayI :: Dynamics a -- ^ the value to delay + -> Dynamics Double -- ^ the lag time + -> Dynamics a -- ^ the initial value + -> Simulation (Dynamics a) -- ^ the delayed value +delayI (Dynamics x) (Dynamics d) (Dynamics i) = M.memo0Dynamics $ Dynamics r + where + r p = do + let t = pointTime p + sc = pointSpecs p + n = pointIteration p + a <- d p + let t' = t - a + n' = fromIntegral $ floor $ (t' - spcStartTime sc) / spcDT sc y | n' < 0 = i $ p { pointTime = spcStartTime sc, pointIteration = 0, pointPhase = 0 } @@ -584,9 +581,10 @@ -- -- @ -- npv stream rate init factor = --- mdo df <- integ (- df * rate) 1 +-- mdo let dt' = liftParameter dt +-- df <- integ (- df * rate) 1 -- accum <- integ (stream * df) init --- return $ (accum + dt * stream * df) * factor +-- return $ (accum + dt' * stream * df) * factor -- @ npv :: Dynamics Double -- ^ the stream -> Dynamics Double -- ^ the discount rate @@ -594,9 +592,10 @@ -> Dynamics Double -- ^ factor -> Simulation (Dynamics Double) -- ^ the Net Present Value (NPV) npv stream rate init factor = - mdo df <- integ (- df * rate) 1 + mdo let dt' = liftParameter dt + df <- integ (- df * rate) 1 accum <- integ (stream * df) init - return $ (accum + dt * stream * df) * factor + return $ (accum + dt' * stream * df) * factor -- | Return the Net Present Value End of period (NPVE) of the stream computed -- using the specified discount rate, the initial value and some factor. @@ -605,9 +604,10 @@ -- -- @ -- npve stream rate init factor = --- mdo df <- integ (- df * rate \/ (1 + rate * dt)) (1 \/ (1 + rate * dt)) +-- mdo let dt' = liftParameter dt +-- df <- integ (- df * rate \/ (1 + rate * dt')) (1 \/ (1 + rate * dt')) -- accum <- integ (stream * df) init --- return $ (accum + dt * stream * df) * factor +-- return $ (accum + dt' * stream * df) * factor -- @ npve :: Dynamics Double -- ^ the stream -> Dynamics Double -- ^ the discount rate @@ -615,6 +615,94 @@ -> Dynamics Double -- ^ factor -> Simulation (Dynamics Double) -- ^ the Net Present Value End (NPVE) npve stream rate init factor = - mdo df <- integ (- df * rate / (1 + rate * dt)) (1 / (1 + rate * dt)) + mdo let dt' = liftParameter dt + df <- integ (- df * rate / (1 + rate * dt')) (1 / (1 + rate * dt')) accum <- integ (stream * df) init - return $ (accum + dt * stream * df) * factor + return $ (accum + dt' * stream * df) * factor + +-- | Computation that returns 0 until the step time and then returns the specified height. +step :: Dynamics Double + -- ^ the height + -> Dynamics Double + -- ^ the step time + -> Dynamics Double +step h st = + discreteDynamics $ + Dynamics $ \p -> + do let sc = pointSpecs p + t = pointTime p + st' <- invokeDynamics p st + let t' = t + spcDT sc / 2 + if st' < t' + then invokeDynamics p h + else return 0 + +-- | Computation that returns 1, starting at the time start, and lasting for the interval +-- width; 0 is returned at all other times. +pulse :: Dynamics Double + -- ^ the time start + -> Dynamics Double + -- ^ the interval width + -> Dynamics Double +pulse st w = + discreteDynamics $ + Dynamics $ \p -> + do let sc = pointSpecs p + t = pointTime p + st' <- invokeDynamics p st + let t' = t + spcDT sc / 2 + if st' < t' + then do w' <- invokeDynamics p w + return $ if t' < st' + w' then 1 else 0 + else return 0 + +-- | Computation that returns 1, starting at the time start, and lasting for the interval +-- width and then repeats this pattern with the specified period; 0 is returned at all +-- other times. +pulseP :: Dynamics Double + -- ^ the time start + -> Dynamics Double + -- ^ the interval width + -> Dynamics Double + -- ^ the time period + -> Dynamics Double +pulseP st w period = + discreteDynamics $ + Dynamics $ \p -> + do let sc = pointSpecs p + t = pointTime p + p' <- invokeDynamics p period + st' <- invokeDynamics p st + let y' = if (p' > 0) && (t > st') + then fromIntegral (floor $ (t - st') / p') * p' + else 0 + let st' = st' + y' + let t' = t + spcDT sc / 2 + if st' < t' + then do w' <- invokeDynamics p w + return $ if t' < st' + w' then 1 else 0 + else return 0 + +-- | Computation that returns 0 until the specified time start and then +-- slopes upward until the end time and then holds constant. +ramp :: Dynamics Double + -- ^ the slope parameter + -> Dynamics Double + -- ^ the time start + -> Dynamics Double + -- ^ the end time + -> Dynamics Double +ramp slope st e = + discreteDynamics $ + Dynamics $ \p -> + do let sc = pointSpecs p + t = pointTime p + st' <- invokeDynamics p st + if st' < t + then do slope' <- invokeDynamics p slope + e' <- invokeDynamics p e + if t < e' + then return $ slope' * (t - st') + else return $ slope' * (e' - st') + else return 0 + diff --git a/Simulation/Aivika/Table.hs b/Simulation/Aivika/Table.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Table.hs @@ -0,0 +1,64 @@ + +-- | +-- Module : Simulation.Aivika.Table +-- Copyright : Copyright (c) 2009-2013, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- It defines the table functions. +-- +module Simulation.Aivika.Table + (tableLookup, + tableLookupStepwise) where + +import Data.Array + +-- | Lookup @x@ in a table of pairs @(x, y)@ using linear interpolation. +tableLookup :: Double -> Array Int (Double, Double) -> Double +tableLookup x tbl = find first last x + where + (first, last) = bounds tbl + find left right x = + if left > right then + error "Incorrect index: tableLookup" + else + let index = (left + 1 + right) `div` 2 + x1 = fst $ tbl ! index + in if x1 <= x then + let y | index < right = find index right x + | right == last = snd $ tbl ! right + | otherwise = + let x2 = fst $ tbl ! (index + 1) + y1 = snd $ tbl ! index + y2 = snd $ tbl ! (index + 1) + in y1 + (y2 - y1) * (x - x1) / (x2 - x1) + in y + else + let y | left < index = find left (index - 1) x + | left == first = snd $ tbl ! left + | otherwise = error "Incorrect index: tableLookup" + in y + +-- | Lookup @x@ in a table of pairs @(x, y)@ using stepwise function. +tableLookupStepwise :: Double -> Array Int (Double, Double) -> Double +tableLookupStepwise x tbl = find first last x + where + (first, last) = bounds tbl + find left right x = + if left > right then + error "Incorrect index: tableLookupStepwise" + else + let index = (left + 1 + right) `div` 2 + x1 = fst $ tbl ! index + in if x1 <= x then + let y | index < right = find index right x + | right == last = snd $ tbl ! right + | otherwise = snd $ tbl ! right + in y + else + let y | left < index = find left (index - 1) x + | left == first = snd $ tbl ! left + | otherwise = error "Incorrect index: tableLookupStepwise" + in y diff --git a/Simulation/Aivika/Task.hs b/Simulation/Aivika/Task.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Task.hs @@ -0,0 +1,170 @@ + +-- | +-- Module : Simulation.Aivika.Task +-- Copyright : Copyright (c) 2009-2013, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- The 'Task' value represents a process that was already started in background. +-- We can check the completion of the task, receive notifications about changing +-- its state and even suspend an outer process awaiting the final result of the task. +-- It complements the 'Process' monad as it allows immediately continuing the main +-- computation without suspension. +-- +module Simulation.Aivika.Task + (-- * Task + Task, + TaskResult(..), + taskId, + tryGetTaskResult, + taskResult, + taskResultReceived, + taskProcess, + cancelTask, + taskCancelled, + -- * Running Task + runTask, + runTaskUsingId, + -- * Spawning Tasks + spawnTask, + spawnTaskUsingId, + -- * Enqueueing Task + enqueueTask, + enqueueTaskUsingId) where + +import Data.IORef +import Data.Monoid + +import Control.Monad +import Control.Monad.Trans +import Control.Exception + +import Simulation.Aivika.Internal.Simulation +import Simulation.Aivika.Internal.Dynamics +import Simulation.Aivika.Internal.Event +import Simulation.Aivika.Internal.Cont +import Simulation.Aivika.Internal.Process +import Simulation.Aivika.Internal.Signal + +-- | The task represents a process that was already started in background. +data Task a = + Task { taskId :: ProcessId, + -- ^ Return an identifier for the process that was launched + -- in background for this task. + taskResultRef :: IORef (Maybe (TaskResult a)), + -- ^ It contains the result of the computation. + taskResultReceived :: Signal (TaskResult a) + -- ^ Return a signal that notifies about receiving + -- the result of the task. + } + +-- | Represents the result of the task. +data TaskResult a = TaskCompleted a + -- ^ the task was successfully completed and + -- it returned the specified result + | TaskError IOException + -- ^ the specified exception was raised when performing the task. + | TaskCancelled + -- ^ the task was cancelled + +-- | Try to get the task result immediately without suspension. +tryGetTaskResult :: Task a -> Event (Maybe (TaskResult a)) +tryGetTaskResult t = + Event $ \p -> readIORef (taskResultRef t) + +-- | Return the task result suspending the outer process if required. +taskResult :: Task a -> Process (TaskResult a) +taskResult t = + do x <- liftIO $ readIORef (taskResultRef t) + case x of + Just x -> return x + Nothing -> + do x <- processAwait (taskResultReceived t) + return x + +-- | Cancel the task. +cancelTask :: Task a -> Event () +cancelTask t = + cancelProcessUsingId (taskId t) + +-- | Test whether the task was cancelled. +taskCancelled :: Task a -> Event Bool +taskCancelled t = + processCancelled (taskId t) + +-- | Create a task by the specified process and its identifier. +newTaskUsingId :: ProcessId -> Process a -> Event (Task a, Process ()) +newTaskUsingId pid p = + do r <- liftIO $ newIORef Nothing + s <- liftSimulation newSignalSource + let t = Task { taskId = pid, + taskResultRef = r, + taskResultReceived = publishSignal s } + let m = + do v <- liftIO $ newIORef TaskCancelled + finallyProcess + (catchProcess + (do a <- p + liftIO $ writeIORef v (TaskCompleted a)) + (\e -> + liftIO $ writeIORef v (TaskError e))) + (liftEvent $ + do x <- liftIO $ readIORef v + liftIO $ writeIORef r (Just x) + triggerSignal s x) + return (t, m) + +-- | Run the process with the specified identifier in background and +-- return the corresponded task immediately. +runTaskUsingId :: ProcessId -> Process a -> Event (Task a) +runTaskUsingId pid p = + do (t, m) <- newTaskUsingId pid p + runProcessUsingId pid m + return t + +-- | Run the process in background and return the corresponded task immediately. +runTask :: Process a -> Event (Task a) +runTask p = + do pid <- liftSimulation newProcessId + runTaskUsingId pid p + +-- | Enqueue the process that will be started at the specified time with the given +-- identifier from the event queue. It returns the corresponded task immediately. +enqueueTaskUsingId :: Double -> ProcessId -> Process a -> Event (Task a) +enqueueTaskUsingId time pid p = + do (t, m) <- newTaskUsingId pid p + enqueueProcessUsingId time pid m + return t + +-- | Enqueue the process that will be started at the specified time from the event queue. +-- It returns the corresponded task immediately. +enqueueTask :: Double -> Process a -> Event (Task a) +enqueueTask time p = + do pid <- liftSimulation newProcessId + enqueueTaskUsingId time pid p + +-- | Run using the specified identifier a child process in background and return +-- immediately the corresponded task. +spawnTaskUsingId :: ContCancellation -> ProcessId -> Process a -> Process (Task a) +spawnTaskUsingId cancellation pid p = + do (t, m) <- liftEvent $ newTaskUsingId pid p + spawnProcessUsingId cancellation pid m + return t + +-- | Run a child process in background and return immediately the corresponded task. +spawnTask :: ContCancellation -> Process a -> Process (Task a) +spawnTask cancellation p = + do pid <- liftSimulation newProcessId + spawnTaskUsingId cancellation pid p + +-- | Return an outer process that behaves like the task itself except for one thing: +-- if the outer process is cancelled then it is not enough to cancel the task. +taskProcess :: Task a -> Process a +taskProcess t = + do x <- taskResult t + case x of + TaskCompleted a -> return a + TaskError e -> throwProcess e + TaskCancelled -> cancelProcess diff --git a/Simulation/Aivika/Unboxed.hs b/Simulation/Aivika/Unboxed.hs --- a/Simulation/Aivika/Unboxed.hs +++ b/Simulation/Aivika/Unboxed.hs diff --git a/Simulation/Aivika/Var.hs b/Simulation/Aivika/Var.hs --- a/Simulation/Aivika/Var.hs +++ b/Simulation/Aivika/Var.hs @@ -121,18 +121,11 @@ let b = f a V.writeVector ys i $! b invokeEvent 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 $! b - invokeEvent p $ triggerSignal s b - else do a <- V.readVector ys $ - (i + 1) - 1 - let b = f a - UV.appendVector xs t - V.appendVector ys $! b - invokeEvent p $ triggerSignal s b + else do a <- V.readVector ys i + let b = f a + UV.appendVector xs t + V.appendVector ys $! b + invokeEvent p $ triggerSignal s b -- | Freeze the variable and return in arrays the time points and corresponded -- values when the variable had changed in different time points: (1) the last diff --git a/Simulation/Aivika/Vector/Unboxed.hs b/Simulation/Aivika/Vector/Unboxed.hs --- a/Simulation/Aivika/Vector/Unboxed.hs +++ b/Simulation/Aivika/Vector/Unboxed.hs diff --git a/aivika.cabal b/aivika.cabal --- a/aivika.cabal +++ b/aivika.cabal @@ -1,5 +1,5 @@ name: aivika -version: 0.7 +version: 1.0 synopsis: A multi-paradigm simulation library description: Aivika is a multi-paradigm simulation library which has @@ -15,12 +15,20 @@ with an ability to resume, suspend and cancel the discontinuous processes; . - * allows working with limited resources (you can define your own behaviour + * allows working with the resources (you can define your own behaviour or use the predefined queue strategies); . * allows customizing the queues (you can define your own behaviour or use the predefined queue strategies); . + * allows defining an infinite stream of data based on the + process-oriented computation (designed but not tested in + anyway - please be very careful when using it); + . + * allows defining processors (actually, the Haskell arrows) that + operate on infinite streams of data (designed but not tested + in anyway - please be very careful when using them); + . * supports the activity-oriented paradigm of DES; . * supports the basic constructs for the agent-based modeling; @@ -66,6 +74,22 @@ This document is included in the distributive of Aivika but you can usually find a more recent version by the link provided. . + P.S. + . + Two items, streams and processors, are not yet tested. This is a + goal for the future version of Aivika. The main reason why I ever uploaded + my three packages is that the Aivika Experiment Chart package + was broken in its dependencies, namely, when using the charting + library. So, I decided to provide the compilable packages again. + . + Although I would like to say that the mentioned streams and processors + will be the main improvement in the future version as they actually + allow defining some DES models on a very high level as you would define + them with help of diagrams. + . + Also the queues and server are not tested carefully. Use at your own + risk. At least, the infinite queue seems to be working. + . \[1] . \[2] @@ -75,7 +99,7 @@ category: Simulation license: BSD3 license-file: LICENSE -copyright: (c) 2009-2013. David Sorokin +copyright: (c) 2009-2014. David Sorokin author: David Sorokin maintainer: David Sorokin homepage: http://github.com/dsorokin/aivika @@ -100,7 +124,8 @@ library - exposed-modules: Simulation.Aivika.Agent + exposed-modules: Simulation.Aivika + Simulation.Aivika.Agent Simulation.Aivika.Cont Simulation.Aivika.DoubleLinkedList Simulation.Aivika.Dynamics @@ -110,20 +135,28 @@ Simulation.Aivika.Dynamics.Memo.Unboxed Simulation.Aivika.Dynamics.Random Simulation.Aivika.Event + Simulation.Aivika.Generator Simulation.Aivika.Parameter Simulation.Aivika.Parameter.Random Simulation.Aivika.PriorityQueue Simulation.Aivika.Process + Simulation.Aivika.Processor + Simulation.Aivika.Processor.RoundRobbin Simulation.Aivika.Queue + Simulation.Aivika.Queue.Infinite Simulation.Aivika.QueueStrategy - Simulation.Aivika.Random Simulation.Aivika.Ref Simulation.Aivika.Resource + Simulation.Aivika.Server Simulation.Aivika.Signal Simulation.Aivika.Simulation Simulation.Aivika.Specs Simulation.Aivika.Statistics + Simulation.Aivika.Stream + Simulation.Aivika.Stream.Random Simulation.Aivika.SystemDynamics + Simulation.Aivika.Table + Simulation.Aivika.Task Simulation.Aivika.Unboxed Simulation.Aivika.Var Simulation.Aivika.Var.Unboxed @@ -133,6 +166,7 @@ other-modules: Simulation.Aivika.Internal.Cont Simulation.Aivika.Internal.Dynamics Simulation.Aivika.Internal.Event + Simulation.Aivika.Internal.Parameter Simulation.Aivika.Internal.Process Simulation.Aivika.Internal.Signal Simulation.Aivika.Internal.Simulation diff --git a/examples/BassDiffusion.hs b/examples/BassDiffusion.hs --- a/examples/BassDiffusion.hs +++ b/examples/BassDiffusion.hs @@ -4,12 +4,7 @@ import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Event -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Agent -import Simulation.Aivika.Ref +import Simulation.Aivika n = 500 -- the number of agents @@ -20,16 +15,12 @@ specs = Specs { spcStartTime = 0.0, spcStopTime = 8.0, spcDT = 0.1, - spcMethod = RungeKutta4 } + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } -exprnd :: Double -> IO Double -exprnd lambda = - do x <- getStdRandom random - return (- log x / lambda) - -boolrnd :: Double -> IO Bool -boolrnd p = - do x <- getStdRandom random +randomTrue :: Double -> Parameter Bool +randomTrue p = + do x <- randomUniform 0 1 return (x <= p) data Person = Person { personAgent :: Agent, @@ -57,21 +48,24 @@ do setStateActivation (personPotentialAdopter p) $ do modifyRef potentialAdopters $ \a -> a + 1 -- add a timeout - t <- liftIO $ exprnd advertisingEffectiveness + t <- liftParameter $ + randomExponential (1 / advertisingEffectiveness) let st = personPotentialAdopter p st' = personAdopter p - addTimeout st t $ activateState st' + addTimeout st t $ selectState st' setStateActivation (personAdopter p) $ do modifyRef adopters $ \a -> a + 1 -- add a timer that works while the state is active - let t = liftIO $ exprnd contactRate -- many times! + let t = liftParameter $ + randomExponential (1 / contactRate) -- many times! addTimer (personAdopter p) t $ do i <- liftIO $ getStdRandom $ randomR (1, n) let p' = ps ! i - st <- agentState (personAgent p') + st <- selectedState (personAgent p') when (st == Just (personPotentialAdopter p')) $ - do b <- liftIO $ boolrnd adoptionFraction - when b $ activateState (personAdopter p') + do b <- liftParameter $ + randomTrue adoptionFraction + when b $ selectState (personAdopter p') setStateDeactivation (personPotentialAdopter p) $ modifyRef potentialAdopters $ \a -> a - 1 setStateDeactivation (personAdopter p) $ @@ -83,7 +77,7 @@ definePerson p ps potentialAdopters adopters activatePerson :: Person -> Event () -activatePerson p = activateState (personPotentialAdopter p) +activatePerson p = selectState (personPotentialAdopter p) activatePersons :: Array Int Person -> Event () activatePersons ps = diff --git a/examples/ChemicalReaction.hs b/examples/ChemicalReaction.hs --- a/examples/ChemicalReaction.hs +++ b/examples/ChemicalReaction.hs @@ -1,15 +1,14 @@ {-# LANGUAGE RecursiveDo #-} -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics +import Simulation.Aivika import Simulation.Aivika.SystemDynamics specs = Specs { spcStartTime = 0, spcStopTime = 13, spcDT = 0.01, - spcMethod = RungeKutta4 } + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } model :: Simulation [Double] model = diff --git a/examples/FishBank.hs b/examples/FishBank.hs --- a/examples/FishBank.hs +++ b/examples/FishBank.hs @@ -3,16 +3,15 @@ import Data.Array -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics +import Simulation.Aivika import Simulation.Aivika.SystemDynamics specs = Specs { spcStartTime = 0, spcStopTime = 13, spcDT = 0.01, -- spcDT = 0.000005, - spcMethod = RungeKutta4 } + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } model :: Simulation Double model = diff --git a/examples/Furnace.hs b/examples/Furnace.hs --- a/examples/Furnace.hs +++ b/examples/Furnace.hs @@ -4,66 +4,46 @@ import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Ref -import Simulation.Aivika.Process -import Simulation.Aivika.Random - -import qualified Simulation.Aivika.DoubleLinkedList as DLL +import Simulation.Aivika +import Simulation.Aivika.Queue.Infinite -- | The simulation specs. specs = Specs { spcStartTime = 0.0, -- spcStopTime = 1000.0, spcStopTime = 300.0, spcDT = 0.1, - spcMethod = RungeKutta4 } + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } --- | Return an exponentially distributed random value with mean --- 1 / @lambda@, where @lambda@ is a parameter of the function. -exprnd :: Double -> IO Double -exprnd lambda = - do x <- getStdRandom random - return (- log x / lambda) - -- | Return a random initial temperature of the item. -temprnd :: IO Double -temprnd = - do x <- getStdRandom random - return (400.0 + (600.0 - 400.0) * x) +randomTemp :: Parameter Double +randomTemp = randomUniform 400 600 -- | Represents the furnace. data Furnace = - Furnace { furnaceNormalGen :: IO Double, - -- ^ The normal random number generator. - furnacePits :: [Pit], + Furnace { furnacePits :: [Pit], -- ^ The pits for ingots. furnacePitCount :: Ref Int, -- ^ The count of active pits with ingots. - furnaceAwaitingIngots :: DLL.DoubleLinkedList Ingot, - -- ^ The awaiting ingots in the queue. - furnaceQueueCount :: Ref Int, - -- ^ The queue count. - furnaceWaitCount :: Ref Int, - -- ^ The count of awaiting ingots. - furnaceWaitTime :: Ref Double, - -- ^ The wait time for all loaded ingots. - furnaceHeatingTime :: Ref Double, - -- ^ The heating time for all unloaded ingots. + furnaceQueue :: FCFSQueue Ingot, + -- ^ The furnace queue. + furnaceUnloadedSource :: SignalSource (), + -- ^ Notifies when the ingots have been + -- unloaded from the furnace. + furnaceHeatingTime :: Ref (SamplingStats Double), + -- ^ The heating time for the ready ingots. furnaceTemp :: Ref Double, -- ^ The furnace temperature. - furnaceTotalCount :: Ref Int, - -- ^ The total count of ingots. - furnaceLoadCount :: Ref Int, - -- ^ The count of loaded ingots. - furnaceUnloadCount :: Ref Int, - -- ^ The count of unloaded ingots. - furnaceUnloadTemps :: Ref [Double] - -- ^ The temperatures of all unloaded ingots. + furnaceReadyCount :: Ref Int, + -- ^ The count of ready ingots. + furnaceReadyTemps :: Ref [Double] + -- ^ The temperatures of all ready ingots. } +-- | Notifies when the ingots have been unloaded from the furnace. +furnaceUnloaded :: Furnace -> Signal () +furnaceUnloaded = publishSignal . furnaceUnloadedSource + -- | A pit in the furnace to place the ingots. data Pit = Pit { pitIngot :: Ref (Maybe Ingot), @@ -90,32 +70,22 @@ -- | Create a furnace. newFurnace :: Simulation Furnace newFurnace = - do normalGen <- liftIO newNormalGen - pits <- sequence [newPit | i <- [1..10]] + do pits <- sequence [newPit | i <- [1..10]] pitCount <- newRef 0 - awaitingIngots <- liftIO DLL.newList - queueCount <- newRef 0 - waitCount <- newRef 0 - waitTime <- newRef 0.0 - heatingTime <- newRef 0.0 + queue <- newFCFSQueue + heatingTime <- newRef emptySamplingStats h <- newRef 1650.0 - totalCount <- newRef 0 - loadCount <- newRef 0 - unloadCount <- newRef 0 - unloadTemps <- newRef [] - return Furnace { furnaceNormalGen = normalGen, - furnacePits = pits, + readyCount <- newRef 0 + readyTemps <- newRef [] + s <- newSignalSource + return Furnace { furnacePits = pits, furnacePitCount = pitCount, - furnaceAwaitingIngots = awaitingIngots, - furnaceQueueCount = queueCount, - furnaceWaitCount = waitCount, - furnaceWaitTime = waitTime, + furnaceQueue = queue, + furnaceUnloadedSource = s, furnaceHeatingTime = heatingTime, furnaceTemp = h, - furnaceTotalCount = totalCount, - furnaceLoadCount = loadCount, - furnaceUnloadCount = unloadCount, - furnaceUnloadTemps = unloadTemps } + furnaceReadyCount = readyCount, + furnaceReadyTemps = readyTemps } -- | Create a new pit. newPit :: Simulation Pit @@ -129,9 +99,9 @@ newIngot :: Furnace -> Event Ingot newIngot furnace = do t <- liftDynamics time - xi <- liftIO $ furnaceNormalGen furnace - h' <- liftIO temprnd - let c = 0.1 + (0.05 + xi * 0.01) + xi <- liftParameter $ randomNormal 0.05 0.01 + h' <- liftParameter randomTemp + let c = 0.1 + xi return Ingot { ingotFurnace = furnace, ingotReceiveTime = t, ingotReceiveTemp = h', @@ -150,7 +120,7 @@ -- update the temperature of the ingot. let furnace = ingotFurnace ingot - dt' <- liftDynamics dt + dt' <- liftParameter dt h' <- readRef (pitTemp pit) h <- readRef (furnaceTemp furnace) writeRef (pitTemp pit) $ @@ -169,84 +139,73 @@ do h' <- readRef (pitTemp pit) when (h' >= 2000.0) $ do Just ingot <- readRef (pitIngot pit) - unloadIngot ingot pit + unloadIngot furnace ingot pit -- | Try to load an awaiting ingot in the specified empty pit. tryLoadPit :: Furnace -> Pit -> Event () tryLoadPit furnace pit = - do let ingots = furnaceAwaitingIngots furnace - flag <- liftIO $ DLL.listNull ingots - unless flag $ - do ingot <- liftIO $ DLL.listFirst ingots - liftIO $ DLL.listRemoveFirst ingots - t' <- liftDynamics time - modifyRef (furnaceQueueCount furnace) (+ (-1)) - loadIngot (ingot { ingotLoadTime = t', - ingotLoadTemp = 400.0 }) pit + do ingot <- tryDequeue (furnaceQueue furnace) + case ingot of + Nothing -> + return () + Just ingot -> + do t' <- liftDynamics time + loadIngot furnace (ingot { ingotLoadTime = t', + ingotLoadTemp = 400.0 }) pit -- | Unload the ingot from the specified pit. -unloadIngot :: Ingot -> Pit -> Event () -unloadIngot ingot pit = +unloadIngot :: Furnace -> Ingot -> Pit -> Event () +unloadIngot furnace ingot pit = do h' <- readRef (pitTemp pit) writeRef (pitIngot pit) Nothing writeRef (pitTemp pit) 0.0 - + -- count the active pits - let furnace = ingotFurnace ingot - count <- readRef (furnacePitCount furnace) - writeRef (furnacePitCount furnace) (count - 1) + modifyRef (furnacePitCount furnace) (+ (- 1)) -- how long did we heat the ingot up? t' <- liftDynamics time - modifyRef (furnaceHeatingTime furnace) - (+ (t' - ingotLoadTime ingot)) + modifyRef (furnaceHeatingTime furnace) $ + addSamplingStats (t' - ingotLoadTime ingot) -- what is the temperature of the unloaded ingot? - modifyRef (furnaceUnloadTemps furnace) (h' :) + modifyRef (furnaceReadyTemps furnace) (h' :) - -- count the unloaded ingots - modifyRef (furnaceUnloadCount furnace) (+ 1) + -- count the ready ingots + modifyRef (furnaceReadyCount furnace) (+ 1) -- | Load the ingot in the specified pit -loadIngot :: Ingot -> Pit -> Event () -loadIngot ingot pit = +loadIngot :: Furnace -> Ingot -> Pit -> Event () +loadIngot furnace ingot pit = do writeRef (pitIngot pit) $ Just ingot writeRef (pitTemp pit) $ ingotLoadTemp ingot - + -- count the active pits - let furnace = ingotFurnace ingot + modifyRef (furnacePitCount furnace) (+ 1) count <- readRef (furnacePitCount furnace) - writeRef (furnacePitCount furnace) (count + 1) -- decrease the furnace temperature h <- readRef (furnaceTemp furnace) let h' = ingotLoadTemp ingot - dh = - (h - h') / fromInteger (toInteger (count + 1)) + dh = - (h - h') / fromIntegral count writeRef (furnaceTemp furnace) $ h + dh - - -- how long did we keep the ingot in the queue? - t' <- liftDynamics time - modifyRef (furnaceWaitCount furnace) (+ 1) - modifyRef (furnaceWaitTime furnace) - (+ (t' - ingotReceiveTime ingot)) - - -- count the loaded ingots - modifyRef (furnaceLoadCount furnace) (+ 1) - + -- | Start iterating the furnace processing through the event queue. startIteratingFurnace :: Furnace -> Event () startIteratingFurnace furnace = let pits = furnacePits furnace in enqueueEventWithIntegTimes $ - do ready <- ingotsReady furnace + do -- try to unload ready ingots + ready <- ingotsReady furnace when ready $ do mapM_ (tryUnloadPit furnace) pits - pits' <- emptyPits furnace - mapM_ (tryLoadPit furnace) pits' + triggerSignal (furnaceUnloadedSource furnace) () + + -- heat up mapM_ heatPitUp pits -- update the temperature of the furnace - dt' <- liftDynamics dt + dt' <- liftParameter dt h <- readRef (furnaceTemp furnace) writeRef (furnaceTemp furnace) $ h + dt' * (2600.0 - h) * 0.2 @@ -257,32 +216,37 @@ filterM (fmap isNothing . readRef . pitIngot) $ furnacePits furnace --- | Accept a new ingot. -acceptIngot :: Furnace -> Event () -acceptIngot furnace = - do ingot <- newIngot furnace - - -- counting - modifyRef (furnaceTotalCount furnace) (+ 1) - - -- check what to do with the new ingot - count <- readRef (furnacePitCount furnace) - if count >= 10 - then do let ingots = furnaceAwaitingIngots furnace - liftIO $ DLL.listAddLast ingots ingot - modifyRef (furnaceQueueCount furnace) (+ 1) - else do pit:_ <- emptyPits furnace - loadIngot ingot pit - --- | Process the furnace. -processFurnace :: Furnace -> Process () -processFurnace furnace = - do delay <- liftIO $ exprnd (1.0 / 2.5) +-- | This process takes ingots from the queue and then +-- loads them in the furnace. +loadingProcess :: Furnace -> Process () +loadingProcess furnace = + do ingot <- dequeue (furnaceQueue furnace) + let wait :: Process () + wait = + do count <- liftEvent $ readRef (furnacePitCount furnace) + when (count >= 10) $ + do processAwait (furnaceUnloaded furnace) + wait + wait + -- take any empty pit and load it + liftEvent $ + do pit: _ <- emptyPits furnace + loadIngot furnace ingot pit + -- repeat it again + loadingProcess furnace + +-- | The input process that adds new ingots to the queue. +inputProcess :: Furnace -> Process () +inputProcess furnace = + do delay <- liftParameter $ + randomExponential 2.5 holdProcess delay -- we have got a new ingot - liftEvent $ acceptIngot furnace + liftEvent $ + do ingot <- newIngot furnace + enqueue (furnaceQueue furnace) ingot -- repeat it again - processFurnace furnace + inputProcess furnace -- | Initialize the furnace. initializeFurnace :: Furnace -> Event () @@ -295,97 +259,92 @@ x6 <- newIngot furnace let p1 : p2 : p3 : p4 : p5 : p6 : ps = furnacePits furnace - loadIngot (x1 { ingotLoadTemp = 550.0 }) p1 - loadIngot (x2 { ingotLoadTemp = 600.0 }) p2 - loadIngot (x3 { ingotLoadTemp = 650.0 }) p3 - loadIngot (x4 { ingotLoadTemp = 700.0 }) p4 - loadIngot (x5 { ingotLoadTemp = 750.0 }) p5 - loadIngot (x6 { ingotLoadTemp = 800.0 }) p6 - writeRef (furnaceTotalCount furnace) 6 + loadIngot furnace (x1 { ingotLoadTemp = 550.0 }) p1 + loadIngot furnace (x2 { ingotLoadTemp = 600.0 }) p2 + loadIngot furnace (x3 { ingotLoadTemp = 650.0 }) p3 + loadIngot furnace (x4 { ingotLoadTemp = 700.0 }) p4 + loadIngot furnace (x5 { ingotLoadTemp = 750.0 }) p5 + loadIngot furnace (x6 { ingotLoadTemp = 800.0 }) p6 writeRef (furnaceTemp furnace) 1650.0 --- | Return a count, average and deviation. -stats :: [Double] -> (Int, Double, Double) -stats xs = (length xs, ex, sx) - where - n = fromInteger $ toInteger $ length xs - ex = sum xs / n - dx = (sum . map rho) xs / (n - 1.0) - sx = sqrt dx - rho x = (x - ex) ^ 2 - -- | The simulation model. model :: Simulation () model = do furnace <- newFurnace - pid <- newProcessId - + -- initialize the furnace and start its iterating in start time runEventInStartTime IncludingCurrentEvents $ do initializeFurnace furnace startIteratingFurnace furnace - -- accept input ingots - runProcessInStartTime IncludingCurrentEvents - pid (processFurnace furnace) + -- generate randomly new input ingots + runProcessInStartTime IncludingCurrentEvents $ + inputProcess furnace + + -- load permanently the input ingots in the furnace + runProcessInStartTime IncludingCurrentEvents $ + loadingProcess furnace -- run the model in the final time point runEventInStopTime IncludingCurrentEvents $ do -- the ingots - c0 <- readRef (furnaceTotalCount furnace) - c1 <- readRef (furnaceLoadCount furnace) - c2 <- readRef (furnaceUnloadCount furnace) - c3 <- readRef (furnaceWaitCount furnace) + c0 <- queueStoreCount (furnaceQueue furnace) + c1 <- queueOutputCount (furnaceQueue furnace) + c2 <- readRef (furnaceReadyCount furnace) liftIO $ do putStrLn "The count of ingots:" + putStrLn "" putStrLn $ " total = " ++ show c0 putStrLn $ " loaded = " ++ show c1 putStrLn $ " ready = " ++ show c2 - putStrLn $ " awaited in the queue = " ++ show c3 putStrLn "" -- the temperature of the ready ingots - (n1, e1, d1) <- - fmap stats $ readRef (furnaceUnloadTemps furnace) - + temps <- readRef (furnaceReadyTemps furnace) + liftIO $ do - putStrLn "The temperature of the ready ingots:" - putStrLn $ " average = " ++ show e1 - putStrLn $ " deviation = " ++ show d1 + putStrLn "The temperature of ready ingots:" putStrLn "" + putStrLn $ samplingStatsSummary (listSamplingStats temps) 2 [] + putStrLn "" + + -- the mean heating time + r5 <- readRef (furnaceHeatingTime furnace) + + liftIO $ do + putStrLn "The heating time:" + putStrLn "" + putStrLn $ samplingStatsSummary r5 2 [] + putStrLn "" -- the ingots in pits r2 <- readRef (furnacePitCount furnace) liftIO $ do - putStrLn "The ingots in pits (in the final time): " + putStr "The ingots in pits (in the final time): " putStrLn $ show r2 putStrLn "" - -- the queue size - r3 <- readRef (furnaceQueueCount furnace) + -- the queue size and mean wait time + r3 <- queueCount (furnaceQueue furnace) + + r4 <- fmap samplingStatsMean $ + queueWaitTime (furnaceQueue furnace) liftIO $ do - putStrLn "The queue size (in the final time): " - putStrLn $ show r3 + putStrLn "The queue summary: " putStrLn "" - - -- the mean wait time in the queue - waitTime <- readRef (furnaceWaitTime furnace) - waitCount <- readRef (furnaceWaitCount furnace) + putStrLn $ " size (in the final time) = " ++ show r3 + putStrLn $ " mean wait time = " ++ show r4 + putStrLn "" - let t4 = waitTime / fromIntegral waitCount - - -- the mean heating time - heatingTime <- readRef (furnaceHeatingTime furnace) - unloadCount <- readRef (furnaceUnloadCount furnace) + summary <- queueSummary (furnaceQueue furnace) 2 - let t5 = heatingTime / fromIntegral unloadCount - liftIO $ do - putStrLn $ "The mean wait time: " ++ show t4 - putStrLn $ "The mean heating time: " ++ show t5 + putStrLn "The detailed info about the queue (in the final time): " + putStrLn "" + putStrLn $ summary [] -- | The main program. main = runSimulation model specs diff --git a/examples/MachRep1.hs b/examples/MachRep1.hs --- a/examples/MachRep1.hs +++ b/examples/MachRep1.hs @@ -15,58 +15,43 @@ -- Output is long-run proportion of up time. Should get value of about -- 0.66. -import System.Random import Control.Monad.Trans -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Event -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Ref -import Simulation.Aivika.Process +import Simulation.Aivika -upRate = 1.0 / 1.0 -- reciprocal of mean up time -repairRate = 1.0 / 0.5 -- reciprocal of mean repair time +meanUpTime = 1.0 +meanRepairTime = 0.5 specs = Specs { spcStartTime = 0.0, spcStopTime = 1000.0, spcDT = 1.0, - spcMethod = RungeKutta4 } + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } -exprnd :: Double -> IO Double -exprnd lambda = - do x <- getStdRandom random - return (- log x / lambda) - model :: Simulation Double model = do totalUpTime <- newRef 0.0 - pid1 <- newProcessId - pid2 <- newProcessId - let machine :: Process () machine = - do startUpTime <- liftDynamics time - upTime <- liftIO $ exprnd upRate + do upTime <- + liftParameter $ + randomExponential meanUpTime holdProcess upTime - finishUpTime <- liftDynamics time liftEvent $ - modifyRef totalUpTime - (+ (finishUpTime - startUpTime)) - repairTime <- liftIO $ exprnd repairRate + modifyRef totalUpTime (+ upTime) + repairTime <- + liftParameter $ + randomExponential meanRepairTime holdProcess repairTime machine - runProcessInStartTime IncludingCurrentEvents - pid1 machine - - runProcessInStartTime IncludingCurrentEvents - pid2 machine + runProcessInStartTime IncludingCurrentEvents machine + runProcessInStartTime IncludingCurrentEvents machine runEventInStopTime IncludingCurrentEvents $ do x <- readRef totalUpTime - y <- liftDynamics stoptime + y <- liftParameter stoptime return $ x / (2 * y) main = runSimulation model specs >>= print diff --git a/examples/MachRep1EventDriven.hs b/examples/MachRep1EventDriven.hs --- a/examples/MachRep1EventDriven.hs +++ b/examples/MachRep1EventDriven.hs @@ -15,28 +15,19 @@ -- Output is long-run proportion of up time. Should get value of about -- 0.66. -import System.Random import Control.Monad.Trans -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Ref +import Simulation.Aivika -upRate = 1.0 / 1.0 -- reciprocal of mean up time -repairRate = 1.0 / 0.5 -- reciprocal of mean repair time +meanUpTime = 1.0 +meanRepairTime = 0.5 specs = Specs { spcStartTime = 0.0, spcStopTime = 1000.0, spcDT = 1.0, - spcMethod = RungeKutta4 } + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } -exprnd :: Double -> IO Double -exprnd lambda = - do x <- getStdRandom random - return (- log x / lambda) - model :: Simulation Double model = do totalUpTime <- newRef 0.0 @@ -46,7 +37,9 @@ do finishUpTime <- liftDynamics time modifyRef totalUpTime (+ (finishUpTime - startUpTime)) - repairTime <- liftIO $ exprnd repairRate + repairTime <- + liftParameter $ + randomExponential meanRepairTime -- enqueue a new event let t = finishUpTime + repairTime @@ -56,7 +49,9 @@ machineRepaired = do startUpTime <- liftDynamics time - upTime <- liftIO $ exprnd upRate + upTime <- + liftParameter $ + randomExponential meanUpTime -- enqueue a new event let t = startUpTime + upTime @@ -70,7 +65,7 @@ runEventInStopTime IncludingCurrentEvents $ do x <- readRef totalUpTime - y <- liftDynamics stoptime + y <- liftParameter stoptime return $ x / (2 * y) main = runSimulation model specs >>= print diff --git a/examples/MachRep1TimeDriven.hs b/examples/MachRep1TimeDriven.hs --- a/examples/MachRep1TimeDriven.hs +++ b/examples/MachRep1TimeDriven.hs @@ -15,28 +15,19 @@ -- Output is long-run proportion of up time. Should get value of about -- 0.66. -import System.Random import Control.Monad.Trans -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Ref +import Simulation.Aivika -upRate = 1.0 / 1.0 -- reciprocal of mean up time -repairRate = 1.0 / 0.5 -- reciprocal of mean repair time +meanUpTime = 1.0 +meanRepairTime = 0.5 specs = Specs { spcStartTime = 0.0, spcStopTime = 1000.0, spcDT = 0.05, - spcMethod = RungeKutta4 } + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } -exprnd :: Double -> IO Double -exprnd lambda = - do x <- getStdRandom random - return (- log x / lambda) - model :: Simulation Double model = do totalUpTime <- newRef 0.0 @@ -69,12 +60,13 @@ -- the machine is broken startUpTime' <- readRef startUpTime finishUpTime' <- liftDynamics time - dt' <- liftDynamics dt + dt' <- liftParameter dt modifyRef totalUpTime $ \a -> a + (finishUpTime' - startUpTime') - repairTime' <- - liftIO $ exprnd repairRate + repairTime' <- + liftParameter $ + randomExponential meanRepairTime writeRef repairNum $ round (repairTime' / dt') @@ -82,18 +74,19 @@ do writeRef repairNum (-1) -- the machine is repaired t' <- liftDynamics time - dt' <- liftDynamics dt + dt' <- liftParameter dt writeRef startUpTime t' - upTime' <- - liftIO $ exprnd upRate + upTime' <- + liftParameter $ + randomExponential meanUpTime writeRef upNum $ round (upTime' / dt') - result | upNum' > 0 = untilBroken + result | upNum' > 0 = untilBroken | upNum' == 0 = broken - | repairNum' > 0 = untilRepaired + | repairNum' > 0 = untilRepaired | repairNum' == 0 = repaired - | otherwise = repaired + | otherwise = repaired result -- create two machines with type Event () @@ -110,7 +103,7 @@ -- return the result in the stop time runEventInStopTime IncludingCurrentEvents $ do x <- readRef totalUpTime - y <- liftDynamics stoptime + y <- liftParameter stoptime return $ x / (2 * y) main = runSimulation model specs >>= print diff --git a/examples/MachRep2.hs b/examples/MachRep2.hs --- a/examples/MachRep2.hs +++ b/examples/MachRep2.hs @@ -17,31 +17,19 @@ -- that a given machine does not have immediate access to the repairperson -- when the machine breaks down. Output values should be about 0.6 and 0.67. -import System.Random import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Ref -import Simulation.Aivika.QueueStrategy -import Simulation.Aivika.Resource -import Simulation.Aivika.Process +import Simulation.Aivika -upRate = 1.0 / 1.0 -- reciprocal of mean up time -repairRate = 1.0 / 0.5 -- reciprocal of mean repair time +meanUpTime = 1.0 +meanRepairTime = 0.5 specs = Specs { spcStartTime = 0.0, spcStopTime = 1000.0, spcDT = 1.0, - spcMethod = RungeKutta4 } - -exprnd :: Double -> IO Double -exprnd lambda = - do x <- getStdRandom random - return (- log x / lambda) + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } model :: Simulation (Double, Double) model = @@ -55,19 +43,16 @@ -- total up time for all machines totalUpTime <- newRef 0.0 - repairPerson <- newResource FCFS 1 - - pid1 <- newProcessId - pid2 <- newProcessId + repairPerson <- newFCFSResource 1 let machine :: Process () machine = - do startUpTime <- liftDynamics time - upTime <- liftIO $ exprnd upRate + do upTime <- + liftParameter $ + randomExponential meanUpTime holdProcess upTime - finishUpTime <- liftDynamics time - liftEvent $ modifyRef totalUpTime - (+ (finishUpTime - startUpTime)) + liftEvent $ + modifyRef totalUpTime (+ upTime) -- check the resource availability liftEvent $ @@ -77,21 +62,20 @@ modifyRef nImmedRep (+ 1) requestResource repairPerson - repairTime <- liftIO $ exprnd repairRate + repairTime <- + liftParameter $ + randomExponential meanRepairTime holdProcess repairTime releaseResource repairPerson machine - runProcessInStartTime IncludingCurrentEvents - pid1 machine - - runProcessInStartTime IncludingCurrentEvents - pid2 machine + runProcessInStartTime IncludingCurrentEvents machine + runProcessInStartTime IncludingCurrentEvents machine runEventInStopTime IncludingCurrentEvents $ do x <- readRef totalUpTime - y <- liftDynamics stoptime + y <- liftParameter stoptime n <- readRef nRep nImmed <- readRef nImmedRep return (x / (2 * y), diff --git a/examples/MachRep3.hs b/examples/MachRep3.hs --- a/examples/MachRep3.hs +++ b/examples/MachRep3.hs @@ -13,31 +13,19 @@ -- until both machines are down. We find the proportion of up time. It -- should come out to about 0.45. -import System.Random import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Ref -import Simulation.Aivika.QueueStrategy -import Simulation.Aivika.Resource -import Simulation.Aivika.Process +import Simulation.Aivika -upRate = 1.0 / 1.0 -- reciprocal of mean up time -repairRate = 1.0 / 0.5 -- reciprocal of mean repair time +meanUpTime = 1.0 +meanRepairTime = 0.5 specs = Specs { spcStartTime = 0.0, spcStopTime = 1000.0, spcDT = 1.0, - spcMethod = RungeKutta4 } - -exprnd :: Double -> IO Double -exprnd lambda = - do x <- getStdRandom random - return (- log x / lambda) + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } model :: Simulation Double model = @@ -54,14 +42,15 @@ let machine :: ProcessId -> Process () machine pid = - do startUpTime <- liftDynamics time - upTime <- liftIO $ exprnd upRate + do upTime <- + liftParameter $ + randomExponential meanUpTime holdProcess upTime - finishUpTime <- liftDynamics time - liftEvent $ modifyRef totalUpTime - (+ (finishUpTime - startUpTime)) - - liftEvent $ modifyRef nUp $ \a -> a - 1 + liftEvent $ + modifyRef totalUpTime (+ upTime) + + liftEvent $ + modifyRef nUp (+ (-1)) nUp' <- liftEvent $ readRef nUp if nUp' == 1 then passivateProcess @@ -71,22 +60,25 @@ reactivateProcess pid requestResource repairPerson - repairTime <- liftIO $ exprnd repairRate + repairTime <- + liftParameter $ + randomExponential meanRepairTime holdProcess repairTime - liftEvent $ modifyRef nUp $ \a -> a + 1 + liftEvent $ + modifyRef nUp (+ 1) releaseResource repairPerson machine pid - runProcessInStartTime IncludingCurrentEvents + runProcessInStartTimeUsingId IncludingCurrentEvents pid1 (machine pid2) - runProcessInStartTime IncludingCurrentEvents + runProcessInStartTimeUsingId IncludingCurrentEvents pid2 (machine pid1) runEventInStopTime IncludingCurrentEvents $ do x <- readRef totalUpTime - y <- liftDynamics stoptime + y <- liftDynamics time return $ x / (2 * y) main = runSimulation model specs >>= print diff --git a/examples/README b/examples/README --- a/examples/README +++ b/examples/README @@ -1,6 +1,6 @@ More examples are bundled with packages aivika-experiment and aivika-experiment-chart. They plot charts, save the simulation results in the CSV files and generate -an HTML web page which can be observed in your favourite Internet browser. +HTML web pages which can be observed in your favourite Internet browser. Some examples define a parametric Monte-Carlo simulation, after which the deviation charts and histograms are plotted, for example. diff --git a/examples/TimeOut.hs b/examples/TimeOut.hs --- a/examples/TimeOut.hs +++ b/examples/TimeOut.hs @@ -18,16 +18,10 @@ -- We find the proportion of messages which timeout. The output should -- be about 0.61. -import System.Random import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Ref -import Simulation.Aivika.Process +import Simulation.Aivika ackRate = 1.0 / 1.0 -- reciprocal of the acknowledge mean time toPeriod = 0.5 -- timeout period @@ -35,12 +29,8 @@ specs = Specs { spcStartTime = 0.0, spcStopTime = 10000.0, spcDT = 1.0, - spcMethod = RungeKutta4 } - -exprnd :: Double -> IO Double -exprnd lambda = - do x <- getStdRandom random - return (- log x / lambda) + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } model :: Simulation Double model = @@ -63,9 +53,9 @@ timeoutPid <- liftSimulation newProcessId ackPid <- liftSimulation newProcessId -- set up the timeout - liftEvent $ runProcess timeoutPid (timeout ackPid) + liftEvent $ runProcessUsingId timeoutPid (timeout ackPid) -- set up the message send/ACK - liftEvent $ runProcess ackPid (acknowledge timeoutPid) + liftEvent $ runProcessUsingId ackPid (acknowledge timeoutPid) passivateProcess liftEvent $ do code <- readRef reactivatedCode @@ -80,18 +70,20 @@ liftEvent $ do writeRef reactivatedCode 1 reactivateProcess nodePid - cancelProcess ackPid + cancelProcessUsingId ackPid acknowledge :: ProcessId -> Process () acknowledge timeoutPid = - do ackTime <- liftIO $ exprnd ackRate + do ackTime <- + liftParameter $ + randomExponential (1 / ackRate) holdProcess ackTime liftEvent $ do writeRef reactivatedCode 2 reactivateProcess nodePid - cancelProcess timeoutPid + cancelProcessUsingId timeoutPid - runProcessInStartTime IncludingCurrentEvents + runProcessInStartTimeUsingId IncludingCurrentEvents nodePid node runEventInStopTime IncludingCurrentEvents $ diff --git a/examples/TimeOutInt.hs b/examples/TimeOutInt.hs --- a/examples/TimeOutInt.hs +++ b/examples/TimeOutInt.hs @@ -16,16 +16,10 @@ -- We find the proportion of messages which timeout. The output should -- be about 0.61. -import System.Random import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Ref -import Simulation.Aivika.Process +import Simulation.Aivika ackRate = 1.0 / 1.0 -- reciprocal of the acknowledge mean time toPeriod = 0.5 -- timeout period @@ -33,12 +27,8 @@ specs = Specs { spcStartTime = 0.0, spcStopTime = 10000.0, spcDT = 1.0, - spcMethod = RungeKutta4 } - -exprnd :: Double -> IO Double -exprnd lambda = - do x <- getStdRandom random - return (- log x / lambda) + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } model :: Simulation Double model = @@ -47,7 +37,7 @@ -- number of timeouts which have occured nTimeOuts <- newRef 0 - + nodePid <- newProcessId let node :: Process () @@ -56,15 +46,17 @@ -- create the process ID timeoutPid <- liftSimulation newProcessId -- set up the timeout - liftEvent $ runProcess timeoutPid timeout + liftEvent $ runProcessUsingId timeoutPid timeout -- wait for ACK, but could be timeout - ackTime <- liftIO $ exprnd ackRate + ackTime <- + liftParameter $ + randomExponential (1 / ackRate) holdProcess ackTime liftEvent $ do interrupted <- processInterrupted nodePid if interrupted then modifyRef nTimeOuts $ (+) 1 - else cancelProcess timeoutPid + else cancelProcessUsingId timeoutPid node timeout :: Process () @@ -72,7 +64,7 @@ do holdProcess toPeriod liftEvent $ interruptProcess nodePid - runProcessInStartTime IncludingCurrentEvents + runProcessInStartTimeUsingId IncludingCurrentEvents nodePid node runEventInStopTime IncludingCurrentEvents $