packages feed

aivika-transformers 4.3.1 → 4.3.2

raw patch · 49 files changed

+6663/−237 lines, 49 files

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2009-2015 David Sorokin <david.sorokin@gmail.com>+Copyright (c) 2009-2016 David Sorokin <david.sorokin@gmail.com>  All rights reserved.
Simulation/Aivika/IO/Generator.hs view
@@ -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
Simulation/Aivika/IO/QueueStrategy.hs view
@@ -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
Simulation/Aivika/IO/Resource/Preemption.hs view
@@ -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) ()
+ Simulation/Aivika/IO/Resource/Preemption/Base.hs view
@@ -0,0 +1,250 @@++{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.IO.Resource.Preemption.Base+-- Copyright  : Copyright (c) 2009-2016, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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'
Simulation/Aivika/Trans.hs view
@@ -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
Simulation/Aivika/Trans/Activity.hs view
@@ -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
Simulation/Aivika/Trans/Activity/Random.hs view
@@ -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
Simulation/Aivika/Trans/Dynamics/Random.hs view
@@ -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'
Simulation/Aivika/Trans/Generator.hs view
@@ -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)
+ Simulation/Aivika/Trans/Generator/Primitive.hs view
@@ -0,0 +1,243 @@++-- |+-- Module     : Simulation.Aivika.Trans.Generator.Primitive+-- Copyright  : Copyright (c) 2009-2016, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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
Simulation/Aivika/Trans/Net.hs view
@@ -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(..))
Simulation/Aivika/Trans/Net/Random.hs view
@@ -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
+ Simulation/Aivika/Trans/Operation.hs view
@@ -0,0 +1,413 @@++-- |+-- Module     : Simulation.Aivika.Trans.Operation+-- Copyright  : Copyright (c) 2009-2016, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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)
+ Simulation/Aivika/Trans/Operation/Random.hs view
@@ -0,0 +1,461 @@++-- |+-- Module     : Simulation.Aivika.Trans.Operation.Random+-- Copyright  : Copyright (c) 2009-2016, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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
Simulation/Aivika/Trans/Parameter/Random.hs view
@@ -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
Simulation/Aivika/Trans/Process/Random.hs view
@@ -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
Simulation/Aivika/Trans/Processor/Random.hs view
@@ -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
Simulation/Aivika/Trans/Processor/RoundRobbin.hs view
@@ -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
Simulation/Aivika/Trans/Queue.hs view
@@ -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
+ Simulation/Aivika/Trans/Queue/Base.hs view
@@ -0,0 +1,519 @@++{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module     : Simulation.Aivika.Trans.Queue.Base+-- Copyright  : Copyright (c) 2009-2016, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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
Simulation/Aivika/Trans/Queue/Infinite.hs view
@@ -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
+ Simulation/Aivika/Trans/Queue/Infinite/Base.hs view
@@ -0,0 +1,396 @@++{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module     : Simulation.Aivika.Trans.Queue.Infinite.Base+-- Copyright  : Copyright (c) 2009-2016, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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
Simulation/Aivika/Trans/QueueStrategy.hs view
@@ -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)
Simulation/Aivika/Trans/Resource.hs view
@@ -3,7 +3,7 @@  -- | -- Module     : Simulation.Aivika.Trans.Resource--- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2016, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- 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) ()
+ Simulation/Aivika/Trans/Resource/Base.hs view
@@ -0,0 +1,405 @@++{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module     : Simulation.Aivika.Trans.Resource.Base+-- Copyright  : Copyright (c) 2009-2016, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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)
Simulation/Aivika/Trans/Resource/Preemption.hs view
@@ -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.
+ Simulation/Aivika/Trans/Resource/Preemption/Base.hs view
@@ -0,0 +1,109 @@++{-# LANGUAGE TypeFamilies #-}++-- |+-- Module     : Simulation.Aivika.Trans.Resource.Preemption.Base+-- Copyright  : Copyright (c) 2009-2016, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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 ()
Simulation/Aivika/Trans/Results.hs view
@@ -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)
Simulation/Aivika/Trans/Results/Locale.hs view
@@ -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
Simulation/Aivika/Trans/Server.hs view
@@ -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
Simulation/Aivika/Trans/Server/Random.hs view
@@ -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
Simulation/Aivika/Trans/Stream.hs view
@@ -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
Simulation/Aivika/Trans/Stream/Random.hs view
@@ -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)
aivika-transformers.cabal view
@@ -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 <david.sorokin@gmail.com>+copyright:       (c) 2009-2016. David Sorokin <david.sorokin@gmail.com> author:          David Sorokin maintainer:      David Sorokin <david.sorokin@gmail.com> 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
examples/BassDiffusion.hs view
@@ -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
+ examples/BouncingBall.hs view
@@ -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
examples/Furnace.hs view
@@ -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.
examples/InspectionAdjustmentStations.hs view
@@ -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, (.))
+ examples/InventorySystem.hs view
@@ -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
+ examples/MachineBreakdowns.hs view
@@ -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
+ examples/PERT.hs view
@@ -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
+ examples/PingPong.hs view
@@ -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
+ examples/PortOperations.hs view
@@ -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
+ examples/QuarryOperations.hs view
@@ -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
+ examples/RenegingFromQueue.hs view
@@ -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
+ examples/SingleLaneTraffic.hs view
@@ -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
+ examples/TruckHaulingSituation.hs view
@@ -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
examples/WorkStationsInSeries.hs view
@@ -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, (.))