aivika 3.1 → 4.0

raw patch · 27 files changed

+2201/−395 lines, 27 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Simulation/Aivika.hs +10/−0
• Simulation/Aivika/Activity.hs +202/−81
• Simulation/Aivika/Activity/Random.hs +230/−0
• Simulation/Aivika/Internal/Cont.hs +240/−62
• Simulation/Aivika/Internal/Process.hs +84/−18
• Simulation/Aivika/Net.hs +8/−1
• Simulation/Aivika/Net/Random.hs +103/−0
• Simulation/Aivika/PriorityQueue.hs +52/−2
• Simulation/Aivika/Process.hs +3/−0
• Simulation/Aivika/Process/Random.hs +199/−0
• Simulation/Aivika/Processor.hs +8/−0
• Simulation/Aivika/Processor/Random.hs +103/−0
• Simulation/Aivika/Resource.hs +31/−5
• Simulation/Aivika/Resource/Preemption.hs +308/−0
• Simulation/Aivika/Results.hs +14/−4
• Simulation/Aivika/Results/Locale.hs +24/−0
• Simulation/Aivika/Server.hs +216/−89
• Simulation/Aivika/Server/Random.hs +230/−0
• Simulation/Aivika/Signal.hs +21/−2
• Simulation/Aivika/Stream.hs +62/−0
• Simulation/Aivika/Stream/Random.hs +0/−2
• aivika.cabal +7/−1
• examples/InspectionAdjustmentStations.hs +3/−8
• examples/MachRep1.hs +2/−6
• examples/MachRep2.hs +2/−6
• examples/MachRep3.hs +2/−6
• examples/MachineBreakdowns.hs +37/−102

@@ -13,6 +13,7 @@ module Simulation.Aivika        (-- * Modules         module Simulation.Aivika.Activity,+        module Simulation.Aivika.Activity.Random,         module Simulation.Aivika.Agent,         module Simulation.Aivika.Arrival,         module Simulation.Aivika.Circuit,@@ -24,10 +25,13 @@         module Simulation.Aivika.Event,         module Simulation.Aivika.Generator,         module Simulation.Aivika.Net,+        module Simulation.Aivika.Net.Random,         module Simulation.Aivika.Parameter,         module Simulation.Aivika.Parameter.Random,         module Simulation.Aivika.Process,+        module Simulation.Aivika.Process.Random,         module Simulation.Aivika.Processor,+        module Simulation.Aivika.Processor.Random,         module Simulation.Aivika.Processor.RoundRobbin,         module Simulation.Aivika.QueueStrategy,         module Simulation.Aivika.Ref,@@ -36,6 +40,7 @@         module Simulation.Aivika.Results.Locale,         module Simulation.Aivika.Results.IO,         module Simulation.Aivika.Server,+        module Simulation.Aivika.Server.Random,         module Simulation.Aivika.Signal,         module Simulation.Aivika.Simulation,         module Simulation.Aivika.Specs,@@ -50,6 +55,7 @@         module Simulation.Aivika.Var.Unboxed) where  import Simulation.Aivika.Activity+import Simulation.Aivika.Activity.Random import Simulation.Aivika.Agent import Simulation.Aivika.Arrival import Simulation.Aivika.Circuit@@ -61,10 +67,13 @@ import Simulation.Aivika.Event import Simulation.Aivika.Generator import Simulation.Aivika.Net+import Simulation.Aivika.Net.Random import Simulation.Aivika.Parameter import Simulation.Aivika.Parameter.Random import Simulation.Aivika.Process+import Simulation.Aivika.Process.Random import Simulation.Aivika.Processor+import Simulation.Aivika.Processor.Random import Simulation.Aivika.Processor.RoundRobbin import Simulation.Aivika.QueueStrategy import Simulation.Aivika.Ref@@ -73,6 +82,7 @@ import Simulation.Aivika.Results.Locale import Simulation.Aivika.Results.IO import Simulation.Aivika.Server+import Simulation.Aivika.Server.Random import Simulation.Aivika.Signal import Simulation.Aivika.Simulation import Simulation.Aivika.Specs

@@ -12,11 +12,10 @@ module Simulation.Aivika.Activity        (-- * Activity         Activity,-        ActivityInterruption(..),         newActivity,         newStateActivity,-        newInterruptibleActivity,-        newInterruptibleStateActivity,+        newPreemptibleActivity,+        newPreemptibleStateActivity,         -- * Processing         activityNet,         -- * Activity Properties@@ -24,10 +23,13 @@         activityState,         activityTotalUtilisationTime,         activityTotalIdleTime,+        activityTotalPreemptionTime,         activityUtilisationTime,         activityIdleTime,+        activityPreemptionTime,         activityUtilisationFactor,         activityIdleFactor,+        activityPreemptionFactor,         -- * Summary         activitySummary,         -- * Derived Signals for Properties@@ -37,18 +39,25 @@         activityTotalUtilisationTimeChanged_,         activityTotalIdleTimeChanged,         activityTotalIdleTimeChanged_,+        activityTotalPreemptionTimeChanged,+        activityTotalPreemptionTimeChanged_,         activityUtilisationTimeChanged,         activityUtilisationTimeChanged_,         activityIdleTimeChanged,         activityIdleTimeChanged_,+        activityPreemptionTimeChanged,+        activityPreemptionTimeChanged_,         activityUtilisationFactorChanged,         activityUtilisationFactorChanged_,         activityIdleFactorChanged,         activityIdleFactorChanged_,+        activityPreemptionFactorChanged,+        activityPreemptionFactorChanged_,         -- * Basic Signals         activityUtilising,         activityUtilised,-        activityInterrupted,+        activityPreempting,+        activityReentering,         -- * Overall Signal         activityChanged_) where @@ -79,49 +88,45 @@              -- ^ The current state of the activity.              activityProcess :: s -> a -> Process (s, b),              -- ^ Provide @b@ by specified @a@.-             activityProcessInterruptible :: Bool,-             -- ^ Whether the process is interruptible.+             activityProcessPreemptible :: Bool,+             -- ^ Whether the process is preemptible.              activityTotalUtilisationTimeRef :: IORef Double,              -- ^ The counted total time of utilising the activity.              activityTotalIdleTimeRef :: IORef Double,-             -- ^ The counted total time, when the activity was idle.+             -- ^ The counted total time when the activity was idle.+             activityTotalPreemptionTimeRef :: IORef Double,+             -- ^ The counted total time when the activity was preempted.               activityUtilisationTimeRef :: IORef (SamplingStats Double),              -- ^ The statistics for the utilisation time.              activityIdleTimeRef :: IORef (SamplingStats Double),-             -- ^ The statistics for the time, when the activity was idle.+             -- ^ The statistics for the time when the activity was idle.+             activityPreemptionTimeRef :: IORef (SamplingStats Double),+             -- ^ The statistics for the time when the activity was preempted.              activityUtilisingSource :: SignalSource a,              -- ^ A signal raised when starting to utilise the activity.              activityUtilisedSource :: SignalSource (a, b),              -- ^ A signal raised when the activity has been utilised.-             activityInterruptedSource :: SignalSource (ActivityInterruption a)-             -- ^ A signal raised when the utilisation was interrupted.+             activityPreemptingSource :: SignalSource a,+             -- ^ A signal raised when the utilisation was preempted.+             activityReenteringSource :: SignalSource a+             -- ^ A signal raised when the utilisation was proceeded after it had been preempted earlier.            } --- | Contains data about the interrupted task.-data ActivityInterruption a =-  ActivityInterruption { activityInterruptedInput :: a,-                         -- ^ The input task that was interrupted.-                         activityStartProcessingTime :: Double,-                         -- ^ The start time of processing the task.-                         activityInterruptionTime :: Double-                         -- ^ The time of interrupting the task.-                       }- -- | Create a new activity that can provide output @b@ by input @a@. ----- By default, it is assumed that the activity utilisation cannot be interrupted,--- because the handling of possible task interruption is rather costly+-- By default, it is assumed that the activity utilisation cannot be preempted,+-- because the handling of possible task preemption is rather costly -- operation. newActivity :: (a -> Process b)                -- ^ provide an output by the specified input                -> Simulation (Activity () a b)-newActivity = newInterruptibleActivity False+newActivity = newPreemptibleActivity False  -- | Create a new activity that can provide output @b@ by input @a@ -- starting from state @s@. ----- By default, it is assumed that the activity utilisation cannot be interrupted,--- because the handling of possible task interruption is rather costly+-- By default, it is assumed that the activity utilisation cannot be preempted,+-- because the handling of possible task preemption is rather costly -- operation. newStateActivity :: (s -> a -> Process (s, b))                     -- ^ provide a new state and output by the specified @@ -129,49 +134,55 @@                     -> s                     -- ^ the initial state                     -> Simulation (Activity s a b)-newStateActivity = newInterruptibleStateActivity False+newStateActivity = newPreemptibleStateActivity False --- | Create a new interruptible activity that can provide output @b@ by input @a@.-newInterruptibleActivity :: Bool-                            -- ^ whether the activity can be interrupted-                            -> (a -> Process b)-                            -- ^ provide an output by the specified input-                            -> Simulation (Activity () a b)-newInterruptibleActivity interruptible provide =-  flip (newInterruptibleStateActivity interruptible) () $ \s a ->+-- | Create a new preemptible activity that can provide output @b@ by input @a@.+newPreemptibleActivity :: Bool+                          -- ^ whether the activity can be preempted+                          -> (a -> Process b)+                          -- ^ provide an output by the specified input+                          -> Simulation (Activity () a b)+newPreemptibleActivity preemptible provide =+  flip (newPreemptibleStateActivity preemptible) () $ \s a ->   do b <- provide a      return (s, b)  -- | Create a new activity that can provide output @b@ by input @a@ -- starting from state @s@.-newInterruptibleStateActivity :: Bool-                                 -- ^ whether the activity can be interrupted-                                 -> (s -> a -> Process (s, b))-                                 -- ^ provide a new state and output by the specified -                                 -- old state and input-                                 -> s-                                 -- ^ the initial state+newPreemptibleStateActivity :: Bool+                               -- ^ whether the activity can be preempted+                               -> (s -> a -> Process (s, b))+                               -- ^ provide a new state and output by the specified +                               -- old state and input+                               -> s+                               -- ^ the initial state                               -> Simulation (Activity s a b)-newInterruptibleStateActivity interruptible provide state =+newPreemptibleStateActivity preemptible provide state =   do r0 <- liftIO $ newIORef state      r1 <- liftIO $ newIORef 0      r2 <- liftIO $ newIORef 0-     r3 <- liftIO $ newIORef emptySamplingStats+     r3 <- liftIO $ newIORef 0      r4 <- liftIO $ newIORef emptySamplingStats+     r5 <- liftIO $ newIORef emptySamplingStats+     r6 <- liftIO $ newIORef emptySamplingStats      s1 <- newSignalSource      s2 <- newSignalSource      s3 <- newSignalSource+     s4 <- newSignalSource      return Activity { activityInitState = state,                        activityStateRef = r0,                        activityProcess = provide,-                       activityProcessInterruptible = interruptible,+                       activityProcessPreemptible = preemptible,                        activityTotalUtilisationTimeRef = r1,                        activityTotalIdleTimeRef = r2,-                       activityUtilisationTimeRef = r3,-                       activityIdleTimeRef = r4,+                       activityTotalPreemptionTimeRef = r3,+                       activityUtilisationTimeRef = r4,+                       activityIdleTimeRef = r5,+                       activityPreemptionTimeRef = r6,                        activityUtilisingSource = s1,                        activityUtilisedSource = s2,-                       activityInterruptedSource = s3 }+                       activityPreemptingSource = s3,+                       activityReenteringSource = s4 }  -- | Return a network computation for the specified activity. --@@ -201,37 +212,52 @@                        addSamplingStats (t0 - t')               triggerSignal (activityUtilisingSource act) a          -- utilise the activity-         (s', b) <- activityProcess act s a-         (s', b) <- if activityProcessInterruptible act-                    then activityProcessInterrupting act s a-                    else activityProcess act s a+         (s', b, dt) <- if activityProcessPreemptible act+                        then activityProcessPreempting act s a+                        else do (s', b) <- activityProcess act s a+                                return (s', b, 0)          t1 <- liftDynamics time          liftEvent $            do liftIO $                 do writeIORef (activityStateRef act) $! s'-                   modifyIORef' (activityTotalUtilisationTimeRef act) (+ (t1 - t0))+                   modifyIORef' (activityTotalUtilisationTimeRef act) (+ (t1 - t0 - dt))                    modifyIORef' (activityUtilisationTimeRef act) $-                     addSamplingStats (t1 - t0)+                     addSamplingStats (t1 - t0 - dt)               triggerSignal (activityUtilisedSource act) (a, b)          return (b, Net $ loop s' (Just t1)) --- | Process the input with ability to handle a possible interruption.-activityProcessInterrupting :: Activity s a b -> s -> a -> Process (s, b)-activityProcessInterrupting act s a =+-- | Process the input with ability to handle a possible preemption.+activityProcessPreempting :: Activity s a b -> s -> a -> Process (s, b, Double)+activityProcessPreempting act s a =   do pid <- processId      t0  <- liftDynamics time-     finallyProcess-       (activityProcess act s a)-       (liftEvent $-        do cancelled <- processCancelled pid-           when cancelled $-             do t1 <- liftDynamics time-                liftIO $-                  do modifyIORef' (activityTotalUtilisationTimeRef act) (+ (t1 - t0))-                     modifyIORef' (activityUtilisationTimeRef act) $-                       addSamplingStats (t1 - t0)-                let x = ActivityInterruption a t0 t1-                triggerSignal (activityInterruptedSource act) x)+     rs  <- liftIO $ newIORef 0+     r0  <- liftIO $ newIORef t0+     h1  <- liftEvent $+            handleSignal (processPreemptionBeginning pid) $ \() ->+            do t0 <- liftDynamics time+               liftIO $ writeIORef r0 t0+               triggerSignal (activityPreemptingSource act) a+     h2  <- liftEvent $+            handleSignal (processPreemptionEnding pid) $ \() ->+            do t0 <- liftIO $ readIORef r0+               t1 <- liftDynamics time+               let dt = t1 - t0+               liftIO $+                 do modifyIORef' rs (+ dt)+                    modifyIORef' (activityTotalPreemptionTimeRef act) (+ dt)+                    modifyIORef' (activityPreemptionTimeRef act) $+                      addSamplingStats dt+               triggerSignal (activityReenteringSource act) a +     let m1 =+           do (s', b) <- activityProcess act s a+              dt <- liftIO $ readIORef rs+              return (s', b, dt)+         m2 =+           liftEvent $+           do disposeEvent h1+              disposeEvent h2+     finallyProcess m1 m2  -- | Return the current state of the activity. --@@ -290,6 +316,27 @@ activityTotalIdleTimeChanged_ act =   mapSignal (const ()) (activityUtilising act) +-- | Return the counted total time when the 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 'activityTotalPreemptionTimeChanged' and 'activityTotalPreemptionTimeChanged_'.+activityTotalPreemptionTime :: Activity s a b -> Event Double+activityTotalPreemptionTime act =+  Event $ \p -> readIORef (activityTotalPreemptionTimeRef act)+  +-- | Signal when the 'activityTotalPreemptionTime' property value has changed.+activityTotalPreemptionTimeChanged :: Activity s a b -> Signal Double+activityTotalPreemptionTimeChanged act =+  mapSignalM (const $ activityTotalPreemptionTime act) (activityTotalPreemptionTimeChanged_ act)+  +-- | Signal when the 'activityTotalPreemptionTime' property value has changed.+activityTotalPreemptionTimeChanged_ :: Activity s a b -> Signal ()+activityTotalPreemptionTimeChanged_ act =+  mapSignal (const ()) (activityReentering act)+ -- | Return the statistics for the time when the activity was utilised. -- -- The value returned changes discretely and it is usually delayed relative@@ -329,14 +376,35 @@ activityIdleTimeChanged_ :: Activity s a b -> Signal () activityIdleTimeChanged_ act =   mapSignal (const ()) (activityUtilising act)++-- | Return the statistics for the time when the 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 'activityPreemptionTimeChanged' and 'activityPreemptionTimeChanged_'.+activityPreemptionTime :: Activity s a b -> Event (SamplingStats Double)+activityPreemptionTime act =+  Event $ \p -> readIORef (activityPreemptionTimeRef act)   +-- | Signal when the 'activityPreemptionTime' property value has changed.+activityPreemptionTimeChanged :: Activity s a b -> Signal (SamplingStats Double)+activityPreemptionTimeChanged act =+  mapSignalM (const $ activityPreemptionTime act) (activityPreemptionTimeChanged_ act)+  +-- | Signal when the 'activityPreemptionTime' property value has changed.+activityPreemptionTimeChanged_ :: Activity s a b -> Signal ()+activityPreemptionTimeChanged_ act =+  mapSignal (const ()) (activityReentering act)+   -- | It returns the factor changing from 0 to 1, which estimates how often -- the activity was utilised. -- -- This factor is calculated as -- -- @---   totalUtilisationTime \/ (totalUtilisationTime + totalIdleTime)+--   totalUtilisationTime \/ (totalUtilisationTime + totalIdleTime + totalPreemptionTime) -- @ -- -- As before in this module, the value returned changes discretely and@@ -348,7 +416,8 @@   Event $ \p ->   do x1 <- readIORef (activityTotalUtilisationTimeRef act)      x2 <- readIORef (activityTotalIdleTimeRef act)-     return (x1 / (x1 + x2))+     x3 <- readIORef (activityTotalPreemptionTimeRef act)+     return (x1 / (x1 + x2 + x3))    -- | Signal when the 'activityUtilisationFactor' property value has changed. activityUtilisationFactorChanged :: Activity s a b -> Signal Double@@ -359,7 +428,8 @@ activityUtilisationFactorChanged_ :: Activity s a b -> Signal () activityUtilisationFactorChanged_ act =   mapSignal (const ()) (activityUtilising act) <>-  mapSignal (const ()) (activityUtilised act)+  mapSignal (const ()) (activityUtilised act) <>+  mapSignal (const ()) (activityReentering act)    -- | It returns the factor changing from 0 to 1, which estimates how often -- the activity was idle.@@ -367,7 +437,7 @@ -- This factor is calculated as -- -- @---   totalIdleTime \/ (totalUtilisationTime + totalIdleTime)+--   totalIdleTime \/ (totalUtilisationTime + totalIdleTime + totalPreemptionTime) -- @ -- -- As before in this module, the value returned changes discretely and@@ -379,7 +449,8 @@   Event $ \p ->   do x1 <- readIORef (activityTotalUtilisationTimeRef act)      x2 <- readIORef (activityTotalIdleTimeRef act)-     return (x2 / (x1 + x2))+     x3 <- readIORef (activityTotalPreemptionTimeRef act)+     return (x2 / (x1 + x2 + x3))    -- | Signal when the 'activityIdleFactor' property value has changed. activityIdleFactorChanged :: Activity s a b -> Signal Double@@ -390,8 +461,42 @@ activityIdleFactorChanged_ :: Activity s a b -> Signal () activityIdleFactorChanged_ act =   mapSignal (const ()) (activityUtilising act) <>-  mapSignal (const ()) (activityUtilised act)+  mapSignal (const ()) (activityUtilised act) <>+  mapSignal (const ()) (activityReentering act) +-- | It returns the factor changing from 0 to 1, which estimates how often+-- the activity was preempted waiting for the further proceeding.+--+-- This factor is calculated as+--+-- @+--   totalUtilisationTime \/ (totalUtilisationTime + totalIdleTime + totalPreemptionTime)+-- @+--+-- As before in this module, the value returned changes discretely and+-- it is usually delayed relative to the current simulation time.+--+-- See also 'activityPreemptionFactorChanged' and 'activityPreemptionFactorChanged_'.+activityPreemptionFactor :: Activity s a b -> Event Double+activityPreemptionFactor act =+  Event $ \p ->+  do x1 <- readIORef (activityTotalUtilisationTimeRef act)+     x2 <- readIORef (activityTotalIdleTimeRef act)+     x3 <- readIORef (activityTotalPreemptionTimeRef act)+     return (x3 / (x1 + x2 + x3))+  +-- | Signal when the 'activityPreemptionFactor' property value has changed.+activityPreemptionFactorChanged :: Activity s a b -> Signal Double+activityPreemptionFactorChanged act =+  mapSignalM (const $ activityPreemptionFactor act) (activityPreemptionFactorChanged_ act)+  +-- | Signal when the 'activityPreemptionFactor' property value has changed.+activityPreemptionFactorChanged_ :: Activity s a b -> Signal ()+activityPreemptionFactorChanged_ act =+  mapSignal (const ()) (activityUtilising act) <>+  mapSignal (const ()) (activityUtilised act) <>+  mapSignal (const ()) (activityReentering act)+   -- | Raised when starting to utilise the activity after a new input task is received. activityUtilising :: Activity s a b -> Signal a activityUtilising = publishSignal . activityUtilisingSource@@ -400,16 +505,20 @@ activityUtilised :: Activity s a b -> Signal (a, b) activityUtilised = publishSignal . activityUtilisedSource --- | Raised when the task utilisation by the activity was interrupted.-activityInterrupted :: Activity s a b -> Signal (ActivityInterruption a)-activityInterrupted = publishSignal . activityInterruptedSource+-- | Raised when the task utilisation by the activity was preempted.+activityPreempting :: Activity s a b -> Signal a+activityPreempting = publishSignal . activityPreemptingSource +-- | Raised when the task utilisation by the activity was proceeded after it had been preempted earlier.+activityReentering :: Activity s a b -> Signal a+activityReentering = publishSignal . activityReenteringSource+ -- | Signal whenever any property of the activity changes. activityChanged_ :: Activity s a b -> Signal () activityChanged_ act =   mapSignal (const ()) (activityUtilising act) <>   mapSignal (const ()) (activityUtilised act) <>-  mapSignal (const ()) (activityInterrupted act)+  mapSignal (const ()) (activityReentering act)  -- | Return the summary for the activity with desciption of its -- properties using the specified indent.@@ -418,10 +527,13 @@   Event $ \p ->   do tx1 <- readIORef (activityTotalUtilisationTimeRef act)      tx2 <- readIORef (activityTotalIdleTimeRef act)-     let xf1 = tx1 / (tx1 + tx2)-         xf2 = tx2 / (tx1 + tx2)+     tx3 <- readIORef (activityTotalPreemptionTimeRef act)+     let xf1 = tx1 / (tx1 + tx2 + tx3)+         xf2 = tx2 / (tx1 + tx2 + tx3)+         xf3 = tx3 / (tx1 + tx2 + tx3)      xs1 <- readIORef (activityUtilisationTimeRef act)      xs2 <- readIORef (activityIdleTimeRef act)+     xs3 <- readIORef (activityPreemptionTimeRef act)      let tab = replicate indent ' '      return $        showString tab .@@ -431,15 +543,24 @@        showString "total idle time = " . shows tx2 .        showString "\n" .        showString tab .+       showString "total preemption time = " . shows tx3 .+       showString "\n" .+       showString tab .        showString "utilisation factor (from 0 to 1) = " . shows xf1 .        showString "\n" .        showString tab .        showString "idle factor (from 0 to 1) = " . shows xf2 .        showString "\n" .        showString tab .+       showString "preemption factor (from 0 to 1) = " . shows xf3 .+       showString "\n" .+       showString tab .        showString "utilisation time (locked while awaiting the input):\n\n" .        samplingStatsSummary xs1 (2 + indent) .        showString "\n\n" .        showString tab .        showString "idle time:\n\n" .-       samplingStatsSummary xs2 (2 + indent)+       samplingStatsSummary xs2 (2 + indent) .+       showString tab .+       showString "preemption time:\n\n" .+       samplingStatsSummary xs3 (2 + indent)

@@ -0,0 +1,230 @@++-- |+-- Module     : Simulation.Aivika.Activity.Random+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines some useful predefined activities that+-- hold the current process for the corresponding random time+-- interval, when processing every input element.+--++module Simulation.Aivika.Activity.Random+       (newRandomUniformActivity,+        newRandomUniformIntActivity,+        newRandomNormalActivity,+        newRandomExponentialActivity,+        newRandomErlangActivity,+        newRandomPoissonActivity,+        newRandomBinomialActivity,+        newPreemptibleRandomUniformActivity,+        newPreemptibleRandomUniformIntActivity,+        newPreemptibleRandomNormalActivity,+        newPreemptibleRandomExponentialActivity,+        newPreemptibleRandomErlangActivity,+        newPreemptibleRandomPoissonActivity,+        newPreemptibleRandomBinomialActivity) where++import Simulation.Aivika.Simulation+import Simulation.Aivika.Process+import Simulation.Aivika.Process.Random+import Simulation.Aivika.Activity++-- | Create a new activity that holds the process for a random time interval+-- distributed uniformly, 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.+newRandomUniformActivity :: Double+                            -- ^ the minimum time interval+                            -> Double+                            -- ^ the maximum time interval+                            -> Simulation (Activity () a a)+newRandomUniformActivity =+  newPreemptibleRandomUniformActivity False++-- | Create a new activity that holds the process for a random time interval+-- distributed uniformly, 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.+newRandomUniformIntActivity :: Int+                               -- ^ the minimum time interval+                               -> Int+                               -- ^ the maximum time interval+                               -> Simulation (Activity () a a)+newRandomUniformIntActivity =+  newPreemptibleRandomUniformIntActivity 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,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomNormalActivity :: Double+                           -- ^ the mean time interval+                           -> Double+                           -- ^ the time interval deviation+                           -> Simulation (Activity () a a)+newRandomNormalActivity =+  newPreemptibleRandomNormalActivity 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.+--+-- By default, it is assumed that the activity process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomExponentialActivity :: Double+                                -- ^ the mean time interval (the reciprocal of the rate)+                                -> Simulation (Activity () a a)+newRandomExponentialActivity =+  newPreemptibleRandomExponentialActivity False+         +-- | Create a new activity 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 activity process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomErlangActivity :: Double+                           -- ^ the scale (the reciprocal of the rate)+                           -> Int+                           -- ^ the shape+                           -> Simulation (Activity () a a)+newRandomErlangActivity =+  newPreemptibleRandomErlangActivity False++-- | Create a new activity 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 activity process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomPoissonActivity :: Double+                            -- ^ the mean time interval+                            -> Simulation (Activity () a a)+newRandomPoissonActivity =+  newPreemptibleRandomPoissonActivity False++-- | Create a new activity 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 activity process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomBinomialActivity :: Double+                             -- ^ the probability+                             -> Int+                             -- ^ the number of trials+                             -> Simulation (Activity () a a)+newRandomBinomialActivity =+  newPreemptibleRandomBinomialActivity False++-- | Create a new activity that holds the process for a random time interval+-- distributed uniformly, when processing every input element.+newPreemptibleRandomUniformActivity :: Bool+                                       -- ^ whether the activity process can be preempted+                                       -> Double+                                       -- ^ the minimum time interval+                                       -> Double+                                       -- ^ the maximum time interval+                                       -> Simulation (Activity () a a)+newPreemptibleRandomUniformActivity preemptible min max =+  newPreemptibleActivity preemptible $ \a ->+  do randomUniformProcess_ min max+     return a++-- | Create a new activity that holds the process for a random time interval+-- distributed uniformly, when processing every input element.+newPreemptibleRandomUniformIntActivity :: Bool+                                          -- ^ whether the activity process can be preempted+                                          -> Int+                                          -- ^ the minimum time interval+                                          -> Int+                                          -- ^ the maximum time interval+                                          -> Simulation (Activity () a a)+newPreemptibleRandomUniformIntActivity preemptible min max =+  newPreemptibleActivity preemptible $ \a ->+  do randomUniformIntProcess_ min max+     return a++-- | Create a new activity that holds the process for a random time interval+-- distributed normally, when processing every input element.+newPreemptibleRandomNormalActivity :: Bool+                                      -- ^ whether the activity process can be preempted+                                      -> Double+                                      -- ^ the mean time interval+                                      -> Double+                                      -- ^ the time interval deviation+                                      -> Simulation (Activity () a a)+newPreemptibleRandomNormalActivity preemptible mu nu =+  newPreemptibleActivity preemptible $ \a ->+  do randomNormalProcess_ 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),+-- when processing every input element.+newPreemptibleRandomExponentialActivity :: Bool+                                           -- ^ whether the activity process can be preempted+                                           -> Double+                                           -- ^ the mean time interval (the reciprocal of the rate)+                                           -> Simulation (Activity () a a)+newPreemptibleRandomExponentialActivity preemptible mu =+  newPreemptibleActivity preemptible $ \a ->+  do randomExponentialProcess_ mu+     return a+         +-- | Create a new activity 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.+newPreemptibleRandomErlangActivity :: Bool+                                      -- ^ whether the activity process can be preempted+                                      -> Double+                                      -- ^ the scale (the reciprocal of the rate)+                                      -> Int+                                      -- ^ the shape+                                      -> Simulation (Activity () a a)+newPreemptibleRandomErlangActivity preemptible beta m =+  newPreemptibleActivity preemptible $ \a ->+  do randomErlangProcess_ beta m+     return a++-- | Create a new activity that holds the process for a random time interval+-- having the Poisson distribution with the specified mean, when processing+-- every input element.+newPreemptibleRandomPoissonActivity :: Bool+                                       -- ^ whether the activity process can be preempted+                                       -> Double+                                       -- ^ the mean time interval+                                       -> Simulation (Activity () a a)+newPreemptibleRandomPoissonActivity preemptible mu =+  newPreemptibleActivity preemptible $ \a ->+  do randomPoissonProcess_ mu+     return a++-- | Create a new activity that holds the process for a random time interval+-- having the binomial distribution with the specified probability and trials,+-- when processing every input element.+newPreemptibleRandomBinomialActivity :: Bool+                                        -- ^ whether the activity process can be preempted+                                        -> Double+                                        -- ^ the probability+                                        -> Int+                                        -- ^ the number of trials+                                        -> Simulation (Activity () a a)+newPreemptibleRandomBinomialActivity preemptible prob trials =+  newPreemptibleActivity preemptible $ \a ->+  do randomBinomialProcess_ prob trials+     return a

@@ -15,15 +15,24 @@ -- module Simulation.Aivika.Internal.Cont        (ContCancellation(..),-        ContCancellationSource,+        ContId,+        ContEvent(..),         Cont(..),         ContParams,-        newContCancellationSource,+        FrozenCont,+        newContId,+        contSignal,         contCancellationInitiated,         contCancellationInitiate,         contCancellationInitiating,+        contCancellationActivated,         contCancellationBind,         contCancellationConnect,+        contPreemptionBegun,+        contPreemptionBegin,+        contPreemptionBeginning,+        contPreemptionEnd,+        contPreemptionEnding,         invokeCont,         runCont,         rerunCont,@@ -35,8 +44,12 @@         throwCont,         resumeCont,         resumeECont,+        reenterCont,+        freezeCont,+        freezeContReentering,+        unfreezeCont,+        substituteCont,         contCanceled,-        contFreeze,         contAwait,         traceCont) where @@ -69,47 +82,66 @@                       | CancelInIsolation                         -- ^ Cancel the computations in isolation. --- | It manages the cancellation process.-data ContCancellationSource =-  ContCancellationSource { contCancellationInitiatedRef :: IORef Bool,-                           contCancellationActivatedRef :: IORef Bool,-                           contCancellationInitiatingSource :: SignalSource ()-                         }+-- | It identifies the 'Cont' computation.+data ContId =+  ContId { contCancellationInitiatedRef :: IORef Bool,+           contCancellationActivatedRef :: IORef Bool,+           contPreemptionCountRef :: IORef Int,+           contSignalSource :: SignalSource ContEvent+         } --- | Create the cancellation source.-newContCancellationSource :: Simulation ContCancellationSource-newContCancellationSource =+instance Eq ContId where+  x == y = contCancellationInitiatedRef x == contCancellationInitiatedRef y  -- unique references++-- | The event that occurs within the 'Cont' computation.+data ContEvent = ContCancellationInitiating+                 -- ^ Cancel the computation.+               | ContPreemptionBeginning+                 -- ^ Preempt the computation.+               | ContPreemptionEnding+                 -- ^ Proceed with the computation after if was preempted.+               deriving (Eq, Ord, Show)++-- | Create a computation identifier.+newContId :: Simulation ContId+newContId =   Simulation $ \r ->   do r1 <- newIORef False      r2 <- newIORef False+     r3 <- newIORef 0      s  <- invokeSimulation r newSignalSource-     return ContCancellationSource { contCancellationInitiatedRef = r1,-                                     contCancellationActivatedRef = r2,-                                     contCancellationInitiatingSource = s-                                   }+     return ContId { contCancellationInitiatedRef = r1,+                     contCancellationActivatedRef = r2,+                     contPreemptionCountRef = r3,+                     contSignalSource = s+                   } +-- | Signal when the computation state changes.+contSignal :: ContId -> Signal ContEvent+contSignal = publishSignal . contSignalSource+ -- | Signal when the cancellation is intiating.-contCancellationInitiating :: ContCancellationSource -> Signal ()+contCancellationInitiating :: ContId -> Signal () contCancellationInitiating =-  publishSignal . contCancellationInitiatingSource+  filterSignal_ (ContCancellationInitiating ==) . contSignal  -- | Whether the cancellation was initiated.-contCancellationInitiated :: ContCancellationSource -> Event Bool+contCancellationInitiated :: ContId -> Event Bool contCancellationInitiated x =   Event $ \p -> readIORef (contCancellationInitiatedRef x)  -- | Whether the cancellation was activated.-contCancellationActivated :: ContCancellationSource -> IO Bool+contCancellationActivated :: ContId -> IO Bool contCancellationActivated =   readIORef . contCancellationActivatedRef  -- | Deactivate the cancellation.-contCancellationDeactivate :: ContCancellationSource -> IO ()+contCancellationDeactivate :: ContId -> IO () contCancellationDeactivate x =   writeIORef (contCancellationActivatedRef x) False  -- | If the main computation is cancelled then all the nested ones will be cancelled too.-contCancellationBind :: ContCancellationSource -> [ContCancellationSource] -> Event DisposableEvent+contCancellationBind :: ContId -> [ContId] -> Event DisposableEvent contCancellationBind x ys =   Event $ \p ->   do hs1 <- forM ys $ \y ->@@ -123,11 +155,11 @@      return $ mconcat hs1 <> mconcat hs2  -- | Connect the parent computation to the child one.-contCancellationConnect :: ContCancellationSource+contCancellationConnect :: ContId                            -- ^ the parent                            -> ContCancellation                            -- ^ how to connect-                           -> ContCancellationSource+                           -> ContId                            -- ^ the child                            -> Event DisposableEvent                            -- ^ computation of the disposable handler@@ -154,15 +186,59 @@      return $ h1 <> h2  -- | Initiate the cancellation.-contCancellationInitiate :: ContCancellationSource -> Event ()+contCancellationInitiate :: ContId -> Event () contCancellationInitiate x =   Event $ \p ->   do f <- readIORef (contCancellationInitiatedRef x)      unless f $        do writeIORef (contCancellationInitiatedRef x) True           writeIORef (contCancellationActivatedRef x) True-          invokeEvent p $ triggerSignal (contCancellationInitiatingSource x) ()+          invokeEvent p $+            triggerSignal (contSignalSource x) ContCancellationInitiating +-- | Preempt the computation.+contPreemptionBegin :: ContId -> Event ()+contPreemptionBegin x =+  Event $ \p ->+  do f <- readIORef (contCancellationInitiatedRef x)+     unless f $+       do n <- readIORef (contPreemptionCountRef x)+          let n' = n + 1+          n' `seq` writeIORef (contPreemptionCountRef x) n'+          when (n == 0) $+            invokeEvent p $+            triggerSignal (contSignalSource x) ContPreemptionBeginning++-- | Proceed with the computation after it was preempted earlier.+contPreemptionEnd :: ContId -> Event ()+contPreemptionEnd x =+  Event $ \p ->+  do f <- readIORef (contCancellationInitiatedRef x)+     unless f $+       do n <- readIORef (contPreemptionCountRef x)+          let n' = n - 1+          n' `seq` writeIORef (contPreemptionCountRef x) n'+          when (n' == 0) $+            invokeEvent p $+            triggerSignal (contSignalSource x) ContPreemptionEnding++-- | Signal when the computation is preempted.+contPreemptionBeginning :: ContId -> Signal ()+contPreemptionBeginning =+  filterSignal_ (ContPreemptionBeginning ==) . contSignal++-- | Signal when the computation is proceeded after it was preempted before.+contPreemptionEnding :: ContId -> Signal ()+contPreemptionEnding =+  filterSignal_ (ContPreemptionEnding ==) . contSignal++-- | Whether the computation was preemtped.+contPreemptionBegun :: ContId -> Event Bool+contPreemptionBegun x =+  Event $ \p ->+  do n <- readIORef (contPreemptionCountRef x)+     return (n > 0)+ -- | The 'Cont' type is similar to the standard @Cont@ monad  -- and F# async workflow but only the result of applying -- the continuations return the 'Event' computation.@@ -177,7 +253,7 @@ data ContParamsAux =   ContParamsAux { contECont :: SomeException -> Event (),                   contCCont :: () -> Event (),-                  contCancelSource :: ContCancellationSource,+                  contId :: ContId,                   contCancelFlag :: IO Bool,                   contCatchFlag  :: Bool } @@ -216,7 +292,7 @@ cancelCont :: Point -> ContParams a -> IO () {-# NOINLINE cancelCont #-} cancelCont p c =-  do contCancellationDeactivate (contCancelSource $ contAux c)+  do contCancellationDeactivate (contId $ contAux c)      invokeEvent p $ (contCCont $ contAux c) ()  returnC :: a -> Cont a@@ -317,18 +393,18 @@            -- ^ the branch for handing exceptions            -> (() -> Event ())            -- ^ the branch for cancellation-           -> ContCancellationSource-           -- ^ the cancellation source+           -> ContId+           -- ^ the computation identifier            -> Bool            -- ^ whether to support the exception handling from the beginning            -> Event ()-runCont (Cont m) cont econt ccont cancelSource catchFlag = +runCont (Cont m) cont econt ccont cid catchFlag =    m ContParams { contCont = cont,                  contAux  =                     ContParamsAux { contECont = econt,                                    contCCont = ccont,-                                   contCancelSource = cancelSource,-                                   contCancelFlag = contCancellationActivated cancelSource, +                                   contId = cid,+                                   contCancelFlag = contCancellationActivated cid,                                     contCatchFlag  = catchFlag } }  -- | Lift the 'Parameter' computation.@@ -440,10 +516,10 @@ -- Here word @parallel@ literally means that the computations are -- actually executed on a single operating system thread but -- they are processed simultaneously by the event queue.-contParallel :: [(Cont a, ContCancellationSource)]+contParallel :: [(Cont a, ContId)]                 -- ^ the list of:                 -- the nested computation,-                -- the cancellation source+                -- the computation identifier                 -> Cont [a] contParallel xs =   Cont $ \c ->@@ -454,7 +530,7 @@               counter   <- newIORef 0               catchRef  <- newIORef Nothing               hs <- invokeEvent p $-                    contCancellationBind (contCancelSource $ contAux c) $+                    contCancellationBind (contId $ contAux c) $                     map snd xs               let propagate =                     Event $ \p ->@@ -489,9 +565,9 @@                     do modifyIORef counter (+ 1)                        -- the main computation was automatically canceled                        invokeEvent p propagate-              forM_ (zip [1..n] xs) $ \(i, (x, cancelSource)) ->+              forM_ (zip [1..n] xs) $ \(i, (x, cid)) ->                 invokeEvent p $-                runCont x (cont i) econt ccont cancelSource (contCatchFlag $ contAux c)+                runCont x (cont i) econt ccont cid (contCatchFlag $ contAux c)      z <- contCanceled c      if z        then cancelCont p c@@ -502,10 +578,10 @@ -- | A partial case of 'contParallel' when we are not interested in -- the results but we are interested in the actions to be peformed by -- the nested computations.-contParallel_ :: [(Cont a, ContCancellationSource)]+contParallel_ :: [(Cont a, ContId)]                  -- ^ the list of:                  -- the nested computation,-                 -- the cancellation source+                 -- the computation identifier                  -> Cont () contParallel_ xs =   Cont $ \c ->@@ -515,7 +591,7 @@            do counter   <- newIORef 0               catchRef  <- newIORef Nothing               hs <- invokeEvent p $-                    contCancellationBind (contCancelSource $ contAux c) $+                    contCancellationBind (contId $ contAux c) $                     map snd xs               let propagate =                     Event $ \p ->@@ -549,9 +625,9 @@                     do modifyIORef counter (+ 1)                        -- the main computation was automatically canceled                        invokeEvent p propagate-              forM_ (zip [1..n] xs) $ \(i, (x, cancelSource)) ->+              forM_ (zip [1..n] xs) $ \(i, (x, cid)) ->                 invokeEvent p $-                runCont x (cont i) econt ccont cancelSource (contCatchFlag $ contAux c)+                runCont x (cont i) econt ccont cid (contCatchFlag $ contAux c)      z <- contCanceled c      if z        then cancelCont p c@@ -559,14 +635,14 @@             then invokeEvent p $ contCont c ()             else worker --- | Rerun the 'Cont' computation with the specified cancellation source.-rerunCont :: Cont a -> ContCancellationSource -> Cont a-rerunCont x cancelSource =+-- | Rerun the 'Cont' computation with the specified identifier.+rerunCont :: Cont a -> ContId -> Cont a+rerunCont x cid =   Cont $ \c ->   Event $ \p ->   do let worker =            do hs <- invokeEvent p $-                    contCancellationBind (contCancelSource $ contAux c) [cancelSource]+                    contCancellationBind (contId $ contAux c) [cid]               let cont a  =                     Event $ \p ->                     do invokeEvent p $ disposeEvent hs  -- unbind the cancellation source@@ -580,21 +656,21 @@                     do invokeEvent p $ disposeEvent hs  -- unbind the cancellation source                        cancelCont p c               invokeEvent p $-                runCont x cont econt ccont cancelSource (contCatchFlag $ contAux c)+                runCont x cont econt ccont cid (contCatchFlag $ contAux c)      z <- contCanceled c      if z        then cancelCont p c        else worker --- | Run the 'Cont' computation in parallel but connect the cancellation sources.-spawnCont :: ContCancellation -> Cont () -> ContCancellationSource -> Cont ()-spawnCont cancellation x cancelSource =+-- | Run the 'Cont' computation in parallel but connect the computations.+spawnCont :: ContCancellation -> Cont () -> ContId -> Cont ()+spawnCont cancellation x cid =   Cont $ \c ->   Event $ \p ->   do let worker =            do hs <- invokeEvent p $                     contCancellationConnect-                    (contCancelSource $ contAux c) cancellation cancelSource+                    (contId $ contAux c) cancellation cid               let cont a  =                     Event $ \p ->                     do invokeEvent p $ disposeEvent hs  -- unbind the cancellation source@@ -609,7 +685,7 @@                        -- do nothing and it will finish the computation               invokeEvent p $                 enqueueEvent (pointTime p) $-                runCont x cont econt ccont cancelSource False+                runCont x cont econt ccont cid False               invokeEvent p $                 resumeCont c ()      z <- contCanceled c@@ -617,21 +693,26 @@        then cancelCont p c        else worker +-- | Represents a temporarily frozen computation.+newtype FrozenCont a =+  FrozenCont { unfreezeCont :: Event (Maybe (ContParams a))+               -- ^ Unfreeze the computation.+             }+ -- | Freeze the computation parameters temporarily.-contFreeze :: ContParams a -> Event (Event (Maybe (ContParams a)))-contFreeze c =+freezeCont :: ContParams a -> Event (FrozenCont a)+freezeCont c =   Event $ \p ->   do rh <- newIORef Nothing      rc <- newIORef $ Just c      h <- invokeEvent p $           handleSignal (contCancellationInitiating $-                        contCancelSource $-                        contAux c) $ \a ->+                        contId $ contAux c) $ \e ->           Event $ \p ->           do h <- readIORef rh              case h of                Nothing ->-                 error "The handler was lost: contFreeze."+                 error "The handler was lost: freezeCont."                Just h ->                  do invokeEvent p $ disposeEvent h                     c <- readIORef rc@@ -646,18 +727,115 @@                                 when z $ cancelCont p c      writeIORef rh (Just h)      return $+       FrozenCont $        Event $ \p ->        do invokeEvent p $ disposeEvent h           c <- readIORef rc           writeIORef rc Nothing           return c-     ++-- | Freeze the computation parameters specifying what should be done when reentering the computation.+freezeContReentering :: ContParams a -> a -> Event () -> Event (FrozenCont a)+freezeContReentering c a m =+  Event $ \p ->+  do rh <- newIORef Nothing+     rc <- newIORef $ Just c+     h <- invokeEvent p $+          handleSignal (contCancellationInitiating $+                        contId $ contAux c) $ \e ->+          Event $ \p ->+          do h <- readIORef rh+             case h of+               Nothing ->+                 error "The handler was lost: freezeContReentering."+               Just h ->+                 do invokeEvent p $ disposeEvent h+                    c <- readIORef rc+                    case c of+                      Nothing -> return ()+                      Just c  ->+                        do writeIORef rc Nothing+                           invokeEvent p $+                             enqueueEvent (pointTime p) $+                             Event $ \p ->+                             do z <- contCanceled c+                                when z $ cancelCont p c+     writeIORef rh (Just h)+     return $+       FrozenCont $+       Event $ \p ->+       do invokeEvent p $ disposeEvent h+          c <- readIORef rc+          writeIORef rc Nothing+          case c of+            Nothing -> return Nothing+            z @ (Just c) ->+              do f <- invokeEvent p $+                      contPreemptionBegun $+                      contId $ contAux c+                 if not f+                   then return z+                   else do let c = c { contCont = \a -> m }+                           invokeEvent p $ sleepCont c a+                           return Nothing++-- | Reenter the computation parameters when needed.+reenterCont :: ContParams a -> a -> Event ()+{-# INLINE reenterCont #-}+reenterCont c a =+  Event $ \p ->+  do f <- invokeEvent p $+          contPreemptionBegun $+          contId $ contAux c+     if not f+       then invokeEvent p $+            enqueueEvent (pointTime p) $+            resumeCont c a+       else invokeEvent p $+            sleepCont c a++-- | Sleep until the preempted computation will be reentered.+sleepCont :: ContParams a -> a -> Event ()+{-# NOINLINE sleepCont #-}+sleepCont c a =+  Event $ \p ->+  do rh <- newIORef Nothing+     h  <- invokeEvent p $+           handleSignal (contSignal $+                         contId $ contAux c) $ \e ->+           Event $ \p ->+           do h <- readIORef rh+              case h of+                Nothing ->+                  error "The handler was lost: sleepCont."+                Just h ->+                  do invokeEvent p $ disposeEvent h+                     case e of+                       ContCancellationInitiating ->+                         invokeEvent p $+                         enqueueEvent (pointTime p) $+                         Event $ \p ->+                         do z <- contCanceled c+                            when z $ cancelCont p c+                       ContPreemptionEnding ->+                         invokeEvent p $+                         enqueueEvent (pointTime p) $+                         resumeCont c a+                       ContPreemptionBeginning ->+                         error "The computation was already preempted: sleepCont."+     writeIORef rh (Just h)++-- | Substitute the continuation.+substituteCont :: ContParams a -> (a -> Event ()) -> ContParams a+{-# INLINE substituteCont #-}+substituteCont c m = c { contCont = m }+ -- | Await the signal. contAwait :: Signal a -> Cont a contAwait signal =   Cont $ \c ->   Event $ \p ->-  do c <- invokeEvent p $ contFreeze c+  do c <- invokeEvent p $ freezeCont c      r <- newIORef Nothing      h <- invokeEvent p $           handleSignal signal $ @@ -668,11 +846,11 @@                              error "The signal was lost: contAwait."                            Just x ->                              do invokeEvent p $ disposeEvent x-                                c <- invokeEvent p c+                                c <- invokeEvent p $ unfreezeCont c                                 case c of                                   Nothing -> return ()                                   Just c  ->-                                    invokeEvent p $ resumeCont c a+                                    invokeEvent p $ reenterCont c a      writeIORef r $ Just h            -- | Show the debug message with the current simulation time.

@@ -61,6 +61,11 @@         whenCancellingProcess,         -- * Awaiting Signal         processAwait,+        -- * Preemption+        processPreemptionBegin,+        processPreemptionEnd,+        processPreemptionBeginning,+        processPreemptionEnding,         -- * Yield of Process         processYield,         -- * Process Timeout@@ -106,9 +111,10 @@ data ProcessId =    ProcessId { processStarted :: IORef Bool,               processReactCont     :: IORef (Maybe (ContParams ())), -              processCancelSource  :: ContCancellationSource,+              processContId  :: ContId,               processInterruptRef  :: IORef Bool, -              processInterruptCont :: IORef (Maybe (ContParams ())), +              processInterruptCont :: IORef (Maybe (ContParams ())),+              processInterruptTime :: IORef Double,               processInterruptVersion :: IORef Int }  -- | Specifies a discontinuous process that can suspend at any time@@ -138,11 +144,13 @@   do when (dt < 0) $        error "Time period dt < 0: holdProcess"      let x = processInterruptCont pid+         t = pointTime p + dt      writeIORef x $ Just c      writeIORef (processInterruptRef pid) False+     writeIORef (processInterruptTime pid) t      v <- readIORef (processInterruptVersion pid)      invokeEvent p $-       enqueueEvent (pointTime p + dt) $+       enqueueEvent t $        Event $ \p ->        do v' <- readIORef (processInterruptVersion pid)           when (v == v') $ @@ -170,6 +178,37 @@   Event $ \p ->   readIORef (processInterruptRef pid) +-- | Define a reaction when the process with the specified identifier is preempted.+processPreempted :: ProcessId -> Event ()+processPreempted pid =+  Event $ \p ->+  do let x = processInterruptCont pid+     a <- readIORef x+     case a of+       Just c ->+         do writeIORef x Nothing+            writeIORef (processInterruptRef pid) True+            modifyIORef (processInterruptVersion pid) $ (+) 1+            t <- readIORef (processInterruptTime pid)+            let dt = t - pointTime p+                c' = substituteCont c $ \a ->+                  Event $ \p ->+                  invokeEvent p $+                  invokeCont c $+                  invokeProcess pid $+                  holdProcess dt+            invokeEvent p $+              reenterCont c' ()+       Nothing ->+         do let x = processReactCont pid+            a <- readIORef x+            case a of+              Nothing ->+                return ()+              Just c ->+                do let c' = substituteCont c $ reenterCont c+                   writeIORef x $ Just c'+ -- | Passivate the process. passivateProcess :: Process () passivateProcess =@@ -213,11 +252,20 @@             "Another process with the specified identifier " ++             "has been started already: processIdPrepare"        else writeIORef (processStarted pid) True-     let signal = processCancelling pid+     let signal = contSignal $ processContId pid      invokeEvent p $-       handleSignal_ signal $ \_ ->-       do interruptProcess pid-          reactivateProcess pid+       handleSignal_ signal $ \e ->+       Event $ \p ->+       case e of+         ContCancellationInitiating ->+           do z <- contCancellationActivated $ processContId pid+              when z $+                do invokeEvent p $ interruptProcess pid+                   invokeEvent p $ reactivateProcess pid+         ContPreemptionBeginning ->+           invokeEvent p $ processPreempted pid+         ContPreemptionEnding ->+           return ()  -- | Run immediately the process. A new 'ProcessId' identifier will be -- assigned to the process.@@ -238,7 +286,7 @@ runProcessUsingId :: ProcessId -> Process () -> Event () runProcessUsingId pid p =   do processIdPrepare pid-     runCont m cont econt ccont (processCancelSource pid) False+     runCont m cont econt ccont (processContId pid) False        where cont  = return              econt = throwEvent              ccont = return@@ -288,20 +336,22 @@ newProcessId =   do x <- liftIO $ newIORef Nothing      y <- liftIO $ newIORef False-     c <- newContCancellationSource+     c <- newContId      i <- liftIO $ newIORef False      z <- liftIO $ newIORef Nothing+     t <- liftIO $ newIORef 0      v <- liftIO $ newIORef 0      return ProcessId { processStarted = y,                         processReactCont     = x, -                        processCancelSource  = c, +                        processContId  = c,                          processInterruptRef  = i,-                        processInterruptCont = z, +                        processInterruptCont = z,+                        processInterruptTime = t,                         processInterruptVersion = v }  -- | Cancel a process with the specified identifier, interrupting it if needed. cancelProcessWithId :: ProcessId -> Event ()-cancelProcessWithId pid = contCancellationInitiate (processCancelSource pid)+cancelProcessWithId pid = contCancellationInitiate (processContId pid)  -- | The process cancels itself. cancelProcess :: Process a@@ -313,12 +363,12 @@  -- | Test whether the process with the specified identifier was cancelled. processCancelled :: ProcessId -> Event Bool-processCancelled pid = contCancellationInitiated (processCancelSource pid)+processCancelled pid = contCancellationInitiated (processContId pid)  -- | Return a signal that notifies about cancelling the process with  -- the specified identifier. processCancelling :: ProcessId -> Signal ()-processCancelling pid = contCancellationInitiating (processCancelSource pid)+processCancelling pid = contCancellationInitiating (processContId pid)  -- | Register a handler that will be invoked in case of cancelling the current process. whenCancellingProcess :: Event () -> Process ()@@ -327,6 +377,22 @@   liftEvent $   handleSignal_ (processCancelling pid) $ \() -> h +-- | Preempt a process with the specified identifier.+processPreemptionBegin :: ProcessId -> Event ()+processPreemptionBegin pid = contPreemptionBegin (processContId pid)++-- | Proceed with the process with the specified identifier after it was preempted with help of 'preemptProcessBegin'.+processPreemptionEnd :: ProcessId -> Event ()+processPreemptionEnd pid = contPreemptionEnd (processContId pid)++-- | Return a signal when the process is preempted.+processPreemptionBeginning :: ProcessId -> Signal ()+processPreemptionBeginning pid = contPreemptionBeginning (processContId pid)++-- | Return a signal when the process is proceeded after it was preempted earlier.+processPreemptionEnding :: ProcessId -> Signal ()+processPreemptionEnding pid = contPreemptionEnding (processContId pid)+ instance Eq ProcessId where   x == y = processReactCont x == processReactCont y    -- for the references are unique @@ -435,7 +501,7 @@   do liftEvent $ processParallelPrepare xs      contParallel $        flip map xs $ \(pid, m) ->-       (invokeProcess pid m, processCancelSource pid)+       (invokeProcess pid m, processContId pid)  -- | Like 'processParallel' but ignores the result. processParallel_ :: [Process a] -> Process ()@@ -449,7 +515,7 @@   do liftEvent $ processParallelPrepare xs      contParallel_ $        flip map xs $ \(pid, m) ->-       (invokeProcess pid m, processCancelSource pid)+       (invokeProcess pid m, processContId pid)  -- | Create the new process identifiers. processParallelCreateIds :: [Process a] -> Simulation [(ProcessId, Process a)]@@ -475,7 +541,7 @@ processUsingId pid x =   Process $ \pid' ->   do liftEvent $ processIdPrepare pid-     rerunCont (invokeProcess pid x) (processCancelSource pid)+     rerunCont (invokeProcess pid x) (processContId pid)  -- | Spawn the child process. In case of cancelling one of the processes, -- other process will be cancelled too.@@ -501,7 +567,7 @@ spawnProcessUsingIdWith cancellation pid x =   Process $ \pid' ->   do liftEvent $ processIdPrepare pid-     spawnCont cancellation (invokeProcess pid x) (processCancelSource pid)+     spawnCont cancellation (invokeProcess pid x) (processContId pid)  -- | Await the signal. processAwait :: Signal a -> Process a

@@ -34,6 +34,7 @@         emptyNet,         arrNet,         accumNet,+        withinNet,         -- * Specifying Identifier         netUsingId,         -- * Arrival Net@@ -168,7 +169,13 @@ accumNet f acc =   Net $ \a ->   do (acc', b) <- f acc a-     return (b, accumNet f acc') +     return (b, accumNet f acc')++-- | Involve the computation with side effect when processing the input.+withinNet :: Process () -> Net a a+withinNet m =+  Net $ \a ->+  do { m; return (a, withinNet m) }  -- | Create a net that will use the specified process identifier. -- It can be useful to refer to the underlying 'Process' computation which

@@ -0,0 +1,103 @@++-- |+-- Module     : Simulation.Aivika.Net.Random+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines some useful random network computations that+-- hold the current process for the corresponding time interval,+-- when processing every input element.+--++module Simulation.Aivika.Net.Random+       (randomUniformNet,+        randomUniformIntNet,+        randomNormalNet,+        randomExponentialNet,+        randomErlangNet,+        randomPoissonNet,+        randomBinomialNet) where++import Simulation.Aivika.Process+import Simulation.Aivika.Process.Random+import Simulation.Aivika.Net++-- | When processing every input element, hold the process+-- for a random time interval distributed uniformly.+randomUniformNet :: Double+                    -- ^ the minimum time interval+                    -> Double+                    -- ^ the maximum time interval+                    -> Net a a+randomUniformNet min max =+  withinNet $+  randomUniformProcess_ min max++-- | When processing every input element, hold the process+-- for a random time interval distributed uniformly.+randomUniformIntNet :: Int+                       -- ^ the minimum time interval+                       -> Int+                       -- ^ the maximum time interval+                       -> Net a a+randomUniformIntNet min max =+  withinNet $+  randomUniformIntProcess_ min max++-- | When processing every input element, hold the process+-- for a random time interval distributed normally.+randomNormalNet :: Double+                   -- ^ the mean time interval+                   -> Double+                   -- ^ the time interval deviation+                   -> Net a a+randomNormalNet mu nu =+  withinNet $+  randomNormalProcess_ 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 :: Double+                        -- ^ the mean time interval (the reciprocal of the rate)+                        -> Net a a+randomExponentialNet mu =+  withinNet $+  randomExponentialProcess_ mu+         +-- | When processing every input element, hold the process+-- for a random time interval having the Erlang distribution with+-- the specified scale (the reciprocal of the rate) and shape parameters.+randomErlangNet :: Double+                   -- ^ the scale (the reciprocal of the rate)+                   -> Int+                   -- ^ the shape+                   -> Net a a+randomErlangNet beta m =+  withinNet $+  randomErlangProcess_ beta m++-- | When processing every input element, hold the process+-- for a random time interval having the Poisson distribution+-- with the specified mean.+randomPoissonNet :: Double+                    -- ^ the mean time interval+                    -> Net a a+randomPoissonNet mu =+  withinNet $+  randomPoissonProcess_ mu++-- | When processing every input element, hold the process+-- for a random time interval having the binomial distribution+-- with the specified probability and trials.+randomBinomialNet :: Double+                     -- ^ the probability+                     -> Int+                     -- ^ the number of trials+                     -> Net a a+randomBinomialNet prob trials =+  withinNet $+  randomBinomialProcess_ prob trials

@@ -16,7 +16,9 @@         newQueue,          enqueue,          dequeue, -        queueFront) where +        queueFront,+        remove,+        removeBy) where   import Data.Array import Data.Array.MArray.Safe@@ -149,7 +151,8 @@      -- v0 <- readArray vals size      writeArray keys i k0      writeArray vals i v0-     siftDown keys vals i 0 k v+     when (i > 0) $+       siftDown keys vals i 0 k v  -- | Return the element with the minimal priority. queueFront :: PriorityQueue a -> IO (Double, a)@@ -161,3 +164,50 @@      k <- readArray keys 0      v <- readArray vals 0      return (k, v)++-- | Remove the specified element from the queue and return a computation of the flag+-- indicating whether the element was actually removed.+--+-- Note that unlike other functions it has complexity O(n).+remove :: Eq a => PriorityQueue a -> a -> IO Bool+remove pq a = removeBy pq (== a)++-- | Remove an element satisfying the predicate and return a computation of the flag+-- indicating whether the element was actually removed.+--+-- Note that unlike other functions it has complexity O(n).+removeBy :: PriorityQueue a -> (a -> Bool) -> IO Bool+removeBy pq pred =+  do index <- indexBy pq pred+     if index < 0+       then return False+       else do size <- readIORef (pqSize pq)+               when (size == 0) $+                 error "Internal error in the priority queue implementation: removeBy"+               let i = size - 1+               writeIORef (pqSize pq) i+               keys <- readIORef (pqKeys pq)+               vals <- readIORef (pqVals pq)+               k <- readArray keys i+               v <- readArray vals i+               let k0 = 0.0+                   v0 = undefined+               writeArray keys i k0+               writeArray vals i v0+               when (i > 0) $+                 siftDown keys vals i index k v+               return True+     +-- | Return the index of the item satisfying the predicate or -1.     +indexBy :: PriorityQueue a -> (a -> Bool) -> IO Int+indexBy pq pred =+  do size <- readIORef (pqSize pq)+     vals <- readIORef (pqVals pq)+     let loop index =+           if index >= size+           then return (-1)+           else do x <- readArray vals index+                   if pred x+                     then return index+                     else loop $ index + 1+     loop 0

@@ -58,6 +58,9 @@         whenCancellingProcess,         -- * Awaiting Signal         processAwait,+        -- * Preemption+        processPreemptionBeginning,+        processPreemptionEnding,         -- * Yield of Process         processYield,         -- * Process Timeout

@@ -0,0 +1,199 @@++-- |+-- Module     : Simulation.Aivika.Process.Random+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines helper functions, which are useful to hold +-- the 'Process' computation for a time interval according to some+-- random distribution.+--++module Simulation.Aivika.Process.Random+       (randomUniformProcess,+        randomUniformProcess_,+        randomUniformIntProcess,+        randomUniformIntProcess_,+        randomNormalProcess,+        randomNormalProcess_,+        randomExponentialProcess,+        randomExponentialProcess_,+        randomErlangProcess,+        randomErlangProcess_,+        randomPoissonProcess,+        randomPoissonProcess_,+        randomBinomialProcess,+        randomBinomialProcess_) where++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Parameter+import Simulation.Aivika.Parameter.Random+import Simulation.Aivika.Process++-- | Hold the process for a random time interval distributed uniformly.+randomUniformProcess :: Double+                        -- ^ the minimum time interval+                        -> Double+                        -- ^ the maximum time interval+                        -> Process Double+                        -- ^ a computation of the time interval+                        -- for which the process was actually held+randomUniformProcess min max =+  do t <- liftParameter $ randomUniform min max+     holdProcess t+     return t++-- | Hold the process for a random time interval distributed uniformly.+randomUniformProcess_ :: Double+                         -- ^ the minimum time interval+                         -> Double+                         -- ^ the maximum time interval+                         -> Process ()+randomUniformProcess_ min max =+  do t <- liftParameter $ randomUniform min max+     holdProcess t++-- | Hold the process for a random time interval distributed uniformly.+randomUniformIntProcess :: Int+                           -- ^ the minimum time interval+                           -> Int+                           -- ^ the maximum time interval+                           -> Process Int+                           -- ^ a computation of the time interval+                           -- for which the process was actually held+randomUniformIntProcess min max =+  do t <- liftParameter $ randomUniformInt min max+     holdProcess $ fromIntegral t+     return t++-- | Hold the process for a random time interval distributed uniformly.+randomUniformIntProcess_ :: Int+                            -- ^ the minimum time interval+                            -> Int+                            -- ^ the maximum time interval+                            -> Process ()+randomUniformIntProcess_ min max =+  do t <- liftParameter $ randomUniformInt min max+     holdProcess $ fromIntegral t++-- | Hold the process for a random time interval distributed normally.+randomNormalProcess :: Double+                       -- ^ the mean time interval+                       -> Double+                       -- ^ the time interval deviation+                       -> Process Double+                       -- ^ a computation of the time interval+                       -- for which the process was actually held+randomNormalProcess mu nu =+  do t <- liftParameter $ randomNormal mu nu+     when (t > 0) $+       holdProcess t+     return t+         +-- | Hold the process for a random time interval distributed normally.+randomNormalProcess_ :: Double+                        -- ^ the mean time interval+                        -> Double+                        -- ^ the time interval deviation+                        -> Process ()+randomNormalProcess_ mu nu =+  do t <- liftParameter $ randomNormal mu nu+     when (t > 0) $+       holdProcess t+         +-- | Hold the process for a random time interval distributed exponentially+-- with the specified mean (the reciprocal of the rate).+randomExponentialProcess :: Double+                            -- ^ the mean time interval (the reciprocal of the rate)+                            -> Process Double+                            -- ^ a computation of the time interval+                            -- for which the process was actually held+randomExponentialProcess mu =+  do t <- liftParameter $ randomExponential mu+     holdProcess t+     return t+         +-- | Hold the process for a random time interval distributed exponentially+-- with the specified mean (the reciprocal of the rate).+randomExponentialProcess_ :: Double+                             -- ^ the mean time interval (the reciprocal of the rate)+                             -> Process ()+randomExponentialProcess_ mu =+  do t <- liftParameter $ randomExponential mu+     holdProcess t+         +-- | Hold the process for a random time interval having the Erlang distribution with+-- the specified scale (the reciprocal of the rate) and shape parameters.+randomErlangProcess :: Double+                       -- ^ the scale (the reciprocal of the rate)+                       -> Int+                       -- ^ the shape+                       -> Process Double+                       -- ^ a computation of the time interval+                       -- for which the process was actually held+randomErlangProcess beta m =+  do t <- liftParameter $ randomErlang beta m+     holdProcess t+     return t++-- | Hold the process for a random time interval having the Erlang distribution with+-- the specified scale (the reciprocal of the rate) and shape parameters.+randomErlangProcess_ :: Double+                        -- ^ the scale (the reciprocal of the rate)+                        -> Int+                        -- ^ the shape+                        -> Process ()+randomErlangProcess_ beta m =+  do t <- liftParameter $ randomErlang beta m+     holdProcess t++-- | Hold the process for a random time interval having the Poisson distribution with+-- the specified mean.+randomPoissonProcess :: Double+                        -- ^ the mean time interval+                        -> Process Int+                        -- ^ a computation of the time interval+                        -- for which the process was actually held+randomPoissonProcess mu =+  do t <- liftParameter $ randomPoisson mu+     holdProcess $ fromIntegral t+     return t++-- | Hold the process for a random time interval having the Poisson distribution with+-- the specified mean.+randomPoissonProcess_ :: Double+                         -- ^ the mean time interval+                         -> Process ()+randomPoissonProcess_ mu =+  do t <- liftParameter $ randomPoisson mu+     holdProcess $ fromIntegral t++-- | Hold the process for a random time interval having the binomial distribution+-- with the specified probability and trials.+randomBinomialProcess :: Double+                         -- ^ the probability+                         -> Int+                         -- ^ the number of trials+                         -> Process Int+                         -- ^ a computation of the time interval+                         -- for which the process was actually held+randomBinomialProcess prob trials =+  do t <- liftParameter $ randomBinomial prob trials+     holdProcess $ fromIntegral t+     return t++-- | Hold the process for a random time interval having the binomial distribution+-- with the specified probability and trials.+randomBinomialProcess_ :: Double+                         -- ^ the probability+                         -> Int+                         -- ^ the number of trials+                         -> Process ()+randomBinomialProcess_ prob trials =+  do t <- liftParameter $ randomBinomial prob trials+     holdProcess $ fromIntegral t

@@ -16,6 +16,7 @@         emptyProcessor,         arrProcessor,         accumProcessor,+        withinProcessor,         -- * Specifying Identifier         processorUsingId,         -- * Prefetch and Delay Processors@@ -146,6 +147,13 @@       do (a, xs') <- runStream xs          (acc', b) <- f acc a          return (b, Cons $ loop xs' acc') ++-- | Involve the computation with side effect when processing a stream of data.+withinProcessor :: Process () -> Processor a a+withinProcessor m =+  Processor $+  mapStreamM $ \a ->+  do { m; return a }  -- | Create a processor that will use the specified process identifier. -- It can be useful to refer to the underlying 'Process' computation which

@@ -0,0 +1,103 @@++-- |+-- Module     : Simulation.Aivika.Processor.Random+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines some useful random processors that+-- hold the current process for the corresponding time interval,+-- when processing every input element.+--++module Simulation.Aivika.Processor.Random+       (randomUniformProcessor,+        randomUniformIntProcessor,+        randomNormalProcessor,+        randomExponentialProcessor,+        randomErlangProcessor,+        randomPoissonProcessor,+        randomBinomialProcessor) where++import Simulation.Aivika.Process+import Simulation.Aivika.Process.Random+import Simulation.Aivika.Processor++-- | When processing every input element, hold the process+-- for a random time interval distributed uniformly.+randomUniformProcessor :: Double+                          -- ^ the minimum time interval+                          -> Double+                          -- ^ the maximum time interval+                          -> Processor a a+randomUniformProcessor min max =+  withinProcessor $+  randomUniformProcess_ min max++-- | When processing every input element, hold the process+-- for a random time interval distributed uniformly.+randomUniformIntProcessor :: Int+                             -- ^ the minimum time interval+                             -> Int+                             -- ^ the maximum time interval+                             -> Processor a a+randomUniformIntProcessor min max =+  withinProcessor $+  randomUniformIntProcess_ min max++-- | When processing every input element, hold the process+-- for a random time interval distributed normally.+randomNormalProcessor :: Double+                         -- ^ the mean time interval+                         -> Double+                         -- ^ the time interval deviation+                         -> Processor a a+randomNormalProcessor mu nu =+  withinProcessor $+  randomNormalProcess_ 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 :: Double+                              -- ^ the mean time interval (the reciprocal of the rate)+                              -> Processor a a+randomExponentialProcessor mu =+  withinProcessor $+  randomExponentialProcess_ mu+         +-- | When processing every input element, hold the process+-- for a random time interval having the Erlang distribution with+-- the specified scale (the reciprocal of the rate) and shape parameters.+randomErlangProcessor :: Double+                         -- ^ the scale (the reciprocal of the rate)+                         -> Int+                         -- ^ the shape+                         -> Processor a a+randomErlangProcessor beta m =+  withinProcessor $+  randomErlangProcess_ beta m++-- | When processing every input element, hold the process+-- for a random time interval having the Poisson distribution+-- with the specified mean.+randomPoissonProcessor :: Double+                          -- ^ the mean time interval+                          -> Processor a a+randomPoissonProcessor mu =+  withinProcessor $+  randomPoissonProcess_ mu++-- | When processing every input element, hold the process+-- for a random time interval having the binomial distribution+-- with the specified probability and trials.+randomBinomialProcessor :: Double+                           -- ^ the probability+                           -> Int+                           -- ^ the number of trials+                           -> Processor a a+randomBinomialProcessor prob trials =+  withinProcessor $+  randomBinomialProcess_ prob trials

@@ -42,7 +42,9 @@         releaseResource,         releaseResourceWithinEvent,         usingResource,-        usingResourceWithPriority) where+        usingResourceWithPriority,+        -- * Altering Resource+        incResourceCount) where  import Data.IORef import Control.Monad@@ -80,7 +82,7 @@              -- ^ Return the maximum count of the resource, where 'Nothing'              -- means that the resource has no upper bound.              resourceCountRef :: IORef Int, -             resourceWaitList :: StrategyQueue s (Event (Maybe (ContParams ()))) }+             resourceWaitList :: StrategyQueue s (FrozenCont ()) }  instance Eq (Resource s) where   x == y = resourceCountRef x == resourceCountRef y  -- unique references@@ -218,7 +220,11 @@   Event $ \p ->   do a <- readIORef (resourceCountRef r)      if a == 0 -       then do c <- invokeEvent p $ contFreeze c+       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@@ -240,7 +246,11 @@   Event $ \p ->   do a <- readIORef (resourceCountRef r)      if a == 0 -       then do c <- invokeEvent p $ contFreeze c+       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@@ -283,7 +293,7 @@        then a' `seq` writeIORef (resourceCountRef r) a'        else do c <- invokeEvent p $                     strategyDequeue (resourceWaitList r)-               c <- invokeEvent p c+               c <- invokeEvent p $ unfreezeCont c                case c of                  Nothing ->                    invokeEvent p $ releaseResourceWithinEvent r@@ -333,3 +343,19 @@ 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 :: DequeueStrategy s+                    => Resource s+                    -- ^ the resource+                    -> Int+                    -- ^ the increment for the resource count+                    -> Event ()+incResourceCount r n+  | n < 0     = error "The increment cannot be negative: incResourceCount"+  | n == 0    = return ()+  | otherwise =+    do releaseResourceWithinEvent r+       incResourceCount r (n - 1)+

@@ -0,0 +1,308 @@++-- |+-- Module     : Simulation.Aivika.Resource.Preemption+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines the preemptible resource.+--+module Simulation.Aivika.Resource.Preemption+       (-- * Resource Type+        Resource,+        -- * Creating Resource+        newResource,+        newResourceWithMaxCount,+        -- * Resource Properties+        resourceMaxCount,+        resourceCount,+        -- * Requesting for and Releasing Resource+        requestResourceWithPriority,+        releaseResource,+        usingResourceWithPriority,+        -- * Altering Resource +        incResourceCount,+        decResourceCount,+        alterResourceCount) where++import Data.IORef++import Control.Monad+import Control.Monad.Trans+import Control.Exception++import Simulation.Aivika.Internal.Specs+import Simulation.Aivika.Internal.Simulation+import Simulation.Aivika.Internal.Event+import Simulation.Aivika.Internal.Cont+import Simulation.Aivika.Internal.Process+import Simulation.Aivika.QueueStrategy++import qualified Simulation.Aivika.PriorityQueue as PQ++-- | Represents a preemptible resource.+data Resource = +  Resource { resourceMaxCount :: Maybe Int,+             -- ^ Return the maximum count of the resource, where 'Nothing'+             -- means that the resource has no upper bound.+             resourceCountRef :: IORef Int,+             resourceActingQueue :: PQ.PriorityQueue ResourceActingItem,+             resourceWaitQueue :: PQ.PriorityQueue ResourceAwaitingItem }++-- | Identifies an acting item that acquired the resource.+data ResourceActingItem =+  ResourceActingItem { actingItemPriority :: Double,+                       actingItemId :: ProcessId }++-- | Idenitifies an awaiting item that waits for releasing of the resource to take it.+type ResourceAwaitingItem = Either ResourceRequestingItem ResourcePreemptedItem++-- | Idenitifies an item that requests for the resource.+data ResourceRequestingItem =+  ResourceRequestingItem { requestingItemPriority :: Double,+                           requestingItemId :: ProcessId,+                           requestingItemCont :: FrozenCont () }++-- | Idenitifies an item that was preempted.+data ResourcePreemptedItem =+  ResourcePreemptedItem { preemptedItemPriority :: Double,+                          preemptedItemId :: ProcessId }++instance Eq Resource where+  x == y = resourceCountRef x == resourceCountRef y  -- unique references++instance Eq ResourceActingItem where+  x == y = actingItemId x == actingItemId y++-- | 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 Resource+newResource count =+  Simulation $ \r ->+  do when (count < 0) $+       error $+       "The resource count cannot be negative: " +++       "newResource."+     countRef <- newIORef count+     actingQueue <- PQ.newQueue+     waitQueue <- PQ.newQueue+     return Resource { resourceMaxCount = Just count,+                       resourceCountRef = countRef,+                       resourceActingQueue = actingQueue,+                       resourceWaitQueue = waitQueue }++-- | 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 Resource+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 <- newIORef count+     actingQueue <- PQ.newQueue+     waitQueue <- PQ.newQueue+     return Resource { resourceMaxCount = maxCount,+                       resourceCountRef = countRef,+                       resourceActingQueue = actingQueue,+                       resourceWaitQueue = waitQueue }++-- | Return the current count of the resource.+resourceCount :: Resource -> Event Int+resourceCount r =+  Event $ \p -> readIORef (resourceCountRef r)++-- | 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+                               -- ^ the requested resource+                               -> Double+                               -- ^ the priority (the less value has a higher priority)+                               -> Process ()+requestResourceWithPriority r priority =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do a <- readIORef (resourceCountRef r)+     if a == 0+       then do f <- PQ.queueNull (resourceActingQueue r)+               if f+                 then do c <- invokeEvent p $+                              freezeContReentering c () $+                              invokeCont c $+                              invokeProcess pid $+                              requestResourceWithPriority r priority+                         PQ.enqueue (resourceWaitQueue r) priority (Left $ ResourceRequestingItem priority pid c)+                 else do (p0', item0) <- PQ.queueFront (resourceActingQueue r)+                         let p0 = - p0'+                             pid0 = actingItemId item0+                         if priority < p0+                           then do PQ.dequeue (resourceActingQueue r)+                                   PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid+                                   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+                                   PQ.enqueue (resourceWaitQueue r) priority (Left $ ResourceRequestingItem priority pid c)+       else do let a' = a - 1+               a' `seq` writeIORef (resourceCountRef r) a'+               PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid+               invokeEvent p $ resumeCont c ()++-- | Release the resource increasing its count and resuming one of the+-- previously suspended or preempted processes as possible.+releaseResource :: Resource+                   -- ^ the resource to release+                   -> Process ()+releaseResource r = +  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do f <- PQ.removeBy (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"++-- | Release the resource increasing its count and resuming one of the+-- previously suspended or preempted processes as possible.+releaseResource' :: Resource+                    -- ^ the resource to release+                    -> Event ()+releaseResource' r =+  Event $ \p ->+  do a <- 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: releaseResourceWithinEvent."+       _ ->+         return ()+     f <- PQ.queueNull (resourceWaitQueue r)+     if f +       then a' `seq` writeIORef (resourceCountRef r) a'+       else do (priority', item) <- PQ.queueFront (resourceWaitQueue r)+               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 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 PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid+                             invokeEvent p $ processPreemptionEnd pid+               +-- | 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+                             -- ^ 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 a+                             -- ^ the action we are going to apply having the resource+                             -> Process a+                             -- ^ the result of the action+usingResourceWithPriority r priority m =+  do requestResourceWithPriority r priority+     finallyProcess m $ releaseResource r++-- | Preempt a process with the lowest priority that acquires yet the resource+-- and decrease the count of available resource by 1. +decResourceCount' :: Resource -> Event ()+decResourceCount' r =+  Event $ \p ->+  do a <- readIORef (resourceCountRef r)+     when (a == 0) $+       error $+       "The resource exceeded and its count is zero: decResourceCount'"+     f <- PQ.queueNull (resourceActingQueue r)+     when f $+       error $+       "The resource acting queue is null: decResourceCount'"+     (p0', item0) <- PQ.queueFront (resourceActingQueue r)+     let p0 = - p0'+         pid0 = actingItemId item0+     PQ.dequeue (resourceActingQueue r)+     PQ.enqueue (resourceWaitQueue r) p0 (Right $ ResourcePreemptedItem p0 pid0)+     invokeEvent p $ processPreemptionEnd pid0+     let a' = a - 1+     a' `seq` writeIORef (resourceCountRef r) a'++-- | Increase the count of available resource by the specified number,+-- invoking the awaiting and preempted processes according to their priorities+-- as needed.+incResourceCount :: Resource+                    -- ^ the resource+                    -> Int+                    -- ^ the increment for the resource count+                    -> Event ()+incResourceCount r n+  | n < 0     = error "The increment cannot be negative: incResourceCount"+  | n == 0    = return ()+  | otherwise =+    do releaseResource' r+       incResourceCount r (n - 1)++-- | Decrease the count of available resource by the specified number,+-- preempting the processes according to their priorities as needed.+decResourceCount :: Resource+                    -- ^ the resource+                    -> Int+                    -- ^ the decrement for the resource count+                    -> Event ()+decResourceCount r n+  | n < 0     = error "The decrement cannot be negative: decResourceCount"+  | n == 0    = return ()+  | otherwise =+    do decResourceCount' r+       decResourceCount r (n - 1)++-- | Alter the resource count either increasing or decreasing it by calling+-- 'incResourceCount' or 'decResourceCount' respectively. +alterResourceCount :: Resource+                      -- ^ the resource+                      -> Int+                      -- ^ a change of the resource count+                      -> Event ()+alterResourceCount r n+  | n < 0  = decResourceCount r (- n)+  | n > 0  = incResourceCount r n+  | n == 0 = return ()

@@ -1651,12 +1651,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 :: ResultContainer (Server s a b)@@ -1674,9 +1677,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 :: (Show s, ResultItemable (ResultValue s))@@ -1696,10 +1701,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 :: ResultContainer (Activity s a b)@@ -1716,8 +1724,10 @@     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 an arbitrary text as a separator source. textResultSource :: String -> ResultSource

@@ -173,18 +173,24 @@                 -- ^ Property 'serverTotalProcessingTime'.               | ServerTotalOutputWaitTimeId                 -- ^ Property 'serverTotalOutputWaitTime'.+              | ServerTotalPreemptionTimeId+                -- ^ Property 'serverTotalPreemptionTime'.               | ServerInputWaitTimeId                 -- ^ Property 'serverInputWaitTime'.               | ServerProcessingTimeId                 -- ^ Property 'serverProcessingTime'.               | ServerOutputWaitTimeId                 -- ^ Property 'serverOutputWaitTime'.+              | ServerPreemptionTimeId+                -- ^ Property 'serverPreemptionTime'.               | ServerInputWaitFactorId                 -- ^ Property 'serverInputWaitFactor'.               | ServerProcessingFactorId                 -- ^ Property 'serverProcessingFactor'.               | ServerOutputWaitFactorId                 -- ^ Property 'serverOutputWaitFactor'.+              | ServerPreemptionFactorId+                -- ^ Property 'serverPreemptionFactor'.               | ActivityId                 -- ^ Represents an 'Activity'.               | ActivityInitStateId@@ -195,14 +201,20 @@                 -- ^ 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'.               | UserDefinedResultId ResultDescription                 -- ^ An user defined description.               | LocalisedResultId (M.Map ResultLocale ResultDescription)@@ -282,21 +294,27 @@ 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 (UserDefinedResultId m) = m russianResultLocalisation x@(LocalisedResultId m) =   lookupResultLocalisation russianResultLocale x@@ -366,21 +384,27 @@ 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 ActivityPreemptionTimeId = "the preemption time" englishResultLocalisation ActivityUtilisationFactorId = "the relative utilisation time (от 0 до 1)" englishResultLocalisation ActivityIdleFactorId = "the relative idle time (от 0 до 1)"+englishResultLocalisation ActivityPreemptionFactorId = "the relative preemption time (от 0 до 1)" englishResultLocalisation (UserDefinedResultId m) = m englishResultLocalisation x@(LocalisedResultId m) =   lookupResultLocalisation englishResultLocale x

@@ -11,11 +11,10 @@ module Simulation.Aivika.Server        (-- * Server         Server,-        ServerInterruption(..),         newServer,         newStateServer,-        newInterruptibleServer,-        newInterruptibleStateServer,+        newPreemptibleServer,+        newPreemptibleStateServer,         -- * Processing         serverProcessor,         -- * Server Properties and Activities@@ -24,12 +23,15 @@         serverTotalInputWaitTime,         serverTotalProcessingTime,         serverTotalOutputWaitTime,+        serverTotalPreemptionTime,         serverInputWaitTime,         serverProcessingTime,         serverOutputWaitTime,+        serverPreemptionTime,         serverInputWaitFactor,         serverProcessingFactor,         serverOutputWaitFactor,+        serverPreemptionFactor,         -- * Summary         serverSummary,         -- * Derived Signals for Properties@@ -41,21 +43,28 @@         serverTotalProcessingTimeChanged_,         serverTotalOutputWaitTimeChanged,         serverTotalOutputWaitTimeChanged_,+        serverTotalPreemptionTimeChanged,+        serverTotalPreemptionTimeChanged_,         serverInputWaitTimeChanged,         serverInputWaitTimeChanged_,         serverProcessingTimeChanged,         serverProcessingTimeChanged_,         serverOutputWaitTimeChanged,         serverOutputWaitTimeChanged_,+        serverPreemptionTimeChanged,+        serverPreemptionTimeChanged_,         serverInputWaitFactorChanged,         serverInputWaitFactorChanged_,         serverProcessingFactorChanged,         serverProcessingFactorChanged_,         serverOutputWaitFactorChanged,         serverOutputWaitFactorChanged_,+        serverPreemptionFactorChanged,+        serverPreemptionFactorChanged_,         -- * Basic Signals         serverInputReceived,-        serverTaskInterrupted,+        serverTaskPreempting,+        serverTaskReentering,         serverTaskProcessed,         serverOutputProvided,         -- * Overall Signal@@ -87,24 +96,30 @@            -- ^ The current state of the server.            serverProcess :: s -> a -> Process (s, b),            -- ^ Provide @b@ by specified @a@.-           serverProcessInterruptible :: Bool,-           -- ^ Whether the process is interruptible.+           serverProcessPreemptible :: Bool,+           -- ^ Whether the process can be preempted.            serverTotalInputWaitTimeRef :: IORef Double,            -- ^ The counted total time spent in awating the input.            serverTotalProcessingTimeRef :: IORef Double,            -- ^ The counted total time spent to process the input and prepare the output.            serverTotalOutputWaitTimeRef :: IORef Double,            -- ^ The counted total time spent for delivering the output.+           serverTotalPreemptionTimeRef :: IORef Double,+           -- ^ The counted total time spent being preempted and waiting for the proceeding.             serverInputWaitTimeRef :: IORef (SamplingStats Double),            -- ^ The statistics for the time spent in awaiting the input.            serverProcessingTimeRef :: IORef (SamplingStats Double),            -- ^ The statistics for the time spent to process the input and prepare the output.            serverOutputWaitTimeRef :: IORef (SamplingStats Double),            -- ^ The statistics for the time spent for delivering the output.+           serverPreemptionTimeRef :: IORef (SamplingStats Double),+           -- ^ The statistics for the time spent being preempted.            serverInputReceivedSource :: SignalSource a,            -- ^ A signal raised when the server recieves a new input to process.-           serverTaskInterruptedSource :: SignalSource (ServerInterruption a),-           -- ^ A signal raised when the task was interrupted.+           serverTaskPreemptingSource :: SignalSource a,+           -- ^ A signal raised when the task was preempted.+           serverTaskReenteringSource :: SignalSource a,+           -- ^ A signal raised when the task was proceeded after it had been preempted earlier.            serverTaskProcessedSource :: SignalSource (a, b),            -- ^ A signal raised when the input is processed and            -- the output is prepared for deliverying.@@ -112,31 +127,21 @@            -- ^ A signal raised when the server has supplied the output.          } --- | Contains data about the interrupted task.-data ServerInterruption a =-  ServerInterruption { serverInterruptedInput :: a,-                       -- ^ The input task that was interrupted.-                       serverStartProcessingTime :: Double,-                       -- ^ The start time of processing the task.-                       serverInterruptionTime :: Double-                       -- ^ The time of interrupting the task.-                     }- -- | Create a new server that can provide output @b@ by input @a@. ----- By default, it is assumed that the server cannot be interrupted,--- because the handling of possible task interruption is rather costly+-- By default, it is assumed that the server process cannot be preempted,+-- because the handling of possible task preemption is rather costly -- operation. newServer :: (a -> Process b)              -- ^ provide an output by the specified input              -> Simulation (Server () a b)-newServer = newInterruptibleServer False+newServer = newPreemptibleServer False  -- | Create a new server that can provide output @b@ by input @a@ -- starting from state @s@. ----- By default, it is assumed that the server cannot be interrupted,--- because the handling of possible task interruption is rather costly+-- By default, it is assumed that the server process cannot be preempted,+-- because the handling of possible task preemption is rather costly -- operation. newStateServer :: (s -> a -> Process (s, b))                   -- ^ provide a new state and output by the specified @@ -144,55 +149,61 @@                   -> s                   -- ^ the initial state                   -> Simulation (Server s a b)-newStateServer = newInterruptibleStateServer False+newStateServer = newPreemptibleStateServer False --- | Create a new interruptible server that can provide output @b@ by input @a@.-newInterruptibleServer :: Bool-                          -- ^ whether the server can be interrupted-                          -> (a -> Process b)-                          -- ^ provide an output by the specified input-                          -> Simulation (Server () a b)-newInterruptibleServer interruptible provide =-  flip (newInterruptibleStateServer interruptible) () $ \s a ->+-- | Create a new preemptible server that can provide output @b@ by input @a@.+newPreemptibleServer :: Bool+                        -- ^ whether the server process can be preempted+                        -> (a -> Process b)+                        -- ^ provide an output by the specified input+                        -> Simulation (Server () a b)+newPreemptibleServer preemptible provide =+  flip (newPreemptibleStateServer preemptible) () $ \s a ->   do b <- provide a      return (s, b) --- | Create a new interruptible server that can provide output @b@ by input @a@+-- | Create a new preemptible server that can provide output @b@ by input @a@ -- starting from state @s@.-newInterruptibleStateServer :: Bool-                               -- ^ whether the server can be interrupted-                               -> (s -> a -> Process (s, b))-                               -- ^ provide a new state and output by the specified -                               -- old state and input-                               -> s-                               -- ^ the initial state-                               -> Simulation (Server s a b)-newInterruptibleStateServer interruptible provide state =+newPreemptibleStateServer :: Bool+                             -- ^ whether the server process can be preempted+                             -> (s -> a -> Process (s, b))+                             -- ^ provide a new state and output by the specified +                             -- old state and input+                             -> s+                             -- ^ the initial state+                             -> Simulation (Server s a b)+newPreemptibleStateServer preemptible provide state =   do r0 <- liftIO $ newIORef state      r1 <- liftIO $ newIORef 0      r2 <- liftIO $ newIORef 0      r3 <- liftIO $ newIORef 0-     r4 <- liftIO $ newIORef emptySamplingStats+     r4 <- liftIO $ newIORef 0      r5 <- liftIO $ newIORef emptySamplingStats      r6 <- liftIO $ newIORef emptySamplingStats+     r7 <- liftIO $ newIORef emptySamplingStats+     r8 <- liftIO $ newIORef emptySamplingStats      s1 <- newSignalSource      s2 <- newSignalSource      s3 <- newSignalSource      s4 <- newSignalSource+     s5 <- newSignalSource      let server = Server { serverInitState = state,                            serverStateRef = r0,                            serverProcess = provide,-                           serverProcessInterruptible = interruptible,+                           serverProcessPreemptible = preemptible,                            serverTotalInputWaitTimeRef = r1,                            serverTotalProcessingTimeRef = r2,                            serverTotalOutputWaitTimeRef = r3,-                           serverInputWaitTimeRef = r4,-                           serverProcessingTimeRef = r5,-                           serverOutputWaitTimeRef = r6,+                           serverTotalPreemptionTimeRef = r4,+                           serverInputWaitTimeRef = r5,+                           serverProcessingTimeRef = r6,+                           serverOutputWaitTimeRef = r7,+                           serverPreemptionTimeRef = r8,                            serverInputReceivedSource = s1,-                           serverTaskInterruptedSource = s2,-                           serverTaskProcessedSource = s3,-                           serverOutputProvidedSource = s4 }+                           serverTaskPreemptingSource = s2,+                           serverTaskReenteringSource = s3,+                           serverTaskProcessedSource = s4,+                           serverOutputProvidedSource = s5 }      return server  -- | Return a processor for the specified server.@@ -242,37 +253,53 @@                      addSamplingStats (t1 - t0)               triggerSignal (serverInputReceivedSource server) a          -- provide the service-         (s', b) <--           if serverProcessInterruptible server-           then serverProcessInterrupting server s a-           else serverProcess server s a+         (s', b, dt) <-+           if serverProcessPreemptible server+           then serverProcessPreempting server s a+           else do (s', b) <- serverProcess server s a+                   return (s', b, 0)          t2 <- liftDynamics time          liftEvent $            do liftIO $                 do writeIORef (serverStateRef server) $! s'-                   modifyIORef' (serverTotalProcessingTimeRef server) (+ (t2 - t1))+                   modifyIORef' (serverTotalProcessingTimeRef server) (+ (t2 - t1 - dt))                    modifyIORef' (serverProcessingTimeRef server) $-                     addSamplingStats (t2 - t1)+                     addSamplingStats (t2 - t1 - dt)               triggerSignal (serverTaskProcessedSource server) (a, b)          return (b, loop s' (Just (t2, a, b)) xs') --- | Process the input with ability to handle a possible interruption.-serverProcessInterrupting :: Server s a b -> s -> a -> Process (s, b)-serverProcessInterrupting server s a =+-- | Process the input with ability to handle a possible preemption.+serverProcessPreempting :: Server s a b -> s -> a -> Process (s, b, Double)+serverProcessPreempting server s a =   do pid <- processId      t1  <- liftDynamics time-     finallyProcess-       (serverProcess server s a)-       (liftEvent $-        do cancelled <- processCancelled pid-           when cancelled $-             do t2 <- liftDynamics time-                liftIO $-                  do modifyIORef' (serverTotalProcessingTimeRef server) (+ (t2 - t1))-                     modifyIORef' (serverProcessingTimeRef server) $-                       addSamplingStats (t2 - t1)-                let x = ServerInterruption a t1 t2-                triggerSignal (serverTaskInterruptedSource server) x)+     rs  <- liftIO $ newIORef 0+     r1  <- liftIO $ newIORef t1+     h1  <- liftEvent $+            handleSignal (processPreemptionBeginning pid) $ \() ->+            do t1 <- liftDynamics time+               liftIO $ writeIORef r1 t1+               triggerSignal (serverTaskPreemptingSource server) a+     h2  <- liftEvent $+            handleSignal (processPreemptionEnding pid) $ \() ->+            do t1 <- liftIO $ readIORef r1+               t2 <- liftDynamics time+               let dt = t2 - t1+               liftIO $+                 do modifyIORef' rs (+ dt)+                    modifyIORef' (serverTotalPreemptionTimeRef server) (+ dt)+                    modifyIORef' (serverPreemptionTimeRef server) $+                      addSamplingStats dt+               triggerSignal (serverTaskReenteringSource server) a +     let m1 =+           do (s', b) <- serverProcess server s a+              dt <- liftIO $ readIORef rs+              return (s', b, dt)+         m2 =+           liftEvent $+           do disposeEvent h1+              disposeEvent h2+     finallyProcess m1 m2  -- | Return the current state of the server. --@@ -352,6 +379,27 @@ serverTotalOutputWaitTimeChanged_ server =   mapSignal (const ()) (serverOutputProvided server) +-- | Return the counted total time spent by the server while it 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 'serverTotalPreemptionTimeChanged' and 'serverTotalPreemptionTimeChanged_'.+serverTotalPreemptionTime :: Server s a b -> Event Double+serverTotalPreemptionTime server =+  Event $ \p -> readIORef (serverTotalPreemptionTimeRef server)+  +-- | Signal when the 'serverTotalPreemptionTime' property value has changed.+serverTotalPreemptionTimeChanged :: Server s a b -> Signal Double+serverTotalPreemptionTimeChanged server =+  mapSignalM (const $ serverTotalPreemptionTime server) (serverTotalPreemptionTimeChanged_ server)+  +-- | Signal when the 'serverTotalPreemptionTime' property value has changed.+serverTotalPreemptionTimeChanged_ :: Server s a b -> Signal ()+serverTotalPreemptionTimeChanged_ server =+  mapSignal (const ()) (serverTaskReentering server)+ -- | Return the statistics of the time when the server was locked while awaiting the input. -- -- The value returned changes discretely and it is usually delayed relative@@ -413,13 +461,34 @@ serverOutputWaitTimeChanged_ server =   mapSignal (const ()) (serverOutputProvided server) +-- | Return the statistics of the time spent by the server while it 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 'serverPreemptionTimeChanged' and 'serverPreemptionTimeChanged_'.+serverPreemptionTime :: Server s a b -> Event (SamplingStats Double)+serverPreemptionTime server =+  Event $ \p -> readIORef (serverPreemptionTimeRef server)+  +-- | Signal when the 'serverPreemptionTime' property value has changed.+serverPreemptionTimeChanged :: Server s a b -> Signal (SamplingStats Double)+serverPreemptionTimeChanged server =+  mapSignalM (const $ serverPreemptionTime server) (serverPreemptionTimeChanged_ server)+  +-- | Signal when the 'serverPreemptionTime' property value has changed.+serverPreemptionTimeChanged_ :: Server s a b -> Signal ()+serverPreemptionTimeChanged_ server =+  mapSignal (const ()) (serverTaskReentering server)+ -- | It returns the factor changing from 0 to 1, which estimates how often -- the server was awaiting for the next input task. -- -- This factor is calculated as -- -- @---   totalInputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime)+--   totalInputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime + totalPreemptionTime) -- @ -- -- As before in this module, the value returned changes discretely and@@ -432,7 +501,8 @@   do x1 <- readIORef (serverTotalInputWaitTimeRef server)      x2 <- readIORef (serverTotalProcessingTimeRef server)      x3 <- readIORef (serverTotalOutputWaitTimeRef server)-     return (x1 / (x1 + x2 + x3))+     x4 <- readIORef (serverTotalPreemptionTimeRef server)+     return (x1 / (x1 + x2 + x3 + x4))    -- | Signal when the 'serverInputWaitFactor' property value has changed. serverInputWaitFactorChanged :: Server s a b -> Signal Double@@ -444,7 +514,8 @@ serverInputWaitFactorChanged_ server =   mapSignal (const ()) (serverInputReceived server) <>   mapSignal (const ()) (serverTaskProcessed server) <>-  mapSignal (const ()) (serverOutputProvided server)+  mapSignal (const ()) (serverOutputProvided server) <>+  mapSignal (const ()) (serverTaskReentering server)  -- | It returns the factor changing from 0 to 1, which estimates how often -- the server was busy with direct processing its tasks.@@ -452,7 +523,7 @@ -- This factor is calculated as -- -- @---   totalProcessingTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime)+--   totalProcessingTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime + totalPreemptionTime) -- @ -- -- As before in this module, the value returned changes discretely and@@ -465,7 +536,8 @@   do x1 <- readIORef (serverTotalInputWaitTimeRef server)      x2 <- readIORef (serverTotalProcessingTimeRef server)      x3 <- readIORef (serverTotalOutputWaitTimeRef server)-     return (x2 / (x1 + x2 + x3))+     x4 <- readIORef (serverTotalPreemptionTimeRef server)+     return (x2 / (x1 + x2 + x3 + x4))    -- | Signal when the 'serverProcessingFactor' property value has changed. serverProcessingFactorChanged :: Server s a b -> Signal Double@@ -477,7 +549,8 @@ serverProcessingFactorChanged_ server =   mapSignal (const ()) (serverInputReceived server) <>   mapSignal (const ()) (serverTaskProcessed server) <>-  mapSignal (const ()) (serverOutputProvided server)+  mapSignal (const ()) (serverOutputProvided server) <>+  mapSignal (const ()) (serverTaskReentering server)  -- | It returns the factor changing from 0 to 1, which estimates how often -- the server was locked trying to deliver the output after the task is finished.@@ -485,7 +558,7 @@ -- This factor is calculated as -- -- @---   totalOutputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime)+--   totalOutputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime + totalPreemptionTime) -- @ -- -- As before in this module, the value returned changes discretely and@@ -498,7 +571,8 @@   do x1 <- readIORef (serverTotalInputWaitTimeRef server)      x2 <- readIORef (serverTotalProcessingTimeRef server)      x3 <- readIORef (serverTotalOutputWaitTimeRef server)-     return (x3 / (x1 + x2 + x3))+     x4 <- readIORef (serverTotalPreemptionTimeRef server)+     return (x3 / (x1 + x2 + x3 + x4))    -- | Signal when the 'serverOutputWaitFactor' property value has changed. serverOutputWaitFactorChanged :: Server s a b -> Signal Double@@ -510,16 +584,56 @@ serverOutputWaitFactorChanged_ server =   mapSignal (const ()) (serverInputReceived server) <>   mapSignal (const ()) (serverTaskProcessed server) <>-  mapSignal (const ()) (serverOutputProvided server)+  mapSignal (const ()) (serverOutputProvided server) <>+  mapSignal (const ()) (serverTaskReentering server) +-- | It returns the factor changing from 0 to 1, which estimates how often+-- the server was preempted waiting for the further proceeding.+--+-- This factor is calculated as+--+-- @+--   totalPreemptionTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime + totalPreemptionTime)+-- @+--+-- As before in this module, the value returned changes discretely and+-- it is usually delayed relative to the current simulation time.+--+-- See also 'serverPreemptionFactorChanged' and 'serverPreemptionFactorChanged_'.+serverPreemptionFactor :: Server s a b -> Event Double+serverPreemptionFactor server =+  Event $ \p ->+  do x1 <- readIORef (serverTotalInputWaitTimeRef server)+     x2 <- readIORef (serverTotalProcessingTimeRef server)+     x3 <- readIORef (serverTotalOutputWaitTimeRef server)+     x4 <- readIORef (serverTotalPreemptionTimeRef server)+     return (x4 / (x1 + x2 + x3 + x4))+  +-- | Signal when the 'serverPreemptionFactor' property value has changed.+serverPreemptionFactorChanged :: Server s a b -> Signal Double+serverPreemptionFactorChanged server =+  mapSignalM (const $ serverPreemptionFactor server) (serverPreemptionFactorChanged_ server)+  +-- | Signal when the 'serverPreemptionFactor' property value has changed.+serverPreemptionFactorChanged_ :: Server s a b -> Signal ()+serverPreemptionFactorChanged_ server =+  mapSignal (const ()) (serverInputReceived server) <>+  mapSignal (const ()) (serverTaskProcessed server) <>+  mapSignal (const ()) (serverOutputProvided server) <>+  mapSignal (const ()) (serverTaskReentering server)+ -- | Raised when the server receives a new input task. serverInputReceived :: Server s a b -> Signal a serverInputReceived = publishSignal . serverInputReceivedSource --- | Raised when the task processing by the server was interrupted.-serverTaskInterrupted :: Server s a b -> Signal (ServerInterruption a)-serverTaskInterrupted = publishSignal . serverTaskInterruptedSource+-- | Raised when the task processing by the server was preempted.+serverTaskPreempting :: Server s a b -> Signal a+serverTaskPreempting = publishSignal . serverTaskPreemptingSource +-- | Raised when the task processing by the server was proceeded after it has been preempeted earlier.+serverTaskReentering :: Server s a b -> Signal a+serverTaskReentering = publishSignal . serverTaskReenteringSource+ -- | Raised when the server has just processed the task. serverTaskProcessed :: Server s a b -> Signal (a, b) serverTaskProcessed = publishSignal . serverTaskProcessedSource@@ -532,9 +646,9 @@ serverChanged_ :: Server s a b -> Signal () serverChanged_ server =   mapSignal (const ()) (serverInputReceived server) <>-  mapSignal (const ()) (serverTaskInterrupted server) <>   mapSignal (const ()) (serverTaskProcessed server) <>-  mapSignal (const ()) (serverOutputProvided server)+  mapSignal (const ()) (serverOutputProvided server) <>+  mapSignal (const ()) (serverTaskReentering server)  -- | Return the summary for the server with desciption of its -- properties and activities using the specified indent.@@ -544,12 +658,15 @@   do tx1 <- readIORef (serverTotalInputWaitTimeRef server)      tx2 <- readIORef (serverTotalProcessingTimeRef server)      tx3 <- readIORef (serverTotalOutputWaitTimeRef server)-     let xf1 = tx1 / (tx1 + tx2 + tx3)-         xf2 = tx2 / (tx1 + tx2 + tx3)-         xf3 = tx3 / (tx1 + tx2 + tx3)+     tx4 <- readIORef (serverTotalPreemptionTimeRef server)+     let xf1 = tx1 / (tx1 + tx2 + tx3 + tx4)+         xf2 = tx2 / (tx1 + tx2 + tx3 + tx4)+         xf3 = tx3 / (tx1 + tx2 + tx3 + tx4)+         xf4 = tx4 / (tx1 + tx3 + tx3 + tx4)      xs1 <- readIORef (serverInputWaitTimeRef server)      xs2 <- readIORef (serverProcessingTimeRef server)      xs3 <- readIORef (serverOutputWaitTimeRef server)+     xs4 <- readIORef (serverPreemptionTimeRef server)      let tab = replicate indent ' '      return $        showString tab .@@ -562,6 +679,9 @@        showString "total output wait time (locked while delivering the output) = " . shows tx3 .        showString "\n\n" .        showString tab .+       showString "total preemption time = " . shows tx4 .+       showString "\n" .+       showString tab .        showString "input wait factor (from 0 to 1) = " . shows xf1 .        showString "\n" .        showString tab .@@ -571,6 +691,9 @@        showString "output wait factor (from 0 to 1) = " . shows xf3 .        showString "\n\n" .        showString tab .+       showString "output preemption factor (from 0 to 1) = " . shows xf4 .+       showString "\n\n" .+       showString tab .        showString "input wait time (locked while awaiting the input):\n\n" .        samplingStatsSummary xs1 (2 + indent) .        showString "\n\n" .@@ -580,4 +703,8 @@        showString "\n\n" .        showString tab .        showString "output wait time (locked while delivering the output):\n\n" .-       samplingStatsSummary xs3 (2 + indent)+       samplingStatsSummary xs3 (2 + indent) .+       showString "\n\n" .+       showString tab .+       showString "preemption time (waiting for the proceeding after preemption):\n\n" .+       samplingStatsSummary xs4 (2 + indent)

@@ -0,0 +1,230 @@++-- |+-- Module     : Simulation.Aivika.Server.Random+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines some useful predefined servers that+-- hold the current process for the corresponding random time+-- interval, when processing every input element.+--++module Simulation.Aivika.Server.Random+       (newRandomUniformServer,+        newRandomUniformIntServer,+        newRandomNormalServer,+        newRandomExponentialServer,+        newRandomErlangServer,+        newRandomPoissonServer,+        newRandomBinomialServer,+        newPreemptibleRandomUniformServer,+        newPreemptibleRandomUniformIntServer,+        newPreemptibleRandomNormalServer,+        newPreemptibleRandomExponentialServer,+        newPreemptibleRandomErlangServer,+        newPreemptibleRandomPoissonServer,+        newPreemptibleRandomBinomialServer) where++import Simulation.Aivika.Simulation+import Simulation.Aivika.Process+import Simulation.Aivika.Process.Random+import Simulation.Aivika.Server++-- | Create a new server that holds the process for a random time interval+-- distributed uniformly, 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.+newRandomUniformServer :: Double+                          -- ^ the minimum time interval+                          -> Double+                          -- ^ the maximum time interval+                          -> Simulation (Server () a a)+newRandomUniformServer =+  newPreemptibleRandomUniformServer False++-- | Create a new server that holds the process for a random time interval+-- distributed uniformly, 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.+newRandomUniformIntServer :: Int+                             -- ^ the minimum time interval+                             -> Int+                             -- ^ the maximum time interval+                             -> Simulation (Server () a a)+newRandomUniformIntServer =+  newPreemptibleRandomUniformIntServer 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,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomNormalServer :: Double+                         -- ^ the mean time interval+                         -> Double+                         -- ^ the time interval deviation+                         -> Simulation (Server () a a)+newRandomNormalServer =+  newPreemptibleRandomNormalServer 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.+--+-- By default, it is assumed that the server process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomExponentialServer :: Double+                              -- ^ the mean time interval (the reciprocal of the rate)+                              -> Simulation (Server () a a)+newRandomExponentialServer =+  newPreemptibleRandomExponentialServer False+         +-- | Create a new server 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 server process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomErlangServer :: Double+                         -- ^ the scale (the reciprocal of the rate)+                         -> Int+                         -- ^ the shape+                         -> Simulation (Server () a a)+newRandomErlangServer =+  newPreemptibleRandomErlangServer False++-- | Create a new server 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 server process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomPoissonServer :: Double+                          -- ^ the mean time interval+                          -> Simulation (Server () a a)+newRandomPoissonServer =+  newPreemptibleRandomPoissonServer False++-- | Create a new server 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 server process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomBinomialServer :: Double+                           -- ^ the probability+                           -> Int+                           -- ^ the number of trials+                           -> Simulation (Server () a a)+newRandomBinomialServer =+  newPreemptibleRandomBinomialServer False++-- | Create a new server that holds the process for a random time interval+-- distributed uniformly, when processing every input element.+newPreemptibleRandomUniformServer :: Bool+                                     -- ^ whether the server process can be preempted+                                     -> Double+                                     -- ^ the minimum time interval+                                     -> Double+                                     -- ^ the maximum time interval+                                     -> Simulation (Server () a a)+newPreemptibleRandomUniformServer preemptible min max =+  newPreemptibleServer preemptible $ \a ->+  do randomUniformProcess_ min max+     return a++-- | Create a new server that holds the process for a random time interval+-- distributed uniformly, when processing every input element.+newPreemptibleRandomUniformIntServer :: Bool+                                        -- ^ whether the server process can be preempted+                                        -> Int+                                        -- ^ the minimum time interval+                                        -> Int+                                        -- ^ the maximum time interval+                                        -> Simulation (Server () a a)+newPreemptibleRandomUniformIntServer preemptible min max =+  newPreemptibleServer preemptible $ \a ->+  do randomUniformIntProcess_ min max+     return a++-- | Create a new server that holds the process for a random time interval+-- distributed normally, when processing every input element.+newPreemptibleRandomNormalServer :: Bool+                                    -- ^ whether the server process can be preempted+                                    -> Double+                                    -- ^ the mean time interval+                                    -> Double+                                    -- ^ the time interval deviation+                                    -> Simulation (Server () a a)+newPreemptibleRandomNormalServer preemptible mu nu =+  newPreemptibleServer preemptible $ \a ->+  do randomNormalProcess_ 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),+-- when processing every input element.+newPreemptibleRandomExponentialServer :: Bool+                                         -- ^ whether the server process can be preempted+                                         -> Double+                                         -- ^ the mean time interval (the reciprocal of the rate)+                                         -> Simulation (Server () a a)+newPreemptibleRandomExponentialServer preemptible mu =+  newPreemptibleServer preemptible $ \a ->+  do randomExponentialProcess_ mu+     return a+         +-- | Create a new server 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.+newPreemptibleRandomErlangServer :: Bool+                                    -- ^ whether the server process can be preempted+                                    -> Double+                                    -- ^ the scale (the reciprocal of the rate)+                                    -> Int+                                    -- ^ the shape+                                    -> Simulation (Server () a a)+newPreemptibleRandomErlangServer preemptible beta m =+  newPreemptibleServer preemptible $ \a ->+  do randomErlangProcess_ beta m+     return a++-- | Create a new server that holds the process for a random time interval+-- having the Poisson distribution with the specified mean, when processing+-- every input element.+newPreemptibleRandomPoissonServer :: Bool+                                     -- ^ whether the server process can be preempted+                                     -> Double+                                     -- ^ the mean time interval+                                  -> Simulation (Server () a a)+newPreemptibleRandomPoissonServer preemptible mu =+  newPreemptibleServer preemptible $ \a ->+  do randomPoissonProcess_ mu+     return a++-- | Create a new server that holds the process for a random time interval+-- having the binomial distribution with the specified probability and trials,+-- when processing every input element.+newPreemptibleRandomBinomialServer :: Bool+                                     -- ^ whether the server process can be preempted+                                     -> Double+                                     -- ^ the probability+                                     -> Int+                                     -- ^ the number of trials+                                     -> Simulation (Server () a a)+newPreemptibleRandomBinomialServer preemptible prob trials =+  newPreemptibleServer preemptible $ \a ->+  do randomBinomialProcess_ prob trials+     return a

@@ -25,7 +25,9 @@         mapSignalM,         apSignal,         filterSignal,+        filterSignal_,         filterSignalM,+        filterSignalM_,         emptySignal,         merge2Signals,         merge3Signals,@@ -174,15 +176,23 @@   Signal { handleSignal = \h ->              handleSignal m $ h . f } --- | Filter only those signal values that satisfy to +-- | Filter only those signal values that satisfy  -- the specified predicate. filterSignal :: (a -> Bool) -> Signal a -> Signal a filterSignal p m =   Signal { handleSignal = \h ->             handleSignal m $ \a ->             when (p a) $ h a }++-- | Filter only those signal values that satisfy+-- the specified predicate, but then ignoring the values.+filterSignal_ :: (a -> Bool) -> Signal a -> Signal ()+filterSignal_ p m =+  Signal { handleSignal = \h ->+            handleSignal m $ \a ->+            when (p a) $ h () }   --- | Filter only those signal values that satisfy to +-- | Filter only those signal values that satisfy -- the specified predicate. filterSignalM :: (a -> Event Bool) -> Signal a -> Signal a filterSignalM p m =@@ -190,6 +200,15 @@             handleSignal m $ \a ->             do x <- p a                when x $ h a }+  +-- | Filter only those signal values that satisfy+-- the specified predicate, but then ignoring the values.+filterSignalM_ :: (a -> Event Bool) -> Signal a -> Signal ()+filterSignalM_ p m =+  Signal { handleSignal = \h ->+            handleSignal m $ \a ->+            do x <- p a+               when x $ h () }    -- | Merge two signals. merge2Signals :: Signal a -> Signal a -> Signal a

@@ -50,6 +50,12 @@         apStreamM,         filterStream,         filterStreamM,+        takeStream,+        takeStreamWhile,+        takeStreamWhileM,+        dropStream,+        dropStreamWhile,+        dropStreamWhileM,         singletonStream,         joinStream,         -- * Failover@@ -595,6 +601,62 @@                             runProcess $ loop ps          liftEvent $ runProcess $ loop ps          runStream $ repeatProcess reader++-- | Return the prefix of the stream of the specified length.+takeStream :: Int -> Stream a -> Stream a+takeStream n s+  | n <= 0    = emptyStream+  | otherwise =+    Cons $+    do (a, xs) <- runStream s+       return (a, takeStream (n - 1) xs)++-- | Return the longest prefix of the stream of elements that satisfy the predicate.+takeStreamWhile :: (a -> Bool) -> Stream a -> Stream a+takeStreamWhile p s =+  Cons $+  do (a, xs) <- runStream s+     if p a+       then return (a, takeStreamWhile p xs)+       else neverProcess++-- | Return the longest prefix of the stream of elements that satisfy the computation.+takeStreamWhileM :: (a -> Process Bool) -> Stream a -> Stream a+takeStreamWhileM p s =+  Cons $+  do (a, xs) <- runStream s+     f <- p a+     if f+       then return (a, takeStreamWhileM p xs)+       else neverProcess++-- | Return the suffix of the stream after the specified first elements.+dropStream :: Int -> Stream a -> Stream a+dropStream n s+  | n <= 0    = s+  | otherwise =+    Cons $+    do (a, xs) <- runStream s+       runStream $ dropStream (n - 1) xs++-- | Return the suffix of the stream of elements remaining after 'takeStreamWhile'.+dropStreamWhile :: (a -> Bool) -> Stream a -> Stream a+dropStreamWhile p s =+  Cons $+  do (a, xs) <- runStream s+     if p a+       then runStream $ dropStreamWhile p xs+       else return (a, xs)++-- | Return the suffix of the stream of elements remaining after 'takeStreamWhileM'.+dropStreamWhileM :: (a -> Process Bool) -> Stream a -> Stream a+dropStreamWhileM p s =+  Cons $+  do (a, xs) <- runStream s+     f <- p a+     if f+       then runStream $ dropStreamWhileM p xs+       else return (a, xs)  -- | Show the debug messages with the current simulation time. traceStream :: Maybe String

@@ -22,8 +22,6 @@         randomPoissonStream,         randomBinomialStream) where -import System.Random- import Control.Monad import Control.Monad.Trans 

@@ -1,5 +1,5 @@ name:            aivika-version:         3.1+version:         4.0 synopsis:        A multi-paradigm simulation library description:     Aivika is a multi-paradigm simulation library with a strong emphasis@@ -119,6 +119,7 @@      exposed-modules: Simulation.Aivika                      Simulation.Aivika.Activity+                     Simulation.Aivika.Activity.Random                      Simulation.Aivika.Agent                      Simulation.Aivika.Arrival                      Simulation.Aivika.Circuit@@ -132,11 +133,14 @@                      Simulation.Aivika.Event                      Simulation.Aivika.Generator                      Simulation.Aivika.Net+                     Simulation.Aivika.Net.Random                      Simulation.Aivika.Parameter                      Simulation.Aivika.Parameter.Random                      Simulation.Aivika.PriorityQueue                      Simulation.Aivika.Process+                     Simulation.Aivika.Process.Random                      Simulation.Aivika.Processor+                     Simulation.Aivika.Processor.Random                      Simulation.Aivika.Processor.RoundRobbin                      Simulation.Aivika.Queue                      Simulation.Aivika.Queue.Infinite@@ -144,10 +148,12 @@                      Simulation.Aivika.Ref                      Simulation.Aivika.Ref.Plain                      Simulation.Aivika.Resource+                     Simulation.Aivika.Resource.Preemption                      Simulation.Aivika.Results.Locale                      Simulation.Aivika.Results                      Simulation.Aivika.Results.IO                      Simulation.Aivika.Server+                     Simulation.Aivika.Server.Random                      Simulation.Aivika.Signal                      Simulation.Aivika.Simulation                      Simulation.Aivika.Specs

@@ -58,9 +58,8 @@ -- create an inspection station (server) newInspectionStation =   newServer $ \a ->-  do holdProcess =<<-       (liftParameter $-        randomUniform minInspectionTime maxInspectionTime)+  do randomUniformProcess_+       minInspectionTime maxInspectionTime      passed <-         liftParameter $        randomTrue inspectionPassingProb@@ -70,11 +69,7 @@  -- create an adjustment station (server) newAdjustmentStation =-  newServer $ \a ->-  do holdProcess =<<-       (liftParameter $-        randomUniform minAdjustmentTime maxAdjustmentTime)-     return a+  newRandomUniformServer minAdjustmentTime maxAdjustmentTime    model :: Simulation Results model = mdo

@@ -35,15 +35,11 @@      let machine :: Process ()          machine =            do upTime <--                liftParameter $-                randomExponential meanUpTime-              holdProcess upTime+                randomExponentialProcess meanUpTime               liftEvent $                  modifyRef totalUpTime (+ upTime)               repairTime <--                liftParameter $-                randomExponential meanRepairTime-              holdProcess repairTime+                randomExponentialProcess meanRepairTime               machine       runProcessInStartTime machine

@@ -48,9 +48,7 @@      let machine :: Process ()          machine =            do upTime <--                liftParameter $-                randomExponential meanUpTime-              holdProcess upTime+                randomExponentialProcess meanUpTime               liftEvent $                 modifyRef totalUpTime (+ upTime)                @@ -63,9 +61,7 @@                                requestResource repairPerson               repairTime <--                liftParameter $-                randomExponential meanRepairTime-              holdProcess repairTime+                randomExponentialProcess meanRepairTime               releaseResource repairPerson                              machine

@@ -43,9 +43,7 @@      let machine :: ProcessId -> Process ()          machine pid =            do upTime <--                liftParameter $-                randomExponential meanUpTime-              holdProcess upTime+                randomExponentialProcess meanUpTime               liftEvent $                 modifyRef totalUpTime (+ upTime)                @@ -61,9 +59,7 @@                              requestResource repairPerson               repairTime <--                liftParameter $-                randomExponential meanRepairTime-              holdProcess repairTime+                randomExponentialProcess meanRepairTime               liftEvent $                 modifyRef nUp (+ 1)               releaseResource repairPerson

@@ -16,6 +16,7 @@  import Simulation.Aivika import qualified Simulation.Aivika.Queue.Infinite as IQ+import qualified Simulation.Aivika.Resource.Preemption as PR  -- | The simulation specs. specs = Specs { spcStartTime = 0.0,@@ -48,123 +49,57 @@ -- | A mean of each of the three repair phases (Erlang). repairMu = 3/4 --- | It defines a job.-data Job = Job { jobProcessingTime :: Double,-                 -- ^ the job processing time defined when arriving.-                 jobRemainingTime :: Double-                 -- ^ the remaining processing time (may differ after return).-               }+-- | A priority of the job (less is higher)+jobPriority = 1 --- | Return the remaining job after interruption.-remainingJobInput :: ServerInterruption (Arrival Job) -> Arrival Job-remainingJobInput x = a'-  where-    t1 = serverStartProcessingTime x-    t2 = serverInterruptionTime x-    dt = t2 - t1-    a  = serverInterruptedInput x-    a' = a { arrivalValue = job' }-    job  = arrivalValue a-    job' = job { jobRemainingTime =-                    max 0 $ jobRemainingTime job - dt }+-- | A priority of the breakdown (less is higher)+breakdownPriority = 0 +-- | The simulation model. model :: Simulation Results model = do   -- create an input queue-  inputQueue <- runEventInStartTime IQ.newPriorityQueue+  inputQueue <- runEventInStartTime IQ.newFCFSQueue   -- a counter of jobs completed   jobsCompleted <- newArrivalTimer-  -- a counter of interrupted jobs but then returned for the further processing+  -- a counter of interrupted jobs   jobsInterrupted <- newRef (0 :: Int)   -- create an input stream   let inputStream =-        traceStream Nothing (Just "taking a job from the queue") $-        repeatProcess $ IQ.dequeue inputQueue-  -- create the setting up phase of processing+        randomExponentialStream jobArrivingMu+  -- create a preemptible resource+  tool <- PR.newResource 1+  -- the machine setting up   machineSettingUp <--    newInterruptibleServer True $ \a ->-    do -- set up the machine-       setUpTime <--         liftParameter $-         randomUniform minSetUpTime maxSetUpTime-       traceProcess "setting up the machine" $-         holdProcess setUpTime-       return a-  -- create the processing phase itself+    newPreemptibleRandomUniformServer True minSetUpTime maxSetUpTime+  -- the machine processing   machineProcessing <--    newInterruptibleServer True $ \a ->-    do -- process the job-       let job = arrivalValue a-       traceProcess "processing the job" $-         holdProcess $ jobRemainingTime job-       -- return the completed job-       return a { arrivalValue = job { jobRemainingTime = 0 } }-  -- enqueue the interrupted jobs again+    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 $-    do handleSignal_ (serverTaskInterrupted machineSettingUp) $ \x ->-         traceEvent "returning the job..." $-         do let a = serverInterruptedInput x-                t = arrivalTime a-            IQ.enqueueWithStoringPriority inputQueue t a-       handleSignal_ (serverTaskInterrupted machineProcessing) $ \x ->-         traceEvent "interrupting the job..." $-         do let a = remainingJobInput x-                t = arrivalTime a-            modifyRef jobsInterrupted (+ 1)-            IQ.enqueueWithStoringPriority inputQueue t a-  let -- launch the machine tool again and again-      machineLaunch =-        joinProcessor $-        do spawnProcess $-             do -- breakdown the machine tool in time (a bound child process)-                breakdownTime <--                  liftParameter $-                  randomNormal breakdownMu breakdownSigma-                when (breakdownTime > 0) $-                  holdProcess breakdownTime-                traceProcess "breakdown" $-                  cancelProcess-           return $-             serverProcessor machineSettingUp >>>-             serverProcessor machineProcessing-      -- repair the machine tool-      machineRepair =-        do repairTime <- liftParameter $-                         randomErlang repairMu 3-           holdProcess repairTime-      -- launch after repairing the machine tool-      machineRepairAndLaunch =-        joinProcessor $-        do machineRepair-           traceProcess "repaired" $-             return machineLaunch-      -- machine loop-      machineLoop = machineLaunch : repeat machineRepairAndLaunch-      -- the network-      network = -        traceProcessor Nothing (Just "the job completed") $-        failoverProcessor machineLoop >>>+    handleSignal_ (serverTaskPreempting 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-  -- model a stream of jobs-  let jobs =-        traceStream Nothing (Just "a new job") $-        randomExponentialStream jobArrivingMu-  -- start the processing of jobs by enqueueing them-  runProcessInStartTime $-    flip consumeStream jobs $ \a ->-    liftEvent $ do-      -- define the processing time for the job-      jobProcessingTime <--        liftParameter $-        randomNormal jobProcessingMu jobProcessingSigma-      -- enqueue the job-      let t0 = arrivalTime a-          dt = max 0 jobProcessingTime-      IQ.enqueueWithStoringPriority inputQueue t0 $-        a { arrivalValue = Job dt dt }   -- return the simulation results in start time   return $     results@@ -173,11 +108,11 @@      inputQueue,      --      resultSource-     "machineSettingUp" "the machine tool (the setting up phase)"+     "machineSettingUp" "the machine setting up"      machineSettingUp,      --      resultSource-     "machineProcessing" "the machine tool (the processing phase)"+     "machineProcessing" "the machine processing"      machineProcessing,      --      resultSource