diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009-2015 David Sorokin +Copyright (c) 2009-2016 David Sorokin All rights reserved. diff --git a/Simulation/Aivika/IO/Generator.hs b/Simulation/Aivika/IO/Generator.hs --- a/Simulation/Aivika/IO/Generator.hs +++ b/Simulation/Aivika/IO/Generator.hs @@ -22,6 +22,7 @@ import Data.IORef import Simulation.Aivika.Trans.Generator +import Simulation.Aivika.Trans.Generator.Primitive import Simulation.Aivika.Trans.Template instance (Functor m, MonadIO m, MonadTemplate m) => MonadGenerator m where @@ -41,9 +42,15 @@ {-# INLINE generateUniformInt #-} generateUniformInt = generateUniformInt01 . generator01 + {-# INLINE generateTriangular #-} + generateTriangular = generateTriangular01 . generator01 + {-# INLINE generateNormal #-} generateNormal = generateNormal01 . generatorNormal01 + {-# INLINE generateLogNormal #-} + generateLogNormal = generateLogNormal01 . generatorNormal01 + {-# INLINE generateExponential #-} generateExponential = generateExponential01 . generator01 @@ -56,6 +63,18 @@ {-# INLINE generateBinomial #-} generateBinomial = generateBinomial01 . generator01 + {-# INLINE generateGamma #-} + generateGamma g = generateGamma01 (generatorNormal01 g) (generator01 g) + + {-# INLINE generateBeta #-} + generateBeta g = generateBeta01 (generatorNormal01 g) (generator01 g) + + {-# INLINE generateWeibull #-} + generateWeibull = generateWeibull01 . generator01 + + {-# INLINE generateDiscrete #-} + generateDiscrete = generateDiscrete01 . generator01 + {-# INLINABLE newGenerator #-} newGenerator tp = case tp of @@ -83,50 +102,6 @@ return Generator { generator01 = g01, generatorNormal01 = gNormal01 } --- | Generate an uniform random number with the specified minimum and maximum. -generateUniform01 :: Monad m - => m Double - -- ^ the generator - -> Double - -- ^ minimum - -> Double - -- ^ maximum - -> m Double -{-# INLINE generateUniform01 #-} -generateUniform01 g min max = - do x <- g - return $ min + x * (max - min) - --- | Generate an uniform random number with the specified minimum and maximum. -generateUniformInt01 :: Monad m - => m Double - -- ^ the generator - -> Int - -- ^ minimum - -> Int - -- ^ maximum - -> m Int -{-# INLINE generateUniformInt01 #-} -generateUniformInt01 g min max = - do x <- g - let min' = fromIntegral min - max' = fromIntegral max - return $ round (min' + x * (max' - min')) - --- | Generate a normal random number by the specified generator, mean and variance. -generateNormal01 :: Monad m - => m Double - -- ^ normal random numbers with mean 0 and variance 1 - -> Double - -- ^ mean - -> Double - -- ^ variance - -> m Double -{-# INLINE generateNormal01 #-} -generateNormal01 g mu nu = - do x <- g - return $ mu + nu * x - -- | Create a normal random number generator with mean 0 and variance 1 -- by the specified generator of uniform random numbers from 0 to 1. newNormalGenerator01 :: MonadIO m @@ -168,71 +143,3 @@ liftIO $ writeIORef flagRef True liftIO $ writeIORef nextRef $ xi2 * psi return $ xi1 * psi - --- | Return the exponential random number with the specified mean. -generateExponential01 :: Monad m - => m Double - -- ^ the generator - -> Double - -- ^ the mean - -> m Double -{-# INLINE generateExponential01 #-} -generateExponential01 g mu = - do x <- g - return (- log x * mu) - --- | Return the Erlang random number. -generateErlang01 :: Monad m - => m Double - -- ^ the generator - -> Double - -- ^ the scale - -> Int - -- ^ the shape - -> m Double -{-# INLINABLE generateErlang01 #-} -generateErlang01 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. -generatePoisson01 :: Monad m - => m Double - -- ^ the generator - -> Double - -- ^ the mean - -> m Int -{-# INLINABLE generatePoisson01 #-} -generatePoisson01 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. -generateBinomial01 :: Monad m - => m Double - -- ^ the generator - -> Double - -- ^ the probability - -> Int - -- ^ the number of trials - -> m Int -{-# INLINABLE generateBinomial01 #-} -generateBinomial01 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 diff --git a/Simulation/Aivika/IO/QueueStrategy.hs b/Simulation/Aivika/IO/QueueStrategy.hs --- a/Simulation/Aivika/IO/QueueStrategy.hs +++ b/Simulation/Aivika/IO/QueueStrategy.hs @@ -71,6 +71,20 @@ strategyEnqueue (FCFSQueue q) i = liftIO $ LL.listAddLast q i +-- | An implementation of the 'FCFS' queue strategy. +instance (DequeueStrategy m FCFS, MonadComp m, MonadIO m, MonadTemplate m) + => DeletingQueueStrategy m FCFS where + + {-# SPECIALISE instance DeletingQueueStrategy IO FCFS #-} + + {-# INLINABLE strategyQueueDeleteBy #-} + strategyQueueDeleteBy (FCFSQueue q) p = + liftIO $ LL.listRemoveBy q p + + {-# INLINABLE strategyQueueContainsBy #-} + strategyQueueContainsBy (FCFSQueue q) p = + liftIO $ LL.listContainsBy q p + -- | An implementation of the 'LCFS' queue strategy. instance (MonadComp m, MonadIO m, MonadTemplate m) => QueueStrategy m LCFS where @@ -112,6 +126,20 @@ strategyEnqueue (LCFSQueue q) i = liftIO $ LL.listInsertFirst q i +-- | An implementation of the 'LCFS' queue strategy. +instance (DequeueStrategy m LCFS, MonadComp m, MonadIO m, MonadTemplate m) + => DeletingQueueStrategy m LCFS where + + {-# SPECIALISE instance DeletingQueueStrategy IO LCFS #-} + + {-# INLINABLE strategyQueueDeleteBy #-} + strategyQueueDeleteBy (LCFSQueue q) p = + liftIO $ LL.listRemoveBy q p + + {-# INLINABLE strategyQueueContainsBy #-} + strategyQueueContainsBy (LCFSQueue q) p = + liftIO $ LL.listContainsBy q p + -- | A template-based implementation of the 'StaticPriorities' queue strategy. instance (MonadComp m, MonadIO m, MonadTemplate m) => QueueStrategy m StaticPriorities where @@ -153,6 +181,20 @@ strategyEnqueueWithPriority (StaticPriorityQueue q) p i = liftIO $ PQ.enqueue q p i +-- | An implementation of the 'StaticPriorities' queue strategy. +instance (DequeueStrategy m StaticPriorities, MonadComp m, MonadIO m, MonadTemplate m) + => DeletingQueueStrategy m StaticPriorities where + + {-# SPECIALISE instance DeletingQueueStrategy IO StaticPriorities #-} + + {-# INLINABLE strategyQueueDeleteBy #-} + strategyQueueDeleteBy (StaticPriorityQueue q) p = + liftIO $ PQ.queueDeleteBy q p + + {-# INLINABLE strategyQueueContainsBy #-} + strategyQueueContainsBy (StaticPriorityQueue q) p = + liftIO $ PQ.queueContainsBy q p + -- | A template-based implementation of the 'SIRO' queue strategy. instance (MonadComp m, MonadIO m, MonadTemplate m) => QueueStrategy m SIRO where @@ -196,3 +238,17 @@ {-# INLINABLE strategyEnqueue #-} strategyEnqueue (SIROQueue q) i = liftIO $ V.appendVector q i + +-- | An implementation of the 'SIRO' queue strategy. +instance (DequeueStrategy m SIRO, MonadComp m, MonadIO m, MonadTemplate m) + => DeletingQueueStrategy m SIRO where + + {-# SPECIALISE instance DeletingQueueStrategy IO SIRO #-} + + {-# INLINABLE strategyQueueDeleteBy #-} + strategyQueueDeleteBy (SIROQueue q) p = + liftIO $ V.vectorDeleteBy q p + + {-# INLINABLE strategyQueueContainsBy #-} + strategyQueueContainsBy (SIROQueue q) p = + liftIO $ V.vectorContainsBy q p diff --git a/Simulation/Aivika/IO/Resource/Preemption.hs b/Simulation/Aivika/IO/Resource/Preemption.hs --- a/Simulation/Aivika/IO/Resource/Preemption.hs +++ b/Simulation/Aivika/IO/Resource/Preemption.hs @@ -19,6 +19,7 @@ import Data.Maybe import Data.IORef +import Data.Monoid import Simulation.Aivika.Trans.Ref.Base import Simulation.Aivika.Trans.DES @@ -29,6 +30,8 @@ import Simulation.Aivika.Trans.Internal.Cont import Simulation.Aivika.Trans.Internal.Process import Simulation.Aivika.Trans.Resource.Preemption +import Simulation.Aivika.Trans.Statistics +import Simulation.Aivika.Trans.Signal import Simulation.Aivika.IO.DES @@ -42,29 +45,33 @@ -- | A template-based implementation of the preemptible resource. data Resource m = Resource { resourceMaxCount0 :: Maybe Int, + -- ^ Return the maximum count of the resource, where 'Nothing' + -- means that the resource has no upper bound. resourceCountRef :: IORef Int, + resourceCountStatsRef :: IORef (TimingStats Int), + resourceCountSource :: SignalSource m Int, + resourceUtilisationCountRef :: IORef Int, + resourceUtilisationCountStatsRef :: IORef (TimingStats Int), + resourceUtilisationCountSource :: SignalSource m Int, + resourceQueueCountRef :: IORef Int, + resourceQueueCountStatsRef :: IORef (TimingStats Int), + resourceQueueCountSource :: SignalSource m Int, + resourceTotalWaitTimeRef :: IORef Double, + resourceWaitTimeRef :: IORef (SamplingStats Double), + resourceWaitTimeSource :: SignalSource m (), resourceActingQueue :: PQ.PriorityQueue (ResourceActingItem m), resourceWaitQueue :: PQ.PriorityQueue (ResourceAwaitingItem m) } {-# INLINABLE newResource #-} newResource count = - Simulation $ \r -> - do when (count < 0) $ - error $ - "The resource count cannot be negative: " ++ - "newResource." - countRef <- liftIO $ newIORef count - actingQueue <- liftIO PQ.newQueue - waitQueue <- liftIO PQ.newQueue - return Resource { resourceMaxCount0 = Just count, - resourceCountRef = countRef, - resourceActingQueue = actingQueue, - resourceWaitQueue = waitQueue } + newResourceWithMaxCount count (Just count) {-# INLINABLE newResourceWithMaxCount #-} newResourceWithMaxCount count maxCount = - Simulation $ \r -> - do when (count < 0) $ + Event $ \p -> + do let r = pointRun p + t = pointTime p + when (count < 0) $ error $ "The resource count cannot be negative: " ++ "newResourceWithMaxCount." @@ -76,26 +83,115 @@ _ -> return () countRef <- liftIO $ newIORef count + countStatsRef <- liftIO $ newIORef $ returnTimingStats t count + countSource <- invokeSimulation r newSignalSource + utilCountRef <- liftIO $ newIORef 0 + utilCountStatsRef <- liftIO $ newIORef $ returnTimingStats t 0 + utilCountSource <- invokeSimulation r newSignalSource + queueCountRef <- liftIO $ newIORef 0 + queueCountStatsRef <- liftIO $ newIORef $ returnTimingStats t 0 + queueCountSource <- invokeSimulation r newSignalSource + totalWaitTimeRef <- liftIO $ newIORef 0 + waitTimeRef <- liftIO $ newIORef emptySamplingStats + waitTimeSource <- invokeSimulation r newSignalSource actingQueue <- liftIO PQ.newQueue waitQueue <- liftIO PQ.newQueue return Resource { resourceMaxCount0 = maxCount, resourceCountRef = countRef, + resourceCountStatsRef = countStatsRef, + resourceCountSource = countSource, + resourceUtilisationCountRef = utilCountRef, + resourceUtilisationCountStatsRef = utilCountStatsRef, + resourceUtilisationCountSource = utilCountSource, + resourceQueueCountRef = queueCountRef, + resourceQueueCountStatsRef = queueCountStatsRef, + resourceQueueCountSource = queueCountSource, + resourceTotalWaitTimeRef = totalWaitTimeRef, + resourceWaitTimeRef = waitTimeRef, + resourceWaitTimeSource = waitTimeSource, resourceActingQueue = actingQueue, resourceWaitQueue = waitQueue } + {-# INLINABLE resourceMaxCount #-} + resourceMaxCount = resourceMaxCount0 + {-# INLINABLE resourceCount #-} resourceCount r = Event $ \p -> liftIO $ readIORef (resourceCountRef r) - {-# INLINABLE resourceMaxCount #-} - resourceMaxCount = resourceMaxCount0 + {-# INLINABLE resourceCountStats #-} + resourceCountStats r = + Event $ \p -> liftIO $ readIORef (resourceCountStatsRef r) + {-# INLINABLE resourceCountChanged #-} + resourceCountChanged r = + publishSignal $ resourceCountSource r + + {-# INLINABLE resourceCountChanged_ #-} + resourceCountChanged_ r = + mapSignal (const ()) $ resourceCountChanged r + + {-# INLINABLE resourceUtilisationCount #-} + resourceUtilisationCount r = + Event $ \p -> liftIO $ readIORef (resourceUtilisationCountRef r) + + {-# INLINABLE resourceUtilisationCountStats #-} + resourceUtilisationCountStats r = + Event $ \p -> liftIO $ readIORef (resourceUtilisationCountStatsRef r) + + {-# INLINABLE resourceUtilisationCountChanged #-} + resourceUtilisationCountChanged r = + publishSignal $ resourceUtilisationCountSource r + + {-# INLINABLE resourceUtilisationCountChanged_ #-} + resourceUtilisationCountChanged_ r = + mapSignal (const ()) $ resourceUtilisationCountChanged r + + {-# INLINABLE resourceQueueCount #-} + resourceQueueCount r = + Event $ \p -> liftIO $ readIORef (resourceQueueCountRef r) + + {-# INLINABLE resourceQueueCountStats #-} + resourceQueueCountStats r = + Event $ \p -> liftIO $ readIORef (resourceQueueCountStatsRef r) + + {-# INLINABLE resourceQueueCountChanged #-} + resourceQueueCountChanged r = + publishSignal $ resourceQueueCountSource r + + {-# INLINABLE resourceQueueCountChanged_ #-} + resourceQueueCountChanged_ r = + mapSignal (const ()) $ resourceQueueCountChanged r + + {-# INLINABLE resourceTotalWaitTime #-} + resourceTotalWaitTime r = + Event $ \p -> liftIO $ readIORef (resourceTotalWaitTimeRef r) + + {-# INLINABLE resourceWaitTime #-} + resourceWaitTime r = + Event $ \p -> liftIO $ readIORef (resourceWaitTimeRef r) + + {-# INLINABLE resourceWaitTimeChanged #-} + resourceWaitTimeChanged r = + mapSignalM (\() -> resourceWaitTime r) $ resourceWaitTimeChanged_ r + + {-# INLINABLE resourceWaitTimeChanged_ #-} + resourceWaitTimeChanged_ r = + publishSignal $ resourceWaitTimeSource r + + {-# INLINABLE resourceChanged_ #-} + resourceChanged_ r = + resourceCountChanged_ r <> + resourceUtilisationCountChanged_ r <> + resourceQueueCountChanged_ r + {-# INLINABLE requestResourceWithPriority #-} requestResourceWithPriority r priority = Process $ \pid -> Cont $ \c -> Event $ \p -> - do a <- liftIO $ readIORef (resourceCountRef r) + do let t = pointTime p + a <- liftIO $ readIORef (resourceCountRef r) if a == 0 then do f <- liftIO $ PQ.queueNull (resourceActingQueue r) if f @@ -104,14 +200,16 @@ invokeCont c $ invokeProcess pid $ requestResourceWithPriority r priority - liftIO $ PQ.enqueue (resourceWaitQueue r) priority (Left $ ResourceRequestingItem priority pid c) + liftIO $ PQ.enqueue (resourceWaitQueue r) priority (Left $ ResourceRequestingItem priority t pid c) + invokeEvent p $ updateResourceQueueCount r 1 else do (p0', item0) <- liftIO $ PQ.queueFront (resourceActingQueue r) let p0 = - p0' pid0 = actingItemId item0 if priority < p0 then do liftIO $ PQ.dequeue (resourceActingQueue r) liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid - liftIO $ PQ.enqueue (resourceWaitQueue r) p0 (Right $ ResourcePreemptedItem p0 pid0) + liftIO $ PQ.enqueue (resourceWaitQueue r) p0 (Right $ ResourcePreemptedItem p0 t pid0) + invokeEvent p $ updateResourceQueueCount r 1 invokeEvent p $ processPreemptionBegin pid0 invokeEvent p $ resumeCont c () else do c <- invokeEvent p $ @@ -119,10 +217,12 @@ invokeCont c $ invokeProcess pid $ requestResourceWithPriority r priority - liftIO $ PQ.enqueue (resourceWaitQueue r) priority (Left $ ResourceRequestingItem priority pid c) - else do let a' = a - 1 - a' `seq` liftIO $ writeIORef (resourceCountRef r) a' - liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid + liftIO $ PQ.enqueue (resourceWaitQueue r) priority (Left $ ResourceRequestingItem priority t pid c) + invokeEvent p $ updateResourceQueueCount r 1 + else do liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid + invokeEvent p $ updateResourceWaitTime r 0 + invokeEvent p $ updateResourceCount r (-1) + invokeEvent p $ updateResourceUtilisationCount r 1 invokeEvent p $ resumeCont c () {-# INLINABLE releaseResource #-} @@ -132,11 +232,12 @@ Event $ \p -> do f <- liftIO $ fmap isJust $ PQ.queueDeleteBy (resourceActingQueue r) (\item -> actingItemId item == pid) if f - then do invokeEvent p $ releaseResource' r + then do invokeEvent p $ updateResourceUtilisationCount r (-1) + invokeEvent p $ releaseResource' r invokeEvent p $ resumeCont c () else error $ "The resource was not acquired by this process: releaseResource" - + {-# INLINABLE usingResourceWithPriority #-} usingResourceWithPriority r priority m = do requestResourceWithPriority r priority @@ -169,21 +270,22 @@ ResourceActingItem { actingItemPriority :: Double, actingItemId :: ProcessId m } +-- | Idenitifies an awaiting item that waits for releasing of the resource to take it. +type ResourceAwaitingItem m = Either (ResourceRequestingItem m) (ResourcePreemptedItem m) + -- | Idenitifies an item that requests for the resource. data ResourceRequestingItem m = ResourceRequestingItem { requestingItemPriority :: Double, + requestingItemTime :: Double, requestingItemId :: ProcessId m, requestingItemCont :: FrozenCont m () } -- | Idenitifies an item that was preempted. data ResourcePreemptedItem m = ResourcePreemptedItem { preemptedItemPriority :: Double, + preemptedItemTime :: Double, preemptedItemId :: ProcessId m } --- | Idenitifies an awaiting item that waits for releasing of the resource to take it. -type ResourceAwaitingItem m = - Either (ResourceRequestingItem m) (ResourcePreemptedItem m) - instance (MonadDES m, MonadIO m, MonadTemplate m) => Eq (Resource m) where {-# INLINABLE (==) #-} @@ -194,7 +296,12 @@ {-# INLINABLE (==) #-} x == y = actingItemId x == actingItemId y -releaseResource' :: (MonadDES m, MonadIO m, MonadTemplate m) => Resource m -> Event m () +-- | Release the resource increasing its count and resuming one of the +-- previously suspended or preempted processes as possible. +releaseResource' :: (MonadDES m, MonadIO m, MonadTemplate m) + => Resource m + -- ^ the resource to release + -> Event m () {-# INLINABLE releaseResource' #-} releaseResource' r = Event $ \p -> @@ -209,32 +316,40 @@ return () f <- liftIO $ PQ.queueNull (resourceWaitQueue r) if f - then a' `seq` liftIO $ writeIORef (resourceCountRef r) a' + then invokeEvent p $ updateResourceCount r 1 else do (priority', item) <- liftIO $ PQ.queueFront (resourceWaitQueue r) liftIO $ PQ.dequeue (resourceWaitQueue r) + invokeEvent p $ updateResourceQueueCount r (-1) case item of - Left (ResourceRequestingItem priority pid c) -> + Left (ResourceRequestingItem priority t pid c) -> do c <- invokeEvent p $ unfreezeCont c case c of Nothing -> invokeEvent p $ releaseResource' r Just c -> do liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid + invokeEvent p $ updateResourceWaitTime r (pointTime p - t) + invokeEvent p $ updateResourceUtilisationCount r 1 invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c () - Right (ResourcePreemptedItem priority pid) -> + Right (ResourcePreemptedItem priority t pid) -> do f <- invokeEvent p $ processCancelled pid case f of True -> invokeEvent p $ releaseResource' r False -> do liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid + invokeEvent p $ updateResourceWaitTime r (pointTime p - t) + invokeEvent p $ updateResourceUtilisationCount r 1 invokeEvent p $ processPreemptionEnd pid +-- | Preempt a process with the lowest priority that acquires yet the resource +-- and decrease the count of available resource by 1. decResourceCount' :: (MonadDES m, MonadIO m, MonadTemplate m) => Resource m -> Event m () {-# INLINABLE decResourceCount' #-} decResourceCount' r = Event $ \p -> - do a <- liftIO $ readIORef (resourceCountRef r) + do let t = pointTime p + a <- liftIO $ readIORef (resourceCountRef r) when (a == 0) $ error $ "The resource exceeded and its count is zero: decResourceCount'" @@ -244,7 +359,64 @@ let p0 = - p0' pid0 = actingItemId item0 liftIO $ PQ.dequeue (resourceActingQueue r) - liftIO $ PQ.enqueue (resourceWaitQueue r) p0 (Right $ ResourcePreemptedItem p0 pid0) + liftIO $ PQ.enqueue (resourceWaitQueue r) p0 (Right $ ResourcePreemptedItem p0 t pid0) invokeEvent p $ processPreemptionBegin pid0 - let a' = a - 1 + invokeEvent p $ updateResourceUtilisationCount r (-1) + invokeEvent p $ updateResourceQueueCount r 1 + invokeEvent p $ updateResourceCount r (-1) + +-- | Update the resource count and its statistics. +updateResourceCount :: (MonadDES m, MonadIO m, MonadTemplate m) => Resource m -> Int -> Event m () +{-# INLINABLE updateResourceCount #-} +updateResourceCount r delta = + Event $ \p -> + do a <- liftIO $ readIORef (resourceCountRef r) + let a' = a + delta a' `seq` liftIO $ writeIORef (resourceCountRef r) a' + liftIO $ + modifyIORef' (resourceCountStatsRef r) $ + addTimingStats (pointTime p) a' + invokeEvent p $ + triggerSignal (resourceCountSource r) a' + +-- | Update the resource queue length and its statistics. +updateResourceQueueCount :: (MonadDES m, MonadIO m, MonadTemplate m) => Resource m -> Int -> Event m () +{-# INLINABLE updateResourceQueueCount #-} +updateResourceQueueCount r delta = + Event $ \p -> + do a <- liftIO $ readIORef (resourceQueueCountRef r) + let a' = a + delta + a' `seq` liftIO $ writeIORef (resourceQueueCountRef r) a' + liftIO $ + modifyIORef' (resourceQueueCountStatsRef r) $ + addTimingStats (pointTime p) a' + invokeEvent p $ + triggerSignal (resourceQueueCountSource r) a' + +-- | Update the resource utilisation count and its statistics. +updateResourceUtilisationCount :: (MonadDES m, MonadIO m, MonadTemplate m) => Resource m -> Int -> Event m () +{-# INLINABLE updateResourceUtilisationCount #-} +updateResourceUtilisationCount r delta = + Event $ \p -> + do a <- liftIO $ readIORef (resourceUtilisationCountRef r) + let a' = a + delta + a' `seq` liftIO $ writeIORef (resourceUtilisationCountRef r) a' + liftIO $ + modifyIORef' (resourceUtilisationCountStatsRef r) $ + addTimingStats (pointTime p) a' + invokeEvent p $ + triggerSignal (resourceUtilisationCountSource r) a' + +-- | Update the resource wait time and its statistics. +updateResourceWaitTime :: (MonadDES m, MonadIO m, MonadTemplate m) => Resource m -> Double -> Event m () +{-# INLINABLE updateResourceWaitTime #-} +updateResourceWaitTime r delta = + Event $ \p -> + do a <- liftIO $ readIORef (resourceTotalWaitTimeRef r) + let a' = a + delta + a' `seq` liftIO $ writeIORef (resourceTotalWaitTimeRef r) a' + liftIO $ + modifyIORef' (resourceWaitTimeRef r) $ + addSamplingStats delta + invokeEvent p $ + triggerSignal (resourceWaitTimeSource r) () diff --git a/Simulation/Aivika/IO/Resource/Preemption/Base.hs b/Simulation/Aivika/IO/Resource/Preemption/Base.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/Resource/Preemption/Base.hs @@ -0,0 +1,250 @@ + +{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.IO.Resource.Preemption.Base +-- Copyright : Copyright (c) 2009-2016, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.10.3 +-- +-- This module defines the optimised preemptible resource, where +-- the 'MonadIO'-based monad can be an instance of 'MonadResource'. +-- +module Simulation.Aivika.IO.Resource.Preemption.Base () where + +import Control.Monad +import Control.Monad.Trans + +import Data.Maybe +import Data.IORef + +import Simulation.Aivika.Trans.Ref.Base +import Simulation.Aivika.Trans.DES +import Simulation.Aivika.Trans.Template +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Cont +import Simulation.Aivika.Trans.Internal.Process +import Simulation.Aivika.Trans.Resource.Preemption.Base + +import Simulation.Aivika.IO.DES + +import qualified Simulation.Aivika.PriorityQueue as PQ + +-- | The 'MonadIO' based monad is an instance of 'MonadResource'. +instance (MonadDES m, MonadIO m, MonadTemplate m) => MonadResource m where + + {-# SPECIALISE instance MonadResource IO #-} + + -- | A template-based implementation of the preemptible resource. + data Resource m = + Resource { resourceMaxCount0 :: Maybe Int, + resourceCountRef :: IORef Int, + resourceActingQueue :: PQ.PriorityQueue (ResourceActingItem m), + resourceWaitQueue :: PQ.PriorityQueue (ResourceAwaitingItem m) } + + {-# INLINABLE newResource #-} + newResource count = + Simulation $ \r -> + do when (count < 0) $ + error $ + "The resource count cannot be negative: " ++ + "newResource." + countRef <- liftIO $ newIORef count + actingQueue <- liftIO PQ.newQueue + waitQueue <- liftIO PQ.newQueue + return Resource { resourceMaxCount0 = Just count, + resourceCountRef = countRef, + resourceActingQueue = actingQueue, + resourceWaitQueue = waitQueue } + + {-# INLINABLE newResourceWithMaxCount #-} + newResourceWithMaxCount count maxCount = + Simulation $ \r -> + 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 <- liftIO $ newIORef count + actingQueue <- liftIO PQ.newQueue + waitQueue <- liftIO PQ.newQueue + return Resource { resourceMaxCount0 = maxCount, + resourceCountRef = countRef, + resourceActingQueue = actingQueue, + resourceWaitQueue = waitQueue } + + {-# INLINABLE resourceCount #-} + resourceCount r = + Event $ \p -> liftIO $ readIORef (resourceCountRef r) + + {-# INLINABLE resourceMaxCount #-} + resourceMaxCount = resourceMaxCount0 + + {-# INLINABLE requestResourceWithPriority #-} + requestResourceWithPriority r priority = + Process $ \pid -> + Cont $ \c -> + Event $ \p -> + do a <- liftIO $ readIORef (resourceCountRef r) + if a == 0 + then do f <- liftIO $ PQ.queueNull (resourceActingQueue r) + if f + then do c <- invokeEvent p $ + freezeContReentering c () $ + invokeCont c $ + invokeProcess pid $ + requestResourceWithPriority r priority + liftIO $ PQ.enqueue (resourceWaitQueue r) priority (Left $ ResourceRequestingItem priority pid c) + else do (p0', item0) <- liftIO $ PQ.queueFront (resourceActingQueue r) + let p0 = - p0' + pid0 = actingItemId item0 + if priority < p0 + then do liftIO $ PQ.dequeue (resourceActingQueue r) + liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid + liftIO $ PQ.enqueue (resourceWaitQueue r) p0 (Right $ ResourcePreemptedItem p0 pid0) + invokeEvent p $ processPreemptionBegin pid0 + invokeEvent p $ resumeCont c () + else do c <- invokeEvent p $ + freezeContReentering c () $ + invokeCont c $ + invokeProcess pid $ + requestResourceWithPriority r priority + liftIO $ PQ.enqueue (resourceWaitQueue r) priority (Left $ ResourceRequestingItem priority pid c) + else do let a' = a - 1 + a' `seq` liftIO $ writeIORef (resourceCountRef r) a' + liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid + invokeEvent p $ resumeCont c () + + {-# INLINABLE releaseResource #-} + releaseResource r = + Process $ \pid -> + Cont $ \c -> + Event $ \p -> + do f <- liftIO $ fmap isJust $ PQ.queueDeleteBy (resourceActingQueue r) (\item -> actingItemId item == pid) + if f + then do invokeEvent p $ releaseResource' r + invokeEvent p $ resumeCont c () + else error $ + "The resource was not acquired by this process: releaseResource" + + {-# INLINABLE usingResourceWithPriority #-} + usingResourceWithPriority r priority m = + do requestResourceWithPriority r priority + finallyProcess m $ releaseResource r + + {-# INLINABLE incResourceCount #-} + incResourceCount r n + | n < 0 = error "The increment cannot be negative: incResourceCount" + | n == 0 = return () + | otherwise = + do releaseResource' r + incResourceCount r (n - 1) + + {-# INLINABLE decResourceCount #-} + decResourceCount r n + | n < 0 = error "The decrement cannot be negative: decResourceCount" + | n == 0 = return () + | otherwise = + do decResourceCount' r + decResourceCount r (n - 1) + + {-# INLINABLE alterResourceCount #-} + alterResourceCount r n + | n < 0 = decResourceCount r (- n) + | n > 0 = incResourceCount r n + | n == 0 = return () + +-- | Identifies an acting item that acquired the resource. +data ResourceActingItem m = + ResourceActingItem { actingItemPriority :: Double, + actingItemId :: ProcessId m } + +-- | Idenitifies an item that requests for the resource. +data ResourceRequestingItem m = + ResourceRequestingItem { requestingItemPriority :: Double, + requestingItemId :: ProcessId m, + requestingItemCont :: FrozenCont m () } + +-- | Idenitifies an item that was preempted. +data ResourcePreemptedItem m = + ResourcePreemptedItem { preemptedItemPriority :: Double, + preemptedItemId :: ProcessId m } + +-- | Idenitifies an awaiting item that waits for releasing of the resource to take it. +type ResourceAwaitingItem m = + Either (ResourceRequestingItem m) (ResourcePreemptedItem m) + +instance (MonadDES m, MonadIO m, MonadTemplate m) => Eq (Resource m) where + + {-# INLINABLE (==) #-} + x == y = resourceCountRef x == resourceCountRef y -- unique references + +instance (MonadDES m, MonadIO m, MonadTemplate m) => Eq (ResourceActingItem m) where + + {-# INLINABLE (==) #-} + x == y = actingItemId x == actingItemId y + +releaseResource' :: (MonadDES m, MonadIO m, MonadTemplate m) => Resource m -> Event m () +{-# INLINABLE releaseResource' #-} +releaseResource' r = + Event $ \p -> + do a <- liftIO $ readIORef (resourceCountRef r) + let a' = a + 1 + case resourceMaxCount r of + Just maxCount | a' > maxCount -> + error $ + "The resource count cannot be greater than " ++ + "its maximum value: releaseResource'." + _ -> + return () + f <- liftIO $ PQ.queueNull (resourceWaitQueue r) + if f + then a' `seq` liftIO $ writeIORef (resourceCountRef r) a' + else do (priority', item) <- liftIO $ PQ.queueFront (resourceWaitQueue r) + liftIO $ PQ.dequeue (resourceWaitQueue r) + case item of + Left (ResourceRequestingItem priority pid c) -> + do c <- invokeEvent p $ unfreezeCont c + case c of + Nothing -> + invokeEvent p $ releaseResource' r + Just c -> + do liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid + invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c () + Right (ResourcePreemptedItem priority pid) -> + do f <- invokeEvent p $ processCancelled pid + case f of + True -> + invokeEvent p $ releaseResource' r + False -> + do liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid + invokeEvent p $ processPreemptionEnd pid + +decResourceCount' :: (MonadDES m, MonadIO m, MonadTemplate m) => Resource m -> Event m () +{-# INLINABLE decResourceCount' #-} +decResourceCount' r = + Event $ \p -> + do a <- liftIO $ readIORef (resourceCountRef r) + when (a == 0) $ + error $ + "The resource exceeded and its count is zero: decResourceCount'" + f <- liftIO $ PQ.queueNull (resourceActingQueue r) + unless f $ + do (p0', item0) <- liftIO $ PQ.queueFront (resourceActingQueue r) + let p0 = - p0' + pid0 = actingItemId item0 + liftIO $ PQ.dequeue (resourceActingQueue r) + liftIO $ PQ.enqueue (resourceWaitQueue r) p0 (Right $ ResourcePreemptedItem p0 pid0) + invokeEvent p $ processPreemptionBegin pid0 + let a' = a - 1 + a' `seq` liftIO $ writeIORef (resourceCountRef r) a' diff --git a/Simulation/Aivika/Trans.hs b/Simulation/Aivika/Trans.hs --- a/Simulation/Aivika/Trans.hs +++ b/Simulation/Aivika/Trans.hs @@ -29,15 +29,19 @@ module Simulation.Aivika.Trans.Gate, module Simulation.Aivika.Trans.Generator, module Simulation.Aivika.Trans.Net, + module Simulation.Aivika.Trans.Net.Random, + module Simulation.Aivika.Trans.Operation, + module Simulation.Aivika.Trans.Operation.Random, module Simulation.Aivika.Trans.Parameter, module Simulation.Aivika.Trans.Parameter.Random, module Simulation.Aivika.Trans.Process, module Simulation.Aivika.Trans.Process.Random, module Simulation.Aivika.Trans.Processor, + module Simulation.Aivika.Trans.Processor.Random, module Simulation.Aivika.Trans.Processor.RoundRobbin, module Simulation.Aivika.Trans.QueueStrategy, module Simulation.Aivika.Trans.Ref, - module Simulation.Aivika.Trans.Resource, + module Simulation.Aivika.Trans.Resource.Base, module Simulation.Aivika.Trans.Results, module Simulation.Aivika.Trans.Results.Locale, module Simulation.Aivika.Trans.Results.IO, @@ -76,6 +80,8 @@ import Simulation.Aivika.Trans.Generator import Simulation.Aivika.Trans.Net import Simulation.Aivika.Trans.Net.Random +import Simulation.Aivika.Trans.Operation +import Simulation.Aivika.Trans.Operation.Random import Simulation.Aivika.Trans.Parameter import Simulation.Aivika.Trans.Parameter.Random import Simulation.Aivika.Trans.Process @@ -85,7 +91,7 @@ import Simulation.Aivika.Trans.Processor.RoundRobbin import Simulation.Aivika.Trans.QueueStrategy import Simulation.Aivika.Trans.Ref -import Simulation.Aivika.Trans.Resource +import Simulation.Aivika.Trans.Resource.Base import Simulation.Aivika.Trans.Results import Simulation.Aivika.Trans.Results.Locale import Simulation.Aivika.Trans.Results.IO diff --git a/Simulation/Aivika/Trans/Activity.hs b/Simulation/Aivika/Trans/Activity.hs --- a/Simulation/Aivika/Trans/Activity.hs +++ b/Simulation/Aivika/Trans/Activity.hs @@ -75,7 +75,6 @@ import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Event import Simulation.Aivika.Trans.Signal -import Simulation.Aivika.Trans.Resource import Simulation.Aivika.Trans.Cont import Simulation.Aivika.Trans.Process import Simulation.Aivika.Trans.Net diff --git a/Simulation/Aivika/Trans/Activity/Random.hs b/Simulation/Aivika/Trans/Activity/Random.hs --- a/Simulation/Aivika/Trans/Activity/Random.hs +++ b/Simulation/Aivika/Trans/Activity/Random.hs @@ -15,20 +15,33 @@ module Simulation.Aivika.Trans.Activity.Random (newRandomUniformActivity, newRandomUniformIntActivity, + newRandomTriangularActivity, newRandomNormalActivity, + newRandomLogNormalActivity, newRandomExponentialActivity, newRandomErlangActivity, newRandomPoissonActivity, newRandomBinomialActivity, + newRandomGammaActivity, + newRandomBetaActivity, + newRandomWeibullActivity, + newRandomDiscreteActivity, newPreemptibleRandomUniformActivity, newPreemptibleRandomUniformIntActivity, + newPreemptibleRandomTriangularActivity, newPreemptibleRandomNormalActivity, + newPreemptibleRandomLogNormalActivity, newPreemptibleRandomExponentialActivity, newPreemptibleRandomErlangActivity, newPreemptibleRandomPoissonActivity, - newPreemptibleRandomBinomialActivity) where + newPreemptibleRandomBinomialActivity, + newPreemptibleRandomGammaActivity, + newPreemptibleRandomBetaActivity, + newPreemptibleRandomWeibullActivity, + newPreemptibleRandomDiscreteActivity) where import Simulation.Aivika.Trans.DES +import Simulation.Aivika.Trans.Generator import Simulation.Aivika.Trans.Simulation import Simulation.Aivika.Trans.Process import Simulation.Aivika.Trans.Process.Random @@ -67,6 +80,24 @@ newPreemptibleRandomUniformIntActivity False -- | Create a new activity 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 activity process cannot be preempted, +-- because the handling of possible task preemption is rather costly +-- operation. +newRandomTriangularActivity :: MonadDES m + => Double + -- ^ the minimum time interval + -> Double + -- ^ the median of the time interval + -> Double + -- ^ the maximum time interval + -> Simulation m (Activity m () a a) +{-# INLINABLE newRandomTriangularActivity #-} +newRandomTriangularActivity = + newPreemptibleRandomTriangularActivity False + +-- | Create a new activity that holds the process for a random time interval -- distributed normally, when processing every input element. -- -- By default, it is assumed that the activity process cannot be preempted, @@ -83,6 +114,24 @@ newPreemptibleRandomNormalActivity False -- | Create a new activity 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 activity process cannot be preempted, +-- because the handling of possible task preemption is rather costly +-- operation. +newRandomLogNormalActivity :: MonadDES m + => 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 + -> Simulation m (Activity m () a a) +{-# INLINABLE newRandomLogNormalActivity #-} +newRandomLogNormalActivity = + newPreemptibleRandomLogNormalActivity False + +-- | Create a new activity 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. -- @@ -147,6 +196,71 @@ newPreemptibleRandomBinomialActivity False -- | Create a new activity 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 activity process cannot be preempted, +-- because the handling of possible task preemption is rather costly +-- operation. +newRandomGammaActivity :: MonadDES m + => Double + -- ^ the shape + -> Double + -- ^ the scale (a reciprocal of the rate) + -> Simulation m (Activity m () a a) +{-# INLINABLE newRandomGammaActivity #-} +newRandomGammaActivity = + newPreemptibleRandomGammaActivity False + +-- | Create a new activity 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 activity process cannot be preempted, +-- because the handling of possible task preemption is rather costly +-- operation. +newRandomBetaActivity :: MonadDES m + => Double + -- ^ shape (alpha) + -> Double + -- ^ shape (beta) + -> Simulation m (Activity m () a a) +{-# INLINABLE newRandomBetaActivity #-} +newRandomBetaActivity = + newPreemptibleRandomBetaActivity False + +-- | Create a new activity 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 activity process cannot be preempted, +-- because the handling of possible task preemption is rather costly +-- operation. +newRandomWeibullActivity :: MonadDES m + => Double + -- ^ shape + -> Double + -- ^ scale + -> Simulation m (Activity m () a a) +{-# INLINABLE newRandomWeibullActivity #-} +newRandomWeibullActivity = + newPreemptibleRandomWeibullActivity False + +-- | Create a new activity 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 activity process cannot be preempted, +-- because the handling of possible task preemption is rather costly +-- operation. +newRandomDiscreteActivity :: MonadDES m + => DiscretePDF Double + -- ^ the discrete probability density function + -> Simulation m (Activity m () a a) +{-# INLINABLE newRandomDiscreteActivity #-} +newRandomDiscreteActivity = + newPreemptibleRandomDiscreteActivity False + +-- | Create a new activity that holds the process for a random time interval -- distributed uniformly, when processing every input element. newPreemptibleRandomUniformActivity :: MonadDES m => Bool @@ -179,6 +293,24 @@ return a -- | Create a new activity that holds the process for a random time interval +-- having the triangular distribution, when processing every input element. +newPreemptibleRandomTriangularActivity :: MonadDES m + => Bool + -- ^ whether the activity process can be preempted + -> Double + -- ^ the minimum time interval + -> Double + -- ^ the median of the time interval + -> Double + -- ^ the maximum time interval + -> Simulation m (Activity m () a a) +{-# INLINABLE newPreemptibleRandomTriangularActivity #-} +newPreemptibleRandomTriangularActivity preemptible min median max = + newPreemptibleActivity preemptible $ \a -> + do randomTriangularProcess_ min median max + return a + +-- | Create a new activity that holds the process for a random time interval -- distributed normally, when processing every input element. newPreemptibleRandomNormalActivity :: MonadDES m => Bool @@ -193,6 +325,24 @@ newPreemptibleActivity preemptible $ \a -> do randomNormalProcess_ mu nu return a + +-- | Create a new activity that holds the process for a random time interval +-- having the lognormal distribution, when processing every input element. +newPreemptibleRandomLogNormalActivity :: MonadDES m + => Bool + -- ^ whether the activity 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 + -> Simulation m (Activity m () a a) +{-# INLINABLE newPreemptibleRandomLogNormalActivity #-} +newPreemptibleRandomLogNormalActivity preemptible mu nu = + newPreemptibleActivity preemptible $ \a -> + do randomLogNormalProcess_ mu nu + return a -- | Create a new activity that holds the process for a random time interval -- distributed exponentially with the specified mean (the reciprocal of the rate), @@ -256,4 +406,69 @@ newPreemptibleRandomBinomialActivity preemptible prob trials = newPreemptibleActivity preemptible $ \a -> do randomBinomialProcess_ prob trials + return a + +-- | Create a new activity that holds the process for a random time interval +-- having the Gamma distribution with the specified shape and scale, +-- when processing every input element. +newPreemptibleRandomGammaActivity :: MonadDES m + => Bool + -- ^ whether the activity process can be preempted + -> Double + -- ^ the shape + -> Double + -- ^ the scale + -> Simulation m (Activity m () a a) +{-# INLINABLE newPreemptibleRandomGammaActivity #-} +newPreemptibleRandomGammaActivity preemptible kappa theta = + newPreemptibleActivity preemptible $ \a -> + do randomGammaProcess_ kappa theta + return a + +-- | Create a new activity 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. +newPreemptibleRandomBetaActivity :: MonadDES m + => Bool + -- ^ whether the activity process can be preempted + -> Double + -- ^ shape (alpha) + -> Double + -- ^ shape (beta) + -> Simulation m (Activity m () a a) +{-# INLINABLE newPreemptibleRandomBetaActivity #-} +newPreemptibleRandomBetaActivity preemptible alpha beta = + newPreemptibleActivity preemptible $ \a -> + do randomBetaProcess_ alpha beta + return a + +-- | Create a new activity that holds the process for a random time interval +-- having the Weibull distribution with the specified shape and scale, +-- when processing every input element. +newPreemptibleRandomWeibullActivity :: MonadDES m + => Bool + -- ^ whether the activity process can be preempted + -> Double + -- ^ shape + -> Double + -- ^ scale + -> Simulation m (Activity m () a a) +{-# INLINABLE newPreemptibleRandomWeibullActivity #-} +newPreemptibleRandomWeibullActivity preemptible alpha beta = + newPreemptibleActivity preemptible $ \a -> + do randomWeibullProcess_ alpha beta + return a + +-- | Create a new activity that holds the process for a random time interval +-- having the specified discrete distribution, when processing every input element. +newPreemptibleRandomDiscreteActivity :: MonadDES m + => Bool + -- ^ whether the activity process can be preempted + -> DiscretePDF Double + -- ^ the discrete probability density function + -> Simulation m (Activity m () a a) +{-# INLINABLE newPreemptibleRandomDiscreteActivity #-} +newPreemptibleRandomDiscreteActivity preemptible dpdf = + newPreemptibleActivity preemptible $ \a -> + do randomDiscreteProcess_ dpdf return a diff --git a/Simulation/Aivika/Trans/Dynamics/Random.hs b/Simulation/Aivika/Trans/Dynamics/Random.hs --- a/Simulation/Aivika/Trans/Dynamics/Random.hs +++ b/Simulation/Aivika/Trans/Dynamics/Random.hs @@ -22,11 +22,17 @@ module Simulation.Aivika.Trans.Dynamics.Random (memoRandomUniformDynamics, memoRandomUniformIntDynamics, + memoRandomTriangularDynamics, memoRandomNormalDynamics, + memoRandomLogNormalDynamics, memoRandomExponentialDynamics, memoRandomErlangDynamics, memoRandomPoissonDynamics, - memoRandomBinomialDynamics) where + memoRandomBinomialDynamics, + memoRandomGammaDynamics, + memoRandomBetaDynamics, + memoRandomWeibullDynamics, + memoRandomDiscreteDynamics) where import Simulation.Aivika.Trans.Generator import Simulation.Aivika.Trans.Internal.Specs @@ -66,6 +72,23 @@ max' <- invokeDynamics p max generateUniformInt g min' max' +-- | Computation that generates random numbers from the triangular distribution +-- and memoizes the numbers in the integration time points. +memoRandomTriangularDynamics :: MonadSD m + => Dynamics m Double -- ^ minimum + -> Dynamics m Double -- ^ median + -> Dynamics m Double -- ^ maximum + -> Simulation m (Dynamics m Double) +{-# INLINABLE memoRandomTriangularDynamics #-} +memoRandomTriangularDynamics min median max = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + min' <- invokeDynamics p min + median' <- invokeDynamics p median + max' <- invokeDynamics p max + generateTriangular g min' median' max' + -- | Computation that generates random numbers distributed normally and -- memoizes them in the integration time points. memoRandomNormalDynamics :: MonadSD m @@ -81,6 +104,25 @@ nu' <- invokeDynamics p nu generateNormal g mu' nu' +-- | Computation that generates random numbers from the lognormal distribution +-- and memoizes the numbers in the integration time points. +memoRandomLogNormalDynamics :: MonadSD m + => Dynamics m Double + -- ^ the mean of a normal distribution which + -- this distribution is derived from + -> Dynamics m Double + -- ^ the deviation of a normal distribution which + -- this distribution is derived from + -> Simulation m (Dynamics m Double) +{-# INLINABLE memoRandomLogNormalDynamics #-} +memoRandomLogNormalDynamics mu nu = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + mu' <- invokeDynamics p mu + nu' <- invokeDynamics p nu + generateLogNormal 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 :: MonadSD m @@ -141,3 +183,62 @@ prob' <- invokeDynamics p prob trials' <- invokeDynamics p trials generateBinomial g prob' trials' + +-- | Computation that generates random numbers from the Gamma distribution +-- with the specified shape and scale but memoizes the numbers in +-- the integration time points. +memoRandomGammaDynamics :: MonadSD m + => Dynamics m Double -- ^ shape + -> Dynamics m Double -- ^ scale (a reciprocal of the rate) + -> Simulation m (Dynamics m Double) +{-# INLINABLE memoRandomGammaDynamics #-} +memoRandomGammaDynamics kappa theta = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + kappa' <- invokeDynamics p kappa + theta' <- invokeDynamics p theta + generateGamma g kappa' theta' + +-- | Computation that generates random numbers from the Beta distribution +-- by the specified shape parameters and memoizes the numbers in +-- the integration time points. +memoRandomBetaDynamics :: MonadSD m + => Dynamics m Double -- ^ shape (alpha) + -> Dynamics m Double -- ^ shape (beta) + -> Simulation m (Dynamics m Double) +{-# INLINABLE memoRandomBetaDynamics #-} +memoRandomBetaDynamics alpha beta = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + alpha' <- invokeDynamics p alpha + beta' <- invokeDynamics p beta + generateBeta g alpha' beta' + +-- | Computation that generates random numbers from the Weibull distribution +-- with the specified shape and scale but memoizes the numbers in +-- the integration time points. +memoRandomWeibullDynamics :: MonadSD m + => Dynamics m Double -- ^ shape + -> Dynamics m Double -- ^ scale + -> Simulation m (Dynamics m Double) +{-# INLINABLE memoRandomWeibullDynamics #-} +memoRandomWeibullDynamics alpha beta = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + alpha' <- invokeDynamics p alpha + beta' <- invokeDynamics p beta + generateWeibull g alpha' beta' + +-- | Computation that generates random values from the specified discrete +-- distribution and memoizes the values in the integration time points. +memoRandomDiscreteDynamics :: (MonadSD m, MonadMemo m a) => Dynamics m (DiscretePDF a) -> Simulation m (Dynamics m a) +{-# INLINABLE memoRandomDiscreteDynamics #-} +memoRandomDiscreteDynamics dpdf = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + dpdf' <- invokeDynamics p dpdf + generateDiscrete g dpdf' diff --git a/Simulation/Aivika/Trans/Generator.hs b/Simulation/Aivika/Trans/Generator.hs --- a/Simulation/Aivika/Trans/Generator.hs +++ b/Simulation/Aivika/Trans/Generator.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies, RankNTypes #-} -- | -- Module : Simulation.Aivika.Trans.Generator @@ -13,10 +13,13 @@ -- module Simulation.Aivika.Trans.Generator (MonadGenerator(..), - GeneratorType(..)) where + GeneratorType(..), + DiscretePDF(..)) where import System.Random +import Simulation.Aivika.Generator (DiscretePDF) + -- | Defines a monad whithin which computation the random number generator can work. class (Functor m, Monad m) => MonadGenerator m where @@ -30,10 +33,18 @@ -- | Generate an uniform integer random number -- with the specified minimum and maximum. generateUniformInt :: Generator m -> Int -> Int -> m Int + + -- | Generate a triangular random number + -- by the specified minimum, median and maximum. + generateTriangular :: Generator m -> Double -> Double -> Double -> m Double -- | Generate a normal random number -- with the specified mean and deviation. generateNormal :: Generator m -> Double -> Double -> m Double + + -- | Generate a random number from the lognormal distribution derived + -- from a normal distribution with the specified mean and deviation. + generateLogNormal :: Generator m -> Double -> Double -> m Double -- | Generate a random number distributed exponentially -- with the specified mean (the reciprocal of the rate). @@ -50,7 +61,30 @@ -- | Generate the binomial random number -- with the specified probability and number of trials. generateBinomial :: Generator m -> Double -> Int -> m Int - + + -- | Generate a random number from the Gamma distribution with + -- the specified shape (kappa) and scale (theta, a reciprocal of the rate). + -- + -- The probability density for the Gamma distribution is + -- + -- @f x = x ** (kappa - 1) * exp (- x \/ theta) \/ theta ** kappa * Gamma kappa@ + generateGamma :: Generator m -> Double -> Double -> m Double + + -- | Generate a random number from the Beta distribution by + -- the specified shape parameters (alpha and beta). + -- + -- The probability density for the Beta distribution is + -- + -- @f x = x ** (alpha - 1) * (1 - x) ** (beta - 1) \/ B alpha beta@ + generateBeta :: Generator m -> Double -> Double -> m Double + + -- | Generate a random number from the Weibull distribution by + -- the specified shape and scale. + generateWeibull :: Generator m -> Double -> Double -> m Double + + -- | Generate a random value from the specified discrete distribution. + generateDiscrete :: forall a. Generator m -> DiscretePDF a -> m a + -- | Create a new random number generator. newGenerator :: GeneratorType m -> m (Generator m) diff --git a/Simulation/Aivika/Trans/Generator/Primitive.hs b/Simulation/Aivika/Trans/Generator/Primitive.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Generator/Primitive.hs @@ -0,0 +1,243 @@ + +-- | +-- Module : Simulation.Aivika.Trans.Generator.Primitive +-- Copyright : Copyright (c) 2009-2016, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.10.3 +-- +-- This helper module defines primitives for generating random numbers. +-- +module Simulation.Aivika.Trans.Generator.Primitive where + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Generator (DiscretePDF) + +-- | Generate an uniform random number with the specified minimum and maximum. +generateUniform01 :: Monad m + => m Double + -- ^ the uniform random number ~ U (0, 1) + -> Double + -- ^ minimum + -> Double + -- ^ maximum + -> m Double +{-# INLINE generateUniform01 #-} +generateUniform01 g min max = + do x <- g + return $ min + x * (max - min) + +-- | Generate an uniform random number with the specified minimum and maximum. +generateUniformInt01 :: Monad m + => m Double + -- ^ the uniform random number ~ U (0, 1) + -> Int + -- ^ minimum + -> Int + -- ^ maximum + -> m Int +{-# INLINE generateUniformInt01 #-} +generateUniformInt01 g min max = + do x <- g + let min' = fromIntegral min + max' = fromIntegral max + return $ round (min' + x * (max' - min')) + +-- | Generate the triangular random number by the specified minimum, median and maximum. +generateTriangular01 :: Monad m + => m Double + -- ^ the uniform random number ~ U (0, 1) + -> Double + -- ^ minimum + -> Double + -- ^ median + -> Double + -- ^ maximum + -> m Double +{-# INLINE generateTriangular01 #-} +generateTriangular01 g min median max = + do x <- g + if x <= (median - min) / (max - min) + then return $ min + sqrt ((median - min) * (max - min) * x) + else return $ max - sqrt ((max - median) * (max - min) * (1 - x)) + +-- | Generate a normal random number by the specified generator, mean and variance. +generateNormal01 :: Monad m + => m Double + -- ^ the normal random number ~ N (0, 1) + -> Double + -- ^ mean + -> Double + -- ^ variance + -> m Double +{-# INLINE generateNormal01 #-} +generateNormal01 g mu nu = + do x <- g + return $ mu + nu * x + +-- | Generate the lognormal random number derived from a normal distribution with +-- the specified generator, mean and variance. +generateLogNormal01 :: Monad m + => m Double + -- ^ the normal random number ~ N (0, 1) + -> Double + -- ^ mean + -> Double + -- ^ variance + -> m Double +{-# INLINE generateLogNormal01 #-} +generateLogNormal01 g mu nu = + do x <- g + return $ exp (mu + nu * x) + +-- | Return the exponential random number with the specified mean. +generateExponential01 :: Monad m + => m Double + -- ^ the uniform random number ~ U (0, 1) + -> Double + -- ^ the mean + -> m Double +{-# INLINE generateExponential01 #-} +generateExponential01 g mu = + do x <- g + return (- log x * mu) + +-- | Return the Erlang random number. +generateErlang01 :: Monad m + => m Double + -- ^ the uniform random number ~ U (0, 1) + -> Double + -- ^ the scale + -> Int + -- ^ the shape + -> m Double +{-# INLINABLE generateErlang01 #-} +generateErlang01 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. +generatePoisson01 :: Monad m + => m Double + -- ^ the uniform random number ~ U (0, 1) + -> Double + -- ^ the mean + -> m Int +{-# INLINABLE generatePoisson01 #-} +generatePoisson01 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. +generateBinomial01 :: Monad m + => m Double + -- ^ the uniform random number ~ U (0, 1) + -> Double + -- ^ the probability + -> Int + -- ^ the number of trials + -> m Int +{-# INLINABLE generateBinomial01 #-} +generateBinomial01 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 + +-- | Generate a random number from the Gamma distribution using Marsaglia and Tsang method. +generateGamma01 :: Monad m + => m Double + -- ^ the normal random number ~ N (0,1) + -> m Double + -- ^ the uniform random number ~ U (0, 1) + -> Double + -- ^ the shape parameter (kappa) + -> Double + -- ^ the scale parameter (theta) + -> m Double +{-# INLINABLE generateGamma01 #-} +generateGamma01 gn gu kappa theta + | kappa <= 0 = error "The shape parameter (kappa) must be positive: generateGamma01" + | kappa > 1 = + let d = kappa - 1 / 3 + c = 1 / sqrt (9 * d) + loop = + do z <- gn + if z <= - (1 / c) + then loop + else do let v = (1 + c * z) ** 3 + u <- gu + if log u > 0.5 * z * z + d - d * v + d * log v + then loop + else return $ d * v * theta + in loop + | otherwise = + do x <- generateGamma01 gn gu (1 + kappa) theta + u <- gu + return $ x * u ** (1 / kappa) + +-- | Generate a random number from the Beta distribution. +generateBeta01 :: Monad m + => m Double + -- ^ the normal random number ~ N (0, 1) + -> m Double + -- ^ the uniform random number ~ U (0, 1) + -> Double + -- ^ the shape parameter alpha + -> Double + -- ^ the shape parameter beta + -> m Double +{-# INLINABLE generateBeta01 #-} +generateBeta01 gn gu alpha beta = + do g1 <- generateGamma01 gn gu alpha 1 + g2 <- generateGamma01 gn gu beta 1 + return $ g1 / (g1 + g2) + +-- | Generate a random number from the Weibull distribution. +generateWeibull01 :: Monad m + => m Double + -- ^ the uniform random number ~ U (0, 1) + -> Double + -- ^ shape + -> Double + -- ^ scale + -> m Double +{-# INLINE generateWeibull01 #-} +generateWeibull01 g alpha beta = + do x <- g + return $ beta * (- log x) ** (1 / alpha) + +-- | Generate a random value from the specified discrete distribution. +generateDiscrete01 :: Monad m + => m Double + -- ^ the uniform random number ~ U (0, 1) + -> DiscretePDF a + -- ^ a discrete probability density function + -> m a +{-# INLINABLE generateDiscrete01 #-} +generateDiscrete01 g [] = error "Empty PDF: generateDiscrete01" +generateDiscrete01 g dpdf = + do x <- g + let loop acc [(a, p)] = a + loop acc ((a, p) : dpdf) = + if x <= acc + p + then a + else loop (acc + p) dpdf + return $ loop 0 dpdf diff --git a/Simulation/Aivika/Trans/Net.hs b/Simulation/Aivika/Trans/Net.hs --- a/Simulation/Aivika/Trans/Net.hs +++ b/Simulation/Aivika/Trans/Net.hs @@ -61,7 +61,7 @@ import Simulation.Aivika.Trans.Process import Simulation.Aivika.Trans.Stream import Simulation.Aivika.Trans.QueueStrategy -import Simulation.Aivika.Trans.Resource +import Simulation.Aivika.Trans.Resource.Base import Simulation.Aivika.Trans.Processor import Simulation.Aivika.Trans.Circuit import Simulation.Aivika.Arrival (Arrival(..)) diff --git a/Simulation/Aivika/Trans/Net/Random.hs b/Simulation/Aivika/Trans/Net/Random.hs --- a/Simulation/Aivika/Trans/Net/Random.hs +++ b/Simulation/Aivika/Trans/Net/Random.hs @@ -15,13 +15,20 @@ module Simulation.Aivika.Trans.Net.Random (randomUniformNet, randomUniformIntNet, + randomTriangularNet, randomNormalNet, + randomLogNormalNet, randomExponentialNet, randomErlangNet, randomPoissonNet, - randomBinomialNet) where + randomBinomialNet, + randomGammaNet, + randomBetaNet, + randomWeibullNet, + randomDiscreteNet) where import Simulation.Aivika.Trans.DES +import Simulation.Aivika.Trans.Generator import Simulation.Aivika.Trans.Process import Simulation.Aivika.Trans.Process.Random import Simulation.Aivika.Trans.Net @@ -53,6 +60,21 @@ randomUniformIntProcess_ min max -- | When processing every input element, hold the process +-- for a random time interval having the triangular distribution. +randomTriangularNet :: MonadDES m + => Double + -- ^ the minimum time interval + -> Double + -- ^ the median of the time interval + -> Double + -- ^ the maximum time interval + -> Net m a a +{-# INLINABLE randomTriangularNet #-} +randomTriangularNet min median max = + withinNet $ + randomTriangularProcess_ min median max + +-- | When processing every input element, hold the process -- for a random time interval distributed normally. randomNormalNet :: MonadDES m => Double @@ -66,6 +88,21 @@ randomNormalProcess_ mu nu -- | When processing every input element, hold the process +-- for a random time interval having the lognormal distribution. +randomLogNormalNet :: MonadDES m + => 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 + -> Net m a a +{-# INLINABLE randomLogNormalNet #-} +randomLogNormalNet mu nu = + withinNet $ + randomLogNormalProcess_ mu nu + +-- | When processing every input element, hold the process -- for a random time interval distributed exponentially -- with the specified mean (the reciprocal of the rate). randomExponentialNet :: MonadDES m @@ -116,3 +153,56 @@ randomBinomialNet prob trials = withinNet $ randomBinomialProcess_ prob trials + +-- | When processing every input element, hold the process +-- for a random time interval having the Gamma distribution +-- with the specified shape and scale. +randomGammaNet :: MonadDES m + => Double + -- ^ the shape + -> Double + -- ^ the scale (a reciprocal of the rate) + -> Net m a a +{-# INLINABLE randomGammaNet #-} +randomGammaNet kappa theta = + withinNet $ + randomGammaProcess_ kappa theta + +-- | When processing every input element, hold the process +-- for a random time interval having the Beta distribution +-- with the specified shape parameters (alpha and beta). +randomBetaNet :: MonadDES m + => Double + -- ^ shape (alpha) + -> Double + -- ^ shape (beta) + -> Net m a a +{-# INLINABLE randomBetaNet #-} +randomBetaNet alpha beta = + withinNet $ + randomBetaProcess_ alpha beta + +-- | When processing every input element, hold the process +-- for a random time interval having the Weibull distribution +-- with the specified shape and scale. +randomWeibullNet :: MonadDES m + => Double + -- ^ shape + -> Double + -- ^ scale + -> Net m a a +{-# INLINABLE randomWeibullNet #-} +randomWeibullNet alpha beta = + withinNet $ + randomWeibullProcess_ alpha beta + +-- | When processing every input element, hold the process +-- for a random time interval having the specified discrete distribution. +randomDiscreteNet :: MonadDES m + => DiscretePDF Double + -- ^ the discrete probability density function + -> Net m a a +{-# INLINABLE randomDiscreteNet #-} +randomDiscreteNet dpdf = + withinNet $ + randomDiscreteProcess_ dpdf diff --git a/Simulation/Aivika/Trans/Operation.hs b/Simulation/Aivika/Trans/Operation.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Operation.hs @@ -0,0 +1,413 @@ + +-- | +-- Module : Simulation.Aivika.Trans.Operation +-- Copyright : Copyright (c) 2009-2016, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.10.3 +-- +-- It defines a stateless activity, some simplification of 'Server' and 'Activity'. +module Simulation.Aivika.Trans.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.Monoid + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Ref.Base +import Simulation.Aivika.Trans.DES +import Simulation.Aivika.Trans.Parameter +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Signal +import Simulation.Aivika.Trans.Cont +import Simulation.Aivika.Trans.Process +import Simulation.Aivika.Trans.Activity +import Simulation.Aivika.Trans.Server +import Simulation.Aivika.Trans.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 m a b = + Operation { operationInitProcess :: a -> Process m b, + -- ^ Provide @b@ by specified @a@. + operationProcessPreemptible :: Bool, + -- ^ Whether the process is preemptible. + operationStartTime :: Double, + -- ^ The start time of creating the operation. + operationLastTimeRef :: Ref m Double, + -- ^ The last time of utilising the operation activity. + operationTotalUtilisationTimeRef :: Ref m Double, + -- ^ The counted total time of utilising the activity. + operationTotalPreemptionTimeRef :: Ref m Double, + -- ^ The counted total time when the activity was preempted. + operationUtilisationTimeRef :: Ref m (SamplingStats Double), + -- ^ The statistics for the utilisation time. + operationPreemptionTimeRef :: Ref m (SamplingStats Double), + -- ^ The statistics for the time when the activity was preempted. + operationUtilisingSource :: SignalSource m a, + -- ^ A signal raised when starting to utilise the activity. + operationUtilisedSource :: SignalSource m (a, b), + -- ^ A signal raised when the activity has been utilised. + operationPreemptionBeginningSource :: SignalSource m a, + -- ^ A signal raised when the utilisation was preempted. + operationPreemptionEndingSource :: SignalSource m 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 :: MonadDES m + => (a -> Process m b) + -- ^ provide an output by the specified input + -> Event m (Operation m a b) +{-# INLINABLE newOperation #-} +newOperation = newPreemptibleOperation False + +-- | Create a new operation that can provide output @b@ by input @a@. +newPreemptibleOperation :: MonadDES m + => Bool + -- ^ whether the activity can be preempted + -> (a -> Process m b) + -- ^ provide an output by the specified input + -> Event m (Operation m a b) +{-# INLINABLE newPreemptibleOperation #-} +newPreemptibleOperation preemptible provide = + do t0 <- liftDynamics time + r0 <- liftSimulation $ newRef t0 + r1 <- liftSimulation $ newRef 0 + r2 <- liftSimulation $ newRef 0 + r3 <- liftSimulation $ newRef emptySamplingStats + r4 <- liftSimulation $ newRef 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 :: MonadDES m => Operation m a b -> a -> Process m b +{-# INLINABLE operationProcess #-} +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 modifyRef (operationTotalUtilisationTimeRef op) (+ (t1 - t0 - dt)) + modifyRef (operationUtilisationTimeRef op) $ + addSamplingStats (t1 - t0 - dt) + writeRef (operationLastTimeRef op) t1 + triggerSignal (operationUtilisedSource op) (a, b) + return b + +-- | Process the input with ability to handle a possible preemption. +operationProcessPreempting :: MonadDES m => Operation m a b -> a -> Process m (b, Double) +{-# INLINABLE operationProcessPreempting #-} +operationProcessPreempting op a = + do pid <- processId + t0 <- liftDynamics time + rs <- liftSimulation $ newRef 0 + r0 <- liftSimulation $ newRef t0 + h1 <- liftEvent $ + handleSignal (processPreemptionBeginning pid) $ \() -> + do t0 <- liftDynamics time + writeRef r0 t0 + triggerSignal (operationPreemptionBeginningSource op) a + h2 <- liftEvent $ + handleSignal (processPreemptionEnding pid) $ \() -> + do t0 <- readRef r0 + t1 <- liftDynamics time + let dt = t1 - t0 + modifyRef rs (+ dt) + modifyRef (operationTotalPreemptionTimeRef op) (+ dt) + modifyRef (operationPreemptionTimeRef op) $ + addSamplingStats dt + writeRef (operationLastTimeRef op) t1 + triggerSignal (operationPreemptionEndingSource op) a + let m1 = + do b <- operationInitProcess op a + dt <- liftEvent $ readRef 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 :: MonadDES m => Operation m a b -> Event m Double +{-# INLINABLE operationTotalUtilisationTime #-} +operationTotalUtilisationTime op = + Event $ \p -> invokeEvent p $ readRef (operationTotalUtilisationTimeRef op) + +-- | Signal when the 'operationTotalUtilisationTime' property value has changed. +operationTotalUtilisationTimeChanged :: MonadDES m => Operation m a b -> Signal m Double +{-# INLINABLE operationTotalUtilisationTimeChanged #-} +operationTotalUtilisationTimeChanged op = + mapSignalM (const $ operationTotalUtilisationTime op) (operationTotalUtilisationTimeChanged_ op) + +-- | Signal when the 'operationTotalUtilisationTime' property value has changed. +operationTotalUtilisationTimeChanged_ :: MonadDES m => Operation m a b -> Signal m () +{-# INLINABLE operationTotalUtilisationTimeChanged_ #-} +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 :: MonadDES m => Operation m a b -> Event m Double +{-# INLINABLE operationTotalPreemptionTime #-} +operationTotalPreemptionTime op = + Event $ \p -> invokeEvent p $ readRef (operationTotalPreemptionTimeRef op) + +-- | Signal when the 'operationTotalPreemptionTime' property value has changed. +operationTotalPreemptionTimeChanged :: MonadDES m => Operation m a b -> Signal m Double +{-# INLINABLE operationTotalPreemptionTimeChanged #-} +operationTotalPreemptionTimeChanged op = + mapSignalM (const $ operationTotalPreemptionTime op) (operationTotalPreemptionTimeChanged_ op) + +-- | Signal when the 'operationTotalPreemptionTime' property value has changed. +operationTotalPreemptionTimeChanged_ :: MonadDES m => Operation m a b -> Signal m () +{-# INLINABLE operationTotalPreemptionTimeChanged_ #-} +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 :: MonadDES m => Operation m a b -> Event m (SamplingStats Double) +{-# INLINABLE operationUtilisationTime #-} +operationUtilisationTime op = + Event $ \p -> invokeEvent p $ readRef (operationUtilisationTimeRef op) + +-- | Signal when the 'operationUtilisationTime' property value has changed. +operationUtilisationTimeChanged :: MonadDES m => Operation m a b -> Signal m (SamplingStats Double) +{-# INLINABLE operationUtilisationTimeChanged #-} +operationUtilisationTimeChanged op = + mapSignalM (const $ operationUtilisationTime op) (operationUtilisationTimeChanged_ op) + +-- | Signal when the 'operationUtilisationTime' property value has changed. +operationUtilisationTimeChanged_ :: MonadDES m => Operation m a b -> Signal m () +{-# INLINABLE operationUtilisationTimeChanged_ #-} +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 :: MonadDES m => Operation m a b -> Event m (SamplingStats Double) +{-# INLINABLE operationPreemptionTime #-} +operationPreemptionTime op = + Event $ \p -> invokeEvent p $ readRef (operationPreemptionTimeRef op) + +-- | Signal when the 'operationPreemptionTime' property value has changed. +operationPreemptionTimeChanged :: MonadDES m => Operation m a b -> Signal m (SamplingStats Double) +{-# INLINABLE operationPreemptionTimeChanged #-} +operationPreemptionTimeChanged op = + mapSignalM (const $ operationPreemptionTime op) (operationPreemptionTimeChanged_ op) + +-- | Signal when the 'operationPreemptionTime' property value has changed. +operationPreemptionTimeChanged_ :: MonadDES m => Operation m a b -> Signal m () +{-# INLINABLE operationPreemptionTimeChanged_ #-} +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 :: MonadDES m => Operation m a b -> Event m Double +{-# INLINABLE operationUtilisationFactor #-} +operationUtilisationFactor op = + Event $ \p -> + do let t0 = operationStartTime op + t1 <- invokeEvent p $ readRef (operationLastTimeRef op) + x <- invokeEvent p $ readRef (operationTotalUtilisationTimeRef op) + return (x / (t1 - t0)) + +-- | Signal when the 'operationUtilisationFactor' property value has changed. +operationUtilisationFactorChanged :: MonadDES m => Operation m a b -> Signal m Double +{-# INLINABLE operationUtilisationFactorChanged #-} +operationUtilisationFactorChanged op = + mapSignalM (const $ operationUtilisationFactor op) (operationUtilisationFactorChanged_ op) + +-- | Signal when the 'operationUtilisationFactor' property value has changed. +operationUtilisationFactorChanged_ :: MonadDES m => Operation m a b -> Signal m () +{-# INLINABLE operationUtilisationFactorChanged_ #-} +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 :: MonadDES m => Operation m a b -> Event m Double +{-# INLINABLE operationPreemptionFactor #-} +operationPreemptionFactor op = + Event $ \p -> + do let t0 = operationStartTime op + t1 <- invokeEvent p $ readRef (operationLastTimeRef op) + x <- invokeEvent p $ readRef (operationTotalPreemptionTimeRef op) + return (x / (t1 - t0)) + +-- | Signal when the 'operationPreemptionFactor' property value has changed. +operationPreemptionFactorChanged :: MonadDES m => Operation m a b -> Signal m Double +{-# INLINABLE operationPreemptionFactorChanged #-} +operationPreemptionFactorChanged op = + mapSignalM (const $ operationPreemptionFactor op) (operationPreemptionFactorChanged_ op) + +-- | Signal when the 'operationPreemptionFactor' property value has changed. +operationPreemptionFactorChanged_ :: MonadDES m => Operation m a b -> Signal m () +{-# INLINABLE operationPreemptionFactorChanged_ #-} +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 :: MonadDES m => Operation m a b -> Signal m a +{-# INLINABLE operationUtilising #-} +operationUtilising = publishSignal . operationUtilisingSource + +-- | Raised when the operation activity has been utilised after the current task is processed. +operationUtilised :: MonadDES m => Operation m a b -> Signal m (a, b) +{-# INLINABLE operationUtilised #-} +operationUtilised = publishSignal . operationUtilisedSource + +-- | Raised when the operation activity utilisation was preempted. +operationPreemptionBeginning :: MonadDES m => Operation m a b -> Signal m a +{-# INLINABLE operationPreemptionBeginning #-} +operationPreemptionBeginning = publishSignal . operationPreemptionBeginningSource + +-- | Raised when the operation activity utilisation was proceeded after it had been preempted earlier. +operationPreemptionEnding :: MonadDES m => Operation m a b -> Signal m a +{-# INLINABLE operationPreemptionEnding #-} +operationPreemptionEnding = publishSignal . operationPreemptionEndingSource + +-- | Signal whenever any property of the operation changes. +operationChanged_ :: MonadDES m => Operation m a b -> Signal m () +{-# INLINABLE operationChanged_ #-} +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 :: MonadDES m => Operation m a b -> Int -> Event m ShowS +{-# INLINABLE operationSummary #-} +operationSummary op indent = + Event $ \p -> + do let t0 = operationStartTime op + t1 <- invokeEvent p $ readRef (operationLastTimeRef op) + tx1 <- invokeEvent p $ readRef (operationTotalUtilisationTimeRef op) + tx2 <- invokeEvent p $ readRef (operationTotalPreemptionTimeRef op) + let xf1 = tx1 / (t1 - t0) + xf2 = tx2 / (t1 - t0) + xs1 <- invokeEvent p $ readRef (operationUtilisationTimeRef op) + xs2 <- invokeEvent p $ readRef (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/Trans/Operation/Random.hs b/Simulation/Aivika/Trans/Operation/Random.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Operation/Random.hs @@ -0,0 +1,461 @@ + +-- | +-- Module : Simulation.Aivika.Trans.Operation.Random +-- Copyright : Copyright (c) 2009-2016, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.10.3 +-- +-- 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.Trans.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.Trans.DES +import Simulation.Aivika.Trans.Generator +import Simulation.Aivika.Trans.Event +import Simulation.Aivika.Trans.Process +import Simulation.Aivika.Trans.Process.Random +import Simulation.Aivika.Trans.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 :: MonadDES m + => Double + -- ^ the minimum time interval + -> Double + -- ^ the maximum time interval + -> Event m (Operation m a a) +{-# INLINABLE newRandomUniformOperation #-} +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 :: MonadDES m + => Int + -- ^ the minimum time interval + -> Int + -- ^ the maximum time interval + -> Event m (Operation m a a) +{-# INLINABLE newRandomUniformIntOperation #-} +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 :: MonadDES m + => Double + -- ^ the minimum time interval + -> Double + -- ^ the median of the time interval + -> Double + -- ^ the maximum time interval + -> Event m (Operation m a a) +{-# INLINABLE newRandomTriangularOperation #-} +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 :: MonadDES m + => Double + -- ^ the mean time interval + -> Double + -- ^ the time interval deviation + -> Event m (Operation m a a) +{-# INLINABLE newRandomNormalOperation #-} +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 :: MonadDES m + => 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 m (Operation m a a) +{-# INLINABLE newRandomLogNormalOperation #-} +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 :: MonadDES m + => Double + -- ^ the mean time interval (the reciprocal of the rate) + -> Event m (Operation m a a) +{-# INLINABLE newRandomExponentialOperation #-} +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 :: MonadDES m + => Double + -- ^ the scale (the reciprocal of the rate) + -> Int + -- ^ the shape + -> Event m (Operation m a a) +{-# INLINABLE newRandomErlangOperation #-} +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 :: MonadDES m + => Double + -- ^ the mean time interval + -> Event m (Operation m a a) +{-# INLINABLE newRandomPoissonOperation #-} +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 :: MonadDES m + => Double + -- ^ the probability + -> Int + -- ^ the number of trials + -> Event m (Operation m a a) +{-# INLINABLE newRandomBinomialOperation #-} +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 :: MonadDES m + => Double + -- ^ the shape + -> Double + -- ^ the scale (a reciprocal of the rate) + -> Event m (Operation m a a) +{-# INLINABLE newRandomGammaOperation #-} +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 :: MonadDES m + => Double + -- ^ shape (alpha) + -> Double + -- ^ shape (beta) + -> Event m (Operation m a a) +{-# INLINABLE newRandomBetaOperation #-} +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 :: MonadDES m + => Double + -- ^ shape + -> Double + -- ^ scale + -> Event m (Operation m a a) +{-# INLINABLE newRandomWeibullOperation #-} +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 :: MonadDES m + => DiscretePDF Double + -- ^ the discrete probability density function + -> Event m (Operation m a a) +{-# INLINABLE newRandomDiscreteOperation #-} +newRandomDiscreteOperation = + newPreemptibleRandomDiscreteOperation False + +-- | Create a new operation that holds the process for a random time interval +-- distributed uniformly, when processing every input element. +newPreemptibleRandomUniformOperation :: MonadDES m + => Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the minimum time interval + -> Double + -- ^ the maximum time interval + -> Event m (Operation m a a) +{-# INLINABLE newPreemptibleRandomUniformOperation #-} +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 :: MonadDES m + => Bool + -- ^ whether the operation process can be preempted + -> Int + -- ^ the minimum time interval + -> Int + -- ^ the maximum time interval + -> Event m (Operation m a a) +{-# INLINABLE newPreemptibleRandomUniformIntOperation #-} +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 :: MonadDES m + => 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 m (Operation m a a) +{-# INLINABLE newPreemptibleRandomTriangularOperation #-} +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 :: MonadDES m + => Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the mean time interval + -> Double + -- ^ the time interval deviation + -> Event m (Operation m a a) +{-# INLINABLE newPreemptibleRandomNormalOperation #-} +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 :: MonadDES m + => 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 m (Operation m a a) +{-# INLINABLE newPreemptibleRandomLogNormalOperation #-} +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 :: MonadDES m + => Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the mean time interval (the reciprocal of the rate) + -> Event m (Operation m a a) +{-# INLINABLE newPreemptibleRandomExponentialOperation #-} +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 :: MonadDES m + => Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the scale (the reciprocal of the rate) + -> Int + -- ^ the shape + -> Event m (Operation m a a) +{-# INLINABLE newPreemptibleRandomErlangOperation #-} +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 :: MonadDES m + => Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the mean time interval + -> Event m (Operation m a a) +{-# INLINABLE newPreemptibleRandomPoissonOperation #-} +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 :: MonadDES m + => Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the probability + -> Int + -- ^ the number of trials + -> Event m (Operation m a a) +{-# INLINABLE newPreemptibleRandomBinomialOperation #-} +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 :: MonadDES m + => Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ the shape + -> Double + -- ^ the scale + -> Event m (Operation m a a) +{-# INLINABLE newPreemptibleRandomGammaOperation #-} +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 :: MonadDES m + => Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ shape (alpha) + -> Double + -- ^ shape (beta) + -> Event m (Operation m a a) +{-# INLINABLE newPreemptibleRandomBetaOperation #-} +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 :: MonadDES m + => Bool + -- ^ whether the operation process can be preempted + -> Double + -- ^ shape + -> Double + -- ^ scale + -> Event m (Operation m a a) +{-# INLINABLE newPreemptibleRandomWeibullOperation #-} +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 :: MonadDES m + => Bool + -- ^ whether the operation process can be preempted + -> DiscretePDF Double + -- ^ the discrete probability density function + -> Event m (Operation m a a) +{-# INLINABLE newPreemptibleRandomDiscreteOperation #-} +newPreemptibleRandomDiscreteOperation preemptible dpdf = + newPreemptibleOperation preemptible $ \a -> + do randomDiscreteProcess_ dpdf + return a diff --git a/Simulation/Aivika/Trans/Parameter/Random.hs b/Simulation/Aivika/Trans/Parameter/Random.hs --- a/Simulation/Aivika/Trans/Parameter/Random.hs +++ b/Simulation/Aivika/Trans/Parameter/Random.hs @@ -22,11 +22,17 @@ module Simulation.Aivika.Trans.Parameter.Random (randomUniform, randomUniformInt, + randomTriangular, randomNormal, + randomLogNormal, randomExponential, randomErlang, randomPoisson, randomBinomial, + randomGamma, + randomBeta, + randomWeibull, + randomDiscrete, randomTrue, randomFalse) where @@ -63,6 +69,18 @@ let g = runGenerator r in generateUniformInt g min max +-- | Computation that generates a new random number from the triangular distribution. +randomTriangular :: MonadComp m + => Double -- ^ minimum + -> Double -- ^ median + -> Double -- ^ maximum + -> Parameter m Double +{-# INLINE randomTriangular #-} +randomTriangular min median max = + Parameter $ \r -> + let g = runGenerator r + in generateTriangular g min median max + -- | Computation that generates a new random number distributed normally. randomNormal :: MonadComp m => Double -- ^ mean @@ -74,6 +92,21 @@ let g = runGenerator r in generateNormal g mu nu +-- | Computation that generates a new random number from the lognormal distribution. +randomLogNormal :: MonadComp m + => 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 + -> Parameter m Double +{-# INLINE randomLogNormal #-} +randomLogNormal mu nu = + Parameter $ \r -> + let g = runGenerator r + in generateLogNormal g mu nu + -- | Computation that returns a new exponential random number with the specified mean -- (the reciprocal of the rate). randomExponential :: MonadComp m @@ -122,6 +155,47 @@ Parameter $ \r -> let g = runGenerator r in generateBinomial g prob trials + +-- | Computation that returns a new random number from the Gamma distribution. +randomGamma :: MonadComp m + => Double -- ^ the shape + -> Double -- ^ the scale (a reciprocal of the rate) + -> Parameter m Double +{-# INLINE randomGamma #-} +randomGamma kappa theta = + Parameter $ \r -> + let g = runGenerator r + in generateGamma g kappa theta + +-- | Computation that returns a new random number from the Beta distribution. +randomBeta :: MonadComp m + => Double -- ^ the shape (alpha) + -> Double -- ^ the shape (beta) + -> Parameter m Double +{-# INLINE randomBeta #-} +randomBeta alpha beta = + Parameter $ \r -> + let g = runGenerator r + in generateBeta g alpha beta + +-- | Computation that returns a new random number from the Weibull distribution. +randomWeibull :: MonadComp m + => Double -- ^ shape + -> Double -- ^ scale + -> Parameter m Double +{-# INLINE randomWeibull #-} +randomWeibull alpha beta = + Parameter $ \r -> + let g = runGenerator r + in generateWeibull g alpha beta + +-- | Computation that returns a new random value from the specified discrete distribution. +randomDiscrete :: MonadComp m => DiscretePDF a -> Parameter m a +{-# INLINE randomDiscrete #-} +randomDiscrete dpdf = + Parameter $ \r -> + let g = runGenerator r + in generateDiscrete g dpdf -- | Computation that returns 'True' in case of success. randomTrue :: MonadComp m diff --git a/Simulation/Aivika/Trans/Process/Random.hs b/Simulation/Aivika/Trans/Process/Random.hs --- a/Simulation/Aivika/Trans/Process/Random.hs +++ b/Simulation/Aivika/Trans/Process/Random.hs @@ -17,8 +17,12 @@ randomUniformProcess_, randomUniformIntProcess, randomUniformIntProcess_, + randomTriangularProcess, + randomTriangularProcess_, randomNormalProcess, randomNormalProcess_, + randomLogNormalProcess, + randomLogNormalProcess_, randomExponentialProcess, randomExponentialProcess_, randomErlangProcess, @@ -26,12 +30,21 @@ randomPoissonProcess, randomPoissonProcess_, randomBinomialProcess, - randomBinomialProcess_) where + randomBinomialProcess_, + randomGammaProcess, + randomGammaProcess_, + randomBetaProcess, + randomBetaProcess_, + randomWeibullProcess, + randomWeibullProcess_, + randomDiscreteProcess, + randomDiscreteProcess_) where import Control.Monad import Control.Monad.Trans import Simulation.Aivika.Trans.DES +import Simulation.Aivika.Trans.Generator import Simulation.Aivika.Trans.Parameter import Simulation.Aivika.Trans.Parameter.Random import Simulation.Aivika.Trans.Process @@ -90,6 +103,37 @@ do t <- liftParameter $ randomUniformInt min max holdProcess $ fromIntegral t +-- | Hold the process for a random time interval having the triangular distribution. +randomTriangularProcess :: MonadDES m + => Double + -- ^ the minimum time interval + -> Double + -- ^ a median of the time interval + -> Double + -- ^ the maximum time interval + -> Process m Double + -- ^ a computation of the time interval + -- for which the process was actually held +{-# INLINABLE randomTriangularProcess #-} +randomTriangularProcess min median max = + do t <- liftParameter $ randomTriangular min median max + holdProcess t + return t + +-- | Hold the process for a random time interval having the triangular distribution. +randomTriangularProcess_ :: MonadDES m + => Double + -- ^ the minimum time interval + -> Double + -- ^ a median of the time interval + -> Double + -- ^ the maximum time interval + -> Process m () +{-# INLINABLE randomTriangularProcess_ #-} +randomTriangularProcess_ min median max = + do t <- liftParameter $ randomTriangular min median max + holdProcess t + -- | Hold the process for a random time interval distributed normally. randomNormalProcess :: MonadDES m => Double @@ -118,6 +162,37 @@ do t <- liftParameter $ randomNormal mu nu when (t > 0) $ holdProcess t + +-- | Hold the process for a random time interval having the lognormal distribution. +randomLogNormalProcess :: MonadDES m + => Double + -- ^ the mean for a normal distribution + -- which this distribution is derived from + -> Double + -- ^ the deviation for a normal distribution + -- which this distribution is derived from + -> Process m Double + -- ^ a computation of the time interval + -- for which the process was actually held +{-# INLINABLE randomLogNormalProcess #-} +randomLogNormalProcess mu nu = + do t <- liftParameter $ randomLogNormal mu nu + holdProcess t + return t + +-- | Hold the process for a random time interval having the lognormal distribution. +randomLogNormalProcess_ :: MonadDES m + => Double + -- ^ the mean for a normal distribution + -- which this distribution is derived from + -> Double + -- ^ the deviation for a normal distribution + -- which this distribution is derived from + -> Process m () +{-# INLINABLE randomLogNormalProcess_ #-} +randomLogNormalProcess_ mu nu = + do t <- liftParameter $ randomLogNormal mu nu + holdProcess t -- | Hold the process for a random time interval distributed exponentially -- with the specified mean (the reciprocal of the rate). @@ -226,3 +301,113 @@ randomBinomialProcess_ prob trials = do t <- liftParameter $ randomBinomial prob trials holdProcess $ fromIntegral t + +-- | Hold the process for a random time interval having the Gamma distribution +-- with the specified shape and scale. +randomGammaProcess :: MonadDES m + => Double + -- ^ the shape + -> Double + -- ^ the scale (a reciprocal of the rate) + -> Process m Double + -- ^ a computation of the time interval + -- for which the process was actually held +{-# INLINABLE randomGammaProcess #-} +randomGammaProcess kappa theta = + do t <- liftParameter $ randomGamma kappa theta + holdProcess t + return t + +-- | Hold the process for a random time interval having the Gamma distribution +-- with the specified shape and scale. +randomGammaProcess_ :: MonadDES m + => Double + -- ^ the shape + -> Double + -- ^ the scale (a reciprocal of the rate) + -> Process m () +{-# INLINABLE randomGammaProcess_ #-} +randomGammaProcess_ kappa theta = + do t <- liftParameter $ randomGamma kappa theta + holdProcess t + +-- | Hold the process for a random time interval having the Beta distribution +-- with the specified shape parameters (alpha and beta). +randomBetaProcess :: MonadDES m + => Double + -- ^ the shape (alpha) + -> Double + -- ^ the shape (beta) + -> Process m Double + -- ^ a computation of the time interval + -- for which the process was actually held +{-# INLINABLE randomBetaProcess #-} +randomBetaProcess alpha beta = + do t <- liftParameter $ randomBeta alpha beta + holdProcess t + return t + +-- | Hold the process for a random time interval having the Beta distribution +-- with the specified shape parameters (alpha and beta). +randomBetaProcess_ :: MonadDES m + => Double + -- ^ the shape (alpha) + -> Double + -- ^ the shape (beta) + -> Process m () +{-# INLINABLE randomBetaProcess_ #-} +randomBetaProcess_ alpha beta = + do t <- liftParameter $ randomBeta alpha beta + holdProcess t + +-- | Hold the process for a random time interval having the Weibull distribution +-- with the specified shape and scale. +randomWeibullProcess :: MonadDES m + => Double + -- ^ the shape + -> Double + -- ^ the scale + -> Process m Double + -- ^ a computation of the time interval + -- for which the process was actually held +{-# INLINABLE randomWeibullProcess #-} +randomWeibullProcess alpha beta = + do t <- liftParameter $ randomWeibull alpha beta + holdProcess t + return t + +-- | Hold the process for a random time interval having the Weibull distribution +-- with the specified shape and scale. +randomWeibullProcess_ :: MonadDES m + => Double + -- ^ the shape + -> Double + -- ^ the scale + -> Process m () +{-# INLINABLE randomWeibullProcess_ #-} +randomWeibullProcess_ alpha beta = + do t <- liftParameter $ randomWeibull alpha beta + holdProcess t + +-- | Hold the process for a random time interval having the specified discrete distribution. +randomDiscreteProcess :: MonadDES m + => DiscretePDF Double + -- ^ the discrete probability density function + -> Process m Double + -- ^ a computation of the time interval + -- for which the process was actually held +{-# INLINABLE randomDiscreteProcess #-} +randomDiscreteProcess dpdf = + do t <- liftParameter $ randomDiscrete dpdf + holdProcess t + return t + +-- | Hold the process for a random time interval having the specified discrete distribution. +randomDiscreteProcess_ :: MonadDES m + => DiscretePDF Double + -- ^ the discrete probability density function + -> Process m () +{-# INLINABLE randomDiscreteProcess_ #-} +randomDiscreteProcess_ dpdf = + do t <- liftParameter $ randomDiscrete dpdf + holdProcess t diff --git a/Simulation/Aivika/Trans/Processor/Random.hs b/Simulation/Aivika/Trans/Processor/Random.hs --- a/Simulation/Aivika/Trans/Processor/Random.hs +++ b/Simulation/Aivika/Trans/Processor/Random.hs @@ -15,13 +15,20 @@ module Simulation.Aivika.Trans.Processor.Random (randomUniformProcessor, randomUniformIntProcessor, + randomTriangularProcessor, randomNormalProcessor, + randomLogNormalProcessor, randomExponentialProcessor, randomErlangProcessor, randomPoissonProcessor, - randomBinomialProcessor) where + randomBinomialProcessor, + randomGammaProcessor, + randomBetaProcessor, + randomWeibullProcessor, + randomDiscreteProcessor) where import Simulation.Aivika.Trans.DES +import Simulation.Aivika.Trans.Generator import Simulation.Aivika.Trans.Process import Simulation.Aivika.Trans.Process.Random import Simulation.Aivika.Trans.Processor @@ -53,6 +60,21 @@ randomUniformIntProcess_ min max -- | When processing every input element, hold the process +-- for a random time interval having the triangular distribution. +randomTriangularProcessor :: MonadDES m + => Double + -- ^ the minimum time interval + -> Double + -- ^ the median of the time interval + -> Double + -- ^ the maximum time interval + -> Processor m a a +{-# INLINABLE randomTriangularProcessor #-} +randomTriangularProcessor min median max = + withinProcessor $ + randomTriangularProcess_ min median max + +-- | When processing every input element, hold the process -- for a random time interval distributed normally. randomNormalProcessor :: MonadDES m => Double @@ -66,6 +88,21 @@ randomNormalProcess_ mu nu -- | When processing every input element, hold the process +-- for a random time interval having the lognormal distribution. +randomLogNormalProcessor :: MonadDES m + => Double + -- ^ the mean for a normal distribution + -- which this distribution is derived from + -> Double + -- ^ the deviation for a normal distribution + -- which this distribution is derived from + -> Processor m a a +{-# INLINABLE randomLogNormalProcessor #-} +randomLogNormalProcessor mu nu = + withinProcessor $ + randomLogNormalProcess_ mu nu + +-- | When processing every input element, hold the process -- for a random time interval distributed exponentially -- with the specified mean (the reciprocal of the rate). randomExponentialProcessor :: MonadDES m @@ -116,3 +153,56 @@ randomBinomialProcessor prob trials = withinProcessor $ randomBinomialProcess_ prob trials + +-- | When processing every input element, hold the process +-- for a random time interval having the Gamma distribution +-- with the specified shape and scale. +randomGammaProcessor :: MonadDES m + => Double + -- ^ the shape + -> Double + -- ^ the scale (a reciprocal of the rate) + -> Processor m a a +{-# INLINABLE randomGammaProcessor #-} +randomGammaProcessor kappa theta = + withinProcessor $ + randomGammaProcess_ kappa theta + +-- | When processing every input element, hold the process +-- for a random time interval having the Beta distribution +-- with the specified shape parameters (alpha and beta). +randomBetaProcessor :: MonadDES m + => Double + -- ^ shape (alpha) + -> Double + -- ^ shape (beta) + -> Processor m a a +{-# INLINABLE randomBetaProcessor #-} +randomBetaProcessor alpha beta = + withinProcessor $ + randomBetaProcess_ alpha beta + +-- | When processing every input element, hold the process +-- for a random time interval having the Weibull distribution +-- with the specified shape and scale. +randomWeibullProcessor :: MonadDES m + => Double + -- ^ shape + -> Double + -- ^ scale + -> Processor m a a +{-# INLINABLE randomWeibullProcessor #-} +randomWeibullProcessor alpha beta = + withinProcessor $ + randomWeibullProcess_ alpha beta + +-- | When processing every input element, hold the process +-- for a random time interval having the specified discrete distribution. +randomDiscreteProcessor :: MonadDES m + => DiscretePDF Double + -- ^ the discrete probability density function + -> Processor m a a +{-# INLINABLE randomDiscreteProcessor #-} +randomDiscreteProcessor dpdf = + withinProcessor $ + randomDiscreteProcess_ dpdf diff --git a/Simulation/Aivika/Trans/Processor/RoundRobbin.hs b/Simulation/Aivika/Trans/Processor/RoundRobbin.hs --- a/Simulation/Aivika/Trans/Processor/RoundRobbin.hs +++ b/Simulation/Aivika/Trans/Processor/RoundRobbin.hs @@ -21,7 +21,7 @@ import Simulation.Aivika.Trans.Process import Simulation.Aivika.Trans.Processor import Simulation.Aivika.Trans.Stream -import Simulation.Aivika.Trans.Queue.Infinite +import Simulation.Aivika.Trans.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 @@ -44,7 +44,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/Trans/Queue.hs b/Simulation/Aivika/Trans/Queue.hs --- a/Simulation/Aivika/Trans/Queue.hs +++ b/Simulation/Aivika/Trans/Queue.hs @@ -65,6 +65,13 @@ enqueueOrLost_, enqueueWithStoringPriorityOrLost, enqueueWithStoringPriorityOrLost_, + queueDelete, + queueDelete_, + queueDeleteBy, + queueDeleteBy_, + queueContains, + queueContainsBy, + clearQueue, -- * Awaiting waitWhileFullQueue, -- * Summary @@ -108,6 +115,7 @@ queueChanged_) where import Data.Monoid +import Data.Maybe import Control.Monad import Control.Monad.Trans @@ -121,7 +129,7 @@ import Simulation.Aivika.Trans.Internal.Event import Simulation.Aivika.Trans.Internal.Process import Simulation.Aivika.Trans.Signal -import Simulation.Aivika.Trans.Resource +import Simulation.Aivika.Trans.Resource.Base import Simulation.Aivika.Trans.QueueStrategy import Simulation.Aivika.Trans.Statistics @@ -667,6 +675,116 @@ fmap Just $ dequeueExtract q t else return Nothing +-- | Remove the item from the queue and return a flag indicating +-- whether the item was found and actually removed. +queueDelete :: (MonadDES m, + Eq a, + DequeueStrategy m si, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item to remove from the queue + -> Event m Bool + -- ^ whether the item was found and removed +{-# INLINABLE queueDelete #-} +queueDelete q a = fmap isJust $ queueDeleteBy q (== a) + +-- | Remove the specified item from the queue. +queueDelete_ :: (MonadDES m, + Eq a, + DequeueStrategy m si, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item to remove from the queue + -> Event m () +{-# INLINABLE queueDelete_ #-} +queueDelete_ q a = fmap (const ()) $ queueDeleteBy q (== a) + +-- | Remove an item satisfying the specified predicate and return the item if found. +queueDeleteBy :: (MonadDES m, + DequeueStrategy m si, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event m (Maybe a) +{-# INLINABLE queueDeleteBy #-} +queueDeleteBy q pred = + do x <- tryRequestResourceWithinEvent (dequeueRes q) + if x + then do i <- strategyQueueDeleteBy (queueStore q) (pred . itemValue) + case i of + Nothing -> + do releaseResourceWithinEvent (dequeueRes q) + return Nothing + Just i -> + do t <- dequeueRequest q + fmap Just $ dequeuePostExtract q t i + else return Nothing + +-- | Remove an item satisfying the specified predicate. +queueDeleteBy_ :: (MonadDES m, + DequeueStrategy m si, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event m () +{-# INLINABLE queueDeleteBy_ #-} +queueDeleteBy_ q pred = fmap (const ()) $ queueDeleteBy q pred + +-- | Detect whether the item is contained in the queue. +queueContains :: (MonadDES m, + Eq a, + DeletingQueueStrategy m sm) + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item to search the queue for + -> Event m Bool + -- ^ whether the item was found +{-# INLINABLE queueContains #-} +queueContains q a = fmap isJust $ queueContainsBy q (== a) + +-- | Detect whether an item satisfying the specified predicate is contained in the queue. +queueContainsBy :: (MonadDES m, + DeletingQueueStrategy m sm) + => Queue m si sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event m (Maybe a) + -- ^ the item if it was found +{-# INLINABLE queueContainsBy #-} +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 :: (MonadDES m, + DequeueStrategy m si, + DequeueStrategy m sm) + => Queue m si sm so a + -- ^ the queue + -> Event m () +{-# INLINABLE clearQueue #-} +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 :: (MonadDES m, EnqueueStrategy m si, @@ -1032,7 +1150,25 @@ Event $ \p -> do i <- invokeEvent p $ strategyDequeue (queueStore q) - c <- invokeEvent p $ + invokeEvent p $ + dequeuePostExtract q t' i + +-- | A post action after extracting the item by the dequeuing request. +dequeuePostExtract :: (MonadDES m, + DequeueStrategy m si, + DequeueStrategy m sm) + => Queue m si sm so a + -- ^ the queue + -> Double + -- ^ the time of the dequeuing request + -> QueueItem a + -- ^ the item to dequeue + -> Event m a + -- ^ the dequeued value +{-# INLINE dequeuePostExtract #-} +dequeuePostExtract q t' i = + Event $ \p -> + do c <- invokeEvent p $ readRef (queueCountRef q) let c' = c - 1 t = pointTime p diff --git a/Simulation/Aivika/Trans/Queue/Base.hs b/Simulation/Aivika/Trans/Queue/Base.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Queue/Base.hs @@ -0,0 +1,519 @@ + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.Queue.Base +-- Copyright : Copyright (c) 2009-2016, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.10.3 +-- +-- This module defines an optimised finite queue, which has no counters nor signals. +-- +module Simulation.Aivika.Trans.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.Monoid +import Data.Maybe + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Ref.Base +import Simulation.Aivika.Trans.DES +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Process +import Simulation.Aivika.Trans.Resource.Base +import Simulation.Aivika.Trans.QueueStrategy + +-- | A type synonym for the ordinary FIFO queue also known as the FCFS +-- (First Come - First Serviced) queue. +type FCFSQueue m a = Queue m FCFS FCFS FCFS a + +-- | A type synonym for the ordinary LIFO queue also known as the LCFS +-- (Last Come - First Serviced) queue. +type LCFSQueue m a = Queue m FCFS LCFS FCFS a + +-- | A type synonym for the SIRO (Serviced in Random Order) queue. +type SIROQueue m a = Queue m FCFS SIRO FCFS a + +-- | A type synonym for the queue with static priorities applied when +-- storing the elements in the queue. +type PriorityQueue m a = Queue m 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. Type @m@ denotes the underlying monad within +-- which the simulation executes. +data Queue m 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 m si, + queueStore :: StrategyQueue m sm a, + dequeueRes :: Resource m so, + queueCountRef :: Ref m Int + } + +-- | Create a new FCFS queue with the specified capacity. +newFCFSQueue :: MonadDES m => Int -> Simulation m (FCFSQueue m a) +{-# INLINABLE newFCFSQueue #-} +newFCFSQueue = newQueue FCFS FCFS FCFS + +-- | Create a new LCFS queue with the specified capacity. +newLCFSQueue :: MonadDES m => Int -> Simulation m (LCFSQueue m a) +{-# INLINABLE newLCFSQueue #-} +newLCFSQueue = newQueue FCFS LCFS FCFS + +-- | Create a new SIRO queue with the specified capacity. +newSIROQueue :: (MonadDES m, QueueStrategy m SIRO) => Int -> Simulation m (SIROQueue m a) +{-# INLINABLE newSIROQueue #-} +newSIROQueue = newQueue FCFS SIRO FCFS + +-- | Create a new priority queue with the specified capacity. +newPriorityQueue :: (MonadDES m, QueueStrategy m StaticPriorities) => Int -> Simulation m (PriorityQueue m a) +{-# INLINABLE newPriorityQueue #-} +newPriorityQueue = newQueue FCFS StaticPriorities FCFS + +-- | Create a new queue with the specified strategies and capacity. +newQueue :: (MonadDES m, + QueueStrategy m si, + QueueStrategy m sm, + QueueStrategy m 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 m (Queue m si sm so a) +{-# INLINABLE newQueue #-} +newQueue si sm so count = + do i <- newRef 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 :: MonadDES m => Queue m si sm so a -> Event m Bool +{-# INLINABLE queueNull #-} +queueNull q = + Event $ \p -> + do n <- invokeEvent p $ readRef (queueCountRef q) + return (n == 0) + +-- | Test whether the queue is full. +-- +-- See also 'queueFullChanged' and 'queueFullChanged_'. +queueFull :: MonadDES m => Queue m si sm so a -> Event m Bool +{-# INLINABLE queueFull #-} +queueFull q = + Event $ \p -> + do n <- invokeEvent p $ readRef (queueCountRef q) + return (n == queueMaxCount q) + +-- | Return the current queue size. +-- +-- See also 'queueCountStats', 'queueCountChanged' and 'queueCountChanged_'. +queueCount :: MonadDES m => Queue m si sm so a -> Event m Int +{-# INLINABLE queueCount #-} +queueCount q = + Event $ \p -> invokeEvent p $ readRef (queueCountRef q) + +-- | Dequeue suspending the process if the queue is empty. +dequeue :: (MonadDES m, + DequeueStrategy m si, + DequeueStrategy m sm, + EnqueueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> Process m a + -- ^ the dequeued value +{-# INLINABLE dequeue #-} +dequeue q = + do requestResource (dequeueRes q) + liftEvent $ dequeueExtract q + +-- | Dequeue with the output priority suspending the process if the queue is empty. +dequeueWithOutputPriority :: (MonadDES m, + DequeueStrategy m si, + DequeueStrategy m sm, + PriorityQueueStrategy m so po) + => Queue m si sm so a + -- ^ the queue + -> po + -- ^ the priority for output + -> Process m a + -- ^ the dequeued value +{-# INLINABLE dequeueWithOutputPriority #-} +dequeueWithOutputPriority q po = + do requestResourceWithPriority (dequeueRes q) po + liftEvent $ dequeueExtract q + +-- | Try to dequeue immediately. +tryDequeue :: (MonadDES m, + DequeueStrategy m si, + DequeueStrategy m sm) + => Queue m si sm so a + -- ^ the queue + -> Event m (Maybe a) + -- ^ the dequeued value of 'Nothing' +{-# INLINABLE tryDequeue #-} +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 :: (MonadDES m, + Eq a, + DequeueStrategy m si, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item to remove from the queue + -> Event m Bool + -- ^ whether the item was found and removed +{-# INLINABLE queueDelete #-} +queueDelete q a = fmap isJust $ queueDeleteBy q (== a) + +-- | Remove the specified item from the queue. +queueDelete_ :: (MonadDES m, + Eq a, + DequeueStrategy m si, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item to remove from the queue + -> Event m () +{-# INLINABLE queueDelete_ #-} +queueDelete_ q a = fmap (const ()) $ queueDeleteBy q (== a) + +-- | Remove an item satisfying the specified predicate and return the item if found. +queueDeleteBy :: (MonadDES m, + DequeueStrategy m si, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event m (Maybe a) +{-# INLINABLE queueDeleteBy #-} +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_ :: (MonadDES m, + DequeueStrategy m si, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event m () +{-# INLINABLE queueDeleteBy_ #-} +queueDeleteBy_ q pred = fmap (const ()) $ queueDeleteBy q pred + +-- | Detect whether the item is contained in the queue. +queueContains :: (MonadDES m, + Eq a, + DeletingQueueStrategy m sm) + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item to search the queue for + -> Event m Bool + -- ^ whether the item was found +{-# INLINABLE queueContains #-} +queueContains q a = fmap isJust $ queueContainsBy q (== a) + +-- | Detect whether an item satisfying the specified predicate is contained in the queue. +queueContainsBy :: (MonadDES m, + DeletingQueueStrategy m sm) + => Queue m si sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event m (Maybe a) + -- ^ the item if it was found +{-# INLINABLE queueContainsBy #-} +queueContainsBy q pred = + strategyQueueContainsBy (queueStore q) pred + +-- | Clear the queue immediately. +clearQueue :: (MonadDES m, + DequeueStrategy m si, + DequeueStrategy m sm) + => Queue m si sm so a + -- ^ the queue + -> Event m () +{-# INLINABLE clearQueue #-} +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 :: (MonadDES m, + EnqueueStrategy m si, + EnqueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item to enqueue + -> Process m () +{-# INLINABLE enqueue #-} +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 :: (MonadDES m, + PriorityQueueStrategy m si pi, + EnqueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> pi + -- ^ the priority for input + -> a + -- ^ the item to enqueue + -> Process m () +{-# INLINABLE enqueueWithInputPriority #-} +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 :: (MonadDES m, + EnqueueStrategy m si, + PriorityQueueStrategy m sm pm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to enqueue + -> Process m () +{-# INLINABLE enqueueWithStoringPriority #-} +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 :: (MonadDES m, + PriorityQueueStrategy m si pi, + PriorityQueueStrategy m sm pm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> pi + -- ^ the priority for input + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to enqueue + -> Process m () +{-# INLINABLE enqueueWithInputStoringPriorities #-} +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 :: (MonadDES m, + EnqueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item which we try to enqueue + -> Event m Bool +{-# INLINABLE tryEnqueue #-} +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 :: (MonadDES m, + PriorityQueueStrategy m sm pm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item which we try to enqueue + -> Event m Bool +{-# INLINABLE tryEnqueueWithStoringPriority #-} +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 :: (MonadDES m, + EnqueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item to be stored + -> Event m () +{-# INLINE enqueueStore #-} +enqueueStore q a = + Event $ \p -> + do invokeEvent p $ + strategyEnqueue (queueStore q) a + c <- invokeEvent p $ + readRef (queueCountRef q) + let c' = c + 1 + c' `seq` invokeEvent p $ + writeRef (queueCountRef q) c' + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + +-- | Store with the priority the item. +enqueueStoreWithPriority :: (MonadDES m, + PriorityQueueStrategy m sm pm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to be enqueued + -> Event m () +{-# INLINE enqueueStoreWithPriority #-} +enqueueStoreWithPriority q pm a = + Event $ \p -> + do invokeEvent p $ + strategyEnqueueWithPriority (queueStore q) pm a + c <- invokeEvent p $ + readRef (queueCountRef q) + let c' = c + 1 + c' `seq` invokeEvent p $ + writeRef (queueCountRef q) c' + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + +-- | Extract an item for the dequeuing request. +dequeueExtract :: (MonadDES m, + DequeueStrategy m si, + DequeueStrategy m sm) + => Queue m si sm so a + -- ^ the queue + -> Event m a + -- ^ the dequeued value +{-# INLINE dequeueExtract #-} +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 :: (MonadDES m, + DequeueStrategy m si, + DequeueStrategy m sm) + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item to dequeue + -> Event m a + -- ^ the dequeued value +{-# INLINE dequeuePostExtract #-} +dequeuePostExtract q a = + Event $ \p -> + do c <- invokeEvent p $ + readRef (queueCountRef q) + let c' = c - 1 + c' `seq` invokeEvent p $ + writeRef (queueCountRef q) c' + invokeEvent p $ + releaseResourceWithinEvent (enqueueRes q) + return a diff --git a/Simulation/Aivika/Trans/Queue/Infinite.hs b/Simulation/Aivika/Trans/Queue/Infinite.hs --- a/Simulation/Aivika/Trans/Queue/Infinite.hs +++ b/Simulation/Aivika/Trans/Queue/Infinite.hs @@ -45,6 +45,13 @@ tryDequeue, enqueue, enqueueWithStoringPriority, + queueDelete, + queueDelete_, + queueDeleteBy, + queueDeleteBy_, + queueContains, + queueContainsBy, + clearQueue, -- * Summary queueSummary, -- * Derived Signals for Properties @@ -72,6 +79,7 @@ queueChanged_) where import Data.Monoid +import Data.Maybe import Control.Monad import Control.Monad.Trans @@ -85,7 +93,7 @@ import Simulation.Aivika.Trans.Internal.Event import Simulation.Aivika.Trans.Internal.Process import Simulation.Aivika.Trans.Signal -import Simulation.Aivika.Trans.Resource +import Simulation.Aivika.Trans.Resource.Base import Simulation.Aivika.Trans.QueueStrategy import Simulation.Aivika.Trans.Statistics @@ -450,6 +458,111 @@ fmap Just $ dequeueExtract q t else return Nothing +-- | Remove the item from the queue and return a flag indicating +-- whether the item was found and actually removed. +queueDelete :: (MonadDES m, + Eq a, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> a + -- ^ the item to remove from the queue + -> Event m Bool + -- ^ whether the item was found and removed +{-# INLINABLE queueDelete #-} +queueDelete q a = fmap isJust $ queueDeleteBy q (== a) + +-- | Remove the specified item from the queue. +queueDelete_ :: (MonadDES m, + Eq a, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> a + -- ^ the item to remove from the queue + -> Event m () +{-# INLINABLE queueDelete_ #-} +queueDelete_ q a = fmap (const ()) $ queueDeleteBy q (== a) + +-- | Remove an item satisfying the specified predicate and return the item if found. +queueDeleteBy :: (MonadDES m, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event m (Maybe a) +{-# INLINABLE queueDeleteBy #-} +queueDeleteBy q pred = + do x <- tryRequestResourceWithinEvent (dequeueRes q) + if x + then do i <- strategyQueueDeleteBy (queueStore q) (pred . itemValue) + case i of + Nothing -> + do releaseResourceWithinEvent (dequeueRes q) + return Nothing + Just i -> + do t <- dequeueRequest q + fmap Just $ dequeuePostExtract q t i + else return Nothing + +-- | Remove an item satisfying the specified predicate. +queueDeleteBy_ :: (MonadDES m, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event m () +{-# INLINABLE queueDeleteBy_ #-} +queueDeleteBy_ q pred = fmap (const ()) $ queueDeleteBy q pred + +-- | Detect whether the item is contained in the queue. +queueContains :: (MonadDES m, + Eq a, + DeletingQueueStrategy m sm) + => Queue m sm so a + -- ^ the queue + -> a + -- ^ the item to search the queue for + -> Event m Bool + -- ^ whether the item was found +{-# INLINABLE queueContains #-} +queueContains q a = fmap isJust $ queueContainsBy q (== a) + +-- | Detect whether an item satisfying the specified predicate is contained in the queue. +queueContainsBy :: (MonadDES m, + DeletingQueueStrategy m sm) + => Queue m sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event m (Maybe a) + -- ^ the item if it was found +{-# INLINABLE queueContainsBy #-} +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 :: (MonadDES m, + DequeueStrategy m sm) + => Queue m sm so a + -- ^ the queue + -> Event m () +{-# INLINABLE clearQueue #-} +clearQueue q = + do x <- tryDequeue q + case x of + Nothing -> return () + Just a -> clearQueue q + -- | Enqueue the item. enqueue :: (MonadDES m, EnqueueStrategy m sm, @@ -585,7 +698,24 @@ Event $ \p -> do i <- invokeEvent p $ strategyDequeue (queueStore q) - c <- invokeEvent p $ + invokeEvent p $ + dequeuePostExtract q t' i + +-- | A post action after extracting the item by the dequeuing request. +dequeuePostExtract :: (MonadDES m, + DequeueStrategy m sm) + => Queue m sm so a + -- ^ the queue + -> Double + -- ^ the time of the dequeuing request + -> QueueItem a + -- ^ the item to dequeue + -> Event m a + -- ^ the dequeued value +{-# INLINE dequeuePostExtract #-} +dequeuePostExtract q t' i = + Event $ \p -> + do c <- invokeEvent p $ readRef (queueCountRef q) let c' = c - 1 t = pointTime p diff --git a/Simulation/Aivika/Trans/Queue/Infinite/Base.hs b/Simulation/Aivika/Trans/Queue/Infinite/Base.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Queue/Infinite/Base.hs @@ -0,0 +1,396 @@ + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.Queue.Infinite.Base +-- Copyright : Copyright (c) 2009-2016, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.10.3 +-- +-- This module defines an infinite optimised queue, which has no counters nor signals. +-- +module Simulation.Aivika.Trans.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.Monoid +import Data.Maybe + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Ref.Base +import Simulation.Aivika.Trans.DES +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Process +import Simulation.Aivika.Trans.Resource.Base +import Simulation.Aivika.Trans.QueueStrategy + +-- | A type synonym for the ordinary FIFO queue also known as the FCFS +-- (First Come - First Serviced) queue. +type FCFSQueue m a = Queue m FCFS FCFS a + +-- | A type synonym for the ordinary LIFO queue also known as the LCFS +-- (Last Come - First Serviced) queue. +type LCFSQueue m a = Queue m LCFS FCFS a + +-- | A type synonym for the SIRO (Serviced in Random Order) queue. +type SIROQueue m a = Queue m SIRO FCFS a + +-- | A type synonym for the queue with static priorities applied when +-- storing the elements in the queue. +type PriorityQueue m a = Queue m 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. Type @m@ denotes the underlying monad within +-- which the simulation executes. +data Queue m 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 m sm a, + dequeueRes :: Resource m so, + queueCountRef :: Ref m Int } + +-- | Create a new infinite FCFS queue. +newFCFSQueue :: MonadDES m => Simulation m (FCFSQueue m a) +{-# INLINABLE newFCFSQueue #-} +newFCFSQueue = newQueue FCFS FCFS + +-- | Create a new infinite LCFS queue. +newLCFSQueue :: MonadDES m => Simulation m (LCFSQueue m a) +{-# INLINABLE newLCFSQueue #-} +newLCFSQueue = newQueue LCFS FCFS + +-- | Create a new infinite SIRO queue. +newSIROQueue :: (MonadDES m, QueueStrategy m SIRO) => Simulation m (SIROQueue m a) +{-# INLINABLE newSIROQueue #-} +newSIROQueue = newQueue SIRO FCFS + +-- | Create a new infinite priority queue. +newPriorityQueue :: (MonadDES m, QueueStrategy m StaticPriorities) => Simulation m (PriorityQueue m a) +{-# INLINABLE newPriorityQueue #-} +newPriorityQueue = newQueue StaticPriorities FCFS + +-- | Create a new infinite queue with the specified strategies. +newQueue :: (MonadDES m, + QueueStrategy m sm, + QueueStrategy m 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 m (Queue m sm so a) +{-# INLINABLE newQueue #-} +newQueue sm so = + do i <- newRef 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 :: MonadDES m => Queue m sm so a -> Event m Bool +{-# INLINABLE queueNull #-} +queueNull q = + Event $ \p -> + do n <- invokeEvent p $ readRef (queueCountRef q) + return (n == 0) + +-- | Return the current queue size. +-- +-- See also 'queueCountStats', 'queueCountChanged' and 'queueCountChanged_'. +queueCount :: MonadDES m => Queue m sm so a -> Event m Int +{-# INLINABLE queueCount #-} +queueCount q = + Event $ \p -> invokeEvent p $ readRef (queueCountRef q) + +-- | Dequeue suspending the process if the queue is empty. +dequeue :: (MonadDES m, + DequeueStrategy m sm, + EnqueueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> Process m a + -- ^ the dequeued value +{-# INLINABLE dequeue #-} +dequeue q = + do requestResource (dequeueRes q) + liftEvent $ dequeueExtract q + +-- | Dequeue with the output priority suspending the process if the queue is empty. +dequeueWithOutputPriority :: (MonadDES m, + DequeueStrategy m sm, + PriorityQueueStrategy m so po) + => Queue m sm so a + -- ^ the queue + -> po + -- ^ the priority for output + -> Process m a + -- ^ the dequeued value +{-# INLINABLE dequeueWithOutputPriority #-} +dequeueWithOutputPriority q po = + do requestResourceWithPriority (dequeueRes q) po + liftEvent $ dequeueExtract q + +-- | Try to dequeue immediately. +tryDequeue :: (MonadDES m, + DequeueStrategy m sm) + => Queue m sm so a + -- ^ the queue + -> Event m (Maybe a) + -- ^ the dequeued value of 'Nothing' +{-# INLINABLE tryDequeue #-} +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 :: (MonadDES m, + Eq a, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> a + -- ^ the item to remove from the queue + -> Event m Bool + -- ^ whether the item was found and removed +{-# INLINABLE queueDelete #-} +queueDelete q a = fmap isJust $ queueDeleteBy q (== a) + +-- | Remove the specified item from the queue. +queueDelete_ :: (MonadDES m, + Eq a, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> a + -- ^ the item to remove from the queue + -> Event m () +{-# INLINABLE queueDelete_ #-} +queueDelete_ q a = fmap (const ()) $ queueDeleteBy q (== a) + +-- | Remove an item satisfying the specified predicate and return the item if found. +queueDeleteBy :: (MonadDES m, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event m (Maybe a) +{-# INLINABLE queueDeleteBy #-} +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_ :: (MonadDES m, + DeletingQueueStrategy m sm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event m () +{-# INLINABLE queueDeleteBy_ #-} +queueDeleteBy_ q pred = fmap (const ()) $ queueDeleteBy q pred + +-- | Detect whether the item is contained in the queue. +queueContains :: (MonadDES m, + Eq a, + DeletingQueueStrategy m sm) + => Queue m sm so a + -- ^ the queue + -> a + -- ^ the item to search the queue for + -> Event m Bool + -- ^ whether the item was found +{-# INLINABLE queueContains #-} +queueContains q a = fmap isJust $ queueContainsBy q (== a) + +-- | Detect whether an item satisfying the specified predicate is contained in the queue. +queueContainsBy :: (MonadDES m, + DeletingQueueStrategy m sm) + => Queue m sm so a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event m (Maybe a) + -- ^ the item if it was found +{-# INLINABLE queueContainsBy #-} +queueContainsBy q pred = + strategyQueueContainsBy (queueStore q) pred + +-- | Clear the queue immediately. +clearQueue :: (MonadDES m, + DequeueStrategy m sm) + => Queue m sm so a + -- ^ the queue + -> Event m () +{-# INLINABLE clearQueue #-} +clearQueue q = + do x <- tryDequeue q + case x of + Nothing -> return () + Just a -> clearQueue q + +-- | Enqueue the item. +enqueue :: (MonadDES m, + EnqueueStrategy m sm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> a + -- ^ the item to enqueue + -> Event m () +{-# INLINABLE enqueue #-} +enqueue = enqueueStore + +-- | Enqueue with the storing priority the item. +enqueueWithStoringPriority :: (MonadDES m, + PriorityQueueStrategy m sm pm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to enqueue + -> Event m () +{-# INLINABLE enqueueWithStoringPriority #-} +enqueueWithStoringPriority = enqueueStoreWithPriority + +-- | Store the item. +enqueueStore :: (MonadDES m, + EnqueueStrategy m sm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> a + -- ^ the item to be stored + -> Event m () +{-# INLINE enqueueStore #-} +enqueueStore q a = + Event $ \p -> + do invokeEvent p $ + strategyEnqueue (queueStore q) a + c <- invokeEvent p $ + readRef (queueCountRef q) + let c' = c + 1 + c' `seq` invokeEvent p $ + writeRef (queueCountRef q) c' + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + +-- | Store with the priority the item. +enqueueStoreWithPriority :: (MonadDES m, + PriorityQueueStrategy m sm pm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to be enqueued + -> Event m () +{-# INLINE enqueueStoreWithPriority #-} +enqueueStoreWithPriority q pm a = + Event $ \p -> + do invokeEvent p $ + strategyEnqueueWithPriority (queueStore q) pm a + c <- invokeEvent p $ + readRef (queueCountRef q) + let c' = c + 1 + c' `seq` invokeEvent p $ + writeRef (queueCountRef q) c' + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + +-- | Extract an item for the dequeuing request. +dequeueExtract :: (MonadDES m, + DequeueStrategy m sm) + => Queue m sm so a + -- ^ the queue + -> Event m a + -- ^ the dequeued value +{-# INLINE dequeueExtract #-} +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 :: (MonadDES m, + DequeueStrategy m sm) + => Queue m sm so a + -- ^ the queue + -> a + -- ^ the item to dequeue + -> Event m a + -- ^ the dequeued value +{-# INLINE dequeuePostExtract #-} +dequeuePostExtract q a = + Event $ \p -> + do c <- invokeEvent p $ + readRef (queueCountRef q) + let c' = c - 1 + c' `seq` invokeEvent p $ + writeRef (queueCountRef q) c' + return a diff --git a/Simulation/Aivika/Trans/QueueStrategy.hs b/Simulation/Aivika/Trans/QueueStrategy.hs --- a/Simulation/Aivika/Trans/QueueStrategy.hs +++ b/Simulation/Aivika/Trans/QueueStrategy.hs @@ -15,6 +15,8 @@ import Control.Monad +import Data.Maybe + import Simulation.Aivika.Trans.Internal.Types -- | Defines the basic queue strategy. @@ -67,6 +69,52 @@ -- ^ the element to be enqueued -> Event m () -- ^ the action of enqueuing + +-- | Defines a strategy with support of the deleting operation. +class DequeueStrategy m s => DeletingQueueStrategy m s where + + -- | Remove the element and return a flag indicating whether + -- the element was found and removed. + strategyQueueDelete :: Eq a + => StrategyQueue m s a + -- ^ the queue + -> a + -- ^ the element + -> Event m Bool + -- ^ whether the element was found and removed + strategyQueueDelete s a = + Event $ \p -> + do x <- invokeEvent p $ strategyQueueDeleteBy s (== a) + return (isJust x) + + -- | Remove an element satisfying the predicate and return the element if found. + strategyQueueDeleteBy :: StrategyQueue m s a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event m (Maybe a) + -- ^ the element if it was found and removed + + -- | Detect whether the specified element is contained in the queue. + strategyQueueContains :: Eq a + => StrategyQueue m s a + -- ^ the queue + -> a + -- ^ the element to find + -> Event m Bool + -- ^ whether the element is contained in the queue + strategyQueueContains s a = + Event $ \p -> + do x <- invokeEvent p $ strategyQueueContainsBy s (== a) + return (isJust x) + + -- | Detect whether an element satifying the specified predicate is contained in the queue. + strategyQueueContainsBy :: StrategyQueue m s a + -- ^ the queue + -> (a -> Bool) + -- ^ the predicate + -> Event m (Maybe a) + -- ^ the element if it was found -- | Strategy: First Come - First Served (FCFS). data FCFS = FCFS deriving (Eq, Ord, Show) diff --git a/Simulation/Aivika/Trans/Resource.hs b/Simulation/Aivika/Trans/Resource.hs --- a/Simulation/Aivika/Trans/Resource.hs +++ b/Simulation/Aivika/Trans/Resource.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Resource --- Copyright : Copyright (c) 2009-2015, David Sorokin +-- Copyright : Copyright (c) 2009-2016, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -37,6 +37,13 @@ resourceStrategy, resourceMaxCount, resourceCount, + resourceCountStats, + resourceUtilisationCount, + resourceUtilisationCountStats, + resourceQueueCount, + resourceQueueCountStats, + resourceTotalWaitTime, + resourceWaitTime, -- * Requesting for and Releasing Resource requestResource, requestResourceWithPriority, @@ -46,8 +53,21 @@ usingResource, usingResourceWithPriority, -- * Altering Resource - incResourceCount) where + incResourceCount, + decResourceCount, + -- * Signals + resourceCountChanged, + resourceCountChanged_, + resourceUtilisationCountChanged, + resourceUtilisationCountChanged_, + resourceQueueCountChanged, + resourceQueueCountChanged_, + resourceWaitTimeChanged, + resourceWaitTimeChanged_, + resourceChanged_) where +import Data.Monoid + import Control.Monad import Control.Monad.Trans import Control.Exception @@ -60,6 +80,8 @@ import Simulation.Aivika.Trans.Internal.Cont import Simulation.Aivika.Trans.Internal.Process import Simulation.Aivika.Trans.QueueStrategy +import Simulation.Aivika.Trans.Statistics +import Simulation.Aivika.Trans.Signal -- | The ordinary FCFS (First Come - First Serviced) resource. type FCFSResource m = Resource m FCFS @@ -80,15 +102,30 @@ resourceMaxCount :: Maybe Int, -- ^ Return the maximum count of the resource, where 'Nothing' -- means that the resource has no upper bound. - resourceCountRef :: Ref m Int, - resourceWaitList :: StrategyQueue m s (FrozenCont m ()) } + resourceCountRef :: Ref m Int, + resourceCountStatsRef :: Ref m (TimingStats Int), + resourceCountSource :: SignalSource m Int, + resourceUtilisationCountRef :: Ref m Int, + resourceUtilisationCountStatsRef :: Ref m (TimingStats Int), + resourceUtilisationCountSource :: SignalSource m Int, + resourceQueueCountRef :: Ref m Int, + resourceQueueCountStatsRef :: Ref m (TimingStats Int), + resourceQueueCountSource :: SignalSource m Int, + resourceTotalWaitTimeRef :: Ref m Double, + resourceWaitTimeRef :: Ref m (SamplingStats Double), + resourceWaitTimeSource :: SignalSource m (), + resourceWaitList :: StrategyQueue m s (ResourceItem m) } +data ResourceItem m = + ResourceItem { resourceItemTime :: Double, + resourceItemCont :: FrozenCont m () } + -- | Create a new FCFS resource with the specified initial count which value becomes -- the upper bound as well. newFCFSResource :: MonadDES m => Int -- ^ the initial count (and maximal count too) of the resource - -> Simulation m (FCFSResource m) + -> Event m (FCFSResource m) {-# INLINABLE newFCFSResource #-} newFCFSResource = newResource FCFS @@ -99,7 +136,7 @@ -- ^ the initial count of the resource -> Maybe Int -- ^ the maximum count of the resource, which can be indefinite - -> Simulation m (FCFSResource m) + -> Event m (FCFSResource m) {-# INLINABLE newFCFSResourceWithMaxCount #-} newFCFSResourceWithMaxCount = newResourceWithMaxCount FCFS @@ -108,7 +145,7 @@ newLCFSResource :: MonadDES m => Int -- ^ the initial count (and maximal count too) of the resource - -> Simulation m (LCFSResource m) + -> Event m (LCFSResource m) {-# INLINABLE newLCFSResource #-} newLCFSResource = newResource LCFS @@ -119,7 +156,7 @@ -- ^ the initial count of the resource -> Maybe Int -- ^ the maximum count of the resource, which can be indefinite - -> Simulation m (LCFSResource m) + -> Event m (LCFSResource m) {-# INLINABLE newLCFSResourceWithMaxCount #-} newLCFSResourceWithMaxCount = newResourceWithMaxCount LCFS @@ -128,7 +165,7 @@ newSIROResource :: (MonadDES m, QueueStrategy m SIRO) => Int -- ^ the initial count (and maximal count too) of the resource - -> Simulation m (SIROResource m) + -> Event m (SIROResource m) {-# INLINABLE newSIROResource #-} newSIROResource = newResource SIRO @@ -139,7 +176,7 @@ -- ^ the initial count of the resource -> Maybe Int -- ^ the maximum count of the resource, which can be indefinite - -> Simulation m (SIROResource m) + -> Event m (SIROResource m) {-# INLINABLE newSIROResourceWithMaxCount #-} newSIROResourceWithMaxCount = newResourceWithMaxCount SIRO @@ -148,7 +185,7 @@ newPriorityResource :: (MonadDES m, QueueStrategy m StaticPriorities) => Int -- ^ the initial count (and maximal count too) of the resource - -> Simulation m (PriorityResource m) + -> Event m (PriorityResource m) {-# INLINABLE newPriorityResource #-} newPriorityResource = newResource StaticPriorities @@ -159,7 +196,7 @@ -- ^ the initial count of the resource -> Maybe Int -- ^ the maximum count of the resource, which can be indefinite - -> Simulation m (PriorityResource m) + -> Event m (PriorityResource m) {-# INLINABLE newPriorityResourceWithMaxCount #-} newPriorityResourceWithMaxCount = newResourceWithMaxCount StaticPriorities @@ -170,20 +207,10 @@ -- ^ the strategy for managing the queuing requests -> Int -- ^ the initial count (and maximal count too) of the resource - -> Simulation m (Resource m s) + -> Event m (Resource m s) {-# INLINABLE newResource #-} newResource s count = - Simulation $ \r -> - do when (count < 0) $ - error $ - "The resource count cannot be negative: " ++ - "newResource." - countRef <- invokeSimulation r $ newRef count - waitList <- invokeSimulation r $ newStrategyQueue s - return Resource { resourceStrategy = s, - resourceMaxCount = Just count, - resourceCountRef = countRef, - resourceWaitList = waitList } + newResourceWithMaxCount s count (Just count) -- | Create a new resource with the specified queue strategy, initial and maximum counts, -- where 'Nothing' means that the resource has no upper bound. @@ -194,11 +221,13 @@ -- ^ the initial count of the resource -> Maybe Int -- ^ the maximum count of the resource, which can be indefinite - -> Simulation m (Resource m s) + -> Event m (Resource m s) {-# INLINABLE newResourceWithMaxCount #-} newResourceWithMaxCount s count maxCount = - Simulation $ \r -> - do when (count < 0) $ + Event $ \p -> + do let r = pointRun p + t = pointTime p + when (count < 0) $ error $ "The resource count cannot be negative: " ++ "newResourceWithMaxCount." @@ -210,23 +239,135 @@ _ -> return () countRef <- invokeSimulation r $ newRef count + countStatsRef <- invokeSimulation r $ newRef $ returnTimingStats t count + countSource <- invokeSimulation r newSignalSource + utilCountRef <- invokeSimulation r $ newRef 0 + utilCountStatsRef <- invokeSimulation r $ newRef $ returnTimingStats t 0 + utilCountSource <- invokeSimulation r newSignalSource + queueCountRef <- invokeSimulation r $ newRef 0 + queueCountStatsRef <- invokeSimulation r $ newRef $ returnTimingStats t 0 + queueCountSource <- invokeSimulation r newSignalSource + totalWaitTimeRef <- invokeSimulation r $ newRef 0 + waitTimeRef <- invokeSimulation r $ newRef emptySamplingStats + waitTimeSource <- invokeSimulation r newSignalSource waitList <- invokeSimulation r $ newStrategyQueue s return Resource { resourceStrategy = s, resourceMaxCount = maxCount, resourceCountRef = countRef, + resourceCountStatsRef = countStatsRef, + resourceCountSource = countSource, + resourceUtilisationCountRef = utilCountRef, + resourceUtilisationCountStatsRef = utilCountStatsRef, + resourceUtilisationCountSource = utilCountSource, + resourceQueueCountRef = queueCountRef, + resourceQueueCountStatsRef = queueCountStatsRef, + resourceQueueCountSource = queueCountSource, + resourceTotalWaitTimeRef = totalWaitTimeRef, + resourceWaitTimeRef = waitTimeRef, + resourceWaitTimeSource = waitTimeSource, resourceWaitList = waitList } --- | Return the current count of the resource. +-- | Return the current available count of the resource. resourceCount :: MonadDES m => Resource m s -> Event m Int {-# INLINABLE resourceCount #-} resourceCount r = Event $ \p -> invokeEvent p $ readRef (resourceCountRef r) +-- | Return the statistics for the available count of the resource. +resourceCountStats :: MonadDES m => Resource m s -> Event m (TimingStats Int) +{-# INLINABLE resourceCountStats #-} +resourceCountStats r = + Event $ \p -> invokeEvent p $ readRef (resourceCountStatsRef r) + +-- | Signal triggered when the 'resourceCount' property changes. +resourceCountChanged :: MonadDES m => Resource m s -> Signal m Int +{-# INLINABLE resourceCountChanged #-} +resourceCountChanged r = + publishSignal $ resourceCountSource r + +-- | Signal triggered when the 'resourceCount' property changes. +resourceCountChanged_ :: MonadDES m => Resource m s -> Signal m () +{-# INLINABLE resourceCountChanged_ #-} +resourceCountChanged_ r = + mapSignal (const ()) $ resourceCountChanged r + +-- | Return the current utilisation count of the resource. +resourceUtilisationCount :: MonadDES m => Resource m s -> Event m Int +{-# INLINABLE resourceUtilisationCount #-} +resourceUtilisationCount r = + Event $ \p -> invokeEvent p $ readRef (resourceUtilisationCountRef r) + +-- | Return the statistics for the utilisation count of the resource. +resourceUtilisationCountStats :: MonadDES m => Resource m s -> Event m (TimingStats Int) +{-# INLINABLE resourceUtilisationCountStats #-} +resourceUtilisationCountStats r = + Event $ \p -> invokeEvent p $ readRef (resourceUtilisationCountStatsRef r) + +-- | Signal triggered when the 'resourceUtilisationCount' property changes. +resourceUtilisationCountChanged :: MonadDES m => Resource m s -> Signal m Int +{-# INLINABLE resourceUtilisationCountChanged #-} +resourceUtilisationCountChanged r = + publishSignal $ resourceUtilisationCountSource r + +-- | Signal triggered when the 'resourceUtilisationCount' property changes. +resourceUtilisationCountChanged_ :: MonadDES m => Resource m s -> Signal m () +{-# INLINABLE resourceUtilisationCountChanged_ #-} +resourceUtilisationCountChanged_ r = + mapSignal (const ()) $ resourceUtilisationCountChanged r + +-- | Return the current queue length of the resource. +resourceQueueCount :: MonadDES m => Resource m s -> Event m Int +{-# INLINABLE resourceQueueCount #-} +resourceQueueCount r = + Event $ \p -> invokeEvent p $ readRef (resourceQueueCountRef r) + +-- | Return the statistics for the queue length of the resource. +resourceQueueCountStats :: MonadDES m => Resource m s -> Event m (TimingStats Int) +{-# INLINABLE resourceQueueCountStats #-} +resourceQueueCountStats r = + Event $ \p -> invokeEvent p $ readRef (resourceQueueCountStatsRef r) + +-- | Signal triggered when the 'resourceQueueCount' property changes. +resourceQueueCountChanged :: MonadDES m => Resource m s -> Signal m Int +{-# INLINABLE resourceQueueCountChanged #-} +resourceQueueCountChanged r = + publishSignal $ resourceQueueCountSource r + +-- | Signal triggered when the 'resourceQueueCount' property changes. +resourceQueueCountChanged_ :: MonadDES m => Resource m s -> Signal m () +{-# INLINABLE resourceQueueCountChanged_ #-} +resourceQueueCountChanged_ r = + mapSignal (const ()) $ resourceQueueCountChanged r + +-- | Return the total wait time of the resource. +resourceTotalWaitTime :: MonadDES m => Resource m s -> Event m Double +{-# INLINABLE resourceTotalWaitTime #-} +resourceTotalWaitTime r = + Event $ \p -> invokeEvent p $ readRef (resourceTotalWaitTimeRef r) + +-- | Return the statistics for the wait time of the resource. +resourceWaitTime :: MonadDES m => Resource m s -> Event m (SamplingStats Double) +{-# INLINABLE resourceWaitTime #-} +resourceWaitTime r = + Event $ \p -> invokeEvent p $ readRef (resourceWaitTimeRef r) + +-- | Signal triggered when the 'resourceTotalWaitTime' and 'resourceWaitTime' properties change. +resourceWaitTimeChanged :: MonadDES m => Resource m s -> Signal m (SamplingStats Double) +{-# INLINABLE resourceWaitTimeChanged #-} +resourceWaitTimeChanged r = + mapSignalM (\() -> resourceWaitTime r) $ resourceWaitTimeChanged_ r + +-- | Signal triggered when the 'resourceTotalWaitTime' and 'resourceWaitTime' properties change. +resourceWaitTimeChanged_ :: MonadDES m => Resource m s -> Signal m () +{-# INLINABLE resourceWaitTimeChanged_ #-} +resourceWaitTimeChanged_ r = + publishSignal $ resourceWaitTimeSource r + -- | Request for the resource decreasing its count in case of success, -- otherwise suspending the discontinuous process until some other -- process releases the resource. requestResource :: (MonadDES m, EnqueueStrategy m s) - => Resource m s + => Resource m s -- ^ the requested resource -> Process m () {-# INLINABLE requestResource #-} @@ -242,9 +383,12 @@ invokeProcess pid $ requestResource r invokeEvent p $ - strategyEnqueue (resourceWaitList r) c - else do let a' = a - 1 - a' `seq` invokeEvent p $ writeRef (resourceCountRef r) a' + strategyEnqueue (resourceWaitList r) $ + ResourceItem (pointTime p) c + invokeEvent p $ updateResourceQueueCount r 1 + else do invokeEvent p $ updateResourceWaitTime r 0 + invokeEvent p $ updateResourceCount r (-1) + invokeEvent p $ updateResourceUtilisationCount r 1 invokeEvent p $ resumeCont c () -- | Request with the priority for the resource decreasing its count @@ -269,9 +413,12 @@ invokeProcess pid $ requestResourceWithPriority r priority invokeEvent p $ - strategyEnqueueWithPriority (resourceWaitList r) priority c - else do let a' = a - 1 - a' `seq` invokeEvent p $ writeRef (resourceCountRef r) a' + strategyEnqueueWithPriority (resourceWaitList r) priority $ + ResourceItem (pointTime p) c + invokeEvent p $ updateResourceQueueCount r 1 + else do invokeEvent p $ updateResourceWaitTime r 0 + invokeEvent p $ updateResourceCount r (-1) + invokeEvent p $ updateResourceUtilisationCount r 1 invokeEvent p $ resumeCont c () -- | Release the resource increasing its count and resuming one of the @@ -297,27 +444,41 @@ {-# INLINABLE releaseResourceWithinEvent #-} releaseResourceWithinEvent r = Event $ \p -> + do invokeEvent p $ updateResourceUtilisationCount r (-1) + invokeEvent p $ releaseResource' r + +-- | Release the resource without affecting its utilisation. +releaseResource' :: (MonadDES m, DequeueStrategy m s) + => Resource m s + -- ^ the resource to release + -> Event m () +{-# INLINABLE releaseResource' #-} +releaseResource' r = + Event $ \p -> do a <- invokeEvent p $ readRef (resourceCountRef r) let a' = a + 1 case resourceMaxCount r of Just maxCount | a' > maxCount -> error $ "The resource count cannot be greater than " ++ - "its maximum value: releaseResourceWithinEvent." + "its maximum value: releaseResource'." _ -> return () f <- invokeEvent p $ strategyQueueNull (resourceWaitList r) if f - then a' `seq` invokeEvent p $ writeRef (resourceCountRef r) a' - else do c <- invokeEvent p $ + then invokeEvent p $ updateResourceCount r 1 + else do x <- invokeEvent p $ strategyDequeue (resourceWaitList r) - c <- invokeEvent p $ unfreezeCont c + invokeEvent p $ updateResourceQueueCount r (-1) + c <- invokeEvent p $ unfreezeCont (resourceItemCont x) case c of Nothing -> - invokeEvent p $ releaseResourceWithinEvent r + invokeEvent p $ releaseResource' r Just c -> - invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c () + do invokeEvent p $ updateResourceWaitTime r (pointTime p - resourceItemTime x) + invokeEvent p $ updateResourceUtilisationCount r 1 + 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'. @@ -331,8 +492,9 @@ do a <- invokeEvent p $ readRef (resourceCountRef r) if a == 0 then return False - else do let a' = a - 1 - a' `seq` invokeEvent p $ writeRef (resourceCountRef r) a' + else do invokeEvent p $ updateResourceWaitTime r 0 + invokeEvent p $ updateResourceCount r (-1) + invokeEvent p $ updateResourceUtilisationCount r 1 return True -- | Acquire the resource, perform some action and safely release the resource @@ -367,6 +529,17 @@ do requestResourceWithPriority r priority finallyProcess m $ releaseResource r +-- | Decrease the count of available resource. +decResourceCount' :: (MonadDES m, EnqueueStrategy m s) + => Resource m s + -- ^ the resource for which to decrease the count + -> Process m () +{-# INLINABLE decResourceCount' #-} +decResourceCount' r = + do liftEvent $ + updateResourceUtilisationCount r (-1) + requestResource r + -- | Increase the count of available resource by the specified number, -- invoking the awaiting processes as needed. incResourceCount :: (MonadDES m, DequeueStrategy m s) @@ -380,7 +553,7 @@ | n < 0 = error "The increment cannot be negative: incResourceCount" | n == 0 = return () | otherwise = - do releaseResourceWithinEvent r + do releaseResource' r incResourceCount r (n - 1) -- | Decrease the count of available resource by the specified number, @@ -396,5 +569,69 @@ | n < 0 = error "The decrement cannot be negative: decResourceCount" | n == 0 = return () | otherwise = - do requestResource r + do decResourceCount' r decResourceCount r (n - 1) + +-- | Signal triggered when one of the resource counters changes. +resourceChanged_ :: MonadDES m => Resource m s -> Signal m () +{-# INLINABLE resourceChanged_ #-} +resourceChanged_ r = + resourceCountChanged_ r <> + resourceUtilisationCountChanged_ r <> + resourceQueueCountChanged_ r + +-- | Update the resource count and its statistics. +updateResourceCount :: MonadDES m => Resource m s -> Int -> Event m () +{-# INLINABLE updateResourceCount #-} +updateResourceCount r delta = + Event $ \p -> + do a <- invokeEvent p $ readRef (resourceCountRef r) + let a' = a + delta + a' `seq` invokeEvent p $ writeRef (resourceCountRef r) a' + invokeEvent p $ + modifyRef (resourceCountStatsRef r) $ + addTimingStats (pointTime p) a' + invokeEvent p $ + triggerSignal (resourceCountSource r) a' + +-- | Update the resource utilisation count and its statistics. +updateResourceUtilisationCount :: MonadDES m => Resource m s -> Int -> Event m () +{-# INLINABLE updateResourceUtilisationCount #-} +updateResourceUtilisationCount r delta = + Event $ \p -> + do a <- invokeEvent p $ readRef (resourceUtilisationCountRef r) + let a' = a + delta + a' `seq` invokeEvent p $ writeRef (resourceUtilisationCountRef r) a' + invokeEvent p $ + modifyRef (resourceUtilisationCountStatsRef r) $ + addTimingStats (pointTime p) a' + invokeEvent p $ + triggerSignal (resourceUtilisationCountSource r) a' + +-- | Update the resource queue length and its statistics. +updateResourceQueueCount :: MonadDES m => Resource m s -> Int -> Event m () +{-# INLINABLE updateResourceQueueCount #-} +updateResourceQueueCount r delta = + Event $ \p -> + do a <- invokeEvent p $ readRef (resourceQueueCountRef r) + let a' = a + delta + a' `seq` invokeEvent p $ writeRef (resourceQueueCountRef r) a' + invokeEvent p $ + modifyRef (resourceQueueCountStatsRef r) $ + addTimingStats (pointTime p) a' + invokeEvent p $ + triggerSignal (resourceQueueCountSource r) a' + +-- | Update the resource wait time and its statistics. +updateResourceWaitTime :: MonadDES m => Resource m s -> Double -> Event m () +{-# INLINABLE updateResourceWaitTime #-} +updateResourceWaitTime r delta = + Event $ \p -> + do a <- invokeEvent p $ readRef (resourceTotalWaitTimeRef r) + let a' = a + delta + a' `seq` invokeEvent p $ writeRef (resourceTotalWaitTimeRef r) a' + invokeEvent p $ + modifyRef (resourceWaitTimeRef r) $ + addSamplingStats delta + invokeEvent p $ + triggerSignal (resourceWaitTimeSource r) () diff --git a/Simulation/Aivika/Trans/Resource/Base.hs b/Simulation/Aivika/Trans/Resource/Base.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Resource/Base.hs @@ -0,0 +1,405 @@ + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.Resource.Base +-- Copyright : Copyright (c) 2009-2016, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.10.3 +-- +-- This module defines an optimised version of 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. +-- +-- The module is optimised in the sense that this kind of the resource +-- has neither additional signals, nor counters that would may slow +-- down the simulation. +-- +module Simulation.Aivika.Trans.Resource.Base + (-- * Resource Types + FCFSResource, + LCFSResource, + SIROResource, + PriorityResource, + Resource, + -- * Creating Resource + newFCFSResource, + newFCFSResourceWithMaxCount, + newLCFSResource, + newLCFSResourceWithMaxCount, + newSIROResource, + newSIROResourceWithMaxCount, + newPriorityResource, + newPriorityResourceWithMaxCount, + newResource, + newResourceWithMaxCount, + -- * Resource Properties + resourceStrategy, + resourceMaxCount, + resourceCount, + -- * Requesting for and Releasing Resource + requestResource, + requestResourceWithPriority, + tryRequestResourceWithinEvent, + releaseResource, + releaseResourceWithinEvent, + usingResource, + usingResourceWithPriority, + -- * Altering Resource + incResourceCount, + decResourceCount) where + +import Control.Monad +import Control.Monad.Trans +import Control.Exception + +import Simulation.Aivika.Trans.Ref.Base +import Simulation.Aivika.Trans.DES +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Cont +import Simulation.Aivika.Trans.Internal.Process +import Simulation.Aivika.Trans.QueueStrategy + +-- | The ordinary FCFS (First Come - First Serviced) resource. +type FCFSResource m = Resource m FCFS + +-- | The ordinary LCFS (Last Come - First Serviced) resource. +type LCFSResource m = Resource m LCFS + +-- | The SIRO (Serviced in Random Order) resource. +type SIROResource m = Resource m SIRO + +-- | The resource with static priorities. +type PriorityResource m = Resource m StaticPriorities + +-- | Represents the resource with strategy @s@ applied for queuing the requests. +data Resource m s = + Resource { resourceStrategy :: s, + -- ^ 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 :: Ref m Int, + resourceWaitList :: StrategyQueue m s (FrozenCont m ()) } + +-- | Create a new FCFS resource with the specified initial count which value becomes +-- the upper bound as well. +newFCFSResource :: MonadDES m + => Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation m (FCFSResource m) +{-# INLINABLE newFCFSResource #-} +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 :: MonadDES m + => Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation m (FCFSResource m) +{-# INLINABLE newFCFSResourceWithMaxCount #-} +newFCFSResourceWithMaxCount = newResourceWithMaxCount FCFS + +-- | Create a new LCFS resource with the specified initial count which value becomes +-- the upper bound as well. +newLCFSResource :: MonadDES m + => Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation m (LCFSResource m) +{-# INLINABLE newLCFSResource #-} +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 :: MonadDES m + => Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation m (LCFSResource m) +{-# INLINABLE newLCFSResourceWithMaxCount #-} +newLCFSResourceWithMaxCount = newResourceWithMaxCount LCFS + +-- | Create a new SIRO resource with the specified initial count which value becomes +-- the upper bound as well. +newSIROResource :: (MonadDES m, QueueStrategy m SIRO) + => Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation m (SIROResource m) +{-# INLINABLE newSIROResource #-} +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 :: (MonadDES m, QueueStrategy m SIRO) + => Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation m (SIROResource m) +{-# INLINABLE newSIROResourceWithMaxCount #-} +newSIROResourceWithMaxCount = newResourceWithMaxCount SIRO + +-- | Create a new priority resource with the specified initial count which value becomes +-- the upper bound as well. +newPriorityResource :: (MonadDES m, QueueStrategy m StaticPriorities) + => Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation m (PriorityResource m) +{-# INLINABLE newPriorityResource #-} +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 :: (MonadDES m, QueueStrategy m StaticPriorities) + => Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation m (PriorityResource m) +{-# INLINABLE newPriorityResourceWithMaxCount #-} +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 :: (MonadDES m, QueueStrategy m s) + => s + -- ^ the strategy for managing the queuing requests + -> Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation m (Resource m s) +{-# INLINABLE newResource #-} +newResource s count = + Simulation $ \r -> + do when (count < 0) $ + error $ + "The resource count cannot be negative: " ++ + "newResource." + countRef <- invokeSimulation r $ newRef count + waitList <- invokeSimulation r $ newStrategyQueue s + return Resource { resourceStrategy = s, + resourceMaxCount = Just count, + resourceCountRef = countRef, + resourceWaitList = waitList } + +-- | Create a new resource with the specified queue strategy, initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newResourceWithMaxCount :: (MonadDES m, QueueStrategy m s) + => 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 m (Resource m s) +{-# INLINABLE newResourceWithMaxCount #-} +newResourceWithMaxCount s count maxCount = + Simulation $ \r -> + 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 <- invokeSimulation r $ newRef count + waitList <- invokeSimulation r $ newStrategyQueue s + return Resource { resourceStrategy = s, + resourceMaxCount = maxCount, + resourceCountRef = countRef, + resourceWaitList = waitList } + +-- | Return the current count of the resource. +resourceCount :: MonadDES m => Resource m s -> Event m Int +{-# INLINABLE resourceCount #-} +resourceCount r = + Event $ \p -> invokeEvent p $ readRef (resourceCountRef r) + +-- | Request for the resource decreasing its count in case of success, +-- otherwise suspending the discontinuous process until some other +-- process releases the resource. +requestResource :: (MonadDES m, EnqueueStrategy m s) + => Resource m s + -- ^ the requested resource + -> Process m () +{-# INLINABLE requestResource #-} +requestResource r = + Process $ \pid -> + Cont $ \c -> + Event $ \p -> + do a <- invokeEvent p $ readRef (resourceCountRef r) + if a == 0 + then do c <- invokeEvent p $ + freezeContReentering c () $ + invokeCont c $ + invokeProcess pid $ + requestResource r + invokeEvent p $ + strategyEnqueue (resourceWaitList r) c + else do let a' = a - 1 + a' `seq` invokeEvent p $ writeRef (resourceCountRef r) a' + invokeEvent p $ resumeCont c () + +-- | 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 :: (MonadDES m, PriorityQueueStrategy m s p) + => Resource m s + -- ^ the requested resource + -> p + -- ^ the priority + -> Process m () +{-# INLINABLE requestResourceWithPriority #-} +requestResourceWithPriority r priority = + Process $ \pid -> + Cont $ \c -> + Event $ \p -> + do a <- invokeEvent p $ readRef (resourceCountRef r) + if a == 0 + then do c <- invokeEvent p $ + freezeContReentering c () $ + invokeCont c $ + invokeProcess pid $ + requestResourceWithPriority r priority + invokeEvent p $ + strategyEnqueueWithPriority (resourceWaitList r) priority c + else do let a' = a - 1 + a' `seq` invokeEvent p $ writeRef (resourceCountRef r) a' + invokeEvent p $ resumeCont c () + +-- | Release the resource increasing its count and resuming one of the +-- previously suspended processes as possible. +releaseResource :: (MonadDES m, DequeueStrategy m s) + => Resource m s + -- ^ the resource to release + -> Process m () +{-# INLINABLE releaseResource #-} +releaseResource r = + Process $ \_ -> + Cont $ \c -> + Event $ \p -> + do invokeEvent p $ releaseResourceWithinEvent r + invokeEvent p $ resumeCont c () + +-- | Release the resource increasing its count and resuming one of the +-- previously suspended processes as possible. +releaseResourceWithinEvent :: (MonadDES m, DequeueStrategy m s) + => Resource m s + -- ^ the resource to release + -> Event m () +{-# INLINABLE releaseResourceWithinEvent #-} +releaseResourceWithinEvent r = + Event $ \p -> + do a <- invokeEvent p $ readRef (resourceCountRef r) + let a' = a + 1 + 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 (resourceWaitList r) + if f + then a' `seq` invokeEvent p $ writeRef (resourceCountRef r) a' + else do c <- invokeEvent p $ + strategyDequeue (resourceWaitList r) + c <- invokeEvent p $ unfreezeCont 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'. +tryRequestResourceWithinEvent :: MonadDES m + => Resource m s + -- ^ the resource which we try to request for + -> Event m Bool +{-# INLINABLE tryRequestResourceWithinEvent #-} +tryRequestResourceWithinEvent r = + Event $ \p -> + do a <- invokeEvent p $ readRef (resourceCountRef r) + if a == 0 + then return False + else do let a' = a - 1 + a' `seq` invokeEvent p $ writeRef (resourceCountRef r) a' + return True + +-- | Acquire the resource, perform some action and safely release the resource +-- in the end, even if the 'IOException' was raised within the action. +usingResource :: (MonadDES m, EnqueueStrategy m s) + => Resource m s + -- ^ the resource we are going to request for and then release in the end + -> Process m a + -- ^ the action we are going to apply having the resource + -> Process m a + -- ^ the result of the action +{-# INLINABLE usingResource #-} +usingResource r m = + do requestResource r + finallyProcess m $ releaseResource r + +-- | 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. +usingResourceWithPriority :: (MonadDES m, PriorityQueueStrategy m s p) + => Resource m s + -- ^ the resource we are going to request for and then + -- release in the end + -> p + -- ^ the priority + -> Process m a + -- ^ the action we are going to apply having the resource + -> Process m a + -- ^ the result of the action +{-# INLINABLE usingResourceWithPriority #-} +usingResourceWithPriority r priority m = + do requestResourceWithPriority r priority + finallyProcess m $ releaseResource r + +-- | Increase the count of available resource by the specified number, +-- invoking the awaiting processes as needed. +incResourceCount :: (MonadDES m, DequeueStrategy m s) + => Resource m s + -- ^ the resource + -> Int + -- ^ the increment for the resource count + -> Event m () +{-# INLINABLE incResourceCount #-} +incResourceCount r n + | n < 0 = error "The increment cannot be negative: incResourceCount" + | n == 0 = return () + | otherwise = + do releaseResourceWithinEvent r + incResourceCount r (n - 1) + +-- | Decrease the count of available resource by the specified number, +-- waiting for the processes capturing the resource as needed. +decResourceCount :: (MonadDES m, EnqueueStrategy m s) + => Resource m s + -- ^ the resource + -> Int + -- ^ the decrement for the resource count + -> Process m () +{-# INLINABLE decResourceCount #-} +decResourceCount r n + | n < 0 = error "The decrement cannot be negative: decResourceCount" + | n == 0 = return () + | otherwise = + do requestResource r + decResourceCount r (n - 1) diff --git a/Simulation/Aivika/Trans/Resource/Preemption.hs b/Simulation/Aivika/Trans/Resource/Preemption.hs --- a/Simulation/Aivika/Trans/Resource/Preemption.hs +++ b/Simulation/Aivika/Trans/Resource/Preemption.hs @@ -20,6 +20,8 @@ import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Event import Simulation.Aivika.Trans.Internal.Process +import Simulation.Aivika.Trans.Statistics +import Simulation.Aivika.Trans.Signal -- | A type class of monads whithin which we can create preemptible resources. class MonadDES m => MonadResource m where @@ -30,7 +32,7 @@ -- | Create a new resource with the specified initial count that becomes the upper bound as well. newResource :: Int -- ^ the initial count (and maximal count too) of the resource - -> Simulation m (Resource m) + -> Event m (Resource m) -- | Create a new resource with the specified initial and maximum counts, -- where 'Nothing' means that the resource has no upper bound. @@ -38,7 +40,7 @@ -- ^ the initial count of the resource -> Maybe Int -- ^ the maximum count of the resource, which can be indefinite - -> Simulation m (Resource m) + -> Event m (Resource m) -- | Return the current count of the resource. resourceCount :: Resource m -> Event m Int @@ -46,7 +48,55 @@ -- | Return the maximum count of the resource, where 'Nothing' -- means that the resource has no upper bound. resourceMaxCount :: Resource m -> Maybe Int - + + -- | Return the statistics for the available count of the resource. + resourceCountStats :: Resource m -> Event m (TimingStats Int) + + -- | Signal triggered when the 'resourceCount' property changes. + resourceCountChanged :: Resource m -> Signal m Int + + -- | Signal triggered when the 'resourceCount' property changes. + resourceCountChanged_ :: Resource m -> Signal m () + + -- | Return the current utilisation count of the resource. + resourceUtilisationCount :: Resource m -> Event m Int + + -- | Return the statistics for the utilisation count of the resource. + resourceUtilisationCountStats :: Resource m -> Event m (TimingStats Int) + + -- | Signal triggered when the 'resourceUtilisationCount' property changes. + resourceUtilisationCountChanged :: Resource m -> Signal m Int + + -- | Signal triggered when the 'resourceUtilisationCount' property changes. + resourceUtilisationCountChanged_ :: Resource m -> Signal m () + + -- | Return the current queue length of the resource. + resourceQueueCount :: Resource m -> Event m Int + + -- | Return the statistics for the queue length of the resource. + resourceQueueCountStats :: Resource m -> Event m (TimingStats Int) + + -- | Signal triggered when the 'resourceQueueCount' property changes. + resourceQueueCountChanged :: Resource m -> Signal m Int + + -- | Signal triggered when the 'resourceQueueCount' property changes. + resourceQueueCountChanged_ :: Resource m -> Signal m () + + -- | Return the total wait time of the resource. + resourceTotalWaitTime :: Resource m -> Event m Double + + -- | Return the statistics for the wait time of the resource. + resourceWaitTime :: Resource m -> Event m (SamplingStats Double) + + -- | Signal triggered when the 'resourceTotalWaitTime' and 'resourceWaitTime' properties change. + resourceWaitTimeChanged :: Resource m -> Signal m (SamplingStats Double) + + -- | Signal triggered when the 'resourceTotalWaitTime' and 'resourceWaitTime' properties change. + resourceWaitTimeChanged_ :: Resource m -> Signal m () + + -- | Signal triggered when one of the resource counters changes. + resourceChanged_ :: Resource m -> Signal m () + -- | 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. diff --git a/Simulation/Aivika/Trans/Resource/Preemption/Base.hs b/Simulation/Aivika/Trans/Resource/Preemption/Base.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Resource/Preemption/Base.hs @@ -0,0 +1,109 @@ + +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Simulation.Aivika.Trans.Resource.Preemption.Base +-- Copyright : Copyright (c) 2009-2016, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.10.3 +-- +-- This module defines the preemptible resource. +-- +-- The module is optimised in the sense that this kind of the resource +-- has neither additional signals, nor counters that would may slow +-- down the simulation. +-- +module Simulation.Aivika.Trans.Resource.Preemption.Base (MonadResource(..)) where + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.DES +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Process + +-- | A type class of monads whithin which we can create preemptible resources. +class MonadDES m => MonadResource m where + + -- | Represents a preemptible resource. + data Resource m + + -- | Create a new resource with the specified initial count that becomes the upper bound as well. + newResource :: Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation m (Resource m) + + -- | Create a new resource with the specified initial and maximum counts, + -- where 'Nothing' means that the resource has no upper bound. + newResourceWithMaxCount :: Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation m (Resource m) + + -- | Return the current count of the resource. + resourceCount :: Resource m -> Event m Int + + -- | Return the maximum count of the resource, where 'Nothing' + -- means that the resource has no upper bound. + resourceMaxCount :: Resource m -> Maybe Int + + -- | 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. + -- + -- It may preempt another process if the latter aquired the resource before + -- but had a lower priority. Then the current process takes an ownership of + -- the resource. + requestResourceWithPriority :: Resource m + -- ^ the requested resource + -> Double + -- ^ the priority (the less value has a higher priority) + -> Process m () + + -- | Release the resource increasing its count and resuming one of the + -- previously suspended or preempted processes as possible. + releaseResource :: Resource m + -- ^ the resource to release + -> Process m () + + -- | 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. + usingResourceWithPriority :: Resource m + -- ^ the resource we are going to request for and then + -- release in the end + -> Double + -- ^ the priority (the less value has a higher priority) + -> Process m a + -- ^ the action we are going to apply having the resource + -> Process m a + -- ^ the result of the action + + -- | Increase the count of available resource by the specified number, + -- invoking the awaiting and preempted processes according to their priorities + -- as needed. + incResourceCount :: Resource m + -- ^ the resource + -> Int + -- ^ the increment for the resource count + -> Event m () + + -- | Decrease the count of available resource by the specified number, + -- preempting the processes according to their priorities as needed. + decResourceCount :: Resource m + -- ^ the resource + -> Int + -- ^ the decrement for the resource count + -> Event m () + + -- | Alter the resource count either increasing or decreasing it by calling + -- 'incResourceCount' or 'decResourceCount' respectively. + alterResourceCount :: Resource m + -- ^ the resource + -> Int + -- ^ a change of the resource count + -> Event m () diff --git a/Simulation/Aivika/Trans/Results.hs b/Simulation/Aivika/Trans/Results.hs --- a/Simulation/Aivika/Trans/Results.hs +++ b/Simulation/Aivika/Trans/Results.hs @@ -131,9 +131,12 @@ import Simulation.Aivika.Trans.Arrival import Simulation.Aivika.Trans.Server import Simulation.Aivika.Trans.Activity +import Simulation.Aivika.Trans.Operation import Simulation.Aivika.Trans.Results.Locale import Simulation.Aivika.Trans.SD import Simulation.Aivika.Trans.DES +import Simulation.Aivika.Trans.Resource +import qualified Simulation.Aivika.Trans.Resource.Preemption as PR -- | A name used for indentifying the results when generating output. type ResultName = String @@ -1670,12 +1673,15 @@ resultContainerProperty c "totalInputWaitTime" ServerTotalInputWaitTimeId serverTotalInputWaitTime serverTotalInputWaitTimeChanged_, resultContainerProperty c "totalProcessingTime" ServerTotalProcessingTimeId serverTotalProcessingTime serverTotalProcessingTimeChanged_, resultContainerProperty c "totalOutputWaitTime" ServerTotalOutputWaitTimeId serverTotalOutputWaitTime serverTotalOutputWaitTimeChanged_, + resultContainerProperty c "totalPreemptionTime" ServerTotalPreemptionTimeId serverTotalPreemptionTime serverTotalPreemptionTimeChanged_, resultContainerProperty c "inputWaitTime" ServerInputWaitTimeId serverInputWaitTime serverInputWaitTimeChanged_, resultContainerProperty c "processingTime" ServerProcessingTimeId serverProcessingTime serverProcessingTimeChanged_, resultContainerProperty c "outputWaitTime" ServerOutputWaitTimeId serverOutputWaitTime serverOutputWaitTimeChanged_, + resultContainerProperty c "preemptionTime" ServerPreemptionTimeId serverPreemptionTime serverPreemptionTimeChanged_, resultContainerProperty c "inputWaitFactor" ServerInputWaitFactorId serverInputWaitFactor serverInputWaitFactorChanged_, resultContainerProperty c "processingFactor" ServerProcessingFactorId serverProcessingFactor serverProcessingFactorChanged_, - resultContainerProperty c "outputWaitFactor" ServerOutputWaitFactorId serverOutputWaitFactor serverOutputWaitFactorChanged_ ] } + resultContainerProperty c "outputWaitFactor" ServerOutputWaitFactorId serverOutputWaitFactor serverOutputWaitFactorChanged_, + resultContainerProperty c "preemptionFactor" ServerPreemptionFactorId serverPreemptionFactor serverPreemptionFactorChanged_ ] } -- | Return the summary by the specified server. serverResultSummary :: MonadDES m @@ -1694,9 +1700,11 @@ resultContainerProperty c "inputWaitTime" ServerInputWaitTimeId serverInputWaitTime serverInputWaitTimeChanged_, resultContainerProperty c "processingTime" ServerProcessingTimeId serverProcessingTime serverProcessingTimeChanged_, resultContainerProperty c "outputWaitTime" ServerOutputWaitTimeId serverOutputWaitTime serverOutputWaitTimeChanged_, + resultContainerProperty c "preemptionTime" ServerPreemptionTimeId serverPreemptionTime serverPreemptionTimeChanged_, resultContainerProperty c "inputWaitFactor" ServerInputWaitFactorId serverInputWaitFactor serverInputWaitFactorChanged_, resultContainerProperty c "processingFactor" ServerProcessingFactorId serverProcessingFactor serverProcessingFactorChanged_, - resultContainerProperty c "outputWaitFactor" ServerOutputWaitFactorId serverOutputWaitFactor serverOutputWaitFactorChanged_ ] } + resultContainerProperty c "outputWaitFactor" ServerOutputWaitFactorId serverOutputWaitFactor serverOutputWaitFactorChanged_, + resultContainerProperty c "preemptionFactor" ServerPreemptionFactorId serverPreemptionFactor serverPreemptionFactorChanged_ ] } -- | Return a source by the specified activity. activityResultSource :: (MonadDES m, @@ -1717,10 +1725,13 @@ resultContainerProperty c "state" ActivityStateId activityState activityStateChanged_, resultContainerProperty c "totalUtilisationTime" ActivityTotalUtilisationTimeId activityTotalUtilisationTime activityTotalUtilisationTimeChanged_, resultContainerProperty c "totalIdleTime" ActivityTotalIdleTimeId activityTotalIdleTime activityTotalIdleTimeChanged_, + resultContainerProperty c "totalPreemptionTime" ActivityTotalPreemptionTimeId activityTotalPreemptionTime activityTotalPreemptionTimeChanged_, resultContainerProperty c "utilisationTime" ActivityUtilisationTimeId activityUtilisationTime activityUtilisationTimeChanged_, resultContainerProperty c "idleTime" ActivityIdleTimeId activityIdleTime activityIdleTimeChanged_, + resultContainerProperty c "preemptionTime" ActivityPreemptionTimeId activityPreemptionTime activityPreemptionTimeChanged_, resultContainerProperty c "utilisationFactor" ActivityUtilisationFactorId activityUtilisationFactor activityUtilisationFactorChanged_, - resultContainerProperty c "idleFactor" ActivityIdleFactorId activityIdleFactor activityIdleFactorChanged_ ] } + resultContainerProperty c "idleFactor" ActivityIdleFactorId activityIdleFactor activityIdleFactorChanged_, + resultContainerProperty c "preemptionFactor" ActivityPreemptionFactorId activityPreemptionFactor activityPreemptionFactorChanged_ ] } -- | Return a summary by the specified activity. activityResultSummary :: MonadDES m @@ -1738,9 +1749,136 @@ resultObjectProperties = [ resultContainerProperty c "utilisationTime" ActivityUtilisationTimeId activityUtilisationTime activityUtilisationTimeChanged_, resultContainerProperty c "idleTime" ActivityIdleTimeId activityIdleTime activityIdleTimeChanged_, + resultContainerProperty c "preemptionTime" ActivityPreemptionTimeId activityPreemptionTime activityPreemptionTimeChanged_, resultContainerProperty c "utilisationFactor" ActivityUtilisationFactorId activityUtilisationFactor activityUtilisationFactorChanged_, - resultContainerProperty c "idleFactor" ActivityIdleFactorId activityIdleFactor activityIdleFactorChanged_ ] } + resultContainerProperty c "idleFactor" ActivityIdleFactorId activityIdleFactor activityIdleFactorChanged_, + resultContainerProperty c "preemptionFactor" ActivityPreemptionFactorId activityPreemptionFactor activityPreemptionFactorChanged_ ] } +-- | Return a source by the specified resource. +resourceResultSource :: (MonadDES m, + Show s, ResultItemable (ResultValue s)) + => ResultContainer (Resource m s) m + -- ^ the resource container + -> ResultSource m +resourceResultSource c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = ResourceId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = resourceResultSummary c, + resultObjectProperties = [ + resultContainerProperty c "queueCount" ResourceQueueCountId resourceQueueCount resourceQueueCountChanged_, + resultContainerProperty c "queueCountStats" ResourceQueueCountStatsId resourceQueueCountStats resourceQueueCountChanged_, + resultContainerProperty c "totalWaitTime" ResourceTotalWaitTimeId resourceTotalWaitTime resourceWaitTimeChanged_, + resultContainerProperty c "waitTime" ResourceWaitTimeId resourceWaitTime resourceWaitTimeChanged_, + resultContainerProperty c "count" ResourceCountId resourceCount resourceCountChanged_, + resultContainerProperty c "countStats" ResourceCountStatsId resourceCountStats resourceCountChanged_, + resultContainerProperty c "utilisationCount" ResourceUtilisationCountId resourceUtilisationCount resourceUtilisationCountChanged_, + resultContainerProperty c "utilisationCountStats" ResourceUtilisationCountStatsId resourceUtilisationCountStats resourceUtilisationCountChanged_ ] } + +-- | Return a summary by the specified resource. +resourceResultSummary :: MonadDES m + => ResultContainer (Resource m s) m + -- ^ the resource container + -> ResultSource m +resourceResultSummary c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = ResourceId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = resourceResultSummary c, + resultObjectProperties = [ + resultContainerProperty c "queueCountStats" ResourceQueueCountStatsId resourceQueueCountStats resourceQueueCountChanged_, + resultContainerProperty c "waitTime" ResourceWaitTimeId resourceWaitTime resourceWaitTimeChanged_, + resultContainerProperty c "countStats" ResourceCountStatsId resourceCountStats resourceCountChanged_, + resultContainerProperty c "utilisationCountStats" ResourceUtilisationCountStatsId resourceUtilisationCountStats resourceUtilisationCountChanged_ ] } + +-- | Return a source by the specified resource. +preemptibleResourceResultSource :: PR.MonadResource m + => ResultContainer (PR.Resource m) m + -- ^ the resource container + -> ResultSource m +preemptibleResourceResultSource c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = ResourceId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = preemptibleResourceResultSummary c, + resultObjectProperties = [ + resultContainerProperty c "queueCount" ResourceQueueCountId PR.resourceQueueCount PR.resourceQueueCountChanged_, + resultContainerProperty c "queueCountStats" ResourceQueueCountStatsId PR.resourceQueueCountStats PR.resourceQueueCountChanged_, + resultContainerProperty c "totalWaitTime" ResourceTotalWaitTimeId PR.resourceTotalWaitTime PR.resourceWaitTimeChanged_, + resultContainerProperty c "waitTime" ResourceWaitTimeId PR.resourceWaitTime PR.resourceWaitTimeChanged_, + resultContainerProperty c "count" ResourceCountId PR.resourceCount PR.resourceCountChanged_, + resultContainerProperty c "countStats" ResourceCountStatsId PR.resourceCountStats PR.resourceCountChanged_, + resultContainerProperty c "utilisationCount" ResourceUtilisationCountId PR.resourceUtilisationCount PR.resourceUtilisationCountChanged_, + resultContainerProperty c "utilisationCountStats" ResourceUtilisationCountStatsId PR.resourceUtilisationCountStats PR.resourceUtilisationCountChanged_ ] } + +-- | Return a summary by the specified resource. +preemptibleResourceResultSummary :: PR.MonadResource m + => ResultContainer (PR.Resource m) m + -- ^ the resource container + -> ResultSource m +preemptibleResourceResultSummary c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = ResourceId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = preemptibleResourceResultSummary c, + resultObjectProperties = [ + resultContainerProperty c "queueCountStats" ResourceQueueCountStatsId PR.resourceQueueCountStats PR.resourceQueueCountChanged_, + resultContainerProperty c "waitTime" ResourceWaitTimeId PR.resourceWaitTime PR.resourceWaitTimeChanged_, + resultContainerProperty c "countStats" ResourceCountStatsId PR.resourceCountStats PR.resourceCountChanged_, + resultContainerProperty c "utilisationCountStats" ResourceUtilisationCountStatsId PR.resourceUtilisationCountStats PR.resourceUtilisationCountChanged_ ] } + +-- | Return a source by the specified operation. +operationResultSource :: MonadDES m + => ResultContainer (Operation m a b) m + -- ^ the operation container + -> ResultSource m +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 :: MonadDES m + => ResultContainer (Operation m a b) m + -- ^ the operation container + -> ResultSource m +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 m textResultSource text = @@ -1973,3 +2111,18 @@ resultSource' name i m = activityResultSource $ ResultContainer name i m (ResultSignal $ activityChanged_ m) + +instance (MonadDES m, Show s, ResultItemable (ResultValue s)) => ResultProvider (Resource m s) m where + + resultSource' name i m = + resourceResultSource $ ResultContainer name i m (ResultSignal $ resourceChanged_ m) + +instance PR.MonadResource m => ResultProvider (PR.Resource m) m where + + resultSource' name i m = + preemptibleResourceResultSource $ ResultContainer name i m (ResultSignal $ PR.resourceChanged_ m) + +instance MonadDES m => ResultProvider (Operation m a b) m where + + resultSource' name i m = + operationResultSource $ ResultContainer name i m (ResultSignal $ operationChanged_ m) diff --git a/Simulation/Aivika/Trans/Results/Locale.hs b/Simulation/Aivika/Trans/Results/Locale.hs --- a/Simulation/Aivika/Trans/Results/Locale.hs +++ b/Simulation/Aivika/Trans/Results/Locale.hs @@ -34,6 +34,8 @@ import Simulation.Aivika.Trans.Arrival import Simulation.Aivika.Trans.Server import Simulation.Aivika.Trans.Activity +import Simulation.Aivika.Trans.Resource +import Simulation.Aivika.Trans.Operation -- | A locale to output the simulation results. -- @@ -173,10 +175,14 @@ -- ^ Property 'serverTotalProcessingTime'. | ServerTotalOutputWaitTimeId -- ^ Property 'serverTotalOutputWaitTime'. + | ServerTotalPreemptionTimeId + -- ^ Property 'serverTotalPreemptionTime'. | ServerInputWaitTimeId -- ^ Property 'serverInputWaitTime'. | ServerProcessingTimeId -- ^ Property 'serverProcessingTime'. + | ServerPreemptionTimeId + -- ^ Property 'serverPreemptionTime'. | ServerOutputWaitTimeId -- ^ Property 'serverOutputWaitTime'. | ServerInputWaitFactorId @@ -185,6 +191,8 @@ -- ^ Property 'serverProcessingFactor'. | ServerOutputWaitFactorId -- ^ Property 'serverOutputWaitFactor'. + | ServerPreemptionFactorId + -- ^ Property 'serverPreemptionFactor'. | ActivityId -- ^ Represents an 'Activity'. | ActivityInitStateId @@ -195,14 +203,52 @@ -- ^ Property 'activityTotalUtilisationTime'. | ActivityTotalIdleTimeId -- ^ Property 'activityTotalIdleTime'. + | ActivityTotalPreemptionTimeId + -- ^ Property 'activityTotalPreemptionTime'. | ActivityUtilisationTimeId -- ^ Property 'activityUtilisationTime'. | ActivityIdleTimeId -- ^ Property 'activityIdleTime'. + | ActivityPreemptionTimeId + -- ^ Property 'activityPreemptionTime'. | ActivityUtilisationFactorId -- ^ Property 'activityUtilisationFactor'. | ActivityIdleFactorId -- ^ Property 'activityIdleFactor'. + | ActivityPreemptionFactorId + -- ^ Property 'activityPreemptionFactor'. + | ResourceId + -- ^ Represents a 'Resource'. + | ResourceCountId + -- ^ Property 'resourceCount'. + | ResourceCountStatsId + -- ^ Property 'resourceCountStats'. + | ResourceUtilisationCountId + -- ^ Property 'resourceUtilisationCount'. + | ResourceUtilisationCountStatsId + -- ^ Property 'resourceUtilisationCountStats'. + | ResourceQueueCountId + -- ^ Property 'resourceQueueCount'. + | ResourceQueueCountStatsId + -- ^ Property 'resourceQueueCountStats'. + | ResourceTotalWaitTimeId + -- ^ 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) @@ -282,21 +328,43 @@ russianResultLocalisation ServerTotalInputWaitTimeId = "общее время блокировки в ожидании ввода" russianResultLocalisation ServerTotalProcessingTimeId = "общее время, потраченное на саму обработку заданий" russianResultLocalisation ServerTotalOutputWaitTimeId = "общее время блокировки при попытке доставить вывод" +russianResultLocalisation ServerTotalPreemptionTimeId = "общее время вытеснения" russianResultLocalisation ServerInputWaitTimeId = "время блокировки в ожидании ввода" russianResultLocalisation ServerProcessingTimeId = "время, потраченное на саму обработку заданий" russianResultLocalisation ServerOutputWaitTimeId = "время блокировки при попытке доставить вывод" +russianResultLocalisation ServerPreemptionTimeId = "время вытеснения" russianResultLocalisation ServerInputWaitFactorId = "относительное время блокировки в ожидании ввода (от 0 до 1)" russianResultLocalisation ServerProcessingFactorId = "относительное время, потраченное на саму обработку заданий (от 0 до 1)" russianResultLocalisation ServerOutputWaitFactorId = "относительное время блокировки при попытке доставить вывод (от 0 до 1)" +russianResultLocalisation ServerPreemptionFactorId = "относительное время вытеснения (от 0 до 1)" russianResultLocalisation ActivityId = "активность" russianResultLocalisation ActivityInitStateId = "начальное состояние" russianResultLocalisation ActivityStateId = "текущее состояние" russianResultLocalisation ActivityTotalUtilisationTimeId = "общее время использования" russianResultLocalisation ActivityTotalIdleTimeId = "общее время простоя" +russianResultLocalisation ActivityTotalPreemptionTimeId = "общее время вытеснения" russianResultLocalisation ActivityUtilisationTimeId = "статистика времени использования" russianResultLocalisation ActivityIdleTimeId = "статистика времени простоя" +russianResultLocalisation ActivityPreemptionTimeId = "статистика времени вытеснения" russianResultLocalisation ActivityUtilisationFactorId = "относительное время использования (от 0 до 1)" russianResultLocalisation ActivityIdleFactorId = "относительное время простоя (от 0 до 1)" +russianResultLocalisation ActivityPreemptionFactorId = "относительное время вытеснения (от 0 до 1)" +russianResultLocalisation ResourceId = "ресурс" +russianResultLocalisation ResourceCountId = "текущее доступное количество ресурса" +russianResultLocalisation ResourceCountStatsId = "статистика по доступному количеству ресурса" +russianResultLocalisation ResourceUtilisationCountId = "текущее используемое количество ресурса" +russianResultLocalisation ResourceUtilisationCountStatsId = "статистика по используемому количеству ресурса" +russianResultLocalisation ResourceQueueCountId = "текущая длина очереди к ресурсу" +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 @@ -366,21 +434,43 @@ englishResultLocalisation ServerTotalInputWaitTimeId = "the total time spent while waiting for input" englishResultLocalisation ServerTotalProcessingTimeId = "the total time spent on actual processing the tasks" englishResultLocalisation ServerTotalOutputWaitTimeId = "the total time spent on delivering the output" +englishResultLocalisation ServerTotalPreemptionTimeId = "the total time spent being preempted" englishResultLocalisation ServerInputWaitTimeId = "the time spent while waiting for input" englishResultLocalisation ServerProcessingTimeId = "the time spent on processing the tasks" englishResultLocalisation ServerOutputWaitTimeId = "the time spent on delivering the output" +englishResultLocalisation ServerPreemptionTimeId = "the time spent being preempted" englishResultLocalisation ServerInputWaitFactorId = "the relative time spent while waiting for input (from 0 to 1)" englishResultLocalisation ServerProcessingFactorId = "the relative time spent on processing the tasks (from 0 to 1)" englishResultLocalisation ServerOutputWaitFactorId = "the relative time spent on delivering the output (from 0 to 1)" +englishResultLocalisation ServerPreemptionFactorId = "the relative time spent being preempted (from 0 to 1)" englishResultLocalisation ActivityId = "the activity" englishResultLocalisation ActivityInitStateId = "the initial state" englishResultLocalisation ActivityStateId = "the current state" englishResultLocalisation ActivityTotalUtilisationTimeId = "the total time of utilisation" englishResultLocalisation ActivityTotalIdleTimeId = "the total idle time" +englishResultLocalisation ActivityTotalPreemptionTimeId = "the total time of preemption" englishResultLocalisation ActivityUtilisationTimeId = "the utilisation time" englishResultLocalisation ActivityIdleTimeId = "the idle time" -englishResultLocalisation ActivityUtilisationFactorId = "the relative utilisation time (от 0 до 1)" +englishResultLocalisation ActivityPreemptionTimeId = "the preemption time" +englishResultLocalisation ActivityUtilisationFactorId = "the relative utilisation time (from 0 to 1)" englishResultLocalisation ActivityIdleFactorId = "the relative idle 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" +englishResultLocalisation ResourceUtilisationCountId = "the current utilisation count" +englishResultLocalisation ResourceUtilisationCountStatsId = "the utilisation count statistics" +englishResultLocalisation ResourceQueueCountId = "the current queue length" +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/Trans/Server.hs b/Simulation/Aivika/Trans/Server.hs --- a/Simulation/Aivika/Trans/Server.hs +++ b/Simulation/Aivika/Trans/Server.hs @@ -83,7 +83,6 @@ import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Event import Simulation.Aivika.Trans.Signal -import Simulation.Aivika.Trans.Resource import Simulation.Aivika.Trans.Cont import Simulation.Aivika.Trans.Process import Simulation.Aivika.Trans.Processor diff --git a/Simulation/Aivika/Trans/Server/Random.hs b/Simulation/Aivika/Trans/Server/Random.hs --- a/Simulation/Aivika/Trans/Server/Random.hs +++ b/Simulation/Aivika/Trans/Server/Random.hs @@ -15,20 +15,33 @@ module Simulation.Aivika.Trans.Server.Random (newRandomUniformServer, newRandomUniformIntServer, + newRandomTriangularServer, newRandomNormalServer, + newRandomLogNormalServer, newRandomExponentialServer, newRandomErlangServer, newRandomPoissonServer, newRandomBinomialServer, + newRandomGammaServer, + newRandomBetaServer, + newRandomWeibullServer, + newRandomDiscreteServer, newPreemptibleRandomUniformServer, newPreemptibleRandomUniformIntServer, + newPreemptibleRandomTriangularServer, newPreemptibleRandomNormalServer, + newPreemptibleRandomLogNormalServer, newPreemptibleRandomExponentialServer, newPreemptibleRandomErlangServer, newPreemptibleRandomPoissonServer, - newPreemptibleRandomBinomialServer) where + newPreemptibleRandomBinomialServer, + newPreemptibleRandomGammaServer, + newPreemptibleRandomBetaServer, + newPreemptibleRandomWeibullServer, + newPreemptibleRandomDiscreteServer) where import Simulation.Aivika.Trans.DES +import Simulation.Aivika.Trans.Generator import Simulation.Aivika.Trans.Simulation import Simulation.Aivika.Trans.Process import Simulation.Aivika.Trans.Process.Random @@ -67,6 +80,24 @@ newPreemptibleRandomUniformIntServer False -- | Create a new server 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 server process cannot be preempted, +-- because the handling of possible task preemption is rather costly +-- operation. +newRandomTriangularServer :: MonadDES m + => Double + -- ^ the minimum time interval + -> Double + -- ^ the median of the time interval + -> Double + -- ^ the maximum time interval + -> Simulation m (Server m () a a) +{-# INLINABLE newRandomTriangularServer #-} +newRandomTriangularServer = + newPreemptibleRandomTriangularServer False + +-- | Create a new server that holds the process for a random time interval -- distributed normally, when processing every input element. -- -- By default, it is assumed that the server process cannot be preempted, @@ -83,6 +114,24 @@ newPreemptibleRandomNormalServer False -- | Create a new server 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 server process cannot be preempted, +-- because the handling of possible task preemption is rather costly +-- operation. +newRandomLogNormalServer :: MonadDES m + => 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 + -> Simulation m (Server m () a a) +{-# INLINABLE newRandomLogNormalServer #-} +newRandomLogNormalServer = + newPreemptibleRandomLogNormalServer False + +-- | Create a new server 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. -- @@ -147,6 +196,71 @@ newPreemptibleRandomBinomialServer False -- | Create a new server 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 server process cannot be preempted, +-- because the handling of possible task preemption is rather costly +-- operation. +newRandomGammaServer :: MonadDES m + => Double + -- ^ the shape + -> Double + -- ^ the scale (a reciprocal of the rate) + -> Simulation m (Server m () a a) +{-# INLINABLE newRandomGammaServer #-} +newRandomGammaServer = + newPreemptibleRandomGammaServer False + +-- | Create a new server 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 server process cannot be preempted, +-- because the handling of possible task preemption is rather costly +-- operation. +newRandomBetaServer :: MonadDES m + => Double + -- ^ shape (alpha) + -> Double + -- ^ shape (beta) + -> Simulation m (Server m () a a) +{-# INLINABLE newRandomBetaServer #-} +newRandomBetaServer = + newPreemptibleRandomBetaServer False + +-- | Create a new server 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 server process cannot be preempted, +-- because the handling of possible task preemption is rather costly +-- operation. +newRandomWeibullServer :: MonadDES m + => Double + -- ^ shape + -> Double + -- ^ scale + -> Simulation m (Server m () a a) +{-# INLINABLE newRandomWeibullServer #-} +newRandomWeibullServer = + newPreemptibleRandomWeibullServer False + +-- | Create a new server 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 server process cannot be preempted, +-- because the handling of possible task preemption is rather costly +-- operation. +newRandomDiscreteServer :: MonadDES m + => DiscretePDF Double + -- ^ the discrete probability density function + -> Simulation m (Server m () a a) +{-# INLINABLE newRandomDiscreteServer #-} +newRandomDiscreteServer = + newPreemptibleRandomDiscreteServer False + +-- | Create a new server that holds the process for a random time interval -- distributed uniformly, when processing every input element. newPreemptibleRandomUniformServer :: MonadDES m => Bool @@ -179,6 +293,24 @@ return a -- | Create a new server that holds the process for a random time interval +-- having the triangular distribution, when processing every input element. +newPreemptibleRandomTriangularServer :: MonadDES m + => Bool + -- ^ whether the server process can be preempted + -> Double + -- ^ the minimum time interval + -> Double + -- ^ the median of the time interval + -> Double + -- ^ the maximum time interval + -> Simulation m (Server m () a a) +{-# INLINABLE newPreemptibleRandomTriangularServer #-} +newPreemptibleRandomTriangularServer preemptible min median max = + newPreemptibleServer preemptible $ \a -> + do randomTriangularProcess_ min median max + return a + +-- | Create a new server that holds the process for a random time interval -- distributed normally, when processing every input element. newPreemptibleRandomNormalServer :: MonadDES m => Bool @@ -193,6 +325,24 @@ newPreemptibleServer preemptible $ \a -> do randomNormalProcess_ mu nu return a + +-- | Create a new server that holds the process for a random time interval +-- having the lognormal distribution, when processing every input element. +newPreemptibleRandomLogNormalServer :: MonadDES m + => Bool + -- ^ whether the server 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 + -> Simulation m (Server m () a a) +{-# INLINABLE newPreemptibleRandomLogNormalServer #-} +newPreemptibleRandomLogNormalServer preemptible mu nu = + newPreemptibleServer preemptible $ \a -> + do randomLogNormalProcess_ mu nu + return a -- | Create a new server that holds the process for a random time interval -- distributed exponentially with the specified mean (the reciprocal of the rate), @@ -256,4 +406,69 @@ newPreemptibleRandomBinomialServer preemptible prob trials = newPreemptibleServer preemptible $ \a -> do randomBinomialProcess_ prob trials + return a + +-- | Create a new server that holds the process for a random time interval +-- having the Gamma distribution with the specified shape and scale, +-- when processing every input element. +newPreemptibleRandomGammaServer :: MonadDES m + => Bool + -- ^ whether the server process can be preempted + -> Double + -- ^ the shape + -> Double + -- ^ the scale (a reciprocal of the rate) + -> Simulation m (Server m () a a) +{-# INLINABLE newPreemptibleRandomGammaServer #-} +newPreemptibleRandomGammaServer preemptible kappa theta = + newPreemptibleServer preemptible $ \a -> + do randomGammaProcess_ kappa theta + return a + +-- | Create a new server 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. +newPreemptibleRandomBetaServer :: MonadDES m + => Bool + -- ^ whether the server process can be preempted + -> Double + -- ^ shape (alpha) + -> Double + -- ^ shape (beta) + -> Simulation m (Server m () a a) +{-# INLINABLE newPreemptibleRandomBetaServer #-} +newPreemptibleRandomBetaServer preemptible alpha beta = + newPreemptibleServer preemptible $ \a -> + do randomBetaProcess_ alpha beta + return a + +-- | Create a new server that holds the process for a random time interval +-- having the Weibull distribution with the specified shape and scale, +-- when processing every input element. +newPreemptibleRandomWeibullServer :: MonadDES m + => Bool + -- ^ whether the server process can be preempted + -> Double + -- ^ shape + -> Double + -- ^ scale + -> Simulation m (Server m () a a) +{-# INLINABLE newPreemptibleRandomWeibullServer #-} +newPreemptibleRandomWeibullServer preemptible alpha beta = + newPreemptibleServer preemptible $ \a -> + do randomWeibullProcess_ alpha beta + return a + +-- | Create a new server that holds the process for a random time interval +-- having the specified discrete distribution, when processing every input element. +newPreemptibleRandomDiscreteServer :: MonadDES m + => Bool + -- ^ whether the server process can be preempted + -> DiscretePDF Double + -- ^ the discrete probability density function + -> Simulation m (Server m () a a) +{-# INLINABLE newPreemptibleRandomDiscreteServer #-} +newPreemptibleRandomDiscreteServer preemptible dpdf = + newPreemptibleServer preemptible $ \a -> + do randomDiscreteProcess_ dpdf return a diff --git a/Simulation/Aivika/Trans/Stream.hs b/Simulation/Aivika/Trans/Stream.hs --- a/Simulation/Aivika/Trans/Stream.hs +++ b/Simulation/Aivika/Trans/Stream.hs @@ -50,6 +50,7 @@ repeatProcess, mapStream, mapStreamM, + accumStream, apStream, apStreamM, filterStream, @@ -73,6 +74,11 @@ replaceLeftStream, replaceRightStream, partitionEitherStream, + -- * Assemblying Streams + cloneStream, + firstArrivalStream, + lastArrivalStream, + assembleAccumStream, -- * Debugging traceStream) where @@ -92,9 +98,9 @@ import Simulation.Aivika.Trans.Cont import Simulation.Aivika.Trans.Process import Simulation.Aivika.Trans.Signal -import Simulation.Aivika.Trans.Resource +import Simulation.Aivika.Trans.Resource.Base import Simulation.Aivika.Trans.QueueStrategy -import Simulation.Aivika.Trans.Queue.Infinite +import Simulation.Aivika.Trans.Queue.Infinite.Base import Simulation.Aivika.Arrival (Arrival(..)) -- | Represents an infinite stream of data in time, @@ -239,6 +245,15 @@ b <- f a return (b, mapStreamM f xs) +-- | Accumulator that outputs a value determined by the supplied function. +accumStream :: MonadDES m => (acc -> a -> Process m (acc, b)) -> acc -> Stream m a -> Stream m b +{-# INLINABLE accumStream #-} +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 :: MonadDES m => Stream m (a -> b) -> Stream m a -> Stream m b {-# INLINABLE apStream #-} @@ -603,7 +618,7 @@ signalStream :: MonadDES m => Signal m a -> Process m (Stream m a) {-# INLINABLE signalStream #-} signalStream s = - do q <- liftEvent newFCFSQueue + do q <- liftSimulation newFCFSQueue h <- liftEvent $ handleSignal s $ enqueue q @@ -759,6 +774,60 @@ if f then runStream $ dropStreamWhileM p xs else return (a, xs) + +-- | Create the specified number of equivalent clones of the input stream. +cloneStream :: MonadDES m => Int -> Stream m a -> Simulation m [Stream m a] +{-# INLINABLE cloneStream #-} +cloneStream n s = + do qs <- forM [1..n] $ \i -> newFCFSQueue + rs <- newFCFSResource 1 + ref <- newRef 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 <- liftEvent $ readRef ref + (a, xs) <- runStream s + liftEvent $ writeRef 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 :: MonadDES m => Int -> Stream m a -> Stream m a +{-# INLINABLE firstArrivalStream #-} +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 :: MonadDES m => Int -> Stream m a -> Stream m a +{-# INLINABLE lastArrivalStream #-} +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 :: MonadDES m => (acc -> a -> Process m (acc, Maybe b)) -> acc -> Stream m a -> Stream m b +{-# INLINABLE assembleAccumStream #-} +assembleAccumStream f acc s = + mapStream fromJust $ + filterStream isJust $ + accumStream f acc s -- | Show the debug messages with the current simulation time. traceStream :: MonadDES m diff --git a/Simulation/Aivika/Trans/Stream/Random.hs b/Simulation/Aivika/Trans/Stream/Random.hs --- a/Simulation/Aivika/Trans/Stream/Random.hs +++ b/Simulation/Aivika/Trans/Stream/Random.hs @@ -16,18 +16,23 @@ randomStream, randomUniformStream, randomUniformIntStream, + randomTriangularStream, randomNormalStream, + randomLogNormalStream, randomExponentialStream, randomErlangStream, randomPoissonStream, - randomBinomialStream) where - -import System.Random + randomBinomialStream, + randomGammaStream, + randomBetaStream, + randomWeibullStream, + randomDiscreteStream) where import Control.Monad import Control.Monad.Trans import Simulation.Aivika.Trans.DES +import Simulation.Aivika.Trans.Generator import Simulation.Aivika.Trans.Parameter import Simulation.Aivika.Trans.Parameter.Random import Simulation.Aivika.Trans.Simulation @@ -99,6 +104,22 @@ randomUniformInt min max >>= \x -> return (fromIntegral x, x) +-- | Create a new stream with random delays having the triangular distribution. +randomTriangularStream :: MonadDES m + => Double + -- ^ the minimum delay + -> Double + -- ^ the median of the delay + -> Double + -- ^ the maximum delay + -> Stream m (Arrival Double) + -- ^ the stream of random events with the delays generated +{-# INLINABLE randomTriangularStream #-} +randomTriangularStream min median max = + randomStream $ + randomTriangular min median max >>= \x -> + return (x, x) + -- | Create a new stream with delays distributed normally. randomNormalStream :: MonadDES m => Double @@ -112,6 +133,22 @@ randomStream $ randomNormal mu nu >>= \x -> return (x, x) + +-- | Create a new stream with random delays having the lognormal distribution. +randomLogNormalStream :: MonadDES m + => 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 + -> Stream m (Arrival Double) + -- ^ the stream of random events with the delays generated +{-# INLINABLE randomLogNormalStream #-} +randomLogNormalStream mu nu = + randomStream $ + randomLogNormal mu nu >>= \x -> + return (x, x) -- | Return a new stream with delays distibuted exponentially with the specified mean -- (the reciprocal of the rate). @@ -168,3 +205,60 @@ randomStream $ randomBinomial prob trials >>= \x -> return (fromIntegral x, x) + +-- | Return a new stream with random delays having the Gamma distribution by the specified +-- shape and scale. +randomGammaStream :: MonadDES m + => Double + -- ^ the shape + -> Double + -- ^ the scale (a reciprocal of the rate) + -> Stream m (Arrival Double) + -- ^ the stream of random events with the delays generated +{-# INLINABLE randomGammaStream #-} +randomGammaStream kappa theta = + randomStream $ + randomGamma kappa theta >>= \x -> + return (x, x) + +-- | Return a new stream with random delays having the Beta distribution by the specified +-- shape parameters (alpha and beta). +randomBetaStream :: MonadDES m + => Double + -- ^ the shape (alpha) + -> Double + -- ^ the shape (beta) + -> Stream m (Arrival Double) + -- ^ the stream of random events with the delays generated +{-# INLINABLE randomBetaStream #-} +randomBetaStream alpha beta = + randomStream $ + randomBeta alpha beta >>= \x -> + return (x, x) + +-- | Return a new stream with random delays having the Weibull distribution by the specified +-- shape and scale. +randomWeibullStream :: MonadDES m + => Double + -- ^ shape + -> Double + -- ^ scale + -> Stream m (Arrival Double) + -- ^ the stream of random events with the delays generated +{-# INLINABLE randomWeibullStream #-} +randomWeibullStream alpha beta = + randomStream $ + randomWeibull alpha beta >>= \x -> + return (x, x) + +-- | Return a new stream with random delays having the specified discrete distribution. +randomDiscreteStream :: MonadDES m + => DiscretePDF Double + -- ^ the discrete probability density function + -> Stream m (Arrival Double) + -- ^ the stream of random events with the delays generated +{-# INLINABLE randomDiscreteStream #-} +randomDiscreteStream dpdf = + randomStream $ + randomDiscrete dpdf >>= \x -> + return (x, x) diff --git a/aivika-transformers.cabal b/aivika-transformers.cabal --- a/aivika-transformers.cabal +++ b/aivika-transformers.cabal @@ -1,5 +1,5 @@ name: aivika-transformers -version: 4.3.1 +version: 4.3.2 synopsis: Transformers for the Aivika simulation library description: This package is a generalization of the Aivika [1] simulation library @@ -10,7 +10,7 @@ category: Simulation license: BSD3 license-file: LICENSE -copyright: (c) 2009-2015. David Sorokin +copyright: (c) 2009-2016. David Sorokin author: David Sorokin maintainer: David Sorokin homepage: http://www.aivikasoft.com/en/products/aivika.html @@ -19,20 +19,30 @@ tested-with: GHC == 7.10.1 extra-source-files: examples/BassDiffusion.hs + examples/BouncingBall.hs examples/ChemicalReaction.hs examples/ChemicalReactionCircuit.hs examples/FishBank.hs + examples/Furnace.hs + examples/InspectionAdjustmentStations.hs + examples/InventorySystem.hs examples/MachRep1.hs examples/MachRep1EventDriven.hs examples/MachRep1TimeDriven.hs examples/MachRep2.hs examples/MachRep3.hs - examples/Furnace.hs - examples/InspectionAdjustmentStations.hs - examples/WorkStationsInSeries.hs + examples/MachineBreakdowns.hs + examples/PERT.hs + examples/PingPong.hs + examples/PortOperations.hs + examples/QuarryOperations.hs + examples/RenegingFromQueue.hs + examples/SingleLaneTraffic.hs examples/TimeOut.hs examples/TimeOutInt.hs examples/TimeOutWait.hs + examples/TruckHaulingSituation.hs + examples/WorkStationsInSeries.hs library @@ -56,9 +66,12 @@ Simulation.Aivika.Trans.Exception Simulation.Aivika.Trans.Gate Simulation.Aivika.Trans.Generator + Simulation.Aivika.Trans.Generator.Primitive Simulation.Aivika.Trans.Internal.Types Simulation.Aivika.Trans.Net Simulation.Aivika.Trans.Net.Random + Simulation.Aivika.Trans.Operation + Simulation.Aivika.Trans.Operation.Random Simulation.Aivika.Trans.Parameter Simulation.Aivika.Trans.Parameter.Random Simulation.Aivika.Trans.Process @@ -67,12 +80,16 @@ Simulation.Aivika.Trans.Processor.Random Simulation.Aivika.Trans.Processor.RoundRobbin Simulation.Aivika.Trans.Queue + Simulation.Aivika.Trans.Queue.Base Simulation.Aivika.Trans.Queue.Infinite + Simulation.Aivika.Trans.Queue.Infinite.Base Simulation.Aivika.Trans.QueueStrategy Simulation.Aivika.Trans.Ref Simulation.Aivika.Trans.Ref.Base Simulation.Aivika.Trans.Resource + Simulation.Aivika.Trans.Resource.Base Simulation.Aivika.Trans.Resource.Preemption + Simulation.Aivika.Trans.Resource.Preemption.Base Simulation.Aivika.Trans.Results.Locale Simulation.Aivika.Trans.Results Simulation.Aivika.Trans.Results.IO @@ -109,6 +126,7 @@ Simulation.Aivika.IO.Signal Simulation.Aivika.IO.Ref.Base Simulation.Aivika.IO.Resource.Preemption + Simulation.Aivika.IO.Resource.Preemption.Base Simulation.Aivika.IO.Var Simulation.Aivika.IO.Var.Unboxed @@ -140,6 +158,7 @@ TypeFamilies, TypeSynonymInstances, DeriveDataTypeable, + RankNTypes, CPP ghc-options: -O2 diff --git a/examples/BassDiffusion.hs b/examples/BassDiffusion.hs --- a/examples/BassDiffusion.hs +++ b/examples/BassDiffusion.hs @@ -2,6 +2,17 @@ -- This is the Bass Diffusion model solved with help of -- the Agent-based Modeling as described in the AnyLogic -- documentation. +-- +-- The model describes a product diffusion process. Potential +-- adopters of a product are influenced into buying the product +-- by advertising and by word of mouth from adopters, those +-- who have already purchased the new product. Adoption of +-- a new product driven by word of mouth is likewise an epidemic. +-- Potential adopters come into contact with adopters through +-- social interactions. A fraction of these contacts results +-- in the purchase of the new product. The advertising causes +-- a constant fraction of the potential adopter population +-- to adopt each time period. import Data.Array diff --git a/examples/BouncingBall.hs b/examples/BouncingBall.hs new file mode 100644 --- /dev/null +++ b/examples/BouncingBall.hs @@ -0,0 +1,63 @@ + +{-# LANGUAGE RecursiveDo #-} + +-- Example: Simulation of a Bouncing Ball. +-- +-- It is described in MATLAB & Simulink example available by the following link: +-- +-- http://www.mathworks.com/help/simulink/examples/simulation-of-a-bouncing-ball.html + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans +import Simulation.Aivika.Trans.SystemDynamics +import Simulation.Aivika.IO + +type SD = IO + +-- | The simulation specs. +specs = Specs { spcStartTime = 0.0, + spcStopTime = 25.0, + spcDT = 0.01, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +-- the acceleration due to gravity +g = 9.81 + +-- the initial velocity +v0 = 15 + +-- the initial position +x0 = 10 + +-- the coefficient of restitution of the ball +k = 0.8 + +model :: Simulation SD (Results SD) +model = mdo + v <- integEither dv v0 + x <- integEither dx x0 + let dv = do + x' <- x + v' <- v + if x' < 0 + then return $ Left (- k * v') + else return $ Right (- g) + dx = do + x' <- x + v' <- v + if x' < 0 + then return $ Left 0 + else return $ Right v' + return $ + results + [resultSource "t" "time" time, + resultSource "x" "position" x, + resultSource "v" "velocity" v] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + model specs diff --git a/examples/Furnace.hs b/examples/Furnace.hs --- a/examples/Furnace.hs +++ b/examples/Furnace.hs @@ -1,9 +1,51 @@ --- This is a model of the Furnace. It is described in different sources [1, 2]. +-- This is a model of the soaking pit furnace. It is described in different sources [1, 2]. -- -- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. -- -- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 +-- +-- Steel ingots arrive at a soaking pit furnace in a steel plant with +-- an interarrival time that is exponentially distributed with mean +-- of 2.25 hours. The soaking pit furnace heats an ingot so that it +-- can be economically rolled in the next stage of the process. +-- The temperature change of an ingot in the soaking pit furnace is +-- described by the following differential equation. +-- +-- d(h_i)/dt = (H - h_i) * C_i, +-- +-- where h_i is the temperature of the i-th ingot in the soaking pit; +-- C_i is the heating time coefficient of an ingot and is equal to X + 0.1 +-- where X is normally distributed with mean of 0.05 and standard deviation +-- of 0.01; and H is the furnace temperature which is heated toward 2600 F +-- with a heating rate constant if 0.2, that is, +-- +-- dH/dt = (2600 - H) * 0.2. +-- +-- The ingots interact with one another in that adding a "cold" ingot +-- to the furnace reduces the temperature of the furnace and thus changes +-- the heating time for all ingots in the furnace. The temperature reduction +-- is equal to the difference between furnace and ingot temperatures, divided +-- by the number of ingots in the furnace. There are 10 soaking pits in +-- the furnace. When a new ingot arrives and the furnace is full, it is +-- stored in an ingot storage bank. It is assumed that the initial temperature +-- of an arriving ingot is uniformly distributed in the interval from 400 to 500 F. +-- All ingots put in the ingot storage bank are assumed to have a temperature of +-- 400 F upon insertion into the soaking pit. The operating policy of the company +-- is to continue heating the ingots in the furnace until one or more ingots +-- reach 2200 F. At such a time all ingots with a temperature greater than 2000 F +-- are removed. The initial conditions are that there are six ingots in the furnace +-- with initial temperatures of 550, 600, 650, 700, 750 and 800 F. Initially, +-- the temperature of the furnace is 1650 F, and the next ingot is due to arrive +-- at time 0. +-- +-- The objective is to simulate the above system for 500 hours to obtain +-- estimates of the following quantities: +-- +-- 1) heating time of the ingots; +-- 2) final temperature distribution of the ingots; +-- 3) waiting time of the ingots in the ingot storage bank; and +-- 4) utilization of the soaking pit furnace. import Data.Maybe import Control.Monad @@ -24,7 +66,7 @@ spcGeneratorType = SimpleGenerator } -- | Return a random initial temperature of the item. -randomTemp :: Parameter IO Double +randomTemp :: Parameter DES Double randomTemp = randomUniform 400 600 -- | Represents the furnace. diff --git a/examples/InspectionAdjustmentStations.hs b/examples/InspectionAdjustmentStations.hs --- a/examples/InspectionAdjustmentStations.hs +++ b/examples/InspectionAdjustmentStations.hs @@ -6,9 +6,28 @@ -- This is a model of the workflow with a loop. Also there are two infinite queues. -- -- It is described in different sources [1, 2]. So, this is chapter 8 of [2] and section 5.15 of [1]. +-- +-- Assembled television sets move through a series of testing stations in the final +-- stage of their production. At the last of these stations, the vertical control +-- setting on the TV sets is tested. If the setting is found to be functioning improperly, +-- the offending set is routed to an adjustment station where the setting is adjusted. +-- After adjustment, the television set is sent back to the last inspection station where +-- the setting is again inspected. Television sets passing the final inspection phase, +-- whether for the first time of after one or more routings through the adjustment station, +-- are routed to a packing area. +-- +-- The time between arrivals of television sets to the final inspection station is uniformly +-- distributed between 3.5 and 7.5 minutes. Two inspectors work side-by-side at the final +-- inspection station. The time required to inspect a set is uniformly distributed between +-- 6 and 12 minutes. On the average, 85 percent of the sets are routed to the adjustment +-- station which is manned by a single worker. Adjustment of the vertical control setting +-- requires between 20 and 40 minutes, uniformly distributed. +-- +-- The inspection station and adjustor are to be simulated for 480 minutes to estimate +-- the time to process television sets through the final production stage and to determine +-- the utilization of the inspectors and the adjustors. -- -- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. --- -- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 import Prelude hiding (id, (.)) diff --git a/examples/InventorySystem.hs b/examples/InventorySystem.hs new file mode 100644 --- /dev/null +++ b/examples/InventorySystem.hs @@ -0,0 +1,175 @@ + +-- Example: Inventory System with Lost Sales and Backorders +-- +-- It is described in different sources [1, 2]. So, this is chapter 11 of [2] and section 6.7 of [1]. +-- +-- A large discount house is planning to install a system to control the inventory of +-- a particular radio. The time between demands for a radio is exponentially distributed +-- with a mean time of 0.2 weeks. In the case where customers demand the radio when it +-- is not in stock, 80 percent will go to another nearby discount house to find it, thereby +-- representing lost sales, while the other 20 percent will backorder the radio and wait +-- for the next shipment arrival. The store employs a periodic review-reorder point +-- inventory system where the inventory status is reviewed every four weeks to decide if +-- an order should be placed. The company policy is to order up to the stock control level +-- of 72 radios whenever the inventory position, consisting of the radios in stock plus +-- the radios on order minus the radios on backorder, is found to be less than or equal to +-- the reorder point of 18 radios. The procurement lead time (the time from the placement +-- of an order to its receipt) is constant and requires three weeks. +-- +-- The objective of this example is to simulate the inventory system for a period of six +-- years (312 weeks) to obtain statistics on the following quantities: +-- +-- 1) number of radios in stock; +-- 2) inventory position; +-- 3) safety stock (radios in stock at order receipt times); and +-- 4) time between lost sales. +-- +-- The initial conditions for the simulation are an inventory position of 72 and no +-- initial backorders. In order to reduce the bias in the statistics due to the initial +-- starting conditions, all the statistics are to be cleared at the end of the first year +-- of the six year simulation period. +-- +-- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. +-- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans +import qualified Simulation.Aivika.Trans.Resource as R +import Simulation.Aivika.IO + +type DES = IO + +-- | The simulation specs. +specs = Specs { spcStartTime = 0.0, + spcStopTime = 312.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +-- | The time between demands for a radio. +avgRadioDemand = 0.2 + +-- | The percent of customers who will backorder the radio. +backorderPercent = 0.2 + +-- | The stock control level to be ordered up. +stockControlLevel = 72 + +-- | The inventory position for reordering radio. +reorderPositionThreshold = 18 + +-- | The initial radios in stock. +radio0 = 72 :: Int + +-- | The time from the placement of an order to its receipt +leadTime = 3 + +-- | How often to order the radios? +reviewPeriod = 4 + +-- | Clear the statistics at the end of the first year +clearingTime = 52 + +model :: Simulation DES (Results DES) +model = do + -- the start time + t0 <- liftParameter starttime + -- the inventory position + invPos <- newRef $ returnTimingCounter t0 radio0 + -- the radios in stock + radio <- runEventInStartTime $ R.newFCFSResource radio0 + -- the time between lost sales + tbLostSales <- newRef emptySamplingStats + -- the last arrive time for the lost sale + lostSaleArrive <- newRef Nothing + -- a customer order + let customerOrder :: Event DES () + customerOrder = do + do t <- liftDynamics time + modifyRef invPos $ + decTimingCounter t 1 + runProcess $ + R.requestResource radio + -- a customer has been lost + let customerLost :: Event DES () + customerLost = do + t0 <- readRef lostSaleArrive + t <- liftDynamics time + case t0 of + Nothing -> return () + Just t0 -> + modifyRef tbLostSales $ + addSamplingStats (t - t0) + writeRef lostSaleArrive (Just t) + -- a customer arrival process + let customerArrival :: Process DES () + customerArrival = do + randomExponentialProcess_ avgRadioDemand + liftEvent $ do + r <- R.resourceCount radio + if r > 0 + then customerOrder + else do b <- liftParameter $ + randomTrue backorderPercent + if b + then customerOrder + else customerLost + customerArrival + -- start the customer arrival process + runProcessInStartTime customerArrival + -- the safety stock + safetyStock <- newRef emptySamplingStats + -- an inventory review process + let invReview :: Process DES () + invReview = do + x <- liftEvent $ readRef invPos + let n = timingCounterValue x + when (n <= reorderPositionThreshold) $ + do let orderQty = stockControlLevel - n + liftEvent $ + do t <- liftDynamics time + modifyRef invPos $ + setTimingCounter t stockControlLevel + holdProcess leadTime + liftEvent $ + do r <- R.resourceCount radio + modifyRef safetyStock $ + addSamplingStats r + R.incResourceCount radio orderQty + -- start the inventory review process + runEventInStartTime $ + enqueueEventWithTimes [t0, t0 + reviewPeriod ..] $ + runProcess invReview + -- clear the statistics at the end of the first year + runEventInStartTime $ + enqueueEvent clearingTime $ + do t <- liftDynamics time + modifyRef invPos $ \x -> + returnTimingCounter t (timingCounterValue x) + writeRef tbLostSales emptySamplingStats + writeRef safetyStock emptySamplingStats + -- return the simulation results + return $ + results + [resultSource + "radio" "the number of radios in stock" + radio, + -- + resultSource + "invPos" "the inventory position" + invPos, + -- + resultSource + "tbLostSales" "the time between lost sales" + tbLostSales, + -- + resultSource + "safetyStock" "the safety stock" + safetyStock] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + (fmap resultSummary model) specs diff --git a/examples/MachineBreakdowns.hs b/examples/MachineBreakdowns.hs new file mode 100644 --- /dev/null +++ b/examples/MachineBreakdowns.hs @@ -0,0 +1,161 @@ + +-- Example: Machine Tool with Breakdowns +-- +-- It is described in different sources [1, 2]. So, this is chapter 13 of [2] and section 6.12 of [1]. +-- +-- Jobs arrive to a machine tool on the average of one per hour. The distribution of +-- these interarrival times is exponential. During normal operation, the jobs are +-- processed on a first-in, first-out basis. The time to process a job in hours is +-- normally distributed with a mean of 0.5 and a standard deviation of 0.1. In addition +-- to the processing time, there is a set up time that is uniformly distributed between +-- 0.2 and 0.5 of an hour. Jobs that have been processed by the machine tool are routed +-- to a different section of the shop and are considered to have left the machine tool +-- area. +-- +-- The machine tool experiences breakdowns during which time it can no longer process +-- jobs. The time between breakdowns is normally distributed with a mean of 20 hours +-- and a standard deviation of 2 hours. When a breakdown occurs, the job being processed +-- is removed from the machine tool and is placed at the head of the queue of jobs +-- waiting to be processed. Jobs preempted restart from the point at which they were +-- interrupted. +-- +-- When the machine tool breaks down, a repair process is initiated which is +-- accomplished in three phases. Each phase is exponentially distributed with a mean of +-- 3/4 of an hour. Since the repair time is the sum of independent and identically +-- distributed exponential random variables, the repair time is Erlang distributed. +-- The machine tool is to be analyzed for 500 hours to obtain information on +-- the utilization of the machine tool and the time required to process a job. +-- Statistics are to be collected for thousand simulation runs. +-- +-- [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.Category + +import Data.Monoid +import Data.List + +import Simulation.Aivika.Trans +import qualified Simulation.Aivika.Trans.Queue.Infinite as IQ +import qualified Simulation.Aivika.Trans.Resource.Preemption as PR + +import Simulation.Aivika.IO +import Simulation.Aivika.IO.Resource.Preemption + +type DES = IO + +-- | The simulation specs. +specs = Specs { spcStartTime = 0.0, + spcStopTime = 500.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +-- | How often do jobs arrive to a machine tool (exponential)? +jobArrivingMu = 1 + +-- | A mean of time to process a job (normal). +jobProcessingMu = 0.5 + +-- | The standard deviation of time to process a job (normal). +jobProcessingSigma = 0.1 + +-- | The minimum set-up time (uniform). +minSetUpTime = 0.2 + +-- | The maximum set-up time (uniform). +maxSetUpTime = 0.5 + +-- | A mean of time between breakdowns (normal). +breakdownMu = 20 + +-- | The standard deviation of time between breakdowns (normal). +breakdownSigma = 2 + +-- | A mean of each of the three repair phases (Erlang). +repairMu = 3/4 + +-- | A priority of the job (less is higher) +jobPriority = 1 + +-- | A priority of the breakdown (less is higher) +breakdownPriority = 0 + +-- | The simulation model. +model :: Simulation DES (Results DES) +model = do + -- create an input queue + inputQueue <- runEventInStartTime IQ.newFCFSQueue + -- a counter of jobs completed + jobsCompleted <- newArrivalTimer + -- a counter of interrupted jobs + jobsInterrupted <- newRef (0 :: Int) + -- create an input stream + let inputStream = + randomExponentialStream jobArrivingMu + -- create a preemptible resource + tool <- runEventInStartTime $ PR.newResource 1 + -- the machine setting up + machineSettingUp <- + newPreemptibleRandomUniformServer True minSetUpTime maxSetUpTime + -- the machine processing + machineProcessing <- + newPreemptibleRandomNormalServer True jobProcessingMu jobProcessingSigma + -- the machine breakdown + let machineBreakdown = + do randomNormalProcess_ breakdownMu breakdownSigma + PR.usingResourceWithPriority tool breakdownPriority $ + randomErlangProcess_ repairMu 3 + machineBreakdown + -- start the process of breakdowns + runProcessInStartTime machineBreakdown + -- update a counter of job interruptions + runEventInStartTime $ + handleSignal_ (serverTaskPreemptionBeginning machineProcessing) $ \a -> + modifyRef jobsInterrupted (+ 1) + -- define the queue network + let network = + queueProcessor + (\a -> liftEvent $ IQ.enqueue inputQueue a) + (IQ.dequeue inputQueue) >>> + (withinProcessor $ PR.requestResourceWithPriority tool jobPriority) >>> + serverProcessor machineSettingUp >>> + serverProcessor machineProcessing >>> + (withinProcessor $ PR.releaseResource tool) >>> + arrivalTimerProcessor jobsCompleted + -- start the machine tool + runProcessInStartTime $ + sinkStream $ runProcessor network inputStream + -- return the simulation results in start time + return $ + results + [resultSource + "inputQueue" "the queue of jobs" + inputQueue, + -- + resultSource + "machineSettingUp" "the machine setting up" + machineSettingUp, + -- + resultSource + "machineProcessing" "the machine processing" + machineProcessing, + -- + resultSource + "jobsInterrupted" "a counter of the interrupted jobs" + jobsInterrupted, + -- + resultSource + "jobsCompleted" "a counter of the completed jobs" + jobsCompleted, + -- + resultSource + "tool" "the machine tool" + tool] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + (fmap resultSummary model) specs diff --git a/examples/PERT.hs b/examples/PERT.hs new file mode 100644 --- /dev/null +++ b/examples/PERT.hs @@ -0,0 +1,151 @@ + +{-# LANGUAGE RecursiveDo #-} + +-- Example: Analysis of a PERT-type Network +-- +-- It is described in different sources [1, 2]. So, this is chapter 14 of [2] and section 7.11 of [1]. +-- +-- PERT is a technique for evaluating and reviewing a project consisting of +-- interdependent activities. A number of books have been written that describe +-- PERT modeling and analysis procedures. A PERT network activity descriptions +-- are given in a table stated below. All activity times will be assumed to be +-- triangularly distributed. For ease of description, activities have been +-- aggregated. The activities relate to power units, instrumentation, and +-- a new assembly and involve standard types of operations. +-- +-- In the following description of the project, activity numbers are given +-- in parentheses. At the beginning of the project, three parallel activities +-- can be performed that involve: the disassembly of power units and +-- instrumentation (1); the installation of a new assembly (2); and +-- the preparation for a retrofit check (3). Cleaning, inspecting, and +-- repairing the power units (4) and calibrating the instrumentation (5) +-- can be done only after the power units and instrumentation have been +-- disassembled. Thus, activities 4 and 5 must follow activity 1 in the network. +-- Following the installation of the new assembly (2) and after the instrumentation +-- have been calibrated (5), a check of interfaces (6) and a check of +-- the new assembly (7) can be made. The retrofit check (9) can be made +-- after the assembly is checked (7) and the preparation for the retrofit +-- check (3) has been completed. The assembly and test of power units (8) +-- can be performed following the cleaning and maintenance of power units (4). +-- The project is considered completed when all nine activities are completed. +-- Since activities 6, 8, and 9 require the other activities to precede them, +-- their completion signifies the end of the project. This is indicated on +-- the network by having activities 6, 8, and 9 incident to node 6, the sink +-- node for the project. The objective of this example is to illustrate +-- the procedures for using Aivika to model and simulate project planning network. +-- +-- Activity Description Mode Minimum Maximum Average +-- +-- 1 Disassemble power units and instrumentation 3 1 5 3 +-- 2 Install new assembly 6 3 9 6 +-- 3 Prepare for retrofit check 13 10 19 14 +-- 4 Clean, inspect, and repair power units 9 3 12 8 +-- 5 Calibrate instrumentation 3 1 8 4 +-- 6 Check interfaces 9 8 16 11 +-- 7 Check assembly 7 4 13 8 +-- 8 Assemble and test power units 6 3 9 6 +-- 9 Retrofit check 3 1 8 4 +-- +-- Node Depends of Activities +-- +-- 1 - +-- 2 1 +-- 3 2, 5 +-- 4 3, 7 +-- 5 4 +-- 6 6, 8, 9 +-- +-- Activity Depends on Node +-- +-- 1 1 +-- 2 1 +-- 3 1 +-- 4 2 +-- 5 2 +-- 6 3 +-- 7 3 +-- 8 5 +-- 9 4 +-- +-- [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.Array +import Data.Maybe +import Data.Monoid + +import Simulation.Aivika.Trans +import Simulation.Aivika.IO + +type DES = IO + +-- | The simulation specs. +specs = Specs { spcStartTime = 0.0, + spcStopTime = 1000.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: Simulation DES (Results DES) +model = mdo + timers' <- forM [2..5] $ \i -> newArrivalTimer + projCompletionTimer <- newArrivalTimer + let timers = array (2, 5) $ zip [2..] timers' + p1 = randomTriangularProcessor 1 3 5 + p2 = randomTriangularProcessor 3 6 9 + p3 = randomTriangularProcessor 10 13 19 + p4 = randomTriangularProcessor 3 9 12 + p5 = randomTriangularProcessor 1 3 8 + p6 = randomTriangularProcessor 8 9 16 + p7 = randomTriangularProcessor 4 7 13 + p8 = randomTriangularProcessor 3 6 9 + p9 = randomTriangularProcessor 1 3 8 + let c2 = arrivalTimerProcessor (timers ! 2) + c3 = arrivalTimerProcessor (timers ! 3) + c4 = arrivalTimerProcessor (timers ! 4) + c5 = arrivalTimerProcessor (timers ! 5) + c6 = arrivalTimerProcessor projCompletionTimer + [i1, i2, i3] <- cloneStream 3 n1 + [i4, i5] <- cloneStream 2 n2 + [i6, i7] <- cloneStream 2 n3 + let i9 = n4 + i8 = n5 + let s1 = runProcessor p1 i1 + s2 = runProcessor p2 i2 + s3 = runProcessor p3 i3 + s4 = runProcessor p4 i4 + s5 = runProcessor p5 i5 + s6 = runProcessor p6 i6 + s7 = runProcessor p7 i7 + s8 = runProcessor p8 i8 + s9 = runProcessor p9 i9 + let n1 = takeStream 1 $ randomStream $ return (0, 0) + n2 = runProcessor c2 s1 + n3 = runProcessor c3 $ firstArrivalStream 2 (s2 <> s5) + n4 = runProcessor c4 $ firstArrivalStream 2 (s3 <> s7) + n5 = runProcessor c5 s4 + n6 = runProcessor c6 $ firstArrivalStream 3 (s6 <> s8 <> s9) + runProcessInStartTime $ sinkStream n6 + return $ + results + [resultSource + "timers" "Timers" + timers, + -- + resultSource + "projCompletion" "Project Completion Timer" + projCompletionTimer] + +modelSummary :: Simulation DES (Results DES) +modelSummary = + fmap resultSummary model + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + -- model specs + modelSummary specs diff --git a/examples/PingPong.hs b/examples/PingPong.hs new file mode 100644 --- /dev/null +++ b/examples/PingPong.hs @@ -0,0 +1,44 @@ + +-- A classic Ping-Pong example. + +import Control.Monad.Trans + +import Simulation.Aivika.Trans +import Simulation.Aivika.IO + +type DES = IO + +delta = 1.0 + +specs = Specs { spcStartTime = 0, + spcStopTime = 10 * delta, + spcDT = delta, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: Simulation DES () +model = + do pingSource <- newSignalSource + pongSource <- newSignalSource + let pingSignal = publishSignal pingSource + pongSignal = publishSignal pongSource + ping = + do holdProcess delta + liftEvent $ + traceEvent "ping" $ + triggerSignal pingSource () + processAwait pongSignal + ping + pong = + do processAwait pingSignal + liftEvent $ + traceEvent "pong" $ + triggerSignal pongSource () + pong + runProcessInStartTime ping + runProcessInStartTime pong + runEventInStopTime $ + traceEvent "end" $ + return () + +main = runSimulation model specs diff --git a/examples/PortOperations.hs b/examples/PortOperations.hs new file mode 100644 --- /dev/null +++ b/examples/PortOperations.hs @@ -0,0 +1,180 @@ + +{-# LANGUAGE RecursiveDo #-} + +-- Example: Port Operations +-- +-- It is described in different sources [1, 2]. So, this is chapter 12 of [2] and section 6.13 of [1]. +-- +-- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. +-- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 +-- +-- A port in Africa is used to load tankers with crude oil for overwater shipment. +-- The port has facilities for loading as many as three tankers simultaneously. +-- The tankers, which arrive at the port every 11 +/- 7 hours, are of three different +-- types. The relative frequency of the various types, and their loading time +-- requirements, are as follows: +-- +-- Type Relative Frequency Loading Time, Hours +-- 1 0.25 18 +/- 2 +-- 2 0.55 24 +/- 3 +-- 3 0.20 36 +/- 4 +-- +-- There is one tug at the port. Tankers of all types require the services of this tug +-- to move into a berth, and later to move out of a berth. When the tug is available, +-- any berthing or de-berthing activity takes about one hour. Top priority is given to +-- the berthing activity. +-- +-- A shipper is considering bidding on a contract to transport oil from the port to +-- the United Kingdom. He has determined that 5 tankers of a particular type would +-- have to be committed to this task to meet contract specifications. These tankers +-- would require 21 +/- 3 hours to load oil at the port. After loading and de-berthing, +-- they would travel to the United Kingdom, offload the oil, and return to the port for +-- reloading. Their round-trip travel time, including offloading, is estimated to be +-- 240 +/- hours. +-- +-- A complicated factor is that the port experiences storms. The time between +-- the onset of storms is exponentially distributed with a mean of 48 hours and a +-- storm lasts 4 +/- 2 hours. No tug can start an operation until a storm is over. +-- +-- Before the port authorities can commit themselves to accommodating the +-- proposed 5 tankers, the effect of the additional port traffic on the in-port residence +-- time of the current port users must be determined. It is desired to simulate the +-- operation of the port for a one-year period (= 8640 hours) under the proposed new +-- commitment to measure in-port residence time of the proposed additional tankers, +-- as well as the three types of tankers which already use the port. All durations +-- given as ranges are uniformly distributed. + +import Prelude hiding (id, (.)) + +import Control.Monad +import Control.Monad.Trans +import Control.Arrow +import Control.Category (id, (.)) + +import Data.Array + +import Simulation.Aivika.Trans +import Simulation.Aivika.Trans.Queue +import qualified Simulation.Aivika.Trans.Resource as R +import Simulation.Aivika.IO + +type DES = IO + +-- | The simulation specs. +specs = Specs { spcStartTime = 0.0, + spcStopTime = 8760.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +data Tunker = + Tunker { tunkerLoadingTime :: Double, + tunkerType :: Int } + +model :: Simulation DES (Results DES) +model = mdo + portTime' <- forM [1..4] $ \i -> + newRef emptySamplingStats + let portTime = + array (1, 4) $ zip [1..] portTime' + berth <- + runEventInStartTime $ + R.newFCFSResource 3 + tug <- + runEventInStartTime $ + R.newFCFSResource 1 + let tunkers13 = randomUniformStream 4 18 + tunkers4 = takeStream 5 $ + randomUniformStream 48 48 + runProcessInStartTime $ + flip consumeStream tunkers13 $ \x -> + do p <- liftParameter $ + randomUniform 0 1 + let tp | p <= 0.25 = 1 + | p <= 0.25 + 0.55 = 2 + | otherwise = 3 + case tp of + 1 -> liftEvent arv1 + 2 -> liftEvent arv2 + 3 -> liftEvent arv3 + runProcessInStartTime $ + flip consumeStream tunkers4 $ \x -> + liftEvent arv4 + let arv1 :: Event DES () + arv1 = do + loadingTime <- liftParameter $ + randomUniform 16 20 + let t = Tunker loadingTime 1 + runProcess (port t) + arv2 :: Event DES () + arv2 = do + loadingTime <- liftParameter $ + randomUniform 21 27 + let t = Tunker loadingTime 2 + runProcess (port t) + arv3 :: Event DES () + arv3 = do + loadingTime <- liftParameter $ + randomUniform 32 40 + let t = Tunker loadingTime 3 + runProcess (port t) + arv4 :: Event DES () + arv4 = do + loadingTime <- liftParameter $ + randomUniform 18 24 + let t = Tunker loadingTime 4 + runProcess (port t) + let port :: Tunker -> Process DES () + port t = do + t0 <- liftDynamics time + R.requestResource berth + R.requestResource tug + holdProcess 1 + R.releaseResource tug + holdProcess (tunkerLoadingTime t) + R.requestResource tug + holdProcess 1 + R.releaseResource tug + R.releaseResource berth + t1 <- liftDynamics time + let tp = tunkerType t + liftEvent $ + modifyRef (portTime ! tp) $ + addSamplingStats (t1 - t0) + when (tp == 4) $ + liftEvent $ + runProcess $ + do randomUniformProcess_ 216 264 + liftEvent arv4 + storm :: Process DES () + storm = do + randomExponentialProcess_ 48 + R.decResourceCount tug 1 + randomUniformProcess_ 2 6 + liftEvent $ + R.incResourceCount tug 1 + storm + runProcessInStartTime storm + return $ + results + [resultSource + "portTime" "Port Time" + portTime, + -- + resultSource + "berth" "Berth" + berth, + -- + resultSource + "tug" "Tug" + tug ] + +modelSummary :: Simulation DES (Results DES) +modelSummary = + fmap resultSummary model + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + -- model specs + modelSummary specs diff --git a/examples/QuarryOperations.hs b/examples/QuarryOperations.hs new file mode 100644 --- /dev/null +++ b/examples/QuarryOperations.hs @@ -0,0 +1,222 @@ + +{-# LANGUAGE Arrows, FlexibleContexts #-} + +-- Example: In this example, the operations of a quarry are modeled. +-- +-- It is described in different sources [1, 2]. So, this is chapter 10 of [2] and section 5.16 of [1]. +-- +-- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. +-- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 +-- +-- In this example, the operations of a quarry are modeled. In the quarry, +-- trucks deliver ore from three shovels to a crusher. A truck always +-- returns to its assigned shovel after dumping a load at the crusher. +-- There are two different truck sizes in use, twenty-ton and fifty-ton. +-- The size of the truck affects its loading time at the shovel, travel +-- time to the crusher, dumping time at the crusher and return trip time +-- from the crusher back to the appropriate shovel. For the twenty-ton +-- trucks, there loading, travel, dumping and return trip times are: +-- exponentially distributed with a mean 5; a constant 2.5; exponentially +-- distributed with mean 2; and a constant 1.5. The corresponding times +-- for the fifty-ton trucks are: exponentially distributed with mean 10; +-- a constant 3; exponentially distributed with mean 4; and a constant 2. +-- To each shovel is assigned two twenty-ton trucks are one fifty-ton truck. +-- The shovel queues are all ranked on a first-in, first-out basis. +-- The crusher queue is ranked on truck size, largest trucks first. +-- It is desired to analyze this system over 480 time units to determine +-- the utilization and queue lengths associated with the shovels and crusher. + +import Control.Monad +import Control.Monad.Trans +import Control.Category + +import Simulation.Aivika.Trans +import qualified Simulation.Aivika.Trans.Queue.Infinite as IQ +import Simulation.Aivika.IO + +type DES = IO + +-- | The simulation specs. +specs = Specs { spcStartTime = 0.0, + spcStopTime = 480.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +-- | The average loading time for twenty-ton truck +avgLoadingTime20 = 5 + +-- | A constant travel time for twenty-ton truck +travelTime20 = 2.5 + +-- | The average dumping time for twenty-ton truck +avgDumpingTime20 = 2 + +-- | A constant return trip time for twenty-ton truck +returnTripTime20 = 1.5 + +-- | A priority of the twenty-ton truck (less is higher) +crushingPriority20 = 2 + +-- | The average loading time for fifty-ton truck +avgLoadingTime50 = 10 + +-- | A constant travel time for fifty-ton truck +travelTime50 = 3 + +-- | The average dumping time for fifty-ton truck +avgDumpingTime50 = 4 + +-- | A constant return trip time for fifty-ton truck +returnTripTime50 = 2 + +-- | A priority of the fifty-ton truck (less is higher) +crushingPriority50 = 1 + +-- | It models a truck assigned to some queue. +data Truck = + Truck { truckQueue :: TruckQueue, + -- ^ a queue to which the truck is assigned + truckTonSize :: TruckTonSize, + -- ^ the truck ton size + truckAvgLoadingTime :: Double, + -- ^ the average loading time + truckTravelTime :: Double, + -- ^ a constant travel time + truckCrushingPriority :: Double, + -- ^ a priority for crushing (less is higher) + truckAvgDumpingTime :: Double, + -- ^ the average dumping time + truckReturnTripTime :: Double + -- ^ a constant return trip time + } + +-- | It defines the truck ton size +data TruckTonSize = TwentyTonSize | FiftyTonSize + +-- | Specifies a queue to which the truck is assigned +data TruckQueue = TruckQueue1 | TruckQueue2 | TruckQueue3 + +-- | Return a truck assigned to the specified queue with the given ton size. +truck :: TruckQueue -> TruckTonSize -> Truck +truck tq TwentyTonSize = + Truck { truckQueue = tq, + truckTonSize = TwentyTonSize, + truckAvgLoadingTime = avgLoadingTime20, + truckTravelTime = travelTime20, + truckCrushingPriority = crushingPriority20, + truckAvgDumpingTime = avgDumpingTime20, + truckReturnTripTime = returnTripTime20 } +truck tq FiftyTonSize = + Truck { truckQueue = tq, + truckTonSize = FiftyTonSize, + truckAvgLoadingTime = avgLoadingTime50, + truckTravelTime = travelTime50, + truckCrushingPriority = crushingPriority50, + truckAvgDumpingTime = avgDumpingTime50, + truckReturnTripTime = returnTripTime50 } + +model :: Simulation DES (Results DES) +model = do + -- create a queue for the first shovel + shovelQueue1 <- + runEventInStartTime IQ.newFCFSQueue + -- create another queue for the second shovel + shovelQueue2 <- + runEventInStartTime IQ.newFCFSQueue + -- create a queue for the thrid shovel + shovelQueue3 <- + runEventInStartTime IQ.newFCFSQueue + -- add initial trucks to the queue + let initShovelQueue q tq = + do IQ.enqueue q $ truck tq TwentyTonSize + IQ.enqueue q $ truck tq TwentyTonSize + IQ.enqueue q $ truck tq FiftyTonSize + -- initiate the three shovel queues + runEventInStartTime $ + do initShovelQueue shovelQueue1 TruckQueue1 + initShovelQueue shovelQueue2 TruckQueue2 + initShovelQueue shovelQueue3 TruckQueue3 + -- create a priority queue for the crusher + crusherQueue <- + runEventInStartTime IQ.newPriorityQueue + -- define how the specified truck travels from the shovel to the crusher + let truckTravel t = + spawnProcess $ + do holdProcess (truckTravelTime t) + liftEvent $ + IQ.enqueueWithStoringPriority crusherQueue (truckCrushingPriority t) t + -- define how the specified truck returns to the queue + let truckReturnTrip t = + spawnProcess $ + do holdProcess (truckReturnTripTime t) + let q = case truckQueue t of + TruckQueue1 -> shovelQueue1 + TruckQueue2 -> shovelQueue2 + TruckQueue3 -> shovelQueue3 + liftEvent $ + IQ.enqueue q t + -- utilise the crusher's activity + let utiliseCrusher q t = + do randomExponentialProcess_ $ + truckAvgDumpingTime t + return t + -- utilise the shovel's activity + let utiliseShovel q t = + do randomExponentialProcess_ $ + truckAvgLoadingTime t + return t + -- create shovel activities + shovelAct1 <- + newActivity $ utiliseShovel shovelQueue1 + shovelAct2 <- + newActivity $ utiliseShovel shovelQueue2 + shovelAct3 <- + newActivity $ utiliseShovel shovelQueue3 + -- create the crusher's activity + crusherAct <- + newActivity $ utiliseCrusher crusherQueue + -- define how we should iterate the crusher + let crusherNet act q = + proc () -> + do t <- arrNet (const $ IQ.dequeue q) -< () + t' <- activityNet act -< t + arrNet truckReturnTrip -< t' + let shovelNet act q = + proc () -> + do t <- arrNet (const $ IQ.dequeue q) -< () + t' <- activityNet act -< t + arrNet truckTravel -< t' + -- start processing the cursher's queue + runProcessInStartTime $ + iterateNet (crusherNet crusherAct crusherQueue) () + -- start processing the shovel queues + runProcessInStartTime $ + iterateNet (shovelNet shovelAct1 shovelQueue1) () + runProcessInStartTime $ + iterateNet (shovelNet shovelAct2 shovelQueue2) () + runProcessInStartTime $ + iterateNet (shovelNet shovelAct3 shovelQueue3) () + -- return the simulation results in start time + return $ + results + [resultSource + "shovelQueue" "the shovel's queue" + [shovelQueue1, shovelQueue2, shovelQueue3], + -- + resultSource + "crusherQueue" "the crusher's queue" + crusherQueue, + -- + resultSource + "shovelActvty" "the shovel's activity" + [shovelAct1, shovelAct2, shovelAct3], + -- + resultSource + "crusherActvty" "the crusher's activity" + crusherAct] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + (fmap resultSummary model) specs diff --git a/examples/RenegingFromQueue.hs b/examples/RenegingFromQueue.hs new file mode 100644 --- /dev/null +++ b/examples/RenegingFromQueue.hs @@ -0,0 +1,88 @@ + +-- Example: Reneging from a Queue +-- +-- It is described in [1]. This is section 7.8. +-- +-- This example models customers arriving to a queue and leaving a queue +-- after a prescribed period of time. The time between arrivals is +-- exponentially distributed with a mean of 20 minutes. The service time +-- for customers is uniformly distributed between 15 and 25 minutes. +-- Customers will only wait for service if the waiting time is less than +-- a renege time which is lognormally distributed with a mean of 10 minutes +-- and a standard deviation of 2 minutes. It is desired to estimate the time +-- in the system for those customers served, the percent of customers that +-- renege and the length of the waiting time. +-- +-- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. + +import Control.Monad +import Control.Monad.Trans + +import Data.Array + +import Simulation.Aivika.Trans +import qualified Simulation.Aivika.Trans.Queue.Infinite as IQ +import Simulation.Aivika.IO + +type DES = IO + +-- | The simulation specs. +specs = Specs { spcStartTime = 0.0, + spcStopTime = 10000.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +mu = 10 +nu = 2 + +logMu = log mu - logNu * logNu / 2 +logNu = sqrt $ log ((nu * nu) / (mu * mu) + 1) + +model :: Simulation DES (Results DES) +model = do + let customers = randomExponentialStream 20 + timeInSystem <- newRef emptySamplingStats + renegeEvents <- newRef (0 :: Int) + queue <- runEventInStartTime $ IQ.newFCFSQueue + let queueProcess = + do x <- IQ.dequeue queue + randomUniformProcess_ 15 25 + t <- liftDynamics time + liftEvent $ + modifyRef timeInSystem $ + addSamplingStats (t - arrivalTime x) + queueProcess + renegingProcess x = + do randomLogNormalProcess_ logMu logNu + liftEvent $ + do f <- IQ.queueDelete queue x + when f $ modifyRef renegeEvents ((+) 1) + runProcessInStartTime queueProcess + runProcessInStartTime $ + flip consumeStream customers $ \x -> + liftEvent $ + do IQ.enqueue queue x + runProcess $ renegingProcess x + return $ + results + [resultSource + "queue" "the queue" + queue, + -- + resultSource + "timeInSystem" "time in system" + timeInSystem, + -- + resultSource + "renegeEvents" "renege events" + renegeEvents] + +modelSummary :: Simulation DES (Results DES) +modelSummary = + fmap resultSummary model + +main = + do printSimulationResultsInStopTime + printResultSourceInEnglish + modelSummary specs diff --git a/examples/SingleLaneTraffic.hs b/examples/SingleLaneTraffic.hs new file mode 100644 --- /dev/null +++ b/examples/SingleLaneTraffic.hs @@ -0,0 +1,149 @@ + +-- Example: Single-Lane Traffic Analysis +-- +-- It is described in different sources [1, 2]. So, this is chapter 15 of [2] and section 6.18 of [1]. +-- +-- The system to be modeled in this example consists of the traffic flow from +-- two directions along a two-lane road, one lane of which has been closed for +-- 500 meters for repairs. Traffic lights have been placed at each end of +-- the closed lane to control the flow of traffic through the repair section. +-- The lights allow traffic to flow for a specified time interval from only +-- one direction. When a light turns green, the waiting cars start and pass +-- the light every two seconds. If a car arrives at a green light when there +-- are no waiting cars, the car passes through the light without delay. The car +-- arrival pattern is exponentially distributed, with an average of 9 seconds +-- between cars from direction 1 and 12 seconds between cars from direction 2. +-- A light cycle consists of green in direction 1, both red, green in direction 2, +-- both red, and then the cycle is repeated. Both lights remain red for 55 seconds +-- to allow the cars in transit to leave the repair section before traffic from +-- the other direction can be initiated. +-- +-- The objective is to simulate the above system to determine values for +-- the green time for direction 1 and the green time for direction 2 which +-- yield a low average waiting time for all cars. +-- +-- [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.Array + +import Simulation.Aivika.Trans +import qualified Simulation.Aivika.Trans.Resource as R +import Simulation.Aivika.IO + +type DES = IO + +-- | The simulation specs. +specs = Specs { spcStartTime = 0.0, + spcStopTime = 3600.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +data LightTime = + LightTime { greenLightTime1 :: Double, + greenLightTime2 :: Double } + +model :: LightTime -> Simulation DES (Results DES) +model lightTime = do + let greenLightTime = + array (1, 2) + [(1, return $ greenLightTime1 lightTime :: Event DES Double), + (2, return $ greenLightTime2 lightTime :: Event DES Double)] + waitTime1 <- newRef emptySamplingStats + waitTime2 <- newRef emptySamplingStats + let waitTime = + array (1, 2) [(1, waitTime1), (2, waitTime2)] + start1 <- + runEventInStartTime $ + R.newFCFSResource 1 + start2 <- + runEventInStartTime $ + R.newFCFSResource 1 + let start = + array (1, 2) [(1, start1), (2, start2)] + light1 <- newGateClosed + light2 <- newGateClosed + let stream1 = randomExponentialStream 9 + stream2 = randomExponentialStream 12 + runProcessInStartTime $ + flip consumeStream stream1 $ \x -> + liftEvent $ + runProcess $ + do R.requestResource start1 + awaitGateOpened light1 + t <- liftDynamics time + liftEvent $ + modifyRef waitTime1 $ + addSamplingStats (t - arrivalTime x) + when (t > arrivalTime x) $ + holdProcess 2 + R.releaseResource start1 + runProcessInStartTime $ + flip consumeStream stream2 $ \x -> + liftEvent $ + runProcess $ + do R.requestResource start2 + awaitGateOpened light2 + t <- liftDynamics time + liftEvent $ + modifyRef waitTime2 $ + addSamplingStats (t - arrivalTime x) + when (t > arrivalTime x) $ + holdProcess 2 + R.releaseResource start2 + let lighting = + do holdProcess 55 + liftEvent $ + openGate light1 + holdProcess $ + greenLightTime1 lightTime + liftEvent $ + closeGate light1 + holdProcess 55 + liftEvent $ + openGate light2 + holdProcess $ + greenLightTime2 lightTime + liftEvent $ + closeGate light2 + lighting + runProcessInStartTime lighting + return $ + results + [resultSource + "start" "Start Resource" + start, + -- + resultSource + "waitTime" "Wait Time" + waitTime, + -- + resultSource + "greenLightTime" "Green Light Time" + greenLightTime] + +modelSummary :: LightTime -> Simulation DES (Results DES) +modelSummary lightTime = + fmap resultSummary $ model lightTime + +lightTime1 = LightTime 60 45 +lightTime2 = LightTime 80 60 +lightTime3 = LightTime 40 30 + +model1 = model lightTime1 +model2 = model lightTime2 +model3 = model lightTime3 + +modelSummary1 = fmap resultSummary model1 +modelSummary2 = fmap resultSummary model2 +modelSummary3 = fmap resultSummary model3 + +main = + do printSimulationResultsInStopTime + printResultSourceInEnglish + modelSummary1 specs diff --git a/examples/TruckHaulingSituation.hs b/examples/TruckHaulingSituation.hs new file mode 100644 --- /dev/null +++ b/examples/TruckHaulingSituation.hs @@ -0,0 +1,140 @@ + +-- 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.Trans +import qualified Simulation.Aivika.Trans.Queue.Infinite as IQ +import Simulation.Aivika.IO + +type DES = IO + +-- | 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 DES (Results DES) +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 DES () + start = + do randomErlangProcess_ 4 2 + randomErlangProcess_ 4 2 + liftEvent $ + IQ.enqueue loadQueue Pile + t <- liftDynamics time + when (t <= 480) start + begin :: Process DES () + 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 diff --git a/examples/WorkStationsInSeries.hs b/examples/WorkStationsInSeries.hs --- a/examples/WorkStationsInSeries.hs +++ b/examples/WorkStationsInSeries.hs @@ -5,8 +5,24 @@ -- -- It is described in different sources [1, 2]. So, this is chapter 7 of [2] and section 5.14 of [1]. -- --- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. +-- The maintenance facility of a large manufacturer performs two operations. +-- These operations must be performed in series; operation 2 always follows operation 1. +-- The units that are maintained are bulky, and space is available for only eight units +-- including the units being worked on. A proposed design leaves space for two units +-- between the work stations, and space for four units before work station 1. [..] +-- Current company policy is to subcontract the maintenance of a unit if it cannot +-- gain access to the in-house facility. +-- +-- Historical data indicates that the time interval between requests for maintenance +-- is exponentially distributed with a mean of 0.4 time units. Service times are also +-- exponentially distributed with the first station requiring on the average 0.25 time +-- units and the second station, 0.5 time units. Units are transported automatically +-- from work station 1 to work station 2 in a negligible amount of time. If the queue of +-- work station 2 is full, that is, if there are two units awaiting for work station 2, +-- the first station is blocked and a unit cannot leave the station. A blocked work +-- station cannot server other units. -- +-- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. -- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 import Prelude hiding (id, (.))