diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,15 @@ +Version 4.3 +----- + +* Added optimised queues which have no counters nor signals. + +* Added assembling functions for streams. + +* Added the operation activity as a simplification of server. + +* Added new functions for the queues. + Version 4.2 ----- diff --git a/Simulation/Aivika.hs b/Simulation/Aivika.hs --- a/Simulation/Aivika.hs +++ b/Simulation/Aivika.hs @@ -27,6 +27,8 @@ module Simulation.Aivika.Generator, module Simulation.Aivika.Net, module Simulation.Aivika.Net.Random, + module Simulation.Aivika.Operation, + module Simulation.Aivika.Operation.Random, module Simulation.Aivika.Parameter, module Simulation.Aivika.Parameter.Random, module Simulation.Aivika.Process, @@ -70,6 +72,8 @@ import Simulation.Aivika.Generator import Simulation.Aivika.Net import Simulation.Aivika.Net.Random +import Simulation.Aivika.Operation +import Simulation.Aivika.Operation.Random import Simulation.Aivika.Parameter import Simulation.Aivika.Parameter.Random import Simulation.Aivika.Process diff --git a/Simulation/Aivika/Activity.hs b/Simulation/Aivika/Activity.hs --- a/Simulation/Aivika/Activity.hs +++ b/Simulation/Aivika/Activity.hs @@ -155,7 +155,7 @@ -- old state and input -> s -- ^ the initial state - -> Simulation (Activity s a b) + -> Simulation (Activity s a b) newPreemptibleStateActivity preemptible provide state = do r0 <- liftIO $ newIORef state r1 <- liftIO $ newIORef 0 @@ -554,7 +554,7 @@ showString "preemption factor (from 0 to 1) = " . shows xf3 . showString "\n" . showString tab . - showString "utilisation time (locked while awaiting the input):\n\n" . + showString "utilisation time:\n\n" . samplingStatsSummary xs1 (2 + indent) . showString "\n\n" . showString tab . diff --git a/Simulation/Aivika/DoubleLinkedList.hs b/Simulation/Aivika/DoubleLinkedList.hs --- a/Simulation/Aivika/DoubleLinkedList.hs +++ b/Simulation/Aivika/DoubleLinkedList.hs @@ -20,6 +20,8 @@ listRemoveLast, listRemove, listRemoveBy, + listContains, + listContainsBy, listFirst, listLast) where @@ -207,3 +209,19 @@ do writeIORef (itemNext prev') (Just next') writeIORef (itemPrev next') (Just prev') return (Just $ itemVal item) + +-- | Detect whether the specified element is contained in the list. +listContains :: Eq a => DoubleLinkedList a -> a -> IO Bool +listContains x v = fmap isJust $ listContainsBy x (== v) + +-- | Detect whether an element satisfying the specified predicate is contained in the list. +listContainsBy :: DoubleLinkedList a -> (a -> Bool) -> IO (Maybe a) +listContainsBy x p = readIORef (listHead x) >>= loop + where loop item = + case item of + Nothing -> return Nothing + Just item -> + do let f = p (itemVal item) + if not f + then readIORef (itemNext item) >>= loop + else return $ Just (itemVal item) diff --git a/Simulation/Aivika/Operation.hs b/Simulation/Aivika/Operation.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Operation.hs @@ -0,0 +1,383 @@ + +-- | +-- Module : Simulation.Aivika.Operation +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.10.1 +-- +-- It defines a stateless activity, some simplification of 'Server' and 'Activity'. +module Simulation.Aivika.Operation + (-- * Operation + Operation, + newOperation, + newPreemptibleOperation, + -- * Processing + operationProcess, + -- * Operation Properties + operationTotalUtilisationTime, + operationTotalPreemptionTime, + operationUtilisationTime, + operationPreemptionTime, + operationUtilisationFactor, + operationPreemptionFactor, + -- * Summary + operationSummary, + -- * Derived Signals for Properties + operationTotalUtilisationTimeChanged, + operationTotalUtilisationTimeChanged_, + operationTotalPreemptionTimeChanged, + operationTotalPreemptionTimeChanged_, + operationUtilisationTimeChanged, + operationUtilisationTimeChanged_, + operationPreemptionTimeChanged, + operationPreemptionTimeChanged_, + operationUtilisationFactorChanged, + operationUtilisationFactorChanged_, + operationPreemptionFactorChanged, + operationPreemptionFactorChanged_, + -- * Basic Signals + operationUtilising, + operationUtilised, + operationPreemptionBeginning, + operationPreemptionEnding, + -- * Overall Signal + operationChanged_) where + +import Data.IORef +import Data.Monoid + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Internal.Event +import Simulation.Aivika.Signal +import Simulation.Aivika.Cont +import Simulation.Aivika.Process +import Simulation.Aivika.Activity +import Simulation.Aivika.Server +import Simulation.Aivika.Statistics + +-- | Like 'Server' it models an activity that takes @a@ and provides @b@. +-- But unlike the former this kind of activity has no state. Also it is destined +-- to be used within 'Process' computations. +data Operation a b = + Operation { operationInitProcess :: a -> Process b, + -- ^ Provide @b@ by specified @a@. + operationProcessPreemptible :: Bool, + -- ^ Whether the process is preemptible. + operationStartTime :: Double, + -- ^ The start time of creating the operation. + operationLastTimeRef :: IORef Double, + -- ^ The last time of utilising the operation activity. + operationTotalUtilisationTimeRef :: IORef Double, + -- ^ The counted total time of utilising the activity. + operationTotalPreemptionTimeRef :: IORef Double, + -- ^ The counted total time when the activity was preempted. + operationUtilisationTimeRef :: IORef (SamplingStats Double), + -- ^ The statistics for the utilisation time. + operationPreemptionTimeRef :: IORef (SamplingStats Double), + -- ^ The statistics for the time when the activity was preempted. + operationUtilisingSource :: SignalSource a, + -- ^ A signal raised when starting to utilise the activity. + operationUtilisedSource :: SignalSource (a, b), + -- ^ A signal raised when the activity has been utilised. + operationPreemptionBeginningSource :: SignalSource a, + -- ^ A signal raised when the utilisation was preempted. + operationPreemptionEndingSource :: SignalSource a + -- ^ A signal raised when the utilisation was proceeded after it had been preempted earlier. + } + +-- | Create a new operation that can provide output @b@ by input @a@. +-- +-- By default, it is assumed that the activity utilisation cannot be preempted, +-- because the handling of possible task preemption is rather costly +-- operation. +newOperation :: (a -> Process b) + -- ^ provide an output by the specified input + -> Event (Operation a b) +newOperation = newPreemptibleOperation False + +-- | Create a new operation that can provide output @b@ by input @a@. +newPreemptibleOperation :: Bool + -- ^ whether the activity can be preempted + -> (a -> Process b) + -- ^ provide an output by the specified input + -> Event (Operation a b) +newPreemptibleOperation preemptible provide = + do t0 <- liftDynamics time + r0 <- liftIO $ newIORef t0 + r1 <- liftIO $ newIORef 0 + r2 <- liftIO $ newIORef 0 + r3 <- liftIO $ newIORef emptySamplingStats + r4 <- liftIO $ newIORef emptySamplingStats + s1 <- liftSimulation newSignalSource + s2 <- liftSimulation newSignalSource + s3 <- liftSimulation newSignalSource + s4 <- liftSimulation newSignalSource + return Operation { operationInitProcess = provide, + operationProcessPreemptible = preemptible, + operationStartTime = t0, + operationLastTimeRef = r0, + operationTotalUtilisationTimeRef = r1, + operationTotalPreemptionTimeRef = r2, + operationUtilisationTimeRef = r3, + operationPreemptionTimeRef = r4, + operationUtilisingSource = s1, + operationUtilisedSource = s2, + operationPreemptionBeginningSource = s3, + operationPreemptionEndingSource = s4 } + +-- | Return a computation for the specified operation. It updates internal counters. +-- +-- The computation can be used only within one process at any time. +operationProcess :: Operation a b -> a -> Process b +operationProcess op a = + do t0 <- liftDynamics time + liftEvent $ + triggerSignal (operationUtilisingSource op) a + -- utilise the activity + (b, dt) <- if operationProcessPreemptible op + then operationProcessPreempting op a + else do b <- operationInitProcess op a + return (b, 0) + t1 <- liftDynamics time + liftEvent $ + do liftIO $ + do modifyIORef' (operationTotalUtilisationTimeRef op) (+ (t1 - t0 - dt)) + modifyIORef' (operationUtilisationTimeRef op) $ + addSamplingStats (t1 - t0 - dt) + writeIORef (operationLastTimeRef op) t1 + triggerSignal (operationUtilisedSource op) (a, b) + return b + +-- | Process the input with ability to handle a possible preemption. +operationProcessPreempting :: Operation a b -> a -> Process (b, Double) +operationProcessPreempting op a = + do pid <- processId + t0 <- liftDynamics time + rs <- liftIO $ newIORef 0 + r0 <- liftIO $ newIORef t0 + h1 <- liftEvent $ + handleSignal (processPreemptionBeginning pid) $ \() -> + do t0 <- liftDynamics time + liftIO $ writeIORef r0 t0 + triggerSignal (operationPreemptionBeginningSource op) a + h2 <- liftEvent $ + handleSignal (processPreemptionEnding pid) $ \() -> + do t0 <- liftIO $ readIORef r0 + t1 <- liftDynamics time + let dt = t1 - t0 + liftIO $ + do modifyIORef' rs (+ dt) + modifyIORef' (operationTotalPreemptionTimeRef op) (+ dt) + modifyIORef' (operationPreemptionTimeRef op) $ + addSamplingStats dt + writeIORef (operationLastTimeRef op) t1 + triggerSignal (operationPreemptionEndingSource op) a + let m1 = + do b <- operationInitProcess op a + dt <- liftIO $ readIORef rs + return (b, dt) + m2 = + liftEvent $ + do disposeEvent h1 + disposeEvent h2 + finallyProcess m1 m2 + +-- | Return the counted total time when the operation activity was utilised. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'operationTotalUtilisationTimeChanged' and 'operationTotalUtilisationTimeChanged_'. +operationTotalUtilisationTime :: Operation a b -> Event Double +operationTotalUtilisationTime op = + Event $ \p -> readIORef (operationTotalUtilisationTimeRef op) + +-- | Signal when the 'operationTotalUtilisationTime' property value has changed. +operationTotalUtilisationTimeChanged :: Operation a b -> Signal Double +operationTotalUtilisationTimeChanged op = + mapSignalM (const $ operationTotalUtilisationTime op) (operationTotalUtilisationTimeChanged_ op) + +-- | Signal when the 'operationTotalUtilisationTime' property value has changed. +operationTotalUtilisationTimeChanged_ :: Operation a b -> Signal () +operationTotalUtilisationTimeChanged_ op = + mapSignal (const ()) (operationUtilised op) + +-- | Return the counted total time when the operation activity was preemted waiting for +-- the further proceeding. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'operationTotalPreemptionTimeChanged' and 'operationTotalPreemptionTimeChanged_'. +operationTotalPreemptionTime :: Operation a b -> Event Double +operationTotalPreemptionTime op = + Event $ \p -> readIORef (operationTotalPreemptionTimeRef op) + +-- | Signal when the 'operationTotalPreemptionTime' property value has changed. +operationTotalPreemptionTimeChanged :: Operation a b -> Signal Double +operationTotalPreemptionTimeChanged op = + mapSignalM (const $ operationTotalPreemptionTime op) (operationTotalPreemptionTimeChanged_ op) + +-- | Signal when the 'operationTotalPreemptionTime' property value has changed. +operationTotalPreemptionTimeChanged_ :: Operation a b -> Signal () +operationTotalPreemptionTimeChanged_ op = + mapSignal (const ()) (operationPreemptionEnding op) + +-- | Return the statistics for the time when the operation activity was utilised. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'operationUtilisationTimeChanged' and 'operationUtilisationTimeChanged_'. +operationUtilisationTime :: Operation a b -> Event (SamplingStats Double) +operationUtilisationTime op = + Event $ \p -> readIORef (operationUtilisationTimeRef op) + +-- | Signal when the 'operationUtilisationTime' property value has changed. +operationUtilisationTimeChanged :: Operation a b -> Signal (SamplingStats Double) +operationUtilisationTimeChanged op = + mapSignalM (const $ operationUtilisationTime op) (operationUtilisationTimeChanged_ op) + +-- | Signal when the 'operationUtilisationTime' property value has changed. +operationUtilisationTimeChanged_ :: Operation a b -> Signal () +operationUtilisationTimeChanged_ op = + mapSignal (const ()) (operationUtilised op) + +-- | Return the statistics for the time when the operation activity was preempted +-- waiting for the further proceeding. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'operationPreemptionTimeChanged' and 'operationPreemptionTimeChanged_'. +operationPreemptionTime :: Operation a b -> Event (SamplingStats Double) +operationPreemptionTime op = + Event $ \p -> readIORef (operationPreemptionTimeRef op) + +-- | Signal when the 'operationPreemptionTime' property value has changed. +operationPreemptionTimeChanged :: Operation a b -> Signal (SamplingStats Double) +operationPreemptionTimeChanged op = + mapSignalM (const $ operationPreemptionTime op) (operationPreemptionTimeChanged_ op) + +-- | Signal when the 'operationPreemptionTime' property value has changed. +operationPreemptionTimeChanged_ :: Operation a b -> Signal () +operationPreemptionTimeChanged_ op = + mapSignal (const ()) (operationPreemptionEnding op) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the operation activity was utilised since the time of creating the operation. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'operationUtilisationFactorChanged' and 'operationUtilisationFactorChanged_'. +operationUtilisationFactor :: Operation a b -> Event Double +operationUtilisationFactor op = + Event $ \p -> + do let t0 = operationStartTime op + t1 <- readIORef (operationLastTimeRef op) + x <- readIORef (operationTotalUtilisationTimeRef op) + return (x / (t1 - t0)) + +-- | Signal when the 'operationUtilisationFactor' property value has changed. +operationUtilisationFactorChanged :: Operation a b -> Signal Double +operationUtilisationFactorChanged op = + mapSignalM (const $ operationUtilisationFactor op) (operationUtilisationFactorChanged_ op) + +-- | Signal when the 'operationUtilisationFactor' property value has changed. +operationUtilisationFactorChanged_ :: Operation a b -> Signal () +operationUtilisationFactorChanged_ op = + mapSignal (const ()) (operationUtilised op) <> + mapSignal (const ()) (operationPreemptionEnding op) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the operation activity was preempted waiting for the further proceeding +-- since the time of creating the operation. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'operationPreemptionFactorChanged' and 'operationPreemptionFactorChanged_'. +operationPreemptionFactor :: Operation a b -> Event Double +operationPreemptionFactor op = + Event $ \p -> + do let t0 = operationStartTime op + t1 <- readIORef (operationLastTimeRef op) + x <- readIORef (operationTotalPreemptionTimeRef op) + return (x / (t1 - t0)) + +-- | Signal when the 'operationPreemptionFactor' property value has changed. +operationPreemptionFactorChanged :: Operation a b -> Signal Double +operationPreemptionFactorChanged op = + mapSignalM (const $ operationPreemptionFactor op) (operationPreemptionFactorChanged_ op) + +-- | Signal when the 'operationPreemptionFactor' property value has changed. +operationPreemptionFactorChanged_ :: Operation a b -> Signal () +operationPreemptionFactorChanged_ op = + mapSignal (const ()) (operationUtilised op) <> + mapSignal (const ()) (operationPreemptionEnding op) + +-- | Raised when starting to utilise the operation activity after a new input task is received. +operationUtilising :: Operation a b -> Signal a +operationUtilising = publishSignal . operationUtilisingSource + +-- | Raised when the operation activity has been utilised after the current task is processed. +operationUtilised :: Operation a b -> Signal (a, b) +operationUtilised = publishSignal . operationUtilisedSource + +-- | Raised when the operation activity utilisation was preempted. +operationPreemptionBeginning :: Operation a b -> Signal a +operationPreemptionBeginning = publishSignal . operationPreemptionBeginningSource + +-- | Raised when the operation activity utilisation was proceeded after it had been preempted earlier. +operationPreemptionEnding :: Operation a b -> Signal a +operationPreemptionEnding = publishSignal . operationPreemptionEndingSource + +-- | Signal whenever any property of the operation changes. +operationChanged_ :: Operation a b -> Signal () +operationChanged_ op = + mapSignal (const ()) (operationUtilising op) <> + mapSignal (const ()) (operationUtilised op) <> + mapSignal (const ()) (operationPreemptionEnding op) + +-- | Return the summary for the operation with desciption of its +-- properties using the specified indent. +operationSummary :: Operation a b -> Int -> Event ShowS +operationSummary op indent = + Event $ \p -> + do let t0 = operationStartTime op + t1 <- readIORef (operationLastTimeRef op) + tx1 <- readIORef (operationTotalUtilisationTimeRef op) + tx2 <- readIORef (operationTotalPreemptionTimeRef op) + let xf1 = tx1 / (t1 - t0) + xf2 = tx2 / (t1 - t0) + xs1 <- readIORef (operationUtilisationTimeRef op) + xs2 <- readIORef (operationPreemptionTimeRef op) + let tab = replicate indent ' ' + return $ + showString tab . + showString "total utilisation time = " . shows tx1 . + showString "\n" . + showString tab . + showString "total preemption time = " . shows tx2 . + showString "\n" . + showString tab . + showString "utilisation factor (from 0 to 1) = " . shows xf1 . + showString "\n" . + showString tab . + showString "preemption factor (from 0 to 1) = " . shows xf2 . + showString "\n" . + showString tab . + showString "utilisation time:\n\n" . + samplingStatsSummary xs1 (2 + indent) . + showString "\n\n" . + showString tab . + showString "preemption time:\n\n" . + samplingStatsSummary xs2 (2 + indent) diff --git a/Simulation/Aivika/Operation/Random.hs b/Simulation/Aivika/Operation/Random.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Operation/Random.hs @@ -0,0 +1,408 @@ + +-- | +-- Module : Simulation.Aivika.Operation.Random +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.10.1 +-- +-- This module defines some useful predefined operations that +-- hold the current process for the corresponding random time +-- interval, when processing every input element. +-- + +module Simulation.Aivika.Operation.Random + (newRandomUniformOperation, + newRandomUniformIntOperation, + newRandomTriangularOperation, + newRandomNormalOperation, + newRandomLogNormalOperation, + newRandomExponentialOperation, + newRandomErlangOperation, + newRandomPoissonOperation, + newRandomBinomialOperation, + newRandomGammaOperation, + newRandomBetaOperation, + newRandomWeibullOperation, + newRandomDiscreteOperation, + newPreemptibleRandomUniformOperation, + newPreemptibleRandomUniformIntOperation, + newPreemptibleRandomTriangularOperation, + newPreemptibleRandomNormalOperation, + newPreemptibleRandomLogNormalOperation, + newPreemptibleRandomExponentialOperation, + newPreemptibleRandomErlangOperation, + newPreemptibleRandomPoissonOperation, + newPreemptibleRandomBinomialOperation, + newPreemptibleRandomGammaOperation, + newPreemptibleRandomBetaOperation, + newPreemptibleRandomWeibullOperation, + newPreemptibleRandomDiscreteOperation) where + +import Simulation.Aivika.Generator +import Simulation.Aivika.Event +import Simulation.Aivika.Process +import Simulation.Aivika.Process.Random +import Simulation.Aivika.Operation + +-- | Create a new operation that holds the process for a random time interval +-- distributed uniformly, when processing every input element. +-- +-- By default, it is assumed that the operation process cannot be preempted, +-- because the handling of possible task preemption is rather costly. +newRandomUniformOperation :: Double + -- ^ the minimum time interval + -> Double + -- ^ the maximum time interval + -> Event (Operation a a) +newRandomUniformOperation = + newPreemptibleRandomUniformOperation False + +-- | Create a new operation that holds the process for a random time interval +-- distributed uniformly, when processing every input element. +-- +-- By default, it is assumed that the operation process cannot be preempted, +-- because the handling of possible task preemption is rather costly. +newRandomUniformIntOperation :: Int + -- ^ the minimum time interval + -> Int + -- ^ the maximum time interval + -> Event (Operation a a) +newRandomUniformIntOperation = + newPreemptibleRandomUniformIntOperation False + +-- | Create a new operation that holds the process for a random time interval +-- having the triangular distribution, when processing every input element. +-- +-- By default, it is assumed that the operation process cannot be preempted, +-- because the handling of possible task preemption is rather costly. +newRandomTriangularOperation :: Double + -- ^ the minimum time interval + -> Double + -- ^ the median of the time interval + -> Double + -- ^ the maximum time interval + -> Event (Operation a a) +newRandomTriangularOperation = + newPreemptibleRandomTriangularOperation False + +-- | Create a new operation that holds the process for a random time interval +-- distributed normally, when processing every input element. +-- +-- By default, it is assumed that the operation process cannot be preempted, +-- because the handling of possible task preemption is rather costly. +newRandomNormalOperation :: Double + -- ^ the mean time interval + -> Double + -- ^ the time interval deviation + -> Event (Operation a a) +newRandomNormalOperation = + newPreemptibleRandomNormalOperation False + +-- | Create a new operation that holds the process for a random time interval +-- having the lognormal distribution, when processing every input element. +-- +-- By default, it is assumed that the operation process cannot be preempted, +-- because the handling of possible task preemption is rather costly. +newRandomLogNormalOperation :: Double + -- ^ the mean of a normal distribution which + -- this distribution is derived from + -> Double + -- ^ the deviation of a normal distribution which + -- this distribution is derived from + -> Event (Operation a a) +newRandomLogNormalOperation = + newPreemptibleRandomLogNormalOperation False + +-- | Create a new operation that holds the process for a random time interval +-- distributed exponentially with the specified mean (the reciprocal of the rate), +-- when processing every input element. +-- +-- By default, it is assumed that the operation process cannot be preempted, +-- because the handling of possible task preemption is rather costly. +newRandomExponentialOperation :: Double + -- ^ the mean time interval (the reciprocal of the rate) + -> Event (Operation a a) +newRandomExponentialOperation = + newPreemptibleRandomExponentialOperation False + +-- | Create a new operation that holds the process for a random time interval +-- having the Erlang distribution with the specified scale (the reciprocal of the rate) +-- and shape parameters, when processing every input element. +-- +-- By default, it is assumed that the operation process cannot be preempted, +-- because the handling of possible task preemption is rather costly. +newRandomErlangOperation :: Double + -- ^ the scale (the reciprocal of the rate) + -> Int + -- ^ the shape + -> Event (Operation a a) +newRandomErlangOperation = + newPreemptibleRandomErlangOperation False + +-- | Create a new operation that holds the process for a random time interval +-- having the Poisson distribution with the specified mean, when processing +-- every input element. +-- +-- By default, it is assumed that the operation process cannot be preempted, +-- because the handling of possible task preemption is rather costly. +newRandomPoissonOperation :: Double + -- ^ the mean time interval + -> Event (Operation a a) +newRandomPoissonOperation = + newPreemptibleRandomPoissonOperation False + +-- | Create a new operation that holds the process for a random time interval +-- having the binomial distribution with the specified probability and trials, +-- when processing every input element. +-- +-- By default, it is assumed that the operation process cannot be preempted, +-- because the handling of possible task preemption is rather costly. +newRandomBinomialOperation :: Double + -- ^ the probability + -> Int + -- ^ the number of trials + -> Event (Operation a a) +newRandomBinomialOperation = + newPreemptibleRandomBinomialOperation False + +-- | Create a new operation that holds the process for a random time interval +-- having the Gamma distribution with the specified shape and scale, +-- when processing every input element. +-- +-- By default, it is assumed that the operation process cannot be preempted, +-- because the handling of possible task preemption is rather costly. +newRandomGammaOperation :: Double + -- ^ the shape + -> Double + -- ^ the scale (a reciprocal of the rate) + -> Event (Operation a a) +newRandomGammaOperation = + newPreemptibleRandomGammaOperation False + +-- | Create a new operation that holds the process for a random time interval +-- having the Beta distribution with the specified shape parameters (alpha and beta), +-- when processing every input element. +-- +-- By default, it is assumed that the operation process cannot be preempted, +-- because the handling of possible task preemption is rather costly. +newRandomBetaOperation :: Double + -- ^ shape (alpha) + -> Double + -- ^ shape (beta) + -> Event (Operation a a) +newRandomBetaOperation = + newPreemptibleRandomBetaOperation False + +-- | Create a new operation that holds the process for a random time interval +-- having the Weibull distribution with the specified shape and scale, +-- when processing every input element. +-- +-- By default, it is assumed that the operation process cannot be preempted, +-- because the handling of possible task preemption is rather costly. +newRandomWeibullOperation :: Double + -- ^ shape + -> Double + -- ^ scale + -> Event (Operation a a) +newRandomWeibullOperation = + newPreemptibleRandomWeibullOperation False + +-- | Create a new operation that holds the process for a random time interval +-- having the specified discrete distribution, when processing every input element. +-- +-- By default, it is assumed that the operation process cannot be preempted, +-- because the handling of possible task preemption is rather costly. +newRandomDiscreteOperation :: DiscretePDF Double + -- ^ the discrete probability density function + -> Event (Operation a a) +newRandomDiscreteOperation = + newPreemptibleRandomDiscreteOperation False + +-- | Create a new operation that holds the process for a random time interval +-- distributed uniformly, when processing every input element. +newPreemptibleRandomUniformOperation :: Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the minimum time interval + -> Double + -- ^ the maximum time interval + -> Event (Operation a a) +newPreemptibleRandomUniformOperation preemptible min max = + newPreemptibleOperation preemptible $ \a -> + do randomUniformProcess_ min max + return a + +-- | Create a new operation that holds the process for a random time interval +-- distributed uniformly, when processing every input element. +newPreemptibleRandomUniformIntOperation :: Bool + -- ^ whether the operation process can be preempted + -> Int + -- ^ the minimum time interval + -> Int + -- ^ the maximum time interval + -> Event (Operation a a) +newPreemptibleRandomUniformIntOperation preemptible min max = + newPreemptibleOperation preemptible $ \a -> + do randomUniformIntProcess_ min max + return a + +-- | Create a new operation that holds the process for a random time interval +-- having the triangular distribution, when processing every input element. +newPreemptibleRandomTriangularOperation :: Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the minimum time interval + -> Double + -- ^ the median of the time interval + -> Double + -- ^ the maximum time interval + -> Event (Operation a a) +newPreemptibleRandomTriangularOperation preemptible min median max = + newPreemptibleOperation preemptible $ \a -> + do randomTriangularProcess_ min median max + return a + +-- | Create a new operation that holds the process for a random time interval +-- distributed normally, when processing every input element. +newPreemptibleRandomNormalOperation :: Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the mean time interval + -> Double + -- ^ the time interval deviation + -> Event (Operation a a) +newPreemptibleRandomNormalOperation preemptible mu nu = + newPreemptibleOperation preemptible $ \a -> + do randomNormalProcess_ mu nu + return a + +-- | Create a new operation that holds the process for a random time interval +-- having the lognormal distribution, when processing every input element. +newPreemptibleRandomLogNormalOperation :: Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the mean of a normal distribution which + -- this distribution is derived from + -> Double + -- ^ the deviation of a normal distribution which + -- this distribution is derived from + -> Event (Operation a a) +newPreemptibleRandomLogNormalOperation preemptible mu nu = + newPreemptibleOperation preemptible $ \a -> + do randomLogNormalProcess_ mu nu + return a + +-- | Create a new operation that holds the process for a random time interval +-- distributed exponentially with the specified mean (the reciprocal of the rate), +-- when processing every input element. +newPreemptibleRandomExponentialOperation :: Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the mean time interval (the reciprocal of the rate) + -> Event (Operation a a) +newPreemptibleRandomExponentialOperation preemptible mu = + newPreemptibleOperation preemptible $ \a -> + do randomExponentialProcess_ mu + return a + +-- | Create a new operation that holds the process for a random time interval +-- having the Erlang distribution with the specified scale (the reciprocal of the rate) +-- and shape parameters, when processing every input element. +newPreemptibleRandomErlangOperation :: Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the scale (the reciprocal of the rate) + -> Int + -- ^ the shape + -> Event (Operation a a) +newPreemptibleRandomErlangOperation preemptible beta m = + newPreemptibleOperation preemptible $ \a -> + do randomErlangProcess_ beta m + return a + +-- | Create a new operation that holds the process for a random time interval +-- having the Poisson distribution with the specified mean, when processing +-- every input element. +newPreemptibleRandomPoissonOperation :: Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the mean time interval + -> Event (Operation a a) +newPreemptibleRandomPoissonOperation preemptible mu = + newPreemptibleOperation preemptible $ \a -> + do randomPoissonProcess_ mu + return a + +-- | Create a new operation that holds the process for a random time interval +-- having the binomial distribution with the specified probability and trials, +-- when processing every input element. +newPreemptibleRandomBinomialOperation :: Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the probability + -> Int + -- ^ the number of trials + -> Event (Operation a a) +newPreemptibleRandomBinomialOperation preemptible prob trials = + newPreemptibleOperation preemptible $ \a -> + do randomBinomialProcess_ prob trials + return a + +-- | Create a new operation that holds the process for a random time interval +-- having the Gamma distribution with the specified shape and scale, +-- when processing every input element. +newPreemptibleRandomGammaOperation :: Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the shape + -> Double + -- ^ the scale + -> Event (Operation a a) +newPreemptibleRandomGammaOperation preemptible kappa theta = + newPreemptibleOperation preemptible $ \a -> + do randomGammaProcess_ kappa theta + return a + +-- | Create a new operation that holds the process for a random time interval +-- having the Beta distribution with the specified shape parameters (alpha and beta), +-- when processing every input element. +newPreemptibleRandomBetaOperation :: Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ shape (alpha) + -> Double + -- ^ shape (beta) + -> Event (Operation a a) +newPreemptibleRandomBetaOperation preemptible alpha beta = + newPreemptibleOperation preemptible $ \a -> + do randomBetaProcess_ alpha beta + return a + +-- | Create a new operation that holds the process for a random time interval +-- having the Weibull distribution with the specified shape and scale, +-- when processing every input element. +newPreemptibleRandomWeibullOperation :: Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ shape + -> Double + -- ^ scale + -> Event (Operation a a) +newPreemptibleRandomWeibullOperation preemptible alpha beta = + newPreemptibleOperation preemptible $ \a -> + do randomWeibullProcess_ alpha beta + return a + +-- | Create a new operation that holds the process for a random time interval +-- having the specified discrete distribution, when processing every input element. +newPreemptibleRandomDiscreteOperation :: Bool + -- ^ whether the operation process can be preempted + -> DiscretePDF Double + -- ^ the discrete probability density function + -> Event (Operation a a) +newPreemptibleRandomDiscreteOperation preemptible dpdf = + newPreemptibleOperation preemptible $ \a -> + do randomDiscreteProcess_ dpdf + return a diff --git a/Simulation/Aivika/PriorityQueue.hs b/Simulation/Aivika/PriorityQueue.hs --- a/Simulation/Aivika/PriorityQueue.hs +++ b/Simulation/Aivika/PriorityQueue.hs @@ -21,6 +21,8 @@ queueFront, queueDelete, queueDeleteBy, + queueContains, + queueContainsBy, remove, removeBy) where @@ -203,6 +205,24 @@ writeArray vals i v0 when (i > 0) $ siftDown keys vals i index k v + return (Just x) + +-- | Detect whether the specified element is contained in the queue. +-- +-- Note that unlike other functions it has complexity O(n). +queueContains :: Eq a => PriorityQueue a -> a -> IO Bool +queueContains pq a = fmap isJust $ queueContainsBy pq (== a) + +-- | Detect whether an element satisfying the predicate is contained in the queue. +-- +-- Note that unlike other functions it has complexity O(n). +queueContainsBy :: PriorityQueue a -> (a -> Bool) -> IO (Maybe a) +queueContainsBy pq pred = + do index <- queueIndexBy pq pred + if index < 0 + then return Nothing + else do vals <- readIORef (pqVals pq) + x <- readArray vals index return (Just x) -- | Return the index of the item satisfying the predicate or -1. diff --git a/Simulation/Aivika/Processor.hs b/Simulation/Aivika/Processor.hs --- a/Simulation/Aivika/Processor.hs +++ b/Simulation/Aivika/Processor.hs @@ -141,12 +141,7 @@ -- | Accumulator that outputs a value determined by the supplied function. accumProcessor :: (acc -> a -> Process (acc, b)) -> acc -> Processor a b -accumProcessor f acc = - Processor $ \xs -> Cons $ loop xs acc where - loop xs acc = - do (a, xs') <- runStream xs - (acc', b) <- f acc a - return (b, Cons $ loop xs' acc') +accumProcessor f acc = Processor $ accumStream f acc -- | Involve the computation with side effect when processing a stream of data. withinProcessor :: Process () -> Processor a a diff --git a/Simulation/Aivika/Processor/RoundRobbin.hs b/Simulation/Aivika/Processor/RoundRobbin.hs --- a/Simulation/Aivika/Processor/RoundRobbin.hs +++ b/Simulation/Aivika/Processor/RoundRobbin.hs @@ -20,7 +20,7 @@ import Simulation.Aivika.Process import Simulation.Aivika.Processor import Simulation.Aivika.Stream -import Simulation.Aivika.Queue.Infinite +import Simulation.Aivika.Queue.Infinite.Base -- | 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 @@ -41,7 +41,7 @@ roundRobbinProcessorUsingIds = Processor $ \xs -> Cons $ - do q <- liftEvent newFCFSQueue + do q <- liftSimulation newFCFSQueue let process = do t@(x, p) <- dequeue q (timeout, pid) <- x diff --git a/Simulation/Aivika/Queue.hs b/Simulation/Aivika/Queue.hs --- a/Simulation/Aivika/Queue.hs +++ b/Simulation/Aivika/Queue.hs @@ -67,6 +67,8 @@ queueDelete_, queueDeleteBy, queueDeleteBy_, + queueContains, + queueContainsBy, clearQueue, -- * Awaiting waitWhileFullQueue, @@ -671,6 +673,31 @@ -- ^ the predicate -> Event () queueDeleteBy_ q pred = fmap (const ()) $ queueDeleteBy q pred + +-- | Detect whether the item is contained in the queue. +queueContains :: (Eq a, + DeletingQueueStrategy sm) + => Queue si sm so a + -- ^ the queue + -> a + -- ^ the item to search the queue for + -> Event Bool + -- ^ whether the item was found +queueContains q a = fmap isJust $ queueContainsBy q (== a) + +-- | Detect whether an item satisfying the specified predicate is contained in the queue. +queueContainsBy :: DeletingQueueStrategy sm + => Queue si sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event (Maybe a) + -- ^ the item if it was found +queueContainsBy q pred = + do x <- strategyQueueContainsBy (queueStore q) (pred . itemValue) + case x of + Nothing -> return Nothing + Just i -> return $ Just (itemValue i) -- | Clear the queue immediately. clearQueue :: (DequeueStrategy si, diff --git a/Simulation/Aivika/Queue/Base.hs b/Simulation/Aivika/Queue/Base.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Queue/Base.hs @@ -0,0 +1,463 @@ + +-- | +-- Module : Simulation.Aivika.Queue.Base +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.10.1 +-- +-- This module defines an optimised finite queue, which has no counters nor signals. +-- +module Simulation.Aivika.Queue.Base + (-- * Queue Types + FCFSQueue, + LCFSQueue, + SIROQueue, + PriorityQueue, + Queue, + -- * Creating Queue + newFCFSQueue, + newLCFSQueue, + newSIROQueue, + newPriorityQueue, + newQueue, + -- * Queue Properties and Activities + enqueueStrategy, + enqueueStoringStrategy, + dequeueStrategy, + queueNull, + queueFull, + queueMaxCount, + queueCount, + -- * Dequeuing and Enqueuing + dequeue, + dequeueWithOutputPriority, + tryDequeue, + enqueue, + enqueueWithInputPriority, + enqueueWithStoringPriority, + enqueueWithInputStoringPriorities, + tryEnqueue, + tryEnqueueWithStoringPriority, + queueDelete, + queueDelete_, + queueDeleteBy, + queueDeleteBy_, + queueContains, + queueContainsBy, + clearQueue) where + +import Data.IORef +import Data.Monoid +import Data.Maybe + +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.Resource.Base +import Simulation.Aivika.QueueStrategy + +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 FCFS FCFS a + +-- | A type synonym for the ordinary LIFO queue also known as the LCFS +-- (Last Come - First Serviced) queue. +type LCFSQueue a = Queue FCFS LCFS FCFS a + +-- | A type synonym for the SIRO (Serviced in Random Order) queue. +type SIROQueue a = Queue FCFS SIRO FCFS a + +-- | A type synonym for the queue with static priorities applied when +-- storing the elements in the queue. +type PriorityQueue a = Queue FCFS StaticPriorities FCFS a + +-- | Represents a queue using the specified strategies for enqueueing (input), @si@, +-- internal storing (in memory), @sm@, and dequeueing (output), @so@, where @a@ denotes +-- the type of items stored in the queue. +data Queue si sm so a = + Queue { queueMaxCount :: Int, + -- ^ The queue capacity. + enqueueStrategy :: si, + -- ^ The strategy applied to the enqueueing (input) processes when the queue is full. + enqueueStoringStrategy :: sm, + -- ^ The strategy applied when storing (in memory) items in the queue. + dequeueStrategy :: so, + -- ^ The strategy applied to the dequeueing (output) processes when the queue is empty. + enqueueRes :: Resource si, + queueStore :: StrategyQueue sm a, + dequeueRes :: Resource so, + queueCountRef :: IORef Int + } + +-- | 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, + QueueStrategy sm, + QueueStrategy so) => + si + -- ^ the strategy applied to the enqueueing (input) processes when the queue is full + -> sm + -- ^ the strategy applied when storing items in the queue + -> so + -- ^ the strategy applied to the dequeueing (output) processes when the queue is empty + -> Int + -- ^ the queue capacity + -> Simulation (Queue si sm so a) +newQueue si sm so count = + do i <- liftIO $ newIORef 0 + ri <- newResourceWithMaxCount si count (Just count) + qm <- newStrategyQueue sm + ro <- newResourceWithMaxCount so 0 (Just count) + return Queue { queueMaxCount = count, + enqueueStrategy = si, + enqueueStoringStrategy = sm, + dequeueStrategy = so, + enqueueRes = ri, + queueStore = qm, + dequeueRes = ro, + queueCountRef = i } + +-- | Test whether the queue is empty. +-- +-- See also 'queueNullChanged' and 'queueNullChanged_'. +queueNull :: Queue si sm so a -> Event Bool +queueNull q = + Event $ \p -> + do n <- readIORef (queueCountRef q) + return (n == 0) + +-- | Test whether the queue is full. +-- +-- See also 'queueFullChanged' and 'queueFullChanged_'. +queueFull :: Queue si sm so a -> Event Bool +queueFull q = + Event $ \p -> + do n <- readIORef (queueCountRef q) + return (n == queueMaxCount q) + +-- | Return the current queue size. +-- +-- See also 'queueCountStats', 'queueCountChanged' and 'queueCountChanged_'. +queueCount :: Queue si sm so a -> Event Int +queueCount q = + Event $ \p -> readIORef (queueCountRef q) + +-- | Dequeue suspending the process if the queue is empty. +dequeue :: (DequeueStrategy si, + DequeueStrategy sm, + EnqueueStrategy so) + => Queue si sm so a + -- ^ the queue + -> Process a + -- ^ the dequeued value +dequeue q = + do requestResource (dequeueRes q) + liftEvent $ dequeueExtract q + +-- | Dequeue with the output priority suspending the process if the queue is empty. +dequeueWithOutputPriority :: (DequeueStrategy si, + DequeueStrategy sm, + PriorityQueueStrategy so po) + => Queue si sm so a + -- ^ the queue + -> po + -- ^ the priority for output + -> Process a + -- ^ the dequeued value +dequeueWithOutputPriority q po = + do requestResourceWithPriority (dequeueRes q) po + liftEvent $ dequeueExtract q + +-- | Try to dequeue immediately. +tryDequeue :: (DequeueStrategy si, + DequeueStrategy sm) + => Queue si sm so a + -- ^ the queue + -> Event (Maybe a) + -- ^ the dequeued value of 'Nothing' +tryDequeue q = + do x <- tryRequestResourceWithinEvent (dequeueRes q) + if x + then fmap Just $ dequeueExtract q + else return Nothing + +-- | Remove the item from the queue and return a flag indicating +-- whether the item was found and actually removed. +queueDelete :: (Eq a, + DequeueStrategy si, + DeletingQueueStrategy sm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> a + -- ^ the item to remove from the queue + -> Event Bool + -- ^ whether the item was found and removed +queueDelete q a = fmap isJust $ queueDeleteBy q (== a) + +-- | Remove the specified item from the queue. +queueDelete_ :: (Eq a, + DequeueStrategy si, + DeletingQueueStrategy sm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> a + -- ^ the item to remove from the queue + -> Event () +queueDelete_ q a = fmap (const ()) $ queueDeleteBy q (== a) + +-- | Remove an item satisfying the specified predicate and return the item if found. +queueDeleteBy :: (DequeueStrategy si, + DeletingQueueStrategy sm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event (Maybe a) +queueDeleteBy q pred = + do x <- tryRequestResourceWithinEvent (dequeueRes q) + if x + then do i <- strategyQueueDeleteBy (queueStore q) pred + case i of + Nothing -> + do releaseResourceWithinEvent (dequeueRes q) + return Nothing + Just i -> + fmap Just $ dequeuePostExtract q i + else return Nothing + +-- | Remove an item satisfying the specified predicate. +queueDeleteBy_ :: (DequeueStrategy si, + DeletingQueueStrategy sm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event () +queueDeleteBy_ q pred = fmap (const ()) $ queueDeleteBy q pred + +-- | Detect whether the item is contained in the queue. +queueContains :: (Eq a, + DeletingQueueStrategy sm) + => Queue si sm so a + -- ^ the queue + -> a + -- ^ the item to search the queue for + -> Event Bool + -- ^ whether the item was found +queueContains q a = fmap isJust $ queueContainsBy q (== a) + +-- | Detect whether an item satisfying the specified predicate is contained in the queue. +queueContainsBy :: DeletingQueueStrategy sm + => Queue si sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event (Maybe a) + -- ^ the item if it was found +queueContainsBy q pred = + strategyQueueContainsBy (queueStore q) pred + +-- | Clear the queue immediately. +clearQueue :: (DequeueStrategy si, + DequeueStrategy sm) + => Queue si sm so a + -- ^ the queue + -> Event () +clearQueue q = + do x <- tryDequeue q + case x of + Nothing -> return () + Just a -> clearQueue q + +-- | Enqueue the item suspending the process if the queue is full. +enqueue :: (EnqueueStrategy si, + EnqueueStrategy sm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> a + -- ^ the item to enqueue + -> Process () +enqueue q a = + do requestResource (enqueueRes q) + liftEvent $ enqueueStore q a + +-- | Enqueue with the input priority the item suspending the process if the queue is full. +enqueueWithInputPriority :: (PriorityQueueStrategy si pi, + EnqueueStrategy sm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> pi + -- ^ the priority for input + -> a + -- ^ the item to enqueue + -> Process () +enqueueWithInputPriority q pi a = + do requestResourceWithPriority (enqueueRes q) pi + liftEvent $ enqueueStore q a + +-- | Enqueue with the storing priority the item suspending the process if the queue is full. +enqueueWithStoringPriority :: (EnqueueStrategy si, + PriorityQueueStrategy sm pm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to enqueue + -> Process () +enqueueWithStoringPriority q pm a = + do requestResource (enqueueRes q) + liftEvent $ enqueueStoreWithPriority q pm a + +-- | Enqueue with the input and storing priorities the item suspending the process if the queue is full. +enqueueWithInputStoringPriorities :: (PriorityQueueStrategy si pi, + PriorityQueueStrategy sm pm, + DequeueStrategy so) + => Queue si sm so 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 requestResourceWithPriority (enqueueRes q) pi + liftEvent $ enqueueStoreWithPriority q pm a + +-- | Try to enqueue the item. Return 'False' in the monad if the queue is full. +tryEnqueue :: (EnqueueStrategy sm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> a + -- ^ the item which we try to enqueue + -> Event Bool +tryEnqueue q a = + do x <- tryRequestResourceWithinEvent (enqueueRes q) + if x + then do enqueueStore q a + 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 pm, + DequeueStrategy so) + => Queue si sm so 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 (enqueueRes q) + if x + then do enqueueStoreWithPriority q pm a + return True + else return False + +-- | Store the item. +enqueueStore :: (EnqueueStrategy sm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> a + -- ^ the item to be stored + -> Event () +enqueueStore q a = + Event $ \p -> + do invokeEvent p $ + strategyEnqueue (queueStore q) a + c <- readIORef (queueCountRef q) + let c' = c + 1 + c' `seq` writeIORef (queueCountRef q) c' + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + +-- | Store with the priority the item. +enqueueStoreWithPriority :: (PriorityQueueStrategy sm pm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to be enqueued + -> Event () +enqueueStoreWithPriority q pm a = + Event $ \p -> + do invokeEvent p $ + strategyEnqueueWithPriority (queueStore q) pm a + c <- readIORef (queueCountRef q) + let c' = c + 1 + c' `seq` writeIORef (queueCountRef q) c' + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + +-- | Extract an item for the dequeuing request. +dequeueExtract :: (DequeueStrategy si, + DequeueStrategy sm) + => Queue si sm so a + -- ^ the queue + -> Event a + -- ^ the dequeued value +dequeueExtract q = + Event $ \p -> + do a <- invokeEvent p $ + strategyDequeue (queueStore q) + invokeEvent p $ + dequeuePostExtract q a + +-- | A post action after extracting the item by the dequeuing request. +dequeuePostExtract :: (DequeueStrategy si, + DequeueStrategy sm) + => Queue si sm so a + -- ^ the queue + -> a + -- ^ the item to dequeue + -> Event a + -- ^ the dequeued value +dequeuePostExtract q a = + Event $ \p -> + do c <- readIORef (queueCountRef q) + let c' = c - 1 + c' `seq` writeIORef (queueCountRef q) c' + invokeEvent p $ + releaseResourceWithinEvent (enqueueRes q) + return a diff --git a/Simulation/Aivika/Queue/Infinite.hs b/Simulation/Aivika/Queue/Infinite.hs --- a/Simulation/Aivika/Queue/Infinite.hs +++ b/Simulation/Aivika/Queue/Infinite.hs @@ -47,6 +47,8 @@ queueDelete_, queueDeleteBy, queueDeleteBy_, + queueContains, + queueContainsBy, clearQueue, -- * Summary queueSummary, @@ -468,6 +470,31 @@ -- ^ the predicate -> Event () queueDeleteBy_ q pred = fmap (const ()) $ queueDeleteBy q pred + +-- | Detect whether the item is contained in the queue. +queueContains :: (Eq a, + DeletingQueueStrategy sm) + => Queue sm so a + -- ^ the queue + -> a + -- ^ the item to search the queue for + -> Event Bool + -- ^ whether the item was found +queueContains q a = fmap isJust $ queueContainsBy q (== a) + +-- | Detect whether an item satisfying the specified predicate is contained in the queue. +queueContainsBy :: DeletingQueueStrategy sm + => Queue sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event (Maybe a) + -- ^ the item if it was found +queueContainsBy q pred = + do x <- strategyQueueContainsBy (queueStore q) (pred . itemValue) + case x of + Nothing -> return Nothing + Just i -> return $ Just (itemValue i) -- | Clear the queue immediately. clearQueue :: DequeueStrategy sm diff --git a/Simulation/Aivika/Queue/Infinite/Base.hs b/Simulation/Aivika/Queue/Infinite/Base.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Queue/Infinite/Base.hs @@ -0,0 +1,349 @@ + +-- | +-- Module : Simulation.Aivika.Queue.Infinite.Base +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.10.1 +-- +-- This module defines an infinite optimised queue, which has no counters nor signals. +-- +module Simulation.Aivika.Queue.Infinite.Base + (-- * Queue Types + FCFSQueue, + LCFSQueue, + SIROQueue, + PriorityQueue, + Queue, + -- * Creating Queue + newFCFSQueue, + newLCFSQueue, + newSIROQueue, + newPriorityQueue, + newQueue, + -- * Queue Properties and Activities + enqueueStoringStrategy, + dequeueStrategy, + queueNull, + queueCount, + -- * Dequeuing and Enqueuing + dequeue, + dequeueWithOutputPriority, + tryDequeue, + enqueue, + enqueueWithStoringPriority, + queueDelete, + queueDelete_, + queueDeleteBy, + queueDeleteBy_, + queueContains, + queueContainsBy, + clearQueue) where + +import Data.IORef +import Data.Monoid +import Data.Maybe + +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.Resource.Base +import Simulation.Aivika.QueueStrategy + +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 FCFS a + +-- | A type synonym for the ordinary LIFO queue also known as the LCFS +-- (Last Come - First Serviced) queue. +type LCFSQueue a = Queue LCFS FCFS a + +-- | A type synonym for the SIRO (Serviced in Random Order) queue. +type SIROQueue a = Queue SIRO FCFS a + +-- | A type synonym for the queue with static priorities applied when +-- storing the elements in the queue. +type PriorityQueue a = Queue StaticPriorities FCFS a + +-- | Represents an infinite queue using the specified strategies for +-- internal storing (in memory), @sm@, and dequeueing (output), @so@, where @a@ denotes +-- the type of items stored in the queue. +data Queue sm so a = + Queue { enqueueStoringStrategy :: sm, + -- ^ The strategy applied when storing (in memory) items in the queue. + dequeueStrategy :: so, + -- ^ The strategy applied to the dequeueing (output) processes. + queueStore :: StrategyQueue sm a, + dequeueRes :: Resource so, + queueCountRef :: IORef Int } + +-- | 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, + QueueStrategy so) => + sm + -- ^ the strategy applied when storing items in the queue + -> so + -- ^ the strategy applied to the dequeueing (output) processes when the queue is empty + -> Simulation (Queue sm so a) +newQueue sm so = + do i <- liftIO $ newIORef 0 + qm <- newStrategyQueue sm + ro <- newResourceWithMaxCount so 0 Nothing + return Queue { enqueueStoringStrategy = sm, + dequeueStrategy = so, + queueStore = qm, + dequeueRes = ro, + queueCountRef = i } + +-- | Test whether the queue is empty. +-- +-- See also 'queueNullChanged' and 'queueNullChanged_'. +queueNull :: Queue sm so a -> Event Bool +queueNull q = + Event $ \p -> + do n <- readIORef (queueCountRef q) + return (n == 0) + +-- | Return the current queue size. +-- +-- See also 'queueCountStats', 'queueCountChanged' and 'queueCountChanged_'. +queueCount :: Queue sm so a -> Event Int +queueCount q = + Event $ \p -> readIORef (queueCountRef q) + +-- | Dequeue suspending the process if the queue is empty. +dequeue :: (DequeueStrategy sm, + EnqueueStrategy so) + => Queue sm so a + -- ^ the queue + -> Process a + -- ^ the dequeued value +dequeue q = + do requestResource (dequeueRes q) + liftEvent $ dequeueExtract q + +-- | Dequeue with the output priority suspending the process if the queue is empty. +dequeueWithOutputPriority :: (DequeueStrategy sm, + PriorityQueueStrategy so po) + => Queue sm so a + -- ^ the queue + -> po + -- ^ the priority for output + -> Process a + -- ^ the dequeued value +dequeueWithOutputPriority q po = + do requestResourceWithPriority (dequeueRes q) po + liftEvent $ dequeueExtract q + +-- | Try to dequeue immediately. +tryDequeue :: DequeueStrategy sm + => Queue sm so a + -- ^ the queue + -> Event (Maybe a) + -- ^ the dequeued value of 'Nothing' +tryDequeue q = + do x <- tryRequestResourceWithinEvent (dequeueRes q) + if x + then fmap Just $ dequeueExtract q + else return Nothing + +-- | Remove the item from the queue and return a flag indicating +-- whether the item was found and actually removed. +queueDelete :: (Eq a, + DeletingQueueStrategy sm, + DequeueStrategy so) + => Queue sm so a + -- ^ the queue + -> a + -- ^ the item to remove from the queue + -> Event Bool + -- ^ whether the item was found and removed +queueDelete q a = fmap isJust $ queueDeleteBy q (== a) + +-- | Remove the specified item from the queue. +queueDelete_ :: (Eq a, + DeletingQueueStrategy sm, + DequeueStrategy so) + => Queue sm so a + -- ^ the queue + -> a + -- ^ the item to remove from the queue + -> Event () +queueDelete_ q a = fmap (const ()) $ queueDeleteBy q (== a) + +-- | Remove an item satisfying the specified predicate and return the item if found. +queueDeleteBy :: (DeletingQueueStrategy sm, + DequeueStrategy so) + => Queue sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event (Maybe a) +queueDeleteBy q pred = + do x <- tryRequestResourceWithinEvent (dequeueRes q) + if x + then do i <- strategyQueueDeleteBy (queueStore q) pred + case i of + Nothing -> + do releaseResourceWithinEvent (dequeueRes q) + return Nothing + Just i -> + fmap Just $ dequeuePostExtract q i + else return Nothing + +-- | Remove an item satisfying the specified predicate. +queueDeleteBy_ :: (DeletingQueueStrategy sm, + DequeueStrategy so) + => Queue sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event () +queueDeleteBy_ q pred = fmap (const ()) $ queueDeleteBy q pred + +-- | Detect whether the item is contained in the queue. +queueContains :: (Eq a, + DeletingQueueStrategy sm) + => Queue sm so a + -- ^ the queue + -> a + -- ^ the item to search the queue for + -> Event Bool + -- ^ whether the item was found +queueContains q a = fmap isJust $ queueContainsBy q (== a) + +-- | Detect whether an item satisfying the specified predicate is contained in the queue. +queueContainsBy :: DeletingQueueStrategy sm + => Queue sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event (Maybe a) + -- ^ the item if it was found +queueContainsBy q pred = + strategyQueueContainsBy (queueStore q) pred + +-- | Clear the queue immediately. +clearQueue :: DequeueStrategy sm + => Queue sm so a + -- ^ the queue + -> Event () +clearQueue q = + do x <- tryDequeue q + case x of + Nothing -> return () + Just a -> clearQueue q + +-- | Enqueue the item. +enqueue :: (EnqueueStrategy sm, + DequeueStrategy so) + => Queue sm so a + -- ^ the queue + -> a + -- ^ the item to enqueue + -> Event () +enqueue = enqueueStore + +-- | Enqueue with the storing priority the item. +enqueueWithStoringPriority :: (PriorityQueueStrategy sm pm, + DequeueStrategy so) + => Queue sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to enqueue + -> Event () +enqueueWithStoringPriority = enqueueStoreWithPriority + +-- | Store the item. +enqueueStore :: (EnqueueStrategy sm, + DequeueStrategy so) + => Queue sm so a + -- ^ the queue + -> a + -- ^ the item to be stored + -> Event () +enqueueStore q a = + Event $ \p -> + do invokeEvent p $ + strategyEnqueue (queueStore q) a + c <- readIORef (queueCountRef q) + let c' = c + 1 + c' `seq` writeIORef (queueCountRef q) c' + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + +-- | Store with the priority the item. +enqueueStoreWithPriority :: (PriorityQueueStrategy sm pm, + DequeueStrategy so) + => Queue sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to be enqueued + -> Event () +enqueueStoreWithPriority q pm a = + Event $ \p -> + do invokeEvent p $ + strategyEnqueueWithPriority (queueStore q) pm a + c <- readIORef (queueCountRef q) + let c' = c + 1 + c' `seq` writeIORef (queueCountRef q) c' + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + +-- | Extract an item for the dequeuing request. +dequeueExtract :: DequeueStrategy sm + => Queue sm so a + -- ^ the queue + -> Event a + -- ^ the dequeued value +dequeueExtract q = + Event $ \p -> + do a <- invokeEvent p $ + strategyDequeue (queueStore q) + invokeEvent p $ + dequeuePostExtract q a + +-- | A post action after extracting the item by the dequeuing request. +dequeuePostExtract :: DequeueStrategy sm + => Queue sm so a + -- ^ the queue + -> a + -- ^ the item to dequeue + -> Event a + -- ^ the dequeued value +dequeuePostExtract q a = + Event $ \p -> + do c <- readIORef (queueCountRef q) + let c' = c - 1 + c' `seq` writeIORef (queueCountRef q) c' + return a diff --git a/Simulation/Aivika/QueueStrategy.hs b/Simulation/Aivika/QueueStrategy.hs --- a/Simulation/Aivika/QueueStrategy.hs +++ b/Simulation/Aivika/QueueStrategy.hs @@ -96,6 +96,24 @@ -> Event (Maybe i) -- ^ the element if it was found and removed + -- | Detect whether the specified element is contained in the queue. + strategyQueueContains :: Eq i + => StrategyQueue s i + -- ^ the queue + -> i + -- ^ the element to find + -> Event Bool + -- ^ whether the element is contained in the queue + strategyQueueContains s i = fmap isJust $ strategyQueueContainsBy s (== i) + + -- | Detect whether an element satifying the specified predicate is contained in the queue. + strategyQueueContainsBy :: StrategyQueue s i + -- ^ the queue + -> (i -> Bool) + -- ^ the predicate + -> Event (Maybe i) + -- ^ the element if it was found + -- | Strategy: First Come - First Served (FCFS). data FCFS = FCFS deriving (Eq, Ord, Show) @@ -137,6 +155,8 @@ strategyQueueDeleteBy (FCFSQueue q) p = liftIO $ listRemoveBy q p + strategyQueueContainsBy (FCFSQueue q) p = liftIO $ listContainsBy q p + -- | An implementation of the 'LCFS' queue strategy. instance QueueStrategy LCFS where @@ -166,6 +186,8 @@ strategyQueueDeleteBy (LCFSQueue q) p = liftIO $ listRemoveBy q p + strategyQueueContainsBy (LCFSQueue q) p = liftIO $ listContainsBy q p + -- | An implementation of the 'StaticPriorities' queue strategy. instance QueueStrategy StaticPriorities where @@ -195,6 +217,8 @@ strategyQueueDeleteBy (StaticPriorityQueue q) p = liftIO $ PQ.queueDeleteBy q p + strategyQueueContainsBy (StaticPriorityQueue q) p = liftIO $ PQ.queueContainsBy q p + -- | An implementation of the 'SIRO' queue strategy. instance QueueStrategy SIRO where @@ -228,3 +252,5 @@ instance DeletingQueueStrategy SIRO where strategyQueueDeleteBy (SIROQueue q) p = liftIO $ V.vectorDeleteBy q p + + strategyQueueContainsBy (SIROQueue q) p = liftIO $ V.vectorContainsBy q p diff --git a/Simulation/Aivika/Results.hs b/Simulation/Aivika/Results.hs --- a/Simulation/Aivika/Results.hs +++ b/Simulation/Aivika/Results.hs @@ -134,6 +134,7 @@ import Simulation.Aivika.Activity import Simulation.Aivika.Resource import qualified Simulation.Aivika.Resource.Preemption as PR +import Simulation.Aivika.Operation import Simulation.Aivika.Results.Locale -- | A name used for indentifying the results when generating output. @@ -1822,6 +1823,44 @@ resultContainerProperty c "countStats" ResourceCountStatsId PR.resourceCountStats PR.resourceCountChanged_, resultContainerProperty c "utilisationCountStats" ResourceUtilisationCountStatsId PR.resourceUtilisationCountStats PR.resourceUtilisationCountChanged_ ] } +-- | Return a source by the specified operation. +operationResultSource :: ResultContainer (Operation a b) + -- ^ the operation container + -> ResultSource +operationResultSource c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = OperationId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = operationResultSummary c, + resultObjectProperties = [ + resultContainerProperty c "totalUtilisationTime" OperationTotalUtilisationTimeId operationTotalUtilisationTime operationTotalUtilisationTimeChanged_, + resultContainerProperty c "totalPreemptionTime" OperationTotalPreemptionTimeId operationTotalPreemptionTime operationTotalPreemptionTimeChanged_, + resultContainerProperty c "utilisationTime" OperationUtilisationTimeId operationUtilisationTime operationUtilisationTimeChanged_, + resultContainerProperty c "preemptionTime" OperationPreemptionTimeId operationPreemptionTime operationPreemptionTimeChanged_, + resultContainerProperty c "utilisationFactor" OperationUtilisationFactorId operationUtilisationFactor operationUtilisationFactorChanged_, + resultContainerProperty c "preemptionFactor" OperationPreemptionFactorId operationPreemptionFactor operationPreemptionFactorChanged_ ] } + +-- | Return a summary by the specified operation. +operationResultSummary :: ResultContainer (Operation a b) + -- ^ the operation container + -> ResultSource +operationResultSummary c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = OperationId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = operationResultSummary c, + resultObjectProperties = [ + resultContainerProperty c "utilisationTime" OperationUtilisationTimeId operationUtilisationTime operationUtilisationTimeChanged_, + resultContainerProperty c "preemptionTime" OperationPreemptionTimeId operationPreemptionTime operationPreemptionTimeChanged_, + resultContainerProperty c "utilisationFactor" OperationUtilisationFactorId operationUtilisationFactor operationUtilisationFactorChanged_, + resultContainerProperty c "preemptionFactor" OperationPreemptionFactorId operationPreemptionFactor operationPreemptionFactorChanged_ ] } + -- | Return an arbitrary text as a separator source. textResultSource :: String -> ResultSource textResultSource text = @@ -2062,3 +2101,8 @@ resultSource' name i m = preemptibleResourceResultSource $ ResultContainer name i m (ResultSignal $ PR.resourceChanged_ m) + +instance ResultProvider (Operation a b) where + + resultSource' name i m = + operationResultSource $ ResultContainer name i m (ResultSignal $ operationChanged_ m) diff --git a/Simulation/Aivika/Results/Locale.hs b/Simulation/Aivika/Results/Locale.hs --- a/Simulation/Aivika/Results/Locale.hs +++ b/Simulation/Aivika/Results/Locale.hs @@ -35,6 +35,7 @@ import Simulation.Aivika.Server import Simulation.Aivika.Activity import Simulation.Aivika.Resource +import Simulation.Aivika.Operation -- | A locale to output the simulation results. -- @@ -234,6 +235,20 @@ -- ^ Property 'resourceTotalWaitTime'. | ResourceWaitTimeId -- ^ Property 'resourceWaitTime'. + | OperationId + -- ^ Represents an 'Operation'. + | OperationTotalUtilisationTimeId + -- ^ Property 'operationTotalUtilisationTime'. + | OperationTotalPreemptionTimeId + -- ^ Property 'operationTotalPreemptionTime'. + | OperationUtilisationTimeId + -- ^ Property 'operationUtilisationTime'. + | OperationPreemptionTimeId + -- ^ Property 'operationPreemptionTime'. + | OperationUtilisationFactorId + -- ^ Property 'operationUtilisationFactor'. + | OperationPreemptionFactorId + -- ^ Property 'operationPreemptionFactor'. | UserDefinedResultId ResultDescription -- ^ An user defined description. | LocalisedResultId (M.Map ResultLocale ResultDescription) @@ -343,6 +358,13 @@ russianResultLocalisation ResourceQueueCountStatsId = "статистика длины очереди к ресурсу" russianResultLocalisation ResourceTotalWaitTimeId = "общее время ожидания ресурса" russianResultLocalisation ResourceWaitTimeId = "время ожидания ресурса" +russianResultLocalisation OperationId = "операция" +russianResultLocalisation OperationTotalUtilisationTimeId = "общее время использования" +russianResultLocalisation OperationTotalPreemptionTimeId = "общее время вытеснения" +russianResultLocalisation OperationUtilisationTimeId = "статистика времени использования" +russianResultLocalisation OperationPreemptionTimeId = "статистика времени вытеснения" +russianResultLocalisation OperationUtilisationFactorId = "относительное время использования (от 0 до 1)" +russianResultLocalisation OperationPreemptionFactorId = "относительное время вытеснения (от 0 до 1)" russianResultLocalisation (UserDefinedResultId m) = m russianResultLocalisation x@(LocalisedResultId m) = lookupResultLocalisation russianResultLocale x @@ -430,9 +452,9 @@ englishResultLocalisation ActivityUtilisationTimeId = "the utilisation time" englishResultLocalisation ActivityIdleTimeId = "the idle time" englishResultLocalisation ActivityPreemptionTimeId = "the preemption time" -englishResultLocalisation ActivityUtilisationFactorId = "the relative utilisation time (от 0 до 1)" +englishResultLocalisation ActivityUtilisationFactorId = "the relative utilisation time (from 0 to 1)" englishResultLocalisation ActivityIdleFactorId = "the relative idle time (от 0 до 1)" -englishResultLocalisation ActivityPreemptionFactorId = "the relative preemption time (от 0 до 1)" +englishResultLocalisation ActivityPreemptionFactorId = "the relative preemption time (from 0 to 1)" englishResultLocalisation ResourceId = "the resource" englishResultLocalisation ResourceCountId = "the current available count" englishResultLocalisation ResourceCountStatsId = "the available count statistics" @@ -442,6 +464,13 @@ englishResultLocalisation ResourceQueueCountStatsId = "the queue length statistics" englishResultLocalisation ResourceTotalWaitTimeId = "the total wait time" englishResultLocalisation ResourceWaitTimeId = "the wait time" +englishResultLocalisation OperationId = "the operation" +englishResultLocalisation OperationTotalUtilisationTimeId = "the total time of utilisation" +englishResultLocalisation OperationTotalPreemptionTimeId = "the total time of preemption" +englishResultLocalisation OperationUtilisationTimeId = "the utilisation time" +englishResultLocalisation OperationPreemptionTimeId = "the preemption time" +englishResultLocalisation OperationUtilisationFactorId = "the relative utilisation time (from 0 to 1)" +englishResultLocalisation OperationPreemptionFactorId = "the relative preemption time (from 0 to 1)" englishResultLocalisation (UserDefinedResultId m) = m englishResultLocalisation x@(LocalisedResultId m) = lookupResultLocalisation englishResultLocale x diff --git a/Simulation/Aivika/Results/Transform.hs b/Simulation/Aivika/Results/Transform.hs --- a/Simulation/Aivika/Results/Transform.hs +++ b/Simulation/Aivika/Results/Transform.hs @@ -112,7 +112,15 @@ resourceQueueCount, resourceQueueCountStats, resourceTotalWaitTime, - resourceWaitTime) where + resourceWaitTime, + -- * Operation + Operation(..), + operationTotalUtilisationTime, + operationTotalPreemptionTime, + operationUtilisationTime, + operationPreemptionTime, + operationUtilisationFactor, + operationPreemptionFactor) where import Control.Arrow @@ -608,3 +616,43 @@ resourceWaitTime :: Resource -> SamplingStats resourceWaitTime (Resource a) = SamplingStats (a >>> resultById ResourceWaitTimeId) + +-- | It models an opreation which actvity can be utilised. +newtype Operation = Operation ResultTransform + +instance ResultTransformer Operation where + tr (Operation a) = a + +-- | Return the counted total time when the operation activity was utilised. +operationTotalUtilisationTime :: Operation -> ResultTransform +operationTotalUtilisationTime (Operation a) = + a >>> resultById OperationTotalUtilisationTimeId + +-- | Return the counted total time when the operation activity was preemted +-- waiting for the further proceeding. +operationTotalPreemptionTime :: Operation -> ResultTransform +operationTotalPreemptionTime (Operation a) = + a >>> resultById OperationTotalPreemptionTimeId + +-- | Return the statistics for the time when the operation activity was utilised. +operationUtilisationTime :: Operation -> SamplingStats +operationUtilisationTime (Operation a) = + SamplingStats (a >>> resultById OperationUtilisationTimeId) + +-- | Return the statistics for the time when the operation activity was preempted +-- waiting for the further proceeding. +operationPreemptionTime :: Operation -> SamplingStats +operationPreemptionTime (Operation a) = + SamplingStats (a >>> resultById OperationPreemptionTimeId) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the operation activity was utilised. +operationUtilisationFactor :: Operation -> ResultTransform +operationUtilisationFactor (Operation a) = + a >>> resultById OperationUtilisationFactorId + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the operation activity was preempted waiting for the further proceeding. +operationPreemptionFactor :: Operation -> ResultTransform +operationPreemptionFactor (Operation a) = + a >>> resultById OperationPreemptionFactorId diff --git a/Simulation/Aivika/Stream.hs b/Simulation/Aivika/Stream.hs --- a/Simulation/Aivika/Stream.hs +++ b/Simulation/Aivika/Stream.hs @@ -46,6 +46,7 @@ repeatProcess, mapStream, mapStreamM, + accumStream, apStream, apStreamM, filterStream, @@ -69,6 +70,11 @@ replaceLeftStream, replaceRightStream, partitionEitherStream, + -- * Assemblying Streams + cloneStream, + firstArrivalStream, + lastArrivalStream, + assembleAccumStream, -- * Debugging traceStream) where @@ -88,7 +94,7 @@ import Simulation.Aivika.Signal import Simulation.Aivika.Resource.Base import Simulation.Aivika.QueueStrategy -import Simulation.Aivika.Queue.Infinite +import Simulation.Aivika.Queue.Infinite.Base import Simulation.Aivika.Internal.Arrival -- | Represents an infinite stream of data in time, @@ -213,6 +219,14 @@ b <- f a return (b, mapStreamM f xs) +-- | Accumulator that outputs a value determined by the supplied function. +accumStream :: (acc -> a -> Process (acc, b)) -> acc -> Stream a -> Stream b +accumStream f acc xs = Cons $ loop xs acc where + loop (Cons s) acc = + do (a, xs) <- s + (acc', b) <- f acc a + return (b, Cons $ loop xs acc') + -- | Sequential application. apStream :: Stream (a -> b) -> Stream a -> Stream b apStream (Cons sf) (Cons sa) = Cons y where @@ -513,7 +527,7 @@ -- Cancel the stream's process to unsubscribe from the specified signal. signalStream :: Signal a -> Process (Stream a) signalStream s = - do q <- liftEvent newFCFSQueue + do q <- liftSimulation newFCFSQueue h <- liftEvent $ handleSignal s $ enqueue q @@ -657,6 +671,56 @@ if f then runStream $ dropStreamWhileM p xs else return (a, xs) + +-- | Create the specified number of equivalent clones of the input stream. +cloneStream :: Int -> Stream a -> Simulation [Stream a] +cloneStream n s = + do qs <- forM [1..n] $ \i -> newFCFSQueue + rs <- newFCFSResource 1 + ref <- liftIO $ newIORef s + let reader m q = + do a <- liftEvent $ tryDequeue q + case a of + Just a -> return a + Nothing -> + usingResource rs $ + do a <- liftEvent $ tryDequeue q + case a of + Just a -> return a + Nothing -> + do s <- liftIO $ readIORef ref + (a, xs) <- runStream s + liftIO $ writeIORef ref xs + forM_ (zip [1..] qs) $ \(i, q) -> + unless (i == m) $ + liftEvent $ enqueue q a + return a + forM (zip [1..] qs) $ \(i, q) -> + return $ repeatProcess $ reader i q + +-- | Return a stream of first arrivals after assembling the specified number of elements. +firstArrivalStream :: Int -> Stream a -> Stream a +firstArrivalStream n s = assembleAccumStream f (1, Nothing) s + where f (i, a0) a = + let a0' = Just $ fromMaybe a a0 + in if i `mod` n == 0 + then return ((1, Nothing), a0') + else return ((i + 1, a0'), Nothing) + +-- | Return a stream of last arrivals after assembling the specified number of elements. +lastArrivalStream :: Int -> Stream a -> Stream a +lastArrivalStream n s = assembleAccumStream f 1 s + where f i a = + if i `mod` n == 0 + then return (1, Just a) + else return (i + 1, Nothing) + +-- | Assemble an accumulated stream using the supplied function. +assembleAccumStream :: (acc -> a -> Process (acc, Maybe b)) -> acc -> Stream a -> Stream b +assembleAccumStream f acc s = + mapStream fromJust $ + filterStream isJust $ + accumStream f acc s -- | Show the debug messages with the current simulation time. traceStream :: Maybe String diff --git a/Simulation/Aivika/Vector.hs b/Simulation/Aivika/Vector.hs --- a/Simulation/Aivika/Vector.hs +++ b/Simulation/Aivika/Vector.hs @@ -26,6 +26,8 @@ vectorDeleteBy, vectorIndex, vectorIndexBy, + vectorContains, + vectorContainsBy, freezeVector) where import Data.Array @@ -218,5 +220,20 @@ if index >= 0 then do a <- readVector vector index vectorDeleteAt vector index + return (Just a) + else return Nothing + +-- | Detect whether the specified element is contained in the vector. +vectorContains :: Eq a => Vector a -> a -> IO Bool +vectorContains vector item = + do index <- vectorIndex vector item + return (index >= 0) + +-- | Detect whether an element satisfying the specified predicate is contained in the vector. +vectorContainsBy :: Vector a -> (a -> Bool) -> IO (Maybe a) +vectorContainsBy vector pred = + do index <- vectorIndexBy vector pred + if index >= 0 + then do a <- readVector vector index return (Just a) else return Nothing 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 @@ -26,6 +26,8 @@ vectorDeleteBy, vectorIndex, vectorIndexBy, + vectorContains, + vectorContainsBy, freezeVector) where import Data.Array @@ -222,3 +224,18 @@ then do vectorDeleteAt vector index return True else return False + +-- | Detect whether the specified element is contained in the vector. +vectorContains :: (Unboxed a, Eq a) => Vector a -> a -> IO Bool +vectorContains vector item = + do index <- vectorIndex vector item + return (index >= 0) + +-- | Detect whether an element satisfying the specified predicate is contained in the vector. +vectorContainsBy :: Unboxed a => Vector a -> (a -> Bool) -> IO (Maybe a) +vectorContainsBy vector pred = + do index <- vectorIndexBy vector pred + if index >= 0 + then do a <- readVector vector index + return (Just a) + else return Nothing diff --git a/aivika.cabal b/aivika.cabal --- a/aivika.cabal +++ b/aivika.cabal @@ -1,5 +1,5 @@ name: aivika -version: 4.2 +version: 4.3 synopsis: A multi-paradigm simulation library description: Aivika is a multi-paradigm simulation library with a strong emphasis @@ -121,6 +121,7 @@ examples/PortOperations.hs examples/SingleLaneTraffic.hs examples/RenegingFromQueue.hs + examples/TruckHaulingSituation.hs CHANGELOG.md library @@ -143,6 +144,8 @@ Simulation.Aivika.Generator Simulation.Aivika.Net Simulation.Aivika.Net.Random + Simulation.Aivika.Operation + Simulation.Aivika.Operation.Random Simulation.Aivika.Parameter Simulation.Aivika.Parameter.Random Simulation.Aivika.PriorityQueue @@ -152,7 +155,9 @@ Simulation.Aivika.Processor.Random Simulation.Aivika.Processor.RoundRobbin Simulation.Aivika.Queue + Simulation.Aivika.Queue.Base Simulation.Aivika.Queue.Infinite + Simulation.Aivika.Queue.Infinite.Base Simulation.Aivika.QueueStrategy Simulation.Aivika.Ref Simulation.Aivika.Ref.Base diff --git a/examples/TruckHaulingSituation.hs b/examples/TruckHaulingSituation.hs new file mode 100644 --- /dev/null +++ b/examples/TruckHaulingSituation.hs @@ -0,0 +1,137 @@ + +-- Example: A Truck Hauling Situation +-- +-- It is described in different sources [1, 2]. So, this is chapter 9 of [2] and section 7.16 of [1]. +-- +-- The system to be modeled in this example consists of one bulldozer, four trucks, +-- and two man-machine loaders. The bulldozer stockpiles material for the loaders. +-- Two piles of material must be stocked prior to the initiation of any load operation. +-- The time for the bulldozer to stockpile material is Erlang distributed and consists +-- of the sum of two exponential variables each with a men of 4. (This corresponds to +-- an Erlang variable with a mean of 8 and a variance of 32.) In addition to this +-- material, a loader and an unloaded truck must be available before the loading +-- operations can begin. Loading time is exponentially distributed with a mean time of +-- 14 minutes for server 1 and 12 minutes for server 2. +-- +-- After a truck is loaded, it is hauled, then dumped and must be returned before +-- the truck is available for further loading. Hauling time is normally distributed. +-- When loaded, the average hauling time is 22 minutes. When unloaded, the average +-- time is 18 minutes. In both cases, the standard deviation is 3 minutes. Dumping +-- time is uniformly distributed between 2 and 8 minutes. Following a loading +-- operation, the loaded must rest for a 5 minute period before he is available +-- to begin loading again. The system is to be analyzed for 8 hours and all operations +-- in progress at the end of 8 hours should be completed before terminating +-- the operations for a run. +-- +-- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. +-- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 + +import Control.Monad +import Control.Monad.Trans +import Control.Arrow + +import Data.Monoid +import Data.List +import Data.Array + +import Simulation.Aivika +import qualified Simulation.Aivika.Queue.Infinite as IQ + +-- | The simulation specs. +specs = Specs { spcStartTime = 0.0, + spcStopTime = 1000.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +data Truck = Truck + +data Pile = Pile + +data Loader = Loader1 + | Loader2 + deriving (Eq, Ord, Show, Ix) + +awaitQueuesNonEmpty q1 q2 q3 = + do n1 <- liftEvent $ IQ.queueCount q1 + n2 <- liftEvent $ IQ.queueCount q2 + n3 <- liftEvent $ IQ.queueCount q3 + when (n1 == 0 || n2 == 0 || n3 == 0) $ + do let signal = IQ.queueCountChanged_ q1 <> + IQ.queueCountChanged_ q2 <> + IQ.queueCountChanged_ q3 + processAwait signal + awaitQueuesNonEmpty q1 q2 q3 + +-- | The simulation model. +model :: Simulation Results +model = do + truckQueue <- runEventInStartTime IQ.newFCFSQueue + loadQueue <- runEventInStartTime IQ.newFCFSQueue + loaderQueue <- runEventInStartTime IQ.newFCFSQueue + loaderOp1 <- runEventInStartTime $ + newRandomExponentialOperation 14 + loaderOp2 <- runEventInStartTime $ + newRandomExponentialOperation 12 + let loaderOps = array (Loader1, Loader2) + [(Loader1, loaderOp1), + (Loader2, loaderOp2)] + let start :: Process () + start = + do randomErlangProcess_ 4 2 + randomErlangProcess_ 4 2 + liftEvent $ + IQ.enqueue loadQueue Pile + t <- liftDynamics time + when (t <= 480) start + begin :: Process () + begin = + do awaitQueuesNonEmpty truckQueue loadQueue loaderQueue + truck <- IQ.dequeue truckQueue + pile <- IQ.dequeue loadQueue + loader <- IQ.dequeue loaderQueue + -- the load operation + operationProcess (loaderOps ! loader) () + -- truck hauling + liftEvent $ + do runProcess $ + do holdProcess 5 + liftEvent $ + IQ.enqueue loaderQueue loader + runProcess $ + do randomNormalProcess_ 22 3 + randomUniformProcess_ 2 8 + randomNormalProcess_ 18 3 + liftEvent $ + IQ.enqueue truckQueue truck + begin + runEventInStartTime $ + do forM_ [1..4] $ \i -> + IQ.enqueue truckQueue Truck + IQ.enqueue loaderQueue Loader1 + IQ.enqueue loaderQueue Loader2 + runProcessInStartTime begin + runProcessInStartTime begin + runProcessInStartTime start + return $ + results + [ resultSource + "loadQueue" "Queue Load" + loadQueue, + -- + resultSource + "truckQueue" "Queue Trucks" + truckQueue, + -- + resultSource + "loaderQueue" "Queue Loader" + loaderQueue, + -- + resultSource + "loaderOps" "Loader Operations" + loaderOps] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + (fmap resultSummary model) specs