packages feed

aivika 0.7 → 1.0

raw patch · 53 files changed

+5798/−1419 lines, 53 files

Files

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