packages feed

aivika-transformers 3.0 → 4.3.1

raw patch · 111 files changed

+7459/−4984 lines, 111 filesdep ~aivika

Dependency ranges changed: aivika

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2009, 2010, 2011, 2012, 2013, 2014 David Sorokin <david.sorokin@gmail.com>+Copyright (c) 2009-2015 David Sorokin <david.sorokin@gmail.com>  All rights reserved.
+ Simulation/Aivika/IO.hs view
@@ -0,0 +1,37 @@++-- |+-- Module     : Simulation.Aivika.IO+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.3+--+-- This module re-exports the most part of the library functionality related+-- to 'IO'-based computations.+--+module Simulation.Aivika.IO+       (-- * Modules+        module Simulation.Aivika.IO.Comp,+        module Simulation.Aivika.IO.DES,+        module Simulation.Aivika.IO.Dynamics.Memo.Unboxed,+        module Simulation.Aivika.IO.Event,+        module Simulation.Aivika.IO.Exception,+        module Simulation.Aivika.IO.Generator,+        module Simulation.Aivika.IO.QueueStrategy,+        module Simulation.Aivika.IO.Ref.Base,+        module Simulation.Aivika.IO.SD,+        module Simulation.Aivika.IO.Signal,+        module Simulation.Aivika.IO.Var.Unboxed) where++import Simulation.Aivika.IO.Comp+import Simulation.Aivika.IO.DES+import Simulation.Aivika.IO.Dynamics.Memo.Unboxed+import Simulation.Aivika.IO.Event+import Simulation.Aivika.IO.Exception+import Simulation.Aivika.IO.Generator+import Simulation.Aivika.IO.QueueStrategy+import Simulation.Aivika.IO.Ref.Base+import Simulation.Aivika.IO.SD+import Simulation.Aivika.IO.Signal+import Simulation.Aivika.IO.Var.Unboxed
+ Simulation/Aivika/IO/Comp.hs view
@@ -0,0 +1,30 @@++{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.IO.Comp+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.3+--+-- It allows making the 'MonadIO'-based monad an instance of type class 'MonadComp'+-- on top of which the simulation monads can be built.+--+module Simulation.Aivika.IO.Comp () where++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.IO.Exception+import Simulation.Aivika.IO.Generator++import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Exception+import Simulation.Aivika.Trans.Template++-- | A template-based instantiation of the 'MonadComp' type class. +instance (Functor m, Monad m, MonadIO m, MonadException m, MonadTemplate m) => MonadComp m where++  {-# SPECIALISE instance MonadComp IO #-}
+ Simulation/Aivika/IO/DES.hs view
@@ -0,0 +1,32 @@++{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.IO.DES+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.3+--+-- It allows making the 'MonadIO'-based monad an instance of type class 'MonadDES'+-- used for Discrete Event Simulation (DES).+--+module Simulation.Aivika.IO.DES () where++import Control.Monad.Trans++import Simulation.Aivika.IO.Comp+import Simulation.Aivika.IO.Ref.Base+import Simulation.Aivika.IO.Event++import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Template++import Simulation.Aivika.IO.QueueStrategy++-- | A template-based instantiation of the 'MonadDES' type class.+instance (MonadComp m, MonadIO m, MonadTemplate m) => MonadDES m where++  {-# SPECIALISE instance MonadDES IO #-}
+ Simulation/Aivika/IO/Dynamics/Memo.hs view
@@ -0,0 +1,112 @@++{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.IO.Dynamics.Memo+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.3+--+-- The 'MonadIO'-based monad can be an instance of the 'MonadMemo' type class.+--++module Simulation.Aivika.IO.Dynamics.Memo () where++import Control.Monad+import Control.Monad.Trans++import Data.Array.IO.Safe+import Data.Array.MArray.Safe+import Data.IORef++import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Internal.Parameter+import Simulation.Aivika.Trans.Internal.Simulation+import Simulation.Aivika.Trans.Internal.Dynamics+import Simulation.Aivika.Trans.Dynamics.Memo+import Simulation.Aivika.Trans.Dynamics.Extra+import Simulation.Aivika.Trans.Template+import Simulation.Aivika.Trans.Array++-- | The 'MonadIO' based monad is an instance of the 'MonadMemo' type class.+instance (MonadIO m, MonadTemplate m) => MonadMemo m where++  {-# SPECIALISE instance MonadMemo IO #-}++  {-# INLINE memoDynamics #-}+  memoDynamics (Dynamics m) = +    Simulation $ \r ->+    do let sc  = runSpecs r+           (phl, phu) = integPhaseBnds sc+           (nl, nu)   = integIterationBnds sc+       arr   <- liftIO $ newIOArray_ ((phl, nl), (phu, nu))+       nref  <- liftIO $ newIORef 0+       phref <- liftIO $ newIORef 0+       let r p = +             do let n  = pointIteration p+                    ph = pointPhase p+                    loop n' ph' = +                      if (n' > n) || ((n' == n) && (ph' > ph)) +                      then +                        liftIO $ readArray arr (ph, n)+                      else +                        let p' = p { pointIteration = n', pointPhase = ph',+                                     pointTime = basicTime sc n' ph' }+                        in do a <- m p'+                              a `seq` liftIO $ writeArray arr (ph', n') a+                              if ph' >= phu +                                then do liftIO $ writeIORef phref 0+                                        liftIO $ writeIORef nref (n' + 1)+                                        loop (n' + 1) 0+                                else do liftIO $ writeIORef phref (ph' + 1)+                                        loop n' (ph' + 1)+                n'  <- liftIO $ readIORef nref+                ph' <- liftIO $ readIORef phref+                loop n' ph'+       return $ interpolateDynamics $ Dynamics r++  {-# INLINE memo0Dynamics #-}+  memo0Dynamics (Dynamics m) = +    Simulation $ \r ->+    do let sc = runSpecs r+           bnds = integIterationBnds sc+       arr  <- liftIO $ newIOArray_ bnds+       nref <- liftIO $ newIORef 0+       let r p =+             do let sc = pointSpecs p+                    n  = pointIteration p+                    loop n' = +                      if n' > n+                      then +                        liftIO $ readArray arr n+                      else +                        let p' = p { pointIteration = n', pointPhase = 0,+                                     pointTime = basicTime sc n' 0 }+                        in do a <- m p'+                              a `seq` liftIO $ writeArray arr n' a+                              liftIO $ writeIORef nref (n' + 1)+                              loop (n' + 1)+                n' <- liftIO $ readIORef nref+                loop n'+       return $ discreteDynamics $ Dynamics r++  {-# INLINE iterateDynamics #-}+  iterateDynamics (Dynamics m) = +    Simulation $ \r ->+    do let sc = runSpecs r+       nref <- liftIO $ newIORef 0+       let r p =+             do let sc = pointSpecs p+                    n  = pointIteration p+                    loop n' = +                      unless (n' > n) $+                      let p' = p { pointIteration = n', pointPhase = 0,+                                   pointTime = basicTime sc n' 0 }+                      in do a <- m p'+                            a `seq` liftIO $ writeIORef nref (n' + 1)+                            loop (n' + 1)+                n' <- liftIO $ readIORef nref+                loop n'+       return $ discreteDynamics $ Dynamics r
+ Simulation/Aivika/IO/Dynamics/Memo/Unboxed.hs view
@@ -0,0 +1,95 @@++{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.IO.Dynamics.Memo.Unboxed+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.3+--+-- The 'MonadIO'-based monad can be an instance of the 'MonadMemo' type class.+--++module Simulation.Aivika.IO.Dynamics.Memo.Unboxed () where++import Control.Monad+import Control.Monad.Trans++import Data.Array.IO.Safe+import Data.Array.MArray.Safe+import Data.IORef++import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Internal.Parameter+import Simulation.Aivika.Trans.Internal.Simulation+import Simulation.Aivika.Trans.Internal.Dynamics+import Simulation.Aivika.Trans.Dynamics.Memo.Unboxed+import Simulation.Aivika.Trans.Dynamics.Extra+import Simulation.Aivika.Trans.Template+import Simulation.Aivika.Trans.Array++-- | The 'MonadIO' based monad is an instance of the 'MonadMemo' type class.+instance (MonadIO m, MonadTemplate m, MArray IOUArray e IO) => MonadMemo m e where++  {-# SPECIALISE instance MonadMemo IO Double #-}+  {-# SPECIALISE instance MonadMemo IO Float #-}+  {-# SPECIALISE instance MonadMemo IO Int #-}++  {-# INLINE memoDynamics #-}+  memoDynamics (Dynamics m) = +    Simulation $ \r ->+    do let sc  = runSpecs r+           (phl, phu) = integPhaseBnds sc+           (nl, nu)   = integIterationBnds sc+       arr   <- liftIO $ newIOUArray_ ((phl, nl), (phu, nu))+       nref  <- liftIO $ newIORef 0+       phref <- liftIO $ newIORef 0+       let r p = +             do let n  = pointIteration p+                    ph = pointPhase p+                    loop n' ph' = +                      if (n' > n) || ((n' == n) && (ph' > ph)) +                      then +                        liftIO $ readArray arr (ph, n)+                      else +                        let p' = p { pointIteration = n', pointPhase = ph',+                                     pointTime = basicTime sc n' ph' }+                        in do a <- m p'+                              a `seq` liftIO $ writeArray arr (ph', n') a+                              if ph' >= phu +                                then do liftIO $ writeIORef phref 0+                                        liftIO $ writeIORef nref (n' + 1)+                                        loop (n' + 1) 0+                                else do liftIO $ writeIORef phref (ph' + 1)+                                        loop n' (ph' + 1)+                n'  <- liftIO $ readIORef nref+                ph' <- liftIO $ readIORef phref+                loop n' ph'+       return $ interpolateDynamics $ Dynamics r++  {-# INLINE memo0Dynamics #-}+  memo0Dynamics (Dynamics m) = +    Simulation $ \r ->+    do let sc = runSpecs r+           bnds = integIterationBnds sc+       arr  <- liftIO $ newIOUArray_ bnds+       nref <- liftIO $ newIORef 0+       let r p =+             do let sc = pointSpecs p+                    n  = pointIteration p+                    loop n' = +                      if n' > n+                      then +                        liftIO $ readArray arr n+                      else +                        let p' = p { pointIteration = n', pointPhase = 0,+                                     pointTime = basicTime sc n' 0 }+                        in do a <- m p'+                              a `seq` liftIO $ writeArray arr n' a+                              liftIO $ writeIORef nref (n' + 1)+                              loop (n' + 1)+                n' <- liftIO $ readIORef nref+                loop n'+       return $ discreteDynamics $ Dynamics r
+ Simulation/Aivika/IO/Event.hs view
@@ -0,0 +1,147 @@++{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.IO.Event+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.3+--+-- The module defines a template-based event queue, where+-- the 'MonadIO'-based monad can be an instance of 'EventQueueing'.+--+module Simulation.Aivika.IO.Event () where++import Control.Monad+import Control.Monad.Trans++import Data.IORef++import qualified Simulation.Aivika.PriorityQueue as PQ++import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Template+import Simulation.Aivika.Trans.Internal.Types++-- | A template-based implementation of the 'EventQueueing' type class.+instance (MonadIO m, MonadTemplate m) => EventQueueing m where++  {-# SPECIALISE instance EventQueueing IO #-}++  data EventQueue m =+    EventQueue { queuePQ :: PQ.PriorityQueue (Point m -> m ()),+                 -- ^ the underlying priority queue+                 queueBusy :: IORef Bool,+                 -- ^ whether the queue is currently processing events+                 queueTime :: IORef Double+                 -- ^ the actual time of the event queue+               }++  {-# INLINABLE newEventQueue #-}+  newEventQueue specs =+    liftIO $+    do f <- newIORef False+       t <- newIORef $ spcStartTime specs+       pq <- PQ.newQueue+       return EventQueue { queuePQ   = pq,+                           queueBusy = f,+                           queueTime = t }++  {-# INLINE enqueueEvent #-}+  enqueueEvent t (Event m) =+    Event $ \p ->+    let pq = queuePQ $ runEventQueue $ pointRun p+    in liftIO $ PQ.enqueue pq t m++  {-# INLINE runEventWith #-}+  runEventWith processing (Event e) =+    Dynamics $ \p ->+    do invokeDynamics p $ processEvents processing+       e p++  {-# INLINE eventQueueCount #-}+  eventQueueCount =+    Event $+    liftIO . PQ.queueCount . queuePQ . runEventQueue . pointRun++-- | Process the pending events.+processPendingEventsCore :: (MonadIO m, MonadTemplate m) => Bool -> Dynamics m ()+{-# INLINE processPendingEventsCore #-}+processPendingEventsCore includingCurrentEvents = Dynamics r where+  r p =+    do let q = runEventQueue $ pointRun p+           f = queueBusy q+       f' <- liftIO $ readIORef f+       unless f' $+         do liftIO $ writeIORef f True+            call q p+            liftIO $ writeIORef f False+  call q p =+    do let pq = queuePQ q+           r  = pointRun p+       f <- liftIO $ PQ.queueNull pq+       unless f $+         do (t2, c2) <- liftIO $ PQ.queueFront pq+            let t = queueTime q+            t' <- liftIO $ readIORef t+            when (t2 < t') $ +              error "The time value is too small: processPendingEventsCore"+            when ((t2 < pointTime p) ||+                  (includingCurrentEvents && (t2 == pointTime p))) $+              do liftIO $ writeIORef t t2+                 liftIO $ PQ.dequeue pq+                 let sc = pointSpecs p+                     t0 = spcStartTime sc+                     dt = spcDT sc+                     n2 = fromIntegral $ floor ((t2 - t0) / dt)+                 c2 $ p { pointTime = t2,+                          pointIteration = n2,+                          pointPhase = -1 }+                 call q p++-- | Process the pending events synchronously, i.e. without past.+processPendingEvents :: (MonadIO m, MonadTemplate m) => Bool -> Dynamics m ()+{-# INLINE processPendingEvents #-}+processPendingEvents includingCurrentEvents = Dynamics r where+  r p =+    do let q = runEventQueue $ pointRun p+           t = queueTime q+       t' <- liftIO $ readIORef t+       if pointTime p < t'+         then error $+              "The current time is less than " +++              "the time in the queue: processPendingEvents"+         else invokeDynamics p m+  m = processPendingEventsCore includingCurrentEvents++-- | A memoized value.+processEventsIncludingCurrent :: (MonadIO m, MonadTemplate m) => Dynamics m ()+{-# INLINE processEventsIncludingCurrent #-}+processEventsIncludingCurrent = processPendingEvents True++-- | A memoized value.+processEventsIncludingEarlier :: (MonadIO m, MonadTemplate m) => Dynamics m ()+{-# INLINE processEventsIncludingEarlier #-}+processEventsIncludingEarlier = processPendingEvents False++-- | A memoized value.+processEventsIncludingCurrentCore :: (MonadIO m, MonadTemplate m) => Dynamics m ()+{-# INLINE processEventsIncludingCurrentCore #-}+processEventsIncludingCurrentCore = processPendingEventsCore True++-- | A memoized value.+processEventsIncludingEarlierCore :: (MonadIO m, MonadTemplate m) => Dynamics m ()+{-# INLINE processEventsIncludingEarlierCore #-}+processEventsIncludingEarlierCore = processPendingEventsCore True++-- | Process the events.+processEvents :: (MonadIO m, MonadTemplate m) => EventProcessing -> Dynamics m ()+{-# INLINABLE processEvents #-}+processEvents CurrentEvents = processEventsIncludingCurrent+processEvents EarlierEvents = processEventsIncludingEarlier+processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore+processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore
+ Simulation/Aivika/IO/Exception.hs view
@@ -0,0 +1,29 @@++-- |+-- Module     : Simulation.Aivika.IO.Exception+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- It provides with exception handling capabilities,+-- where 'IO' is an instance of 'MonadException'.+--+module Simulation.Aivika.IO.Exception () where++import Control.Exception++import Simulation.Aivika.Trans.Exception++-- | An instance of the type class.+instance MonadException IO where++  {-# INLINE catchComp #-}+  catchComp = catch++  {-# INLINE finallyComp #-}+  finallyComp = finally++  {-# INLINE throwComp #-}+  throwComp = throw
+ Simulation/Aivika/IO/Generator.hs view
@@ -0,0 +1,238 @@++{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.IO.Generator+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- Here is defined a random number generator, where+-- the 'MonadIO'-based monad can be an instance of 'MonadGenerator'.+--+module Simulation.Aivika.IO.Generator () where++import Control.Monad+import Control.Monad.Trans++import System.Random++import Data.IORef++import Simulation.Aivika.Trans.Generator+import Simulation.Aivika.Trans.Template++instance (Functor m, MonadIO m, MonadTemplate m) => MonadGenerator m where++  {-# SPECIALISE instance MonadGenerator IO #-}++  data Generator m =+    Generator { generator01 :: m Double,+                -- ^ the generator of uniform numbers from 0 to 1+                generatorNormal01 :: m Double+                -- ^ the generator of normal numbers with mean 0 and variance 1+              }++  {-# INLINE generateUniform #-}+  generateUniform = generateUniform01 . generator01++  {-# INLINE generateUniformInt #-}+  generateUniformInt = generateUniformInt01 . generator01++  {-# INLINE generateNormal #-}+  generateNormal = generateNormal01 . generatorNormal01++  {-# INLINE generateExponential #-}+  generateExponential = generateExponential01 . generator01++  {-# INLINE generateErlang #-}+  generateErlang = generateErlang01 . generator01++  {-# INLINE generatePoisson #-}+  generatePoisson = generatePoisson01 . generator01++  {-# INLINE generateBinomial #-}+  generateBinomial = generateBinomial01 . generator01++  {-# INLINABLE newGenerator #-}+  newGenerator tp =+    case tp of+      SimpleGenerator ->+        liftIO newStdGen >>= newRandomGenerator+      SimpleGeneratorWithSeed x ->+        newRandomGenerator $ mkStdGen x+      CustomGenerator g ->+        g+      CustomGenerator01 g ->+        newRandomGenerator01 g++  {-# INLINABLE newRandomGenerator #-}+  newRandomGenerator g = +    do r <- liftIO $ newIORef g+       let g01 = do g <- liftIO $ readIORef r+                    let (x, g') = random g+                    liftIO $ writeIORef r g'+                    return x+       newRandomGenerator01 g01++  {-# INLINABLE newRandomGenerator01 #-}+  newRandomGenerator01 g01 =+    do gNormal01 <- newNormalGenerator01 g01+       return Generator { generator01 = g01,+                          generatorNormal01 = gNormal01 }++-- | Generate an uniform random number with the specified minimum and maximum.+generateUniform01 :: Monad m+                     => m Double+                     -- ^ the generator+                     -> Double+                     -- ^ minimum+                     -> Double+                     -- ^ maximum+                     -> m Double+{-# INLINE generateUniform01 #-}+generateUniform01 g min max =+  do x <- g+     return $ min + x * (max - min)++-- | Generate an uniform random number with the specified minimum and maximum.+generateUniformInt01 :: Monad m+                        => m Double+                        -- ^ the generator+                        -> Int+                        -- ^ minimum+                        -> Int+                        -- ^ maximum+                        -> m Int+{-# INLINE generateUniformInt01 #-}+generateUniformInt01 g min max =+  do x <- g+     let min' = fromIntegral min+         max' = fromIntegral max+     return $ round (min' + x * (max' - min'))++-- | Generate a normal random number by the specified generator, mean and variance.+generateNormal01 :: Monad m+                    => m Double+                    -- ^ normal random numbers with mean 0 and variance 1+                    -> Double+                    -- ^ mean+                    -> Double+                    -- ^ variance+                    -> m Double+{-# INLINE generateNormal01 #-}+generateNormal01 g mu nu =+  do x <- g+     return $ mu + nu * x++-- | Create a normal random number generator with mean 0 and variance 1+-- by the specified generator of uniform random numbers from 0 to 1.+newNormalGenerator01 :: MonadIO m+                        => m Double+                        -- ^ the generator+                        -> m (m Double)+{-# INLINABLE newNormalGenerator01 #-}+newNormalGenerator01 g =+  do nextRef <- liftIO $ newIORef 0.0+     flagRef <- liftIO $ newIORef False+     xi1Ref  <- liftIO $ newIORef 0.0+     xi2Ref  <- liftIO $ newIORef 0.0+     psiRef  <- liftIO $ newIORef 0.0+     let loop =+           do psi <- liftIO $ 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+                        liftIO $ writeIORef xi1Ref xi1+                        liftIO $ writeIORef xi2Ref xi2+                        liftIO $ writeIORef psiRef psi+                        loop+                else liftIO $ writeIORef psiRef $ sqrt (- 2.0 * log psi / psi)+     return $+       do flag <- liftIO $ readIORef flagRef+          if flag+            then do liftIO $ writeIORef flagRef False+                    liftIO $ readIORef nextRef+            else do liftIO $ writeIORef xi1Ref 0.0+                    liftIO $ writeIORef xi2Ref 0.0+                    liftIO $ writeIORef psiRef 0.0+                    loop+                    xi1 <- liftIO $ readIORef xi1Ref+                    xi2 <- liftIO $ readIORef xi2Ref+                    psi <- liftIO $ readIORef psiRef+                    liftIO $ writeIORef flagRef True+                    liftIO $ writeIORef nextRef $ xi2 * psi+                    return $ xi1 * psi++-- | Return the exponential random number with the specified mean.+generateExponential01 :: Monad m+                         => m Double+                         -- ^ the generator+                         -> Double+                         -- ^ the mean+                         -> m Double+{-# INLINE generateExponential01 #-}+generateExponential01 g mu =+  do x <- g+     return (- log x * mu)++-- | Return the Erlang random number.+generateErlang01 :: Monad m+                    => m Double+                    -- ^ the generator+                    -> Double+                    -- ^ the scale+                    -> Int+                    -- ^ the shape+                    -> m Double+{-# INLINABLE generateErlang01 #-}+generateErlang01 g beta m =+  do x <- loop m 1+     return (- log x * beta)+       where loop m acc+               | m < 0     = error "Negative shape: generateErlang."+               | m == 0    = return acc+               | otherwise = do x <- g+                                loop (m - 1) (x * acc)++-- | Generate the Poisson random number with the specified mean.+generatePoisson01 :: Monad m+                     => m Double+                     -- ^ the generator+                     -> Double+                     -- ^ the mean+                     -> m Int+{-# INLINABLE generatePoisson01 #-}+generatePoisson01 g mu =+  do prob0 <- g+     let loop prob prod acc+           | prob <= prod = return acc+           | otherwise    = loop+                            (prob - prod)+                            (prod * mu / fromIntegral (acc + 1))+                            (acc + 1)+     loop prob0 (exp (- mu)) 0++-- | Generate a binomial random number with the specified probability and number of trials. +generateBinomial01 :: Monad m+                      => m Double+                      -- ^ the generator+                      -> Double +                      -- ^ the probability+                      -> Int+                      -- ^ the number of trials+                      -> m Int+{-# INLINABLE generateBinomial01 #-}+generateBinomial01 g prob trials = loop trials 0 where+  loop n acc+    | n < 0     = error "Negative number of trials: generateBinomial."+    | n == 0    = return acc+    | otherwise = do x <- g+                     if x <= prob+                       then loop (n - 1) (acc + 1)+                       else loop (n - 1) acc
+ Simulation/Aivika/IO/QueueStrategy.hs view
@@ -0,0 +1,198 @@++{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, FunctionalDependencies, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.IO.QueueStrategy+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.3+--+-- This module defines some queue strategy instances+-- for the 'MonadIO'-based computations.+--+module Simulation.Aivika.IO.QueueStrategy () where++import Control.Monad.Trans++import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Parameter+import Simulation.Aivika.Trans.Parameter.Random+import Simulation.Aivika.Trans.Simulation+import Simulation.Aivika.Trans.Event+import Simulation.Aivika.Trans.QueueStrategy+import Simulation.Aivika.Trans.Template++import Simulation.Aivika.IO.Comp++import qualified Simulation.Aivika.DoubleLinkedList as LL+import qualified Simulation.Aivika.PriorityQueue as PQ+import qualified Simulation.Aivika.Vector as V++-- | An implementation of the 'FCFS' queue strategy.+instance (MonadComp m, MonadIO m, MonadTemplate m)+         => QueueStrategy m FCFS where++  {-# SPECIALISE instance QueueStrategy IO FCFS #-}++  -- | A queue used by the 'FCFS' strategy.+  newtype StrategyQueue m FCFS a = FCFSQueue (LL.DoubleLinkedList a)++  {-# INLINABLE newStrategyQueue #-}+  newStrategyQueue s =+    fmap FCFSQueue $+    liftIO LL.newList++  {-# INLINABLE strategyQueueNull #-}+  strategyQueueNull (FCFSQueue q) =+    liftIO $ LL.listNull q++-- | An implementation of the 'FCFS' queue strategy.+instance (QueueStrategy m FCFS, MonadComp m, MonadIO m, MonadTemplate m)+         => DequeueStrategy m FCFS where++  {-# SPECIALISE instance DequeueStrategy IO FCFS #-}++  {-# INLINABLE strategyDequeue #-}+  strategyDequeue (FCFSQueue q) =+    liftIO $+    do i <- LL.listFirst q+       LL.listRemoveFirst q+       return i++-- | An implementation of the 'FCFS' queue strategy.+instance (DequeueStrategy m FCFS, MonadComp m, MonadIO m, MonadTemplate m)+         => EnqueueStrategy m FCFS where++  {-# SPECIALISE instance EnqueueStrategy IO FCFS #-}++  {-# INLINABLE strategyEnqueue #-}+  strategyEnqueue (FCFSQueue q) i =+    liftIO $ LL.listAddLast q i++-- | An implementation of the 'LCFS' queue strategy.+instance (MonadComp m, MonadIO m, MonadTemplate m)+         => QueueStrategy m LCFS where++  {-# SPECIALISE instance QueueStrategy IO LCFS #-}++  -- | A queue used by the 'LCFS' strategy.+  newtype StrategyQueue m LCFS a = LCFSQueue (LL.DoubleLinkedList a)++  {-# INLINABLE newStrategyQueue #-}+  newStrategyQueue s =+    fmap LCFSQueue $+    liftIO LL.newList+       +  {-# INLINABLE strategyQueueNull #-}+  strategyQueueNull (LCFSQueue q) =+    liftIO $ LL.listNull q++-- | An implementation of the 'LCFS' queue strategy.+instance (QueueStrategy m LCFS, MonadComp m, MonadIO m, MonadTemplate m)+         => DequeueStrategy m LCFS where++  {-# SPECIALISE instance DequeueStrategy IO LCFS #-}++  {-# INLINABLE strategyDequeue #-}+  strategyDequeue (LCFSQueue q) =+    liftIO $+    do i <- LL.listFirst q+       LL.listRemoveFirst q+       return i++-- | An implementation of the 'LCFS' queue strategy.+instance (DequeueStrategy m LCFS, MonadComp m, MonadIO m, MonadTemplate m)+         => EnqueueStrategy m LCFS where++  {-# SPECIALISE instance EnqueueStrategy IO LCFS #-}++  {-# INLINABLE strategyEnqueue #-}+  strategyEnqueue (LCFSQueue q) i =+    liftIO $ LL.listInsertFirst q i++-- | A template-based implementation of the 'StaticPriorities' queue strategy.+instance (MonadComp m, MonadIO m, MonadTemplate m)+         => QueueStrategy m StaticPriorities where++  {-# SPECIALISE instance QueueStrategy IO StaticPriorities #-}++  -- | A queue used by the 'StaticPriorities' strategy.+  newtype StrategyQueue m StaticPriorities a = StaticPriorityQueue (PQ.PriorityQueue a)++  {-# INLINABLE newStrategyQueue #-}+  newStrategyQueue s =+    fmap StaticPriorityQueue $+    liftIO $ PQ.newQueue++  {-# INLINABLE strategyQueueNull #-}+  strategyQueueNull (StaticPriorityQueue q) =+    liftIO $ PQ.queueNull q++-- | A template-based implementation of the 'StaticPriorities' queue strategy.+instance (QueueStrategy m StaticPriorities, MonadComp m, MonadIO m, MonadTemplate m)+         => DequeueStrategy m StaticPriorities where++  {-# SPECIALISE instance DequeueStrategy IO StaticPriorities #-}++  {-# INLINABLE strategyDequeue #-}+  strategyDequeue (StaticPriorityQueue q) =+    liftIO $+    do (_, i) <- PQ.queueFront q+       PQ.dequeue q+       return i++-- | A template-based implementation of the 'StaticPriorities' queue strategy.+instance (DequeueStrategy m StaticPriorities, MonadComp m, MonadIO m, MonadTemplate m)+         => PriorityQueueStrategy m StaticPriorities Double where++  {-# SPECIALISE instance PriorityQueueStrategy IO StaticPriorities Double #-}++  {-# INLINABLE strategyEnqueueWithPriority #-}+  strategyEnqueueWithPriority (StaticPriorityQueue q) p i =+    liftIO $ PQ.enqueue q p i++-- | A template-based implementation of the 'SIRO' queue strategy.+instance (MonadComp m, MonadIO m, MonadTemplate m)+         => QueueStrategy m SIRO where++  {-# SPECIALISE instance QueueStrategy IO SIRO #-}++  -- | A queue used by the 'SIRO' strategy.+  newtype StrategyQueue m SIRO a = SIROQueue (V.Vector a)+  +  {-# INLINABLE newStrategyQueue #-}+  newStrategyQueue s =+    fmap SIROQueue $+    liftIO $ V.newVector++  {-# INLINABLE strategyQueueNull #-}+  strategyQueueNull (SIROQueue q) =+    liftIO $+    do n <- V.vectorCount q+       return (n == 0)++-- | A template-based implementation of the 'SIRO' queue strategy.+instance (QueueStrategy m SIRO, MonadComp m, MonadIO m, MonadTemplate m)+         => DequeueStrategy m SIRO where++  {-# SPECIALISE instance DequeueStrategy IO SIRO #-}++  {-# INLINABLE strategyDequeue #-}+  strategyDequeue (SIROQueue q) =+    do n <- liftIO $ V.vectorCount q+       i <- liftParameter $ randomUniformInt 0 (n - 1)+       x <- liftIO $ V.readVector q i+       liftIO $ V.vectorDeleteAt q i+       return x++-- | A template-based implementation of the 'SIRO' queue strategy.+instance (DequeueStrategy m SIRO, MonadComp m, MonadIO m, MonadTemplate m)+         => EnqueueStrategy m SIRO where++  {-# SPECIALISE instance EnqueueStrategy IO SIRO #-}++  {-# INLINABLE strategyEnqueue #-}+  strategyEnqueue (SIROQueue q) i =+    liftIO $ V.appendVector q i
+ Simulation/Aivika/IO/Ref/Base.hs view
@@ -0,0 +1,65 @@++{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.IO.Ref.Base+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- The 'MonadIO'-based monad can be an instance of 'MonadRef'.+--+module Simulation.Aivika.IO.Ref.Base () where++import Data.IORef++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Trans.Internal.Types+import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.Template++-- | The 'MonadIO' based monad is an instance of 'MonadRef'.+instance (MonadIO m, MonadTemplate m) => MonadRef m where++  {-# SPECIALISE instance MonadRef IO #-}++  -- | A type safe wrapper for the 'IORef' reference.+  newtype Ref m a = Ref { refValue :: IORef a }++  {-# INLINE newRef #-}+  newRef a =+    Simulation $ \r ->+    do x <- liftIO $ newIORef a+       return Ref { refValue = x }+     +  {-# INLINE readRef #-}+  readRef r = Event $ \p ->+    liftIO $ readIORef (refValue r)++  {-# INLINE writeRef #-}+  writeRef r a = Event $ \p -> +    a `seq` liftIO $ writeIORef (refValue r) a++  {-# INLINE modifyRef #-}+  modifyRef r f = Event $ \p -> +    do a <- liftIO $ readIORef (refValue r)+       let b = f a+       b `seq` liftIO $ writeIORef (refValue r) b++  {-# INLINE equalRef #-}+  equalRef (Ref r1) (Ref r2) = (r1 == r2)++-- | The 'MonadIO' based monad is an instance of 'MonadRef0'.+instance (MonadIO m, MonadTemplate m) => MonadRef0 m where++  {-# SPECIALISE instance MonadRef0 IO #-}++  {-# INLINE newRef0 #-}+  newRef0 a =+    do x <- liftIO $ newIORef a+       return Ref { refValue = x }+
+ Simulation/Aivika/IO/Resource/Preemption.hs view
@@ -0,0 +1,250 @@++{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.IO.Resource.Preemption+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.3+--+-- This module defines the preemptible resource, where+-- the 'MonadIO'-based monad can be an instance of 'MonadResource'.+--+module Simulation.Aivika.IO.Resource.Preemption () where++import Control.Monad+import Control.Monad.Trans++import Data.Maybe+import Data.IORef++import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Template+import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Internal.Simulation+import Simulation.Aivika.Trans.Internal.Event+import Simulation.Aivika.Trans.Internal.Cont+import Simulation.Aivika.Trans.Internal.Process+import Simulation.Aivika.Trans.Resource.Preemption++import Simulation.Aivika.IO.DES++import qualified Simulation.Aivika.PriorityQueue as PQ++-- | The 'MonadIO' based monad is an instance of 'MonadResource'.+instance (MonadDES m, MonadIO m, MonadTemplate m) => MonadResource m where++  {-# SPECIALISE instance MonadResource IO #-}++  -- | A template-based implementation of the preemptible resource.+  data Resource m = +    Resource { resourceMaxCount0 :: Maybe Int,+               resourceCountRef :: IORef Int,+               resourceActingQueue :: PQ.PriorityQueue (ResourceActingItem m),+               resourceWaitQueue :: PQ.PriorityQueue (ResourceAwaitingItem m) }++  {-# INLINABLE newResource #-}+  newResource count =+    Simulation $ \r ->+    do when (count < 0) $+         error $+         "The resource count cannot be negative: " +++         "newResource."+       countRef <- liftIO $ newIORef count+       actingQueue <- liftIO PQ.newQueue+       waitQueue <- liftIO PQ.newQueue+       return Resource { resourceMaxCount0 = Just count,+                         resourceCountRef = countRef,+                         resourceActingQueue = actingQueue,+                         resourceWaitQueue = waitQueue }++  {-# INLINABLE newResourceWithMaxCount #-}+  newResourceWithMaxCount count maxCount =+    Simulation $ \r ->+    do when (count < 0) $+         error $+         "The resource count cannot be negative: " +++         "newResourceWithMaxCount."+       case maxCount of+         Just maxCount | count > maxCount ->+           error $+           "The resource count cannot be greater than " +++           "its maximum value: newResourceWithMaxCount."+         _ ->+           return ()+       countRef <- liftIO $ newIORef count+       actingQueue <- liftIO PQ.newQueue+       waitQueue <- liftIO PQ.newQueue+       return Resource { resourceMaxCount0 = maxCount,+                         resourceCountRef = countRef,+                         resourceActingQueue = actingQueue,+                         resourceWaitQueue = waitQueue }++  {-# INLINABLE resourceCount #-}+  resourceCount r =+    Event $ \p -> liftIO $ readIORef (resourceCountRef r)++  {-# INLINABLE resourceMaxCount #-}+  resourceMaxCount = resourceMaxCount0++  {-# INLINABLE requestResourceWithPriority #-}+  requestResourceWithPriority r priority =+    Process $ \pid ->+    Cont $ \c ->+    Event $ \p ->+    do a <- liftIO $ readIORef (resourceCountRef r)+       if a == 0+         then do f <- liftIO $ PQ.queueNull (resourceActingQueue r)+                 if f+                   then do c <- invokeEvent p $+                                freezeContReentering c () $+                                invokeCont c $+                                invokeProcess pid $+                                requestResourceWithPriority r priority+                           liftIO $ PQ.enqueue (resourceWaitQueue r) priority (Left $ ResourceRequestingItem priority pid c)+                   else do (p0', item0) <- liftIO $ PQ.queueFront (resourceActingQueue r)+                           let p0 = - p0'+                               pid0 = actingItemId item0+                           if priority < p0+                             then do liftIO $ PQ.dequeue (resourceActingQueue r)+                                     liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid+                                     liftIO $ PQ.enqueue (resourceWaitQueue r) p0 (Right $ ResourcePreemptedItem p0 pid0)+                                     invokeEvent p $ processPreemptionBegin pid0+                                     invokeEvent p $ resumeCont c ()+                             else do c <- invokeEvent p $+                                          freezeContReentering c () $+                                          invokeCont c $+                                          invokeProcess pid $+                                          requestResourceWithPriority r priority+                                     liftIO $ PQ.enqueue (resourceWaitQueue r) priority (Left $ ResourceRequestingItem priority pid c)+         else do let a' = a - 1+                 a' `seq` liftIO $ writeIORef (resourceCountRef r) a'+                 liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid+                 invokeEvent p $ resumeCont c ()++  {-# INLINABLE releaseResource #-}+  releaseResource r = +    Process $ \pid ->+    Cont $ \c ->+    Event $ \p ->+    do f <- liftIO $ fmap isJust $ PQ.queueDeleteBy (resourceActingQueue r) (\item -> actingItemId item == pid)+       if f+         then do invokeEvent p $ releaseResource' r+                 invokeEvent p $ resumeCont c ()+         else error $+              "The resource was not acquired by this process: releaseResource"+               +  {-# INLINABLE usingResourceWithPriority #-}+  usingResourceWithPriority r priority m =+    do requestResourceWithPriority r priority+       finallyProcess m $ releaseResource r++  {-# INLINABLE incResourceCount #-}+  incResourceCount r n+    | n < 0     = error "The increment cannot be negative: incResourceCount"+    | n == 0    = return ()+    | otherwise =+      do releaseResource' r+         incResourceCount r (n - 1)++  {-# INLINABLE decResourceCount #-}+  decResourceCount r n+    | n < 0     = error "The decrement cannot be negative: decResourceCount"+    | n == 0    = return ()+    | otherwise =+      do decResourceCount' r+         decResourceCount r (n - 1)++  {-# INLINABLE alterResourceCount #-}+  alterResourceCount r n+    | n < 0  = decResourceCount r (- n)+    | n > 0  = incResourceCount r n+    | n == 0 = return ()++-- | Identifies an acting item that acquired the resource.+data ResourceActingItem m =+  ResourceActingItem { actingItemPriority :: Double,+                       actingItemId :: ProcessId m }++-- | Idenitifies an item that requests for the resource.+data ResourceRequestingItem m =+  ResourceRequestingItem { requestingItemPriority :: Double,+                           requestingItemId :: ProcessId m,+                           requestingItemCont :: FrozenCont m () }++-- | Idenitifies an item that was preempted.+data ResourcePreemptedItem m =+  ResourcePreemptedItem { preemptedItemPriority :: Double,+                          preemptedItemId :: ProcessId m }++-- | Idenitifies an awaiting item that waits for releasing of the resource to take it.+type ResourceAwaitingItem m =+  Either (ResourceRequestingItem m) (ResourcePreemptedItem m)++instance (MonadDES m, MonadIO m, MonadTemplate m) => Eq (Resource m) where++  {-# INLINABLE (==) #-}+  x == y = resourceCountRef x == resourceCountRef y  -- unique references++instance (MonadDES m, MonadIO m, MonadTemplate m) => Eq (ResourceActingItem m) where++  {-# INLINABLE (==) #-}+  x == y = actingItemId x == actingItemId y++releaseResource' :: (MonadDES m, MonadIO m, MonadTemplate m) => Resource m -> Event m ()+{-# INLINABLE releaseResource' #-}+releaseResource' r =+  Event $ \p ->+  do a <- liftIO $ readIORef (resourceCountRef r)+     let a' = a + 1+     case resourceMaxCount r of+       Just maxCount | a' > maxCount ->+         error $+         "The resource count cannot be greater than " +++         "its maximum value: releaseResource'."+       _ ->+         return ()+     f <- liftIO $ PQ.queueNull (resourceWaitQueue r)+     if f +       then a' `seq` liftIO $ writeIORef (resourceCountRef r) a'+       else do (priority', item) <- liftIO $ PQ.queueFront (resourceWaitQueue r)+               liftIO $ PQ.dequeue (resourceWaitQueue r)+               case item of+                 Left (ResourceRequestingItem priority pid c) ->+                   do c <- invokeEvent p $ unfreezeCont c+                      case c of+                        Nothing ->+                          invokeEvent p $ releaseResource' r+                        Just c ->+                          do liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid+                             invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c ()+                 Right (ResourcePreemptedItem priority pid) ->+                   do f <- invokeEvent p $ processCancelled pid+                      case f of+                        True ->+                          invokeEvent p $ releaseResource' r+                        False ->+                          do liftIO $ PQ.enqueue (resourceActingQueue r) (- priority) $ ResourceActingItem priority pid+                             invokeEvent p $ processPreemptionEnd pid++decResourceCount' :: (MonadDES m, MonadIO m, MonadTemplate m) => Resource m -> Event m ()+{-# INLINABLE decResourceCount' #-}+decResourceCount' r =+  Event $ \p ->+  do a <- liftIO $ readIORef (resourceCountRef r)+     when (a == 0) $+       error $+       "The resource exceeded and its count is zero: decResourceCount'"+     f <- liftIO $ PQ.queueNull (resourceActingQueue r)+     unless f $+       do (p0', item0) <- liftIO $ PQ.queueFront (resourceActingQueue r)+          let p0 = - p0'+              pid0 = actingItemId item0+          liftIO $ PQ.dequeue (resourceActingQueue r)+          liftIO $ PQ.enqueue (resourceWaitQueue r) p0 (Right $ ResourcePreemptedItem p0 pid0)+          invokeEvent p $ processPreemptionBegin pid0+     let a' = a - 1+     a' `seq` liftIO $ writeIORef (resourceCountRef r) a'
+ Simulation/Aivika/IO/SD.hs view
@@ -0,0 +1,30 @@++{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.IO.SD+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.3+--+-- It allows making the 'MonadIO'-based monad an instance of type class 'MonadSD'+-- used for System Dynamics (SD).+--+module Simulation.Aivika.IO.SD () where++import Control.Monad.Trans++import Simulation.Aivika.IO.Comp+import qualified Simulation.Aivika.IO.Dynamics.Memo as M+import qualified Simulation.Aivika.IO.Dynamics.Memo.Unboxed as MU++import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.SD+import Simulation.Aivika.Trans.Template++-- | A template-based instantiation of the 'MonadSD' type class.+instance (MonadComp m, MonadIO m, MonadTemplate m) => MonadSD m where+  +  {-# SPECIALISE instance MonadSD IO #-}
+ Simulation/Aivika/IO/Signal.hs view
@@ -0,0 +1,88 @@++-- |+-- Module     : Simulation.Aivika.IO.Signal+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- This module allows collecting the signal history.+--++module Simulation.Aivika.IO.Signal+       (-- * Signal History+        SignalHistory,+        signalHistorySignal,+        newSignalHistory,+        newSignalHistoryStartingWith,+        readSignalHistory) where++import Data.Monoid+import Data.List+import Data.Array+import Data.Array.MArray.Safe++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Internal.Event+import Simulation.Aivika.Trans.Template+import Simulation.Aivika.Trans.Signal++import Simulation.Aivika.IO.DES++import qualified Simulation.Aivika.Vector as V+import qualified Simulation.Aivika.Vector.Unboxed as UV+                                    +-- | Represents the history of the signal values.+data SignalHistory m a =+  SignalHistory { signalHistorySignal :: Signal m 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 :: (MonadDES m, MonadIO m, MonadTemplate m)+                    => Signal m a -> Event m (SignalHistory m a)+{-# INLINABLE newSignalHistory #-}+newSignalHistory =+  newSignalHistoryStartingWith Nothing++-- | Create a history of the signal values starting with+-- the optional initial value.+newSignalHistoryStartingWith :: (MonadDES m, MonadIO m, MonadTemplate m)+                                => Maybe a -> Signal m a -> Event m (SignalHistory m a)+{-# INLINABLE newSignalHistoryStartingWith #-}+newSignalHistoryStartingWith init signal =+  Event $ \p ->+  do ts <- liftIO UV.newVector+     xs <- liftIO V.newVector+     case init of+       Nothing -> return ()+       Just a ->+         liftIO $+         do UV.appendVector ts (pointTime p)+            V.appendVector xs a+     invokeEvent p $+       handleSignal_ signal $ \a ->+       Event $ \p ->+       liftIO $+       do UV.appendVector ts (pointTime p)+          V.appendVector xs a+     return SignalHistory { signalHistorySignal = signal,+                            signalHistoryTimes  = ts,+                            signalHistoryValues = xs }+       +-- | Read the history of signal values.+readSignalHistory :: (MonadDES m, MonadIO m, MonadTemplate m)+                     => SignalHistory m a -> Event m (Array Int Double, Array Int a)+{-# INLINABLE readSignalHistory #-}+readSignalHistory history =+  Event $ \p ->+  liftIO $+  do xs <- UV.freezeVector (signalHistoryTimes history)+     ys <- V.freezeVector (signalHistoryValues history)+     return (xs, ys)
+ Simulation/Aivika/IO/Var.hs view
@@ -0,0 +1,163 @@++{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.IO.Var+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.3+--+-- The 'MonadIO'-based monad can be an instance 'MonadVar'.+--+module Simulation.Aivika.IO.Var () where++import Control.Monad.Trans++import Data.Array++import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Internal.Simulation+import Simulation.Aivika.Trans.Internal.Dynamics+import Simulation.Aivika.Trans.Internal.Event+import Simulation.Aivika.Trans.Ref+import Simulation.Aivika.Trans.Signal+import Simulation.Aivika.Trans.Template+import Simulation.Aivika.Trans.Var++import Simulation.Aivika.IO.DES++import qualified Simulation.Aivika.Vector as V+import qualified Simulation.Aivika.Vector.Unboxed as UV++-- | The 'MonadIO' based monad is an instance of 'MonadVar'.+instance (MonadDES m, MonadIO m, MonadTemplate m) => MonadVar m where++  {-# SPECIALISE instance MonadVar IO #-}++  -- | A template-based implementation of the variable.+  data Var m a = +    Var { varXS    :: UV.Vector Double,+          varMS    :: V.Vector a,+          varYS    :: V.Vector a,+          varChangedSource :: SignalSource m a }++  {-# INLINABLE newVar #-}+  newVar a =+    Simulation $ \r ->+    do xs <- liftIO UV.newVector+       ms <- liftIO V.newVector+       ys <- liftIO V.newVector+       liftIO $ UV.appendVector xs $ spcStartTime $ runSpecs r+       liftIO $ V.appendVector ms a+       liftIO $ V.appendVector ys a+       s  <- invokeSimulation r newSignalSource+       return Var { varXS = xs,+                    varMS = ms,+                    varYS = ms,+                    varChangedSource = s }++  {-# INLINABLE varMemo #-}+  varMemo v =+    runEventWith CurrentEventsOrFromPast $+    Event $ \p ->+    liftIO $+    do let xs = varXS v+           ms = varMS v+           ys = varYS v+           t  = pointTime p+       count <- UV.vectorCount xs+       let i = count - 1+       x <- UV.readVector xs i+       if x < t+         then do a <- V.readVector ys i+                 UV.appendVector xs t+                 V.appendVector ms a+                 V.appendVector ys a+                 return a+         else if x == t+              then V.readVector ms i+              else do i <- UV.vectorBinarySearch xs t+                      if i >= 0+                        then V.readVector ms i+                        else V.readVector ms $ - (i + 1) - 1++  {-# INLINABLE readVar #-}+  readVar v = +    Event $ \p ->+    liftIO $+    do let xs = varXS v+           ys = varYS v+           t  = pointTime p+       count <- UV.vectorCount xs+       let i = count - 1+       x <- UV.readVector xs i+       if x <= t +         then V.readVector ys i+         else do i <- UV.vectorBinarySearch xs t+                 if i >= 0+                   then V.readVector ys i+                   else V.readVector ys $ - (i + 1) - 1++  {-# INLINABLE writeVar #-}+  writeVar v a =+    Event $ \p ->+    do let xs = varXS v+           ms = varMS v+           ys = varYS v+           t  = pointTime p+           s  = varChangedSource v+       count <- liftIO $ UV.vectorCount xs+       let i = count - 1+       x <- liftIO $ UV.readVector xs i+       if t < x +         then error "Cannot update the past data: writeVar."+         else if t == x+              then liftIO $ V.writeVector ys i $! a+              else liftIO $+                   do UV.appendVector xs t+                      V.appendVector ms $! a+                      V.appendVector ys $! a+       invokeEvent p $ triggerSignal s a++  {-# INLINABLE modifyVar #-}+  modifyVar v f =+    Event $ \p ->+    do let xs = varXS v+           ms = varMS v+           ys = varYS v+           t  = pointTime p+           s  = varChangedSource v+       count <- liftIO $ UV.vectorCount xs+       let i = count - 1+       x <- liftIO $ UV.readVector xs i+       if t < x+         then error "Cannot update the past data: modifyVar."+         else if t == x+              then do a <- liftIO $ V.readVector ys i+                      let b = f a+                      liftIO $ V.writeVector ys i $! b+                      invokeEvent p $ triggerSignal s b+              else do a <- liftIO $ V.readVector ys i+                      let b = f a+                      liftIO $ UV.appendVector xs t+                      liftIO $ V.appendVector ms $! b+                      liftIO $ V.appendVector ys $! b+                      invokeEvent p $ triggerSignal s b++  {-# INLINABLE freezeVar #-}+  freezeVar v =+    Event $ \p ->+    liftIO $+    do xs <- UV.freezeVector (varXS v)+       ms <- V.freezeVector (varMS v)+       ys <- V.freezeVector (varYS v)+       return (xs, ms, ys)+     +  {-# INLINE varChanged #-}+  varChanged v = publishSignal (varChangedSource v)++  {-# INLINE varChanged_ #-}+  varChanged_ v = mapSignal (const ()) $ varChanged v
+ Simulation/Aivika/IO/Var/Unboxed.hs view
@@ -0,0 +1,165 @@++{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.IO.Var.Unboxed+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.3+--+-- The 'MonadIO'-based monad can be an instance 'MonadVar'.+--+module Simulation.Aivika.IO.Var.Unboxed () where++import Control.Monad.Trans++import Data.Array++import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Internal.Simulation+import Simulation.Aivika.Trans.Internal.Dynamics+import Simulation.Aivika.Trans.Internal.Event+import Simulation.Aivika.Trans.Ref+import Simulation.Aivika.Trans.Signal+import Simulation.Aivika.Trans.Template+import Simulation.Aivika.Trans.Var.Unboxed++import Simulation.Aivika.IO.DES++import Simulation.Aivika.Unboxed+import qualified Simulation.Aivika.Vector.Unboxed as UV++-- | The 'MonadIO' based monad is an instance of 'MonadVar'.+instance (MonadDES m, MonadIO m, MonadTemplate m, Unboxed a) => MonadVar m a where++  {-# SPECIALISE instance MonadVar IO Double #-}+  {-# SPECIALISE instance MonadVar IO Float #-}+  {-# SPECIALISE instance MonadVar IO Int #-}++  -- | A template-based implementation of the variable.+  data Var m a = +    Var { varXS    :: UV.Vector Double,+          varMS    :: UV.Vector a,+          varYS    :: UV.Vector a,+          varChangedSource :: SignalSource m a }+     +  {-# INLINABLE newVar #-}+  newVar a =+    Simulation $ \r ->+    do xs <- liftIO UV.newVector+       ms <- liftIO UV.newVector+       ys <- liftIO UV.newVector+       liftIO $ UV.appendVector xs $ spcStartTime $ runSpecs r+       liftIO $ UV.appendVector ms a+       liftIO $ UV.appendVector ys a+       s  <- invokeSimulation r newSignalSource+       return Var { varXS = xs,+                    varMS = ms,+                    varYS = ms,+                    varChangedSource = s }++  {-# INLINABLE varMemo #-}+  varMemo v =+    runEventWith CurrentEventsOrFromPast $+    Event $ \p ->+    liftIO $+    do let xs = varXS v+           ms = varMS v+           ys = varYS v+           t  = pointTime p+       count <- UV.vectorCount xs+       let i = count - 1+       x <- UV.readVector xs i+       if x < t+         then do a <- UV.readVector ys i+                 UV.appendVector xs t+                 UV.appendVector ms a+                 UV.appendVector ys a+                 return a+         else if x == t+              then UV.readVector ms i+              else do i <- UV.vectorBinarySearch xs t+                      if i >= 0+                        then UV.readVector ms i+                        else UV.readVector ms $ - (i + 1) - 1++  {-# INLINABLE readVar #-}+  readVar v = +    Event $ \p ->+    liftIO $+    do let xs = varXS v+           ys = varYS v+           t  = pointTime p+       count <- UV.vectorCount xs+       let i = count - 1+       x <- UV.readVector xs i+       if x <= t +         then UV.readVector ys i+         else do i <- UV.vectorBinarySearch xs t+                 if i >= 0+                   then UV.readVector ys i+                   else UV.readVector ys $ - (i + 1) - 1++  {-# INLINABLE writeVar #-}+  writeVar v a =+    Event $ \p ->+    do let xs = varXS v+           ms = varMS v+           ys = varYS v+           t  = pointTime p+           s  = varChangedSource v+       count <- liftIO $ UV.vectorCount xs+       let i = count - 1+       x <- liftIO $ UV.readVector xs i+       if t < x +         then error "Cannot update the past data: writeVar."+         else if t == x+              then liftIO $ UV.writeVector ys i $! a+              else liftIO $+                   do UV.appendVector xs t+                      UV.appendVector ms $! a+                      UV.appendVector ys $! a+       invokeEvent p $ triggerSignal s a++  {-# INLINABLE modifyVar #-}+  modifyVar v f =+    Event $ \p ->+    do let xs = varXS v+           ms = varMS v+           ys = varYS v+           t  = pointTime p+           s  = varChangedSource v+       count <- liftIO $ UV.vectorCount xs+       let i = count - 1+       x <- liftIO $ UV.readVector xs i+       if t < x+         then error "Cannot update the past data: modifyVar."+         else if t == x+              then do a <- liftIO $ UV.readVector ys i+                      let b = f a+                      liftIO $ UV.writeVector ys i $! b+                      invokeEvent p $ triggerSignal s b+              else do a <- liftIO $ UV.readVector ys i+                      let b = f a+                      liftIO $ UV.appendVector xs t+                      liftIO $ UV.appendVector ms $! b+                      liftIO $ UV.appendVector ys $! b+                      invokeEvent p $ triggerSignal s b++  {-# INLINABLE freezeVar #-}+  freezeVar v =+    Event $ \p ->+    liftIO $+    do xs <- UV.freezeVector (varXS v)+       ms <- UV.freezeVector (varMS v)+       ys <- UV.freezeVector (varYS v)+       return (xs, ms, ys)+     +  {-# INLINE varChanged #-}+  varChanged v = publishSignal (varChangedSource v)++  {-# INLINE varChanged_ #-}+  varChanged_ v = mapSignal (const ()) $ varChanged v
Simulation/Aivika/Trans.hs view
@@ -1,35 +1,38 @@  -- | -- Module     : Simulation.Aivika.Trans--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module re-exports the most part of the library functionality.--- But there are modules that must be imported explicitly, though.+-- There are modules that must be imported explicitly, though. -- module Simulation.Aivika.Trans        (-- * Modules         module Simulation.Aivika.Trans.Activity,+        module Simulation.Aivika.Trans.Activity.Random,         module Simulation.Aivika.Trans.Agent,         module Simulation.Aivika.Trans.Arrival,         module Simulation.Aivika.Trans.Circuit,         module Simulation.Aivika.Trans.Comp,-        module Simulation.Aivika.Trans.Comp.IO,-        module Simulation.Aivika.Trans.Comp.Template,         module Simulation.Aivika.Trans.Cont,+        module Simulation.Aivika.Trans.DES,         module Simulation.Aivika.Trans.Dynamics,         module Simulation.Aivika.Trans.Dynamics.Extra,         module Simulation.Aivika.Trans.Dynamics.Memo.Unboxed,         module Simulation.Aivika.Trans.Dynamics.Random,         module Simulation.Aivika.Trans.Event,+        module Simulation.Aivika.Trans.Exception,+        module Simulation.Aivika.Trans.Gate,         module Simulation.Aivika.Trans.Generator,         module Simulation.Aivika.Trans.Net,         module Simulation.Aivika.Trans.Parameter,         module Simulation.Aivika.Trans.Parameter.Random,         module Simulation.Aivika.Trans.Process,+        module Simulation.Aivika.Trans.Process.Random,         module Simulation.Aivika.Trans.Processor,         module Simulation.Aivika.Trans.Processor.RoundRobbin,         module Simulation.Aivika.Trans.QueueStrategy,@@ -38,7 +41,9 @@         module Simulation.Aivika.Trans.Results,         module Simulation.Aivika.Trans.Results.Locale,         module Simulation.Aivika.Trans.Results.IO,+        module Simulation.Aivika.Trans.SD,         module Simulation.Aivika.Trans.Server,+        module Simulation.Aivika.Trans.Server.Random,         module Simulation.Aivika.Trans.Signal,         module Simulation.Aivika.Trans.Simulation,         module Simulation.Aivika.Trans.Specs,@@ -47,30 +52,36 @@         module Simulation.Aivika.Trans.Stream,         module Simulation.Aivika.Trans.Stream.Random,         module Simulation.Aivika.Trans.Task,+        module Simulation.Aivika.Trans.Template,         module Simulation.Aivika.Trans.Transform,         module Simulation.Aivika.Trans.Transform.Extra,         module Simulation.Aivika.Trans.Transform.Memo.Unboxed,         module Simulation.Aivika.Trans.Var.Unboxed) where  import Simulation.Aivika.Trans.Activity+import Simulation.Aivika.Trans.Activity.Random import Simulation.Aivika.Trans.Agent import Simulation.Aivika.Trans.Arrival import Simulation.Aivika.Trans.Circuit import Simulation.Aivika.Trans.Comp-import Simulation.Aivika.Trans.Comp.IO-import Simulation.Aivika.Trans.Comp.Template import Simulation.Aivika.Trans.Cont+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Dynamics import Simulation.Aivika.Trans.Dynamics.Extra import Simulation.Aivika.Trans.Dynamics.Memo.Unboxed import Simulation.Aivika.Trans.Dynamics.Random import Simulation.Aivika.Trans.Event+import Simulation.Aivika.Trans.Exception+import Simulation.Aivika.Trans.Gate import Simulation.Aivika.Trans.Generator import Simulation.Aivika.Trans.Net+import Simulation.Aivika.Trans.Net.Random import Simulation.Aivika.Trans.Parameter import Simulation.Aivika.Trans.Parameter.Random import Simulation.Aivika.Trans.Process+import Simulation.Aivika.Trans.Process.Random import Simulation.Aivika.Trans.Processor+import Simulation.Aivika.Trans.Processor.Random import Simulation.Aivika.Trans.Processor.RoundRobbin import Simulation.Aivika.Trans.QueueStrategy import Simulation.Aivika.Trans.Ref@@ -78,7 +89,9 @@ import Simulation.Aivika.Trans.Results import Simulation.Aivika.Trans.Results.Locale import Simulation.Aivika.Trans.Results.IO+import Simulation.Aivika.Trans.SD import Simulation.Aivika.Trans.Server+import Simulation.Aivika.Trans.Server.Random import Simulation.Aivika.Trans.Signal import Simulation.Aivika.Trans.Simulation import Simulation.Aivika.Trans.Specs@@ -87,6 +100,7 @@ import Simulation.Aivika.Trans.Stream import Simulation.Aivika.Trans.Stream.Random import Simulation.Aivika.Trans.Task+import Simulation.Aivika.Trans.Template import Simulation.Aivika.Trans.Transform import Simulation.Aivika.Trans.Transform.Extra import Simulation.Aivika.Trans.Transform.Memo.Unboxed
Simulation/Aivika/Trans/Activity.hs view
@@ -1,22 +1,21 @@  -- | -- Module     : Simulation.Aivika.Trans.Activity--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- It models an activity that can be utilised. The activity is similar to a 'Server' -- but destined for simulation within 'Net' computation. module Simulation.Aivika.Trans.Activity        (-- * Activity         Activity,-        ActivityInterruption(..),         newActivity,         newStateActivity,-        newInterruptibleActivity,-        newInterruptibleStateActivity,+        newPreemptibleActivity,+        newPreemptibleStateActivity,         -- * Processing         activityNet,         -- * Activity Properties@@ -24,10 +23,13 @@         activityState,         activityTotalUtilisationTime,         activityTotalIdleTime,+        activityTotalPreemptionTime,         activityUtilisationTime,         activityIdleTime,+        activityPreemptionTime,         activityUtilisationFactor,         activityIdleFactor,+        activityPreemptionFactor,         -- * Summary         activitySummary,         -- * Derived Signals for Properties@@ -37,18 +39,25 @@         activityTotalUtilisationTimeChanged_,         activityTotalIdleTimeChanged,         activityTotalIdleTimeChanged_,+        activityTotalPreemptionTimeChanged,+        activityTotalPreemptionTimeChanged_,         activityUtilisationTimeChanged,         activityUtilisationTimeChanged_,         activityIdleTimeChanged,         activityIdleTimeChanged_,+        activityPreemptionTimeChanged,+        activityPreemptionTimeChanged_,         activityUtilisationFactorChanged,         activityUtilisationFactorChanged_,         activityIdleFactorChanged,         activityIdleFactorChanged_,+        activityPreemptionFactorChanged,+        activityPreemptionFactorChanged_,         -- * Basic Signals         activityUtilising,         activityUtilised,-        activityInterrupted,+        activityPreemptionBeginning,+        activityPreemptionEnding,         -- * Overall Signal         activityChanged_) where @@ -58,15 +67,14 @@ import Control.Monad.Trans import Control.Arrow -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Parameter import Simulation.Aivika.Trans.Simulation import Simulation.Aivika.Trans.Dynamics import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Event-import Simulation.Aivika.Trans.Internal.Signal+import Simulation.Aivika.Trans.Signal import Simulation.Aivika.Trans.Resource import Simulation.Aivika.Trans.Cont import Simulation.Aivika.Trans.Process@@ -74,105 +82,118 @@ import Simulation.Aivika.Trans.Server import Simulation.Aivika.Trans.Statistics -import Simulation.Aivika.Activity (ActivityInterruption(..))- -- | Like 'Server' it models an activity that takes @a@ and provides @b@ having state @s@. -- But unlike the former the activity is destined for simulation within 'Net' computation. data Activity m s a b =   Activity { activityInitState :: s,              -- ^ The initial state of the activity.-             activityStateRef :: ProtoRef m s,+             activityStateRef :: Ref m s,              -- ^ The current state of the activity.              activityProcess :: s -> a -> Process m (s, b),              -- ^ Provide @b@ by specified @a@.-             activityProcessInterruptible :: Bool,-             -- ^ Whether the process is interruptible.-             activityTotalUtilisationTimeRef :: ProtoRef m Double,+             activityProcessPreemptible :: Bool,+             -- ^ Whether the process is preemptible.+             activityTotalUtilisationTimeRef :: Ref m Double,              -- ^ The counted total time of utilising the activity.-             activityTotalIdleTimeRef :: ProtoRef m Double,-             -- ^ The counted total time, when the activity was idle.-             activityUtilisationTimeRef :: ProtoRef m (SamplingStats Double),+             activityTotalIdleTimeRef :: Ref m Double,+             -- ^ The counted total time when the activity was idle.+             activityTotalPreemptionTimeRef :: Ref m Double,+             -- ^ The counted total time when the activity was preempted. +             activityUtilisationTimeRef :: Ref m (SamplingStats Double),              -- ^ The statistics for the utilisation time.-             activityIdleTimeRef :: ProtoRef m (SamplingStats Double),-             -- ^ The statistics for the time, when the activity was idle.+             activityIdleTimeRef :: Ref m (SamplingStats Double),+             -- ^ The statistics for the time when the activity was idle.+             activityPreemptionTimeRef :: Ref m (SamplingStats Double),+             -- ^ The statistics for the time when the activity was preempted.              activityUtilisingSource :: SignalSource m a,              -- ^ A signal raised when starting to utilise the activity.              activityUtilisedSource :: SignalSource m (a, b),              -- ^ A signal raised when the activity has been utilised.-             activityInterruptedSource :: SignalSource m (ActivityInterruption a)-             -- ^ A signal raised when the utilisation was interrupted.+             activityPreemptionBeginningSource :: SignalSource m a,+             -- ^ A signal raised when the utilisation was preempted.+             activityPreemptionEndingSource :: SignalSource m a+             -- ^ A signal raised when the utilisation was proceeded after it had been preempted earlier.            }  -- | Create a new activity that can provide output @b@ by input @a@. ----- By default, it is assumed that the activity utilisation cannot be interrupted,--- because the handling of possible task interruption is rather costly+-- By default, it is assumed that the activity utilisation cannot be preempted,+-- because the handling of possible task preemption is rather costly -- operation.-newActivity :: MonadComp m+newActivity :: MonadDES m                => (a -> Process m b)                -- ^ provide an output by the specified input                -> Simulation m (Activity m () a b)-newActivity = newInterruptibleActivity False+{-# INLINABLE newActivity #-}+newActivity = newPreemptibleActivity False  -- | Create a new activity that can provide output @b@ by input @a@ -- starting from state @s@. ----- By default, it is assumed that the activity utilisation cannot be interrupted,--- because the handling of possible task interruption is rather costly+-- By default, it is assumed that the activity utilisation cannot be preempted,+-- because the handling of possible task preemption is rather costly -- operation.-newStateActivity :: MonadComp m+newStateActivity :: MonadDES m                     => (s -> a -> Process m (s, b))                     -- ^ provide a new state and output by the specified                      -- old state and input                     -> s                     -- ^ the initial state                     -> Simulation m (Activity m s a b)-newStateActivity = newInterruptibleStateActivity False+{-# INLINABLE newStateActivity #-}+newStateActivity = newPreemptibleStateActivity False  -- | Create a new interruptible activity that can provide output @b@ by input @a@.-newInterruptibleActivity :: MonadComp m-                            => Bool-                            -- ^ whether the activity can be interrupted-                            -> (a -> Process m b)-                            -- ^ provide an output by the specified input-                            -> Simulation m (Activity m () a b)-newInterruptibleActivity interruptible provide =-  flip (newInterruptibleStateActivity interruptible) () $ \s a ->+newPreemptibleActivity :: MonadDES m+                          => Bool+                          -- ^ whether the activity can be preempted+                          -> (a -> Process m b)+                          -- ^ provide an output by the specified input+                          -> Simulation m (Activity m () a b)+{-# INLINABLE newPreemptibleActivity #-}+newPreemptibleActivity preemptible provide =+  flip (newPreemptibleStateActivity preemptible) () $ \s a ->   do b <- provide a      return (s, b)  -- | Create a new activity that can provide output @b@ by input @a@ -- starting from state @s@.-newInterruptibleStateActivity :: MonadComp m-                                 => Bool-                                 -- ^ whether the activity can be interrupted-                                 -> (s -> a -> Process m (s, b))-                                 -- ^ provide a new state and output by the specified -                                 -- old state and input-                                 -> s-                                 -- ^ the initial state-                                 -> Simulation m (Activity m s a b)-newInterruptibleStateActivity interruptible provide state =-  do sn <- liftParameter simulationSession-     r0 <- liftComp $ newProtoRef sn state-     r1 <- liftComp $ newProtoRef sn 0-     r2 <- liftComp $ newProtoRef sn 0-     r3 <- liftComp $ newProtoRef sn emptySamplingStats-     r4 <- liftComp $ newProtoRef sn emptySamplingStats+newPreemptibleStateActivity :: MonadDES m+                               => Bool+                               -- ^ whether the activity can be preempted+                               -> (s -> a -> Process m (s, b))+                               -- ^ provide a new state and output by the specified +                               -- old state and input+                               -> s+                               -- ^ the initial state+                               -> Simulation m (Activity m s a b)+{-# INLINABLE newPreemptibleStateActivity #-}+newPreemptibleStateActivity preemptible provide state =+  do r0 <- newRef state+     r1 <- newRef 0+     r2 <- newRef 0+     r3 <- newRef 0+     r4 <- newRef emptySamplingStats+     r5 <- newRef emptySamplingStats+     r6 <- newRef emptySamplingStats      s1 <- newSignalSource      s2 <- newSignalSource      s3 <- newSignalSource+     s4 <- newSignalSource      return Activity { activityInitState = state,                        activityStateRef = r0,                        activityProcess = provide,-                       activityProcessInterruptible = interruptible,+                       activityProcessPreemptible = preemptible,                        activityTotalUtilisationTimeRef = r1,                        activityTotalIdleTimeRef = r2,-                       activityUtilisationTimeRef = r3,-                       activityIdleTimeRef = r4,+                       activityTotalPreemptionTimeRef = r3,+                       activityUtilisationTimeRef = r4,+                       activityIdleTimeRef = r5,+                       activityPreemptionTimeRef = r6,                        activityUtilisingSource = s1,                        activityUtilisedSource = s2,-                       activityInterruptedSource = s3 }+                       activityPreemptionBeginningSource = s3,+                       activityPreemptionEndingSource = s4 }  -- | Return a network computation for the specified activity. --@@ -187,7 +208,8 @@ -- whole, where the first activity will take a new task only after the last activity  -- finishes its current task and requests for the next one from the previous activity  -- in the chain. This is not always that thing you might need.-activityNet :: MonadComp m => Activity m s a b -> Net m a b+activityNet :: MonadDES m => Activity m s a b -> Net m a b+{-# INLINABLE activityNet #-} activityNet act = Net $ loop (activityInitState act) Nothing   where     loop s r a =@@ -196,57 +218,74 @@            do case r of                 Nothing -> return ()                 Just t' ->-                  liftComp $-                  do modifyProtoRef' (activityTotalIdleTimeRef act) (+ (t0 - t'))-                     modifyProtoRef' (activityIdleTimeRef act) $+                  do modifyRef (activityTotalIdleTimeRef act) (+ (t0 - t'))+                     modifyRef (activityIdleTimeRef act) $                        addSamplingStats (t0 - t')               triggerSignal (activityUtilisingSource act) a          -- utilise the activity-         (s', b) <- if activityProcessInterruptible act-                    then activityProcessInterrupting act s a-                    else activityProcess act s a+         (s', b, dt) <- if activityProcessPreemptible act+                        then activityProcessPreempting act s a+                        else do (s', b) <- activityProcess act s a+                                return (s', b, 0)          t1 <- liftDynamics time          liftEvent $-           do liftComp $-                do writeProtoRef (activityStateRef act) $! s'-                   modifyProtoRef' (activityTotalUtilisationTimeRef act) (+ (t1 - t0))-                   modifyProtoRef' (activityUtilisationTimeRef act) $-                     addSamplingStats (t1 - t0)+           do writeRef (activityStateRef act) $! s'+              modifyRef (activityTotalUtilisationTimeRef act) (+ (t1 - t0 - dt))+              modifyRef (activityUtilisationTimeRef act) $+                addSamplingStats (t1 - t0 - dt)               triggerSignal (activityUtilisedSource act) (a, b)          return (b, Net $ loop s' (Just t1)) --- | Process the input with ability to handle a possible interruption.-activityProcessInterrupting :: MonadComp m => Activity m s a b -> s -> a -> Process m (s, b)-activityProcessInterrupting act s a =+-- | Process the input with ability to handle a possible preemption.+activityProcessPreempting :: MonadDES m => Activity m s a b -> s -> a -> Process m (s, b, Double)+{-# INLINABLE activityProcessPreempting #-}+activityProcessPreempting act s a =   do pid <- processId      t0  <- liftDynamics time-     finallyProcess-       (activityProcess act s a)-       (liftEvent $-        do cancelled <- processCancelled pid-           when cancelled $-             do t1 <- liftDynamics time-                liftComp $-                  do modifyProtoRef' (activityTotalUtilisationTimeRef act) (+ (t1 - t0))-                     modifyProtoRef' (activityUtilisationTimeRef act) $-                       addSamplingStats (t1 - t0)-                let x = ActivityInterruption a t0 t1-                triggerSignal (activityInterruptedSource act) x)+     rs  <- liftSimulation $ newRef 0+     r0  <- liftSimulation $ newRef t0+     h1  <- liftEvent $+            handleSignal (processPreemptionBeginning pid) $ \() ->+            do t0 <- liftDynamics time+               writeRef r0 t0+               triggerSignal (activityPreemptionBeginningSource act) a+     h2  <- liftEvent $+            handleSignal (processPreemptionEnding pid) $ \() ->+            do t0 <- readRef r0+               t1 <- liftDynamics time+               let dt = t1 - t0+               modifyRef rs (+ dt)+               modifyRef (activityTotalPreemptionTimeRef act) (+ dt)+               modifyRef (activityPreemptionTimeRef act) $+                 addSamplingStats dt+               triggerSignal (activityPreemptionEndingSource act) a +     let m1 =+           do (s', b) <- activityProcess act s a+              dt <- liftEvent $ readRef rs+              return (s', b, dt)+         m2 =+           liftEvent $+           do disposeEvent h1+              disposeEvent h2+     finallyProcess m1 m2  -- | Return the current state of the activity. -- -- See also 'activityStateChanged' and 'activityStateChanged_'.-activityState :: MonadComp m => Activity m s a b -> Event m s+activityState :: MonadDES m => Activity m s a b -> Event m s+{-# INLINABLE activityState #-} activityState act =-  Event $ \p -> readProtoRef (activityStateRef act)+  Event $ \p -> invokeEvent p $ readRef (activityStateRef act)    -- | Signal when the 'activityState' property value has changed.-activityStateChanged :: MonadComp m => Activity m s a b -> Signal m s+activityStateChanged :: MonadDES m => Activity m s a b -> Signal m s+{-# INLINABLE activityStateChanged #-} activityStateChanged act =   mapSignalM (const $ activityState act) (activityStateChanged_ act)    -- | Signal when the 'activityState' property value has changed.-activityStateChanged_ :: MonadComp m => Activity m s a b -> Signal m ()+activityStateChanged_ :: MonadDES m => Activity m s a b -> Signal m ()+{-# INLINABLE activityStateChanged_ #-} activityStateChanged_ act =   mapSignal (const ()) (activityUtilised act) @@ -256,17 +295,20 @@ -- to the current simulation time. -- -- See also 'activityTotalUtilisationTimeChanged' and 'activityTotalUtilisationTimeChanged_'.-activityTotalUtilisationTime :: MonadComp m => Activity m s a b -> Event m Double+activityTotalUtilisationTime :: MonadDES m => Activity m s a b -> Event m Double+{-# INLINABLE activityTotalUtilisationTime #-} activityTotalUtilisationTime act =-  Event $ \p -> readProtoRef (activityTotalUtilisationTimeRef act)+  Event $ \p -> invokeEvent p $ readRef (activityTotalUtilisationTimeRef act)    -- | Signal when the 'activityTotalUtilisationTime' property value has changed.-activityTotalUtilisationTimeChanged :: MonadComp m => Activity m s a b -> Signal m Double+activityTotalUtilisationTimeChanged :: MonadDES m => Activity m s a b -> Signal m Double+{-# INLINABLE activityTotalUtilisationTimeChanged #-} activityTotalUtilisationTimeChanged act =   mapSignalM (const $ activityTotalUtilisationTime act) (activityTotalUtilisationTimeChanged_ act)    -- | Signal when the 'activityTotalUtilisationTime' property value has changed.-activityTotalUtilisationTimeChanged_ :: MonadComp m => Activity m s a b -> Signal m ()+activityTotalUtilisationTimeChanged_ :: MonadDES m => Activity m s a b -> Signal m ()+{-# INLINABLE activityTotalUtilisationTimeChanged_ #-} activityTotalUtilisationTimeChanged_ act =   mapSignal (const ()) (activityUtilised act) @@ -276,37 +318,67 @@ -- to the current simulation time. -- -- See also 'activityTotalIdleTimeChanged' and 'activityTotalIdleTimeChanged_'.-activityTotalIdleTime :: MonadComp m => Activity m s a b -> Event m Double+activityTotalIdleTime :: MonadDES m => Activity m s a b -> Event m Double+{-# INLINABLE activityTotalIdleTime #-} activityTotalIdleTime act =-  Event $ \p -> readProtoRef (activityTotalIdleTimeRef act)+  Event $ \p -> invokeEvent p $ readRef (activityTotalIdleTimeRef act)    -- | Signal when the 'activityTotalIdleTime' property value has changed.-activityTotalIdleTimeChanged :: MonadComp m => Activity m s a b -> Signal m Double+activityTotalIdleTimeChanged :: MonadDES m => Activity m s a b -> Signal m Double+{-# INLINABLE activityTotalIdleTimeChanged #-} activityTotalIdleTimeChanged act =   mapSignalM (const $ activityTotalIdleTime act) (activityTotalIdleTimeChanged_ act)    -- | Signal when the 'activityTotalIdleTime' property value has changed.-activityTotalIdleTimeChanged_ :: MonadComp m => Activity m s a b -> Signal m ()+activityTotalIdleTimeChanged_ :: MonadDES m => Activity m s a b -> Signal m ()+{-# INLINABLE activityTotalIdleTimeChanged_ #-} activityTotalIdleTimeChanged_ act =   mapSignal (const ()) (activityUtilising act) +-- | Return the counted total time when the activity was preemted waiting for+-- the further proceeding.+--+-- The value returned changes discretely and it is usually delayed relative+-- to the current simulation time.+--+-- See also 'activityTotalPreemptionTimeChanged' and 'activityTotalPreemptionTimeChanged_'.+activityTotalPreemptionTime :: MonadDES m => Activity m s a b -> Event m Double+{-# INLINABLE activityTotalPreemptionTime #-}+activityTotalPreemptionTime act =+  Event $ \p -> invokeEvent p $ readRef (activityTotalPreemptionTimeRef act)+  +-- | Signal when the 'activityTotalPreemptionTime' property value has changed.+activityTotalPreemptionTimeChanged :: MonadDES m => Activity m s a b -> Signal m Double+{-# INLINABLE activityTotalPreemptionTimeChanged #-}+activityTotalPreemptionTimeChanged act =+  mapSignalM (const $ activityTotalPreemptionTime act) (activityTotalPreemptionTimeChanged_ act)+  +-- | Signal when the 'activityTotalPreemptionTime' property value has changed.+activityTotalPreemptionTimeChanged_ :: MonadDES m => Activity m s a b -> Signal m ()+{-# INLINABLE activityTotalPreemptionTimeChanged_ #-}+activityTotalPreemptionTimeChanged_ act =+  mapSignal (const ()) (activityPreemptionEnding act)+ -- | Return the statistics for the time when the activity was utilised. -- -- The value returned changes discretely and it is usually delayed relative -- to the current simulation time. -- -- See also 'activityUtilisationTimeChanged' and 'activityUtilisationTimeChanged_'.-activityUtilisationTime :: MonadComp m => Activity m s a b -> Event m (SamplingStats Double)+activityUtilisationTime :: MonadDES m => Activity m s a b -> Event m (SamplingStats Double)+{-# INLINABLE activityUtilisationTime #-} activityUtilisationTime act =-  Event $ \p -> readProtoRef (activityUtilisationTimeRef act)+  Event $ \p -> invokeEvent p $ readRef (activityUtilisationTimeRef act)    -- | Signal when the 'activityUtilisationTime' property value has changed.-activityUtilisationTimeChanged :: MonadComp m => Activity m s a b -> Signal m (SamplingStats Double)+activityUtilisationTimeChanged :: MonadDES m => Activity m s a b -> Signal m (SamplingStats Double)+{-# INLINABLE activityUtilisationTimeChanged #-} activityUtilisationTimeChanged act =   mapSignalM (const $ activityUtilisationTime act) (activityUtilisationTimeChanged_ act)    -- | Signal when the 'activityUtilisationTime' property value has changed.-activityUtilisationTimeChanged_ :: MonadComp m => Activity m s a b -> Signal m ()+activityUtilisationTimeChanged_ :: MonadDES m => Activity m s a b -> Signal m ()+{-# INLINABLE activityUtilisationTimeChanged_ #-} activityUtilisationTimeChanged_ act =   mapSignal (const ()) (activityUtilised act) @@ -316,50 +388,82 @@ -- to the current simulation time. -- -- See also 'activityIdleTimeChanged' and 'activityIdleTimeChanged_'.-activityIdleTime :: MonadComp m => Activity m s a b -> Event m (SamplingStats Double)+activityIdleTime :: MonadDES m => Activity m s a b -> Event m (SamplingStats Double)+{-# INLINABLE activityIdleTime #-} activityIdleTime act =-  Event $ \p -> readProtoRef (activityIdleTimeRef act)+  Event $ \p -> invokeEvent p $ readRef (activityIdleTimeRef act)    -- | Signal when the 'activityIdleTime' property value has changed.-activityIdleTimeChanged :: MonadComp m => Activity m s a b -> Signal m (SamplingStats Double)+activityIdleTimeChanged :: MonadDES m => Activity m s a b -> Signal m (SamplingStats Double)+{-# INLINABLE activityIdleTimeChanged #-} activityIdleTimeChanged act =   mapSignalM (const $ activityIdleTime act) (activityIdleTimeChanged_ act)    -- | Signal when the 'activityIdleTime' property value has changed.-activityIdleTimeChanged_ :: MonadComp m => Activity m s a b -> Signal m ()+activityIdleTimeChanged_ :: MonadDES m => Activity m s a b -> Signal m ()+{-# INLINABLE activityIdleTimeChanged_ #-} activityIdleTimeChanged_ act =   mapSignal (const ()) (activityUtilising act)++-- | Return the statistics for the time when the activity was preempted+-- waiting for the further proceeding.+--+-- The value returned changes discretely and it is usually delayed relative+-- to the current simulation time.+--+-- See also 'activityPreemptionTimeChanged' and 'activityPreemptionTimeChanged_'.+activityPreemptionTime :: MonadDES m => Activity m s a b -> Event m (SamplingStats Double)+{-# INLINABLE activityPreemptionTime #-}+activityPreemptionTime act =+  Event $ \p -> invokeEvent p $ readRef (activityPreemptionTimeRef act)   +-- | Signal when the 'activityPreemptionTime' property value has changed.+activityPreemptionTimeChanged :: MonadDES m => Activity m s a b -> Signal m (SamplingStats Double)+{-# INLINABLE activityPreemptionTimeChanged #-}+activityPreemptionTimeChanged act =+  mapSignalM (const $ activityPreemptionTime act) (activityPreemptionTimeChanged_ act)+  +-- | Signal when the 'activityPreemptionTime' property value has changed.+activityPreemptionTimeChanged_ :: MonadDES m => Activity m s a b -> Signal m ()+{-# INLINABLE activityPreemptionTimeChanged_ #-}+activityPreemptionTimeChanged_ act =+  mapSignal (const ()) (activityPreemptionEnding act)+   -- | It returns the factor changing from 0 to 1, which estimates how often -- the activity was utilised. -- -- This factor is calculated as -- -- @---   totalUtilisationTime \/ (totalUtilisationTime + totalIdleTime)+--   totalUtilisationTime \/ (totalUtilisationTime + totalIdleTime + totalPreemptionTime) -- @ -- -- As before in this module, the value returned changes discretely and -- it is usually delayed relative to the current simulation time. -- -- See also 'activityUtilisationFactorChanged' and 'activityUtilisationFactorChanged_'.-activityUtilisationFactor :: MonadComp m => Activity m s a b -> Event m Double+activityUtilisationFactor :: MonadDES m => Activity m s a b -> Event m Double+{-# INLINABLE activityUtilisationFactor #-} activityUtilisationFactor act =   Event $ \p ->-  do x1 <- readProtoRef (activityTotalUtilisationTimeRef act)-     x2 <- readProtoRef (activityTotalIdleTimeRef act)-     return (x1 / (x1 + x2))+  do x1 <- invokeEvent p $ readRef (activityTotalUtilisationTimeRef act)+     x2 <- invokeEvent p $ readRef (activityTotalIdleTimeRef act)+     x3 <- invokeEvent p $ readRef (activityTotalPreemptionTimeRef act)+     return (x1 / (x1 + x2 + x3))    -- | Signal when the 'activityUtilisationFactor' property value has changed.-activityUtilisationFactorChanged :: MonadComp m => Activity m s a b -> Signal m Double+activityUtilisationFactorChanged :: MonadDES m => Activity m s a b -> Signal m Double+{-# INLINABLE activityUtilisationFactorChanged #-} activityUtilisationFactorChanged act =   mapSignalM (const $ activityUtilisationFactor act) (activityUtilisationFactorChanged_ act)    -- | Signal when the 'activityUtilisationFactor' property value has changed.-activityUtilisationFactorChanged_ :: MonadComp m => Activity m s a b -> Signal m ()+activityUtilisationFactorChanged_ :: MonadDES m => Activity m s a b -> Signal m ()+{-# INLINABLE activityUtilisationFactorChanged_ #-} activityUtilisationFactorChanged_ act =   mapSignal (const ()) (activityUtilising act) <>-  mapSignal (const ()) (activityUtilised act)+  mapSignal (const ()) (activityUtilised act) <>+  mapSignal (const ()) (activityPreemptionEnding act)    -- | It returns the factor changing from 0 to 1, which estimates how often -- the activity was idle.@@ -367,61 +471,115 @@ -- This factor is calculated as -- -- @---   totalIdleTime \/ (totalUtilisationTime + totalIdleTime)+--   totalIdleTime \/ (totalUtilisationTime + totalIdleTime + totalPreemptionTime) -- @ -- -- As before in this module, the value returned changes discretely and -- it is usually delayed relative to the current simulation time. -- -- See also 'activityIdleFactorChanged' and 'activityIdleFactorChanged_'.-activityIdleFactor :: MonadComp m => Activity m s a b -> Event m Double+activityIdleFactor :: MonadDES m => Activity m s a b -> Event m Double+{-# INLINABLE activityIdleFactor #-} activityIdleFactor act =   Event $ \p ->-  do x1 <- readProtoRef (activityTotalUtilisationTimeRef act)-     x2 <- readProtoRef (activityTotalIdleTimeRef act)-     return (x2 / (x1 + x2))+  do x1 <- invokeEvent p $ readRef (activityTotalUtilisationTimeRef act)+     x2 <- invokeEvent p $ readRef (activityTotalIdleTimeRef act)+     x3 <- invokeEvent p $ readRef (activityTotalPreemptionTimeRef act)+     return (x2 / (x1 + x2 + x3))    -- | Signal when the 'activityIdleFactor' property value has changed.-activityIdleFactorChanged :: MonadComp m => Activity m s a b -> Signal m Double+activityIdleFactorChanged :: MonadDES m => Activity m s a b -> Signal m Double+{-# INLINABLE activityIdleFactorChanged #-} activityIdleFactorChanged act =   mapSignalM (const $ activityIdleFactor act) (activityIdleFactorChanged_ act)    -- | Signal when the 'activityIdleFactor' property value has changed.-activityIdleFactorChanged_ :: MonadComp m => Activity m s a b -> Signal m ()+activityIdleFactorChanged_ :: MonadDES m => Activity m s a b -> Signal m ()+{-# INLINABLE activityIdleFactorChanged_ #-} activityIdleFactorChanged_ act =   mapSignal (const ()) (activityUtilising act) <>-  mapSignal (const ()) (activityUtilised act)+  mapSignal (const ()) (activityUtilised act) <>+  mapSignal (const ()) (activityPreemptionEnding act) +-- | It returns the factor changing from 0 to 1, which estimates how often+-- the activity was preempted waiting for the further proceeding.+--+-- This factor is calculated as+--+-- @+--   totalUtilisationTime \/ (totalUtilisationTime + totalIdleTime + totalPreemptionTime)+-- @+--+-- As before in this module, the value returned changes discretely and+-- it is usually delayed relative to the current simulation time.+--+-- See also 'activityPreemptionFactorChanged' and 'activityPreemptionFactorChanged_'.+activityPreemptionFactor :: MonadDES m => Activity m s a b -> Event m Double+{-# INLINABLE activityPreemptionFactor #-}+activityPreemptionFactor act =+  Event $ \p ->+  do x1 <- invokeEvent p $ readRef (activityTotalUtilisationTimeRef act)+     x2 <- invokeEvent p $ readRef (activityTotalIdleTimeRef act)+     x3 <- invokeEvent p $ readRef (activityTotalPreemptionTimeRef act)+     return (x3 / (x1 + x2 + x3))+  +-- | Signal when the 'activityPreemptionFactor' property value has changed.+activityPreemptionFactorChanged :: MonadDES m => Activity m s a b -> Signal m Double+{-# INLINABLE activityPreemptionFactorChanged #-}+activityPreemptionFactorChanged act =+  mapSignalM (const $ activityPreemptionFactor act) (activityPreemptionFactorChanged_ act)+  +-- | Signal when the 'activityPreemptionFactor' property value has changed.+activityPreemptionFactorChanged_ :: MonadDES m => Activity m s a b -> Signal m ()+{-# INLINABLE activityPreemptionFactorChanged_ #-}+activityPreemptionFactorChanged_ act =+  mapSignal (const ()) (activityUtilising act) <>+  mapSignal (const ()) (activityUtilised act) <>+  mapSignal (const ()) (activityPreemptionEnding act)+   -- | Raised when starting to utilise the activity after a new input task is received. activityUtilising :: Activity m s a b -> Signal m a+{-# INLINABLE activityUtilising #-} activityUtilising = publishSignal . activityUtilisingSource  -- | Raised when the activity has been utilised after the current task is processed. activityUtilised :: Activity m s a b -> Signal m (a, b)+{-# INLINABLE activityUtilised #-} activityUtilised = publishSignal . activityUtilisedSource --- | Raised when the task utilisation by the activity was interrupted.-activityInterrupted :: Activity m s a b -> Signal m (ActivityInterruption a)-activityInterrupted = publishSignal . activityInterruptedSource+-- | Raised when the activity utilisation was preempted.+activityPreemptionBeginning :: Activity m s a b -> Signal m a+{-# INLINABLE activityPreemptionBeginning #-}+activityPreemptionBeginning = publishSignal . activityPreemptionBeginningSource +-- | Raised when the activity utilisation was proceeded after it had been preempted earlier.+activityPreemptionEnding :: Activity m s a b -> Signal m a+{-# INLINABLE activityPreemptionEnding #-}+activityPreemptionEnding = publishSignal . activityPreemptionEndingSource+ -- | Signal whenever any property of the activity changes.-activityChanged_ :: MonadComp m => Activity m s a b -> Signal m ()+activityChanged_ :: MonadDES m => Activity m s a b -> Signal m ()+{-# INLINABLE activityChanged_ #-} activityChanged_ act =   mapSignal (const ()) (activityUtilising act) <>   mapSignal (const ()) (activityUtilised act) <>-  mapSignal (const ()) (activityInterrupted act)+  mapSignal (const ()) (activityPreemptionEnding act)  -- | Return the summary for the activity with desciption of its -- properties using the specified indent.-activitySummary :: MonadComp m => Activity m s a b -> Int -> Event m ShowS+activitySummary :: MonadDES m => Activity m s a b -> Int -> Event m ShowS+{-# INLINABLE activitySummary #-} activitySummary act indent =   Event $ \p ->-  do tx1 <- readProtoRef (activityTotalUtilisationTimeRef act)-     tx2 <- readProtoRef (activityTotalIdleTimeRef act)-     let xf1 = tx1 / (tx1 + tx2)-         xf2 = tx2 / (tx1 + tx2)-     xs1 <- readProtoRef (activityUtilisationTimeRef act)-     xs2 <- readProtoRef (activityIdleTimeRef act)+  do tx1 <- invokeEvent p $ readRef (activityTotalUtilisationTimeRef act)+     tx2 <- invokeEvent p $ readRef (activityTotalIdleTimeRef act)+     tx3 <- invokeEvent p $ readRef (activityTotalPreemptionTimeRef act)+     let xf1 = tx1 / (tx1 + tx2 + tx3)+         xf2 = tx2 / (tx1 + tx2 + tx3)+         xf3 = tx3 / (tx1 + tx2 + tx3)+     xs1 <- invokeEvent p $ readRef (activityUtilisationTimeRef act)+     xs2 <- invokeEvent p $ readRef (activityIdleTimeRef act)+     xs3 <- invokeEvent p $ readRef (activityPreemptionTimeRef act)      let tab = replicate indent ' '      return $        showString tab .@@ -431,15 +589,24 @@        showString "total idle time = " . shows tx2 .        showString "\n" .        showString tab .+       showString "total preemption time = " . shows tx3 .+       showString "\n" .+       showString tab .        showString "utilisation factor (from 0 to 1) = " . shows xf1 .        showString "\n" .        showString tab .        showString "idle factor (from 0 to 1) = " . shows xf2 .        showString "\n" .        showString tab .+       showString "preemption factor (from 0 to 1) = " . shows xf3 .+       showString "\n" .+       showString tab .        showString "utilisation time (locked while awaiting the input):\n\n" .        samplingStatsSummary xs1 (2 + indent) .        showString "\n\n" .        showString tab .        showString "idle time:\n\n" .-       samplingStatsSummary xs2 (2 + indent)+       samplingStatsSummary xs2 (2 + indent) .+       showString tab .+       showString "preemption time:\n\n" .+       samplingStatsSummary xs3 (2 + indent)
+ Simulation/Aivika/Trans/Activity/Random.hs view
@@ -0,0 +1,259 @@++-- |+-- Module     : Simulation.Aivika.Trans.Activity.Random+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- This module defines some useful predefined activities that+-- hold the current process for the corresponding random time+-- interval, when processing every input element.+--++module Simulation.Aivika.Trans.Activity.Random+       (newRandomUniformActivity,+        newRandomUniformIntActivity,+        newRandomNormalActivity,+        newRandomExponentialActivity,+        newRandomErlangActivity,+        newRandomPoissonActivity,+        newRandomBinomialActivity,+        newPreemptibleRandomUniformActivity,+        newPreemptibleRandomUniformIntActivity,+        newPreemptibleRandomNormalActivity,+        newPreemptibleRandomExponentialActivity,+        newPreemptibleRandomErlangActivity,+        newPreemptibleRandomPoissonActivity,+        newPreemptibleRandomBinomialActivity) where++import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Simulation+import Simulation.Aivika.Trans.Process+import Simulation.Aivika.Trans.Process.Random+import Simulation.Aivika.Trans.Activity++-- | Create a new activity that holds the process for a random time interval+-- distributed uniformly, when processing every input element.+--+-- By default, it is assumed that the activity process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomUniformActivity :: MonadDES m+                            => Double+                            -- ^ the minimum time interval+                            -> Double+                            -- ^ the maximum time interval+                            -> Simulation m (Activity m () a a)+{-# INLINABLE newRandomUniformActivity #-}+newRandomUniformActivity =+  newPreemptibleRandomUniformActivity False++-- | Create a new activity that holds the process for a random time interval+-- distributed uniformly, when processing every input element.+--+-- By default, it is assumed that the activity process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomUniformIntActivity :: MonadDES m+                               => Int+                               -- ^ the minimum time interval+                               -> Int+                               -- ^ the maximum time interval+                               -> Simulation m (Activity m () a a)+{-# INLINABLE newRandomUniformIntActivity #-}+newRandomUniformIntActivity =+  newPreemptibleRandomUniformIntActivity False++-- | Create a new activity that holds the process for a random time interval+-- distributed normally, when processing every input element.+--+-- By default, it is assumed that the activity process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomNormalActivity :: MonadDES m+                           => Double+                           -- ^ the mean time interval+                           -> Double+                           -- ^ the time interval deviation+                           -> Simulation m (Activity m () a a)+{-# INLINABLE newRandomNormalActivity #-}+newRandomNormalActivity =+  newPreemptibleRandomNormalActivity False+         +-- | Create a new activity that holds the process for a random time interval+-- distributed exponentially with the specified mean (the reciprocal of the rate),+-- when processing every input element.+--+-- By default, it is assumed that the activity process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomExponentialActivity :: MonadDES m+                                => Double+                                -- ^ the mean time interval (the reciprocal of the rate)+                                -> Simulation m (Activity m () a a)+{-# INLINABLE newRandomExponentialActivity #-}+newRandomExponentialActivity =+  newPreemptibleRandomExponentialActivity False+         +-- | Create a new activity that holds the process for a random time interval+-- having the Erlang distribution with the specified scale (the reciprocal of the rate)+-- and shape parameters, when processing every input element.+--+-- By default, it is assumed that the activity process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomErlangActivity :: MonadDES m+                           => Double+                           -- ^ the scale (the reciprocal of the rate)+                           -> Int+                           -- ^ the shape+                           -> Simulation m (Activity m () a a)+{-# INLINABLE newRandomErlangActivity #-}+newRandomErlangActivity =+  newPreemptibleRandomErlangActivity False++-- | Create a new activity that holds the process for a random time interval+-- having the Poisson distribution with the specified mean, when processing+-- every input element.+--+-- By default, it is assumed that the activity process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomPoissonActivity :: MonadDES m+                            => Double+                            -- ^ the mean time interval+                            -> Simulation m (Activity m () a a)+{-# INLINABLE newRandomPoissonActivity #-}+newRandomPoissonActivity =+  newPreemptibleRandomPoissonActivity False++-- | Create a new activity that holds the process for a random time interval+-- having the binomial distribution with the specified probability and trials,+-- when processing every input element.+--+-- By default, it is assumed that the activity process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomBinomialActivity :: MonadDES m+                             => Double+                             -- ^ the probability+                             -> Int+                             -- ^ the number of trials+                             -> Simulation m (Activity m () a a)+{-# INLINABLE newRandomBinomialActivity #-}+newRandomBinomialActivity =+  newPreemptibleRandomBinomialActivity False++-- | Create a new activity that holds the process for a random time interval+-- distributed uniformly, when processing every input element.+newPreemptibleRandomUniformActivity :: MonadDES m+                                       => Bool+                                       -- ^ whether the activity process can be preempted+                                       -> Double+                                       -- ^ the minimum time interval+                                       -> Double+                                       -- ^ the maximum time interval+                                       -> Simulation m (Activity m () a a)+{-# INLINABLE newPreemptibleRandomUniformActivity #-}+newPreemptibleRandomUniformActivity preemptible min max =+  newPreemptibleActivity preemptible $ \a ->+  do randomUniformProcess_ min max+     return a++-- | Create a new activity that holds the process for a random time interval+-- distributed uniformly, when processing every input element.+newPreemptibleRandomUniformIntActivity :: MonadDES m+                                          => Bool+                                          -- ^ whether the activity process can be preempted+                                          -> Int+                                          -- ^ the minimum time interval+                                          -> Int+                                          -- ^ the maximum time interval+                                          -> Simulation m (Activity m () a a)+{-# INLINABLE newPreemptibleRandomUniformIntActivity #-}+newPreemptibleRandomUniformIntActivity preemptible min max =+  newPreemptibleActivity preemptible $ \a ->+  do randomUniformIntProcess_ min max+     return a++-- | Create a new activity that holds the process for a random time interval+-- distributed normally, when processing every input element.+newPreemptibleRandomNormalActivity :: MonadDES m+                                      => Bool+                                      -- ^ whether the activity process can be preempted+                                      -> Double+                                      -- ^ the mean time interval+                                      -> Double+                                      -- ^ the time interval deviation+                                      -> Simulation m (Activity m () a a)+{-# INLINABLE newPreemptibleRandomNormalActivity #-}+newPreemptibleRandomNormalActivity preemptible mu nu =+  newPreemptibleActivity preemptible $ \a ->+  do randomNormalProcess_ mu nu+     return a+         +-- | Create a new activity that holds the process for a random time interval+-- distributed exponentially with the specified mean (the reciprocal of the rate),+-- when processing every input element.+newPreemptibleRandomExponentialActivity :: MonadDES m+                                           => Bool+                                           -- ^ whether the activity process can be preempted+                                           -> Double+                                           -- ^ the mean time interval (the reciprocal of the rate)+                                           -> Simulation m (Activity m () a a)+{-# INLINABLE newPreemptibleRandomExponentialActivity #-}+newPreemptibleRandomExponentialActivity preemptible mu =+  newPreemptibleActivity preemptible $ \a ->+  do randomExponentialProcess_ mu+     return a+         +-- | Create a new activity that holds the process for a random time interval+-- having the Erlang distribution with the specified scale (the reciprocal of the rate)+-- and shape parameters, when processing every input element.+newPreemptibleRandomErlangActivity :: MonadDES m+                                      => Bool+                                      -- ^ whether the activity process can be preempted+                                      -> Double+                                      -- ^ the scale (the reciprocal of the rate)+                                      -> Int+                                      -- ^ the shape+                                      -> Simulation m (Activity m () a a)+{-# INLINABLE newPreemptibleRandomErlangActivity #-}+newPreemptibleRandomErlangActivity preemptible beta m =+  newPreemptibleActivity preemptible $ \a ->+  do randomErlangProcess_ beta m+     return a++-- | Create a new activity that holds the process for a random time interval+-- having the Poisson distribution with the specified mean, when processing+-- every input element.+newPreemptibleRandomPoissonActivity :: MonadDES m+                                       => Bool+                                       -- ^ whether the activity process can be preempted+                                       -> Double+                                       -- ^ the mean time interval+                                       -> Simulation m (Activity m () a a)+{-# INLINABLE newPreemptibleRandomPoissonActivity #-}+newPreemptibleRandomPoissonActivity preemptible mu =+  newPreemptibleActivity preemptible $ \a ->+  do randomPoissonProcess_ mu+     return a++-- | Create a new activity that holds the process for a random time interval+-- having the binomial distribution with the specified probability and trials,+-- when processing every input element.+newPreemptibleRandomBinomialActivity :: MonadDES m+                                        => Bool+                                        -- ^ whether the activity process can be preempted+                                        -> Double+                                        -- ^ the probability+                                        -> Int+                                        -- ^ the number of trials+                                        -> Simulation m (Activity m () a a)+{-# INLINABLE newPreemptibleRandomBinomialActivity #-}+newPreemptibleRandomBinomialActivity preemptible prob trials =+  newPreemptibleActivity preemptible $ \a ->+  do randomBinomialProcess_ prob trials+     return a
Simulation/Aivika/Trans/Agent.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Agent--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module introduces basic entities for the agent-based modeling. --@@ -29,22 +29,20 @@  import Control.Monad -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Event-import Simulation.Aivika.Trans.Internal.Signal+import Simulation.Aivika.Trans.Signal  -- -- Agent-based Modeling --  -- | Represents an agent.-data Agent m = Agent { agentMarker             :: SessionMarker m,-                       agentModeRef            :: ProtoRef m AgentMode,-                       agentStateRef           :: ProtoRef m (Maybe (AgentState m)), +data Agent m = Agent { agentModeRef            :: Ref m AgentMode,+                       agentStateRef           :: Ref m (Maybe (AgentState m)),                         agentStateChangedSource :: SignalSource m (Maybe (AgentState m)) }  -- | Represents the agent state.@@ -52,29 +50,33 @@                                  -- ^ Return the corresponded agent.                                  stateParent        :: Maybe (AgentState m),                                  -- ^ Return the parent state or 'Nothing'.-                                 stateMarker        :: SessionMarker m,-                                 stateActivateRef   :: ProtoRef m (Event m ()),-                                 stateDeactivateRef :: ProtoRef m (Event m ()),-                                 stateTransitRef    :: ProtoRef m (Event m (Maybe (AgentState m))),-                                 stateVersionRef    :: ProtoRef m Int }+                                 stateActivateRef   :: Ref m (Event m ()),+                                 stateDeactivateRef :: Ref m (Event m ()),+                                 stateTransitRef    :: Ref m (Event m (Maybe (AgentState m))),+                                 stateVersionRef    :: Ref m Int }                    data AgentMode = CreationMode                | TransientMode                | ProcessingMode                       -instance MonadComp m => Eq (Agent m) where-  x == y = agentMarker x == agentMarker y+instance MonadDES m => Eq (Agent m) where++  {-# INLINE (==) #-}+  x == y = agentStateRef x == agentStateRef y   -instance MonadComp m => Eq (AgentState m) where-  x == y = stateMarker x == stateMarker y+instance MonadDES m => Eq (AgentState m) where +  {-# INLINE (==) #-}+  x == y = stateVersionRef x == stateVersionRef y+ fullPath :: AgentState m -> [AgentState m] -> [AgentState m] fullPath st acc =   case stateParent st of     Nothing  -> st : acc     Just st' -> fullPath st' (st : acc) -partitionPath :: MonadComp m => [AgentState m] -> [AgentState m] -> ([AgentState m], [AgentState m])+partitionPath :: MonadDES m => [AgentState m] -> [AgentState m] -> ([AgentState m], [AgentState m])+{-# INLINABLE partitionPath #-} partitionPath path1 path2 =   case (path1, path2) of     (h1 : t1, [h2]) | h1 == h2 -> @@ -84,7 +86,8 @@     _ ->       (reverse path1, path2) -findPath :: MonadComp m => Maybe (AgentState m) -> AgentState m -> ([AgentState m], [AgentState m])+findPath :: MonadDES m => Maybe (AgentState m) -> AgentState m -> ([AgentState m], [AgentState m])+{-# INLINABLE findPath #-} findPath Nothing target = ([], fullPath target []) findPath (Just source) target   | stateAgent source /= stateAgent target =@@ -95,41 +98,43 @@     path1 = fullPath source []     path2 = fullPath target [] -traversePath :: MonadComp m => Maybe (AgentState m) -> AgentState m -> Event m ()+traversePath :: MonadDES m => Maybe (AgentState m) -> AgentState m -> Event m ()+{-# INLINABLE traversePath #-} traversePath source target =   let (path1, path2) = findPath source target       agent = stateAgent target-      activate st p   = invokeEvent p =<< readProtoRef (stateActivateRef st)-      deactivate st p = invokeEvent p =<< readProtoRef (stateDeactivateRef st)-      transit st p    = invokeEvent p =<< readProtoRef (stateTransitRef st)+      activate st p   = invokeEvent p =<< (invokeEvent p $ readRef (stateActivateRef st))+      deactivate st p = invokeEvent p =<< (invokeEvent p $ readRef (stateDeactivateRef st))+      transit st p    = invokeEvent p =<< (invokeEvent p $ readRef (stateTransitRef st))       continue st p   = invokeEvent p $ traversePath (Just target) st   in Event $ \p ->        unless (null path1 && null path2) $-       do writeProtoRef (agentModeRef agent) TransientMode+       do invokeEvent p $ writeRef (agentModeRef agent) TransientMode           forM_ path1 $ \st ->-            do writeProtoRef (agentStateRef agent) (Just st)+            do invokeEvent p $ writeRef (agentStateRef agent) (Just st)                deactivate st p                -- it makes all timeout and timer handlers outdated-               modifyProtoRef (stateVersionRef st) (1 +)+               invokeEvent p $ modifyRef (stateVersionRef st) (1 +)           forM_ path2 $ \st ->-            do writeProtoRef (agentStateRef agent) (Just st)+            do invokeEvent p $ writeRef (agentStateRef agent) (Just st)                activate st p           st' <- transit target p           case st' of             Nothing ->-              do writeProtoRef (agentModeRef agent) ProcessingMode+              do invokeEvent p $ writeRef (agentModeRef agent) ProcessingMode                  triggerAgentStateChanged p agent             Just st' ->               continue st' p  -- | Add to the state a timeout handler that will be actuated  -- in the specified time period if the state will remain active.-addTimeout :: MonadComp m => AgentState m -> Double -> Event m () -> Event m ()+addTimeout :: MonadDES m => AgentState m -> Double -> Event m () -> Event m ()+{-# INLINABLE addTimeout #-} addTimeout st dt action =   Event $ \p ->-  do v <- readProtoRef (stateVersionRef st)+  do v <- invokeEvent p $ readRef (stateVersionRef st)      let m1 = Event $ \p ->-           do v' <- readProtoRef (stateVersionRef st)+           do v' <- invokeEvent p $ readRef (stateVersionRef st)               when (v == v') $                 invokeEvent p action          m2 = enqueueEvent (pointTime p + dt) m1@@ -138,12 +143,13 @@ -- | Add to the state a timer handler that will be actuated -- in the specified time period and then repeated again many times, -- while the state remains active.-addTimer :: MonadComp m => AgentState m -> Event m Double -> Event m () -> Event m ()+addTimer :: MonadDES m => AgentState m -> Event m Double -> Event m () -> Event m ()+{-# INLINABLE addTimer #-} addTimer st dt action =   Event $ \p ->-  do v <- readProtoRef (stateVersionRef st)+  do v <- invokeEvent p $ readRef (stateVersionRef st)      let m1 = Event $ \p ->-           do v' <- readProtoRef (stateVersionRef st)+           do v' <- invokeEvent p $ readRef (stateVersionRef st)               when (v == v') $                 do invokeEvent p m2                    invokeEvent p action@@ -153,113 +159,108 @@      invokeEvent p m2  -- | Create a new state.-newState :: MonadComp m => Agent m -> Simulation m (AgentState m)+newState :: MonadDES m => Agent m -> Simulation m (AgentState m)+{-# INLINABLE newState #-} newState agent =-  Simulation $ \r ->-  do let s = runSession r-     aref <- newProtoRef s $ return ()-     dref <- newProtoRef s $ return ()-     tref <- newProtoRef s $ return Nothing-     vref <- newProtoRef s 0-     mrkr <- newSessionMarker s+  do aref <- newRef $ return ()+     dref <- newRef $ return ()+     tref <- newRef $ return Nothing+     vref <- newRef 0      return AgentState { stateAgent = agent,                          stateParent = Nothing,-                         stateMarker = mrkr,                          stateActivateRef = aref,                          stateDeactivateRef = dref,                          stateTransitRef = tref,                          stateVersionRef = vref }  -- | Create a child state.-newSubstate :: MonadComp m => AgentState m -> Simulation m (AgentState m)+newSubstate :: MonadDES m => AgentState m -> Simulation m (AgentState m)+{-# INLINABLE newSubstate #-} newSubstate parent =-  Simulation $ \r ->   do let agent = stateAgent parent-         s = runSession r-     aref <- newProtoRef s $ return ()-     dref <- newProtoRef s $ return ()-     tref <- newProtoRef s $ return Nothing-     vref <- newProtoRef s 0-     mrkr <- newSessionMarker s+     aref <- newRef $ return ()+     dref <- newRef $ return ()+     tref <- newRef $ return Nothing+     vref <- newRef 0      return AgentState { stateAgent = agent,                          stateParent = Just parent,-                         stateMarker = mrkr,                          stateActivateRef= aref,                          stateDeactivateRef = dref,                          stateTransitRef = tref,                          stateVersionRef = vref }  -- | Create an agent.-newAgent :: MonadComp m => Simulation m (Agent m)+newAgent :: MonadDES m => Simulation m (Agent m)+{-# INLINABLE newAgent #-} newAgent =-  Simulation $ \r ->-  do let s = runSession r-     modeRef  <- newProtoRef s CreationMode-     stateRef <- newProtoRef s Nothing-     stateChangedSource <- invokeSimulation r newSignalSource-     mrkr <- newSessionMarker s-     return Agent { agentMarker = mrkr,-                    agentModeRef = modeRef,+  do modeRef  <- newRef CreationMode+     stateRef <- newRef Nothing+     stateChangedSource <- newSignalSource+     return Agent { agentModeRef = modeRef,                     agentStateRef = stateRef,                      agentStateChangedSource = stateChangedSource }  -- | Return the selected active state.-selectedState :: MonadComp m => Agent m -> Event m (Maybe (AgentState m))-selectedState agent =-  Event $ \p -> readProtoRef (agentStateRef agent)+selectedState :: MonadDES m => Agent m -> Event m (Maybe (AgentState m))+{-# INLINABLE selectedState #-}+selectedState agent = readRef (agentStateRef agent)                     -- | Select the state. The activation and selection are repeated while -- there is the transition state defined by 'setStateTransition'.-selectState :: MonadComp m => AgentState m -> Event m ()+selectState :: MonadDES m => AgentState m -> Event m ()+{-# INLINABLE selectState #-} selectState st =   Event $ \p ->   do let agent = stateAgent st-     mode <- readProtoRef (agentModeRef agent)+     mode <- invokeEvent p $ readRef (agentModeRef agent)      case mode of        CreationMode ->-         do x0 <- readProtoRef (agentStateRef agent)+         do x0 <- invokeEvent p $ readRef (agentStateRef agent)             invokeEvent p $ traversePath x0 st        TransientMode ->          error $          "Use the setStateTransition function to define " ++          "the transition state: activateState."        ProcessingMode ->-         do x0 @ (Just st0) <- readProtoRef (agentStateRef agent)+         do x0 @ (Just st0) <- invokeEvent p $ readRef (agentStateRef agent)             invokeEvent p $ traversePath x0 st  -- | Set the activation computation for the specified state.-setStateActivation :: MonadComp m => AgentState m -> Event m () -> Simulation m ()+setStateActivation :: MonadDES m => AgentState m -> Event m () -> Event m ()+{-# INLINABLE setStateActivation #-} setStateActivation st action =-  Simulation $ \r ->-  writeProtoRef (stateActivateRef st) action+  writeRef (stateActivateRef st) action    -- | Set the deactivation computation for the specified state.-setStateDeactivation :: MonadComp m => AgentState m -> Event m () -> Simulation m ()+setStateDeactivation :: MonadDES m => AgentState m -> Event m () -> Event m ()+{-# INLINABLE setStateDeactivation #-} setStateDeactivation st action =-  Simulation $ \r ->-  writeProtoRef (stateDeactivateRef st) action+  writeRef (stateDeactivateRef st) action    -- | Set the transition state which will be next and which is used only -- 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 :: MonadComp m => AgentState m -> Event m (Maybe (AgentState m)) -> Simulation m ()+setStateTransition :: MonadDES m => AgentState m -> Event m (Maybe (AgentState m)) -> Event m ()+{-# INLINABLE setStateTransition #-} setStateTransition st action =-  Simulation $ \r ->-  writeProtoRef (stateTransitRef st) action+  writeRef (stateTransitRef st) action    -- | Trigger the signal when the agent state changes.-triggerAgentStateChanged :: MonadComp m => Point m -> Agent m -> m ()+triggerAgentStateChanged :: MonadDES m => Point m -> Agent m -> m ()+{-# INLINABLE triggerAgentStateChanged #-} triggerAgentStateChanged p agent =-  do st <- readProtoRef (agentStateRef agent)+  do st <- invokeEvent p $ readRef (agentStateRef agent)      invokeEvent p $ triggerSignal (agentStateChangedSource agent) st  -- | Return a signal that notifies about every change of the selected state. selectedStateChanged :: Agent m -> Signal m (Maybe (AgentState m))+{-# INLINABLE selectedStateChanged #-} selectedStateChanged agent =   publishSignal (agentStateChangedSource agent)  -- | Return a signal that notifies about every change of the selected state.-selectedStateChanged_ :: MonadComp m => Agent m -> Signal m ()+selectedStateChanged_ :: MonadDES m => Agent m -> Signal m ()+{-# INLINABLE selectedStateChanged_ #-} selectedStateChanged_ agent =   mapSignal (const ()) $ selectedStateChanged agent
+ Simulation/Aivika/Trans/Array.hs view
@@ -0,0 +1,27 @@++{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module     : Simulation.Aivika.Trans.Array+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- The module defines helper functions for creating mutable arrays.+--+module Simulation.Aivika.Trans.Array+       (newIOArray_,+        newIOUArray_) where++import Data.Array.IO.Safe+import Data.Array.MArray.Safe++-- | Create a new 'IOArray'.+newIOArray_ :: Ix i => (i, i) -> IO (IOArray i e)+newIOArray_ = newArray_++-- | Create a new 'IOUArray'.+newIOUArray_ :: (Ix i, MArray IOUArray e IO) => (i, i) -> IO (IOUArray i e)+newIOUArray_ = newArray_
Simulation/Aivika/Trans/Arrival.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Arrival--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines the types and functions for working with the events -- that can represent something that arrive from outside the model, or@@ -34,6 +34,7 @@ import Simulation.Aivika.Trans.Statistics import Simulation.Aivika.Trans.Ref import Simulation.Aivika.Trans.Signal+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Arrival (Arrival(..))  -- | Accumulates the statistics about that how long the arrived events are processed.@@ -42,8 +43,8 @@                  arrivalProcessingTimeChangedSource :: SignalSource m () }  -- | Create a new timer that measures how long the arrived events are processed.-newArrivalTimer :: MonadComp m => Simulation m (ArrivalTimer m)-{-# INLINE newArrivalTimer #-}+newArrivalTimer :: MonadDES m => Simulation m (ArrivalTimer m)+{-# INLINABLE newArrivalTimer #-} newArrivalTimer =   do r <- newRef emptySamplingStats      s <- newSignalSource@@ -51,27 +52,26 @@                            arrivalProcessingTimeChangedSource = s }  -- | Return the statistics about that how long the arrived events were processed.-arrivalProcessingTime :: MonadComp m => ArrivalTimer m -> Event m (SamplingStats Double)-{-# INLINE arrivalProcessingTime #-}+arrivalProcessingTime :: MonadDES m => ArrivalTimer m -> Event m (SamplingStats Double)+{-# INLINABLE arrivalProcessingTime #-} arrivalProcessingTime = readRef . arrivalProcessingTimeRef  -- | Return a signal raised when the the processing time statistics changes.-arrivalProcessingTimeChanged :: MonadComp m => ArrivalTimer m -> Signal m (SamplingStats Double)-{-# INLINE arrivalProcessingTimeChanged #-}+arrivalProcessingTimeChanged :: MonadDES m => ArrivalTimer m -> Signal m (SamplingStats Double)+{-# INLINABLE arrivalProcessingTimeChanged #-} arrivalProcessingTimeChanged timer =   mapSignalM (const $ arrivalProcessingTime timer) (arrivalProcessingTimeChanged_ timer)  -- | Return a signal raised when the the processing time statistics changes.-arrivalProcessingTimeChanged_ :: MonadComp m => ArrivalTimer m -> Signal m ()-{-# INLINE arrivalProcessingTimeChanged_ #-}+arrivalProcessingTimeChanged_ :: MonadDES m => ArrivalTimer m -> Signal m ()+{-# INLINABLE arrivalProcessingTimeChanged_ #-} arrivalProcessingTimeChanged_ timer =   publishSignal (arrivalProcessingTimeChangedSource timer)  -- | Return a processor that actually measures how much time has passed from -- the time of arriving the events.-arrivalTimerProcessor :: MonadComp m => ArrivalTimer m -> Processor m (Arrival a) (Arrival a)+arrivalTimerProcessor :: MonadDES m => ArrivalTimer m -> Processor m (Arrival a) (Arrival a) {-# INLINABLE arrivalTimerProcessor #-}-{-# SPECIALISE arrivalTimerProcessor :: ArrivalTimer IO -> Processor IO (Arrival a) (Arrival a) #-} arrivalTimerProcessor timer =   Processor $ \xs -> Cons $ loop xs where     loop xs =
Simulation/Aivika/Trans/Circuit.hs view
@@ -3,11 +3,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Circuit--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- It represents a circuit synchronized with the event queue. -- Also it allows creating the recursive links with help of@@ -58,9 +58,9 @@ import Control.Arrow import Control.Monad.Fix -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.SD import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Dynamics@@ -84,10 +84,12 @@             -- ^ Run the circuit.           } -instance MonadComp m => C.Category (Circuit m) where+instance MonadDES m => C.Category (Circuit m) where +  {-# INLINABLE id #-}   id = Circuit $ \a -> return (a, C.id) +  {-# INLINABLE (.) #-}   (.) = dot     where        (Circuit g) `dot` (Circuit f) =@@ -97,22 +99,26 @@            (c, cir2) <- invokeEvent p (g b)            return (c, cir2 `dot` cir1) -instance MonadComp m => Arrow (Circuit m) where+instance MonadDES m => Arrow (Circuit m) where +  {-# INLINABLE arr #-}   arr f = Circuit $ \a -> return (f a, arr f) +  {-# INLINABLE first #-}   first (Circuit f) =     Circuit $ \(b, d) ->     Event $ \p ->     do (c, cir) <- invokeEvent p (f b)        return ((c, d), first cir) +  {-# INLINABLE second #-}   second (Circuit f) =     Circuit $ \(d, b) ->     Event $ \p ->     do (c, cir) <- invokeEvent p (f b)        return ((d, c), second cir) +  {-# INLINABLE (***) #-}   (Circuit f) *** (Circuit g) =     Circuit $ \(b, b') ->     Event $ \p ->@@ -120,6 +126,7 @@        (c', cir2) <- invokeEvent p (g b')        return ((c, c'), cir1 *** cir2)        +  {-# INLINABLE (&&&) #-}   (Circuit f) &&& (Circuit g) =     Circuit $ \b ->     Event $ \p ->@@ -127,16 +134,18 @@        (c', cir2) <- invokeEvent p (g b)        return ((c, c'), cir1 &&& cir2) -instance (MonadComp m, MonadFix m) => ArrowLoop (Circuit m) where+instance (MonadDES m, MonadFix m) => ArrowLoop (Circuit m) where +  {-# INLINABLE loop #-}   loop (Circuit f) =     Circuit $ \b ->     Event $ \p ->     do rec ((c, d), cir) <- invokeEvent p (f (b, d))        return (c, loop cir) -instance MonadComp m => ArrowChoice (Circuit m) where+instance MonadDES m => ArrowChoice (Circuit m) where +  {-# INLINABLE left #-}   left x@(Circuit f) =     Circuit $ \ebd ->     Event $ \p ->@@ -147,6 +156,7 @@       Right d ->         return (Right d, left x) +  {-# INLINABLE right #-}   right x@(Circuit f) =     Circuit $ \edb ->     Event $ \p ->@@ -157,6 +167,7 @@       Left d ->         return (Left d, right x) +  {-# INLINABLE (+++) #-}   x@(Circuit f) +++ y@(Circuit g) =     Circuit $ \ebb' ->     Event $ \p ->@@ -168,6 +179,7 @@         do (c', cir2) <- invokeEvent p (g b')            return (Right c', x +++ cir2) +  {-# INLINABLE (|||) #-}   x@(Circuit f) ||| y@(Circuit g) =     Circuit $ \ebc ->     Event $ \p ->@@ -180,22 +192,21 @@            return (d, x ||| cir2)  -- | Get a signal transform by the specified circuit.-circuitSignaling :: MonadComp m => Circuit m a b -> Signal m a -> Signal m b+circuitSignaling :: MonadDES m => Circuit m a b -> Signal m a -> Signal m b+{-# INLINABLE circuitSignaling #-} circuitSignaling (Circuit cir) sa =   Signal { handleSignal = \f ->-            Event $ \p ->-            do let s = runSession (pointRun p)-               r <- newProtoRef s cir-               invokeEvent p $-                 handleSignal sa $ \a ->+            do r <- liftSimulation $ newRef cir+               handleSignal sa $ \a ->                  Event $ \p ->-                 do cir <- readProtoRef r+                 do cir <- invokeEvent p $ readRef r                     (b, Circuit cir') <- invokeEvent p (cir a)-                    writeProtoRef r cir'+                    invokeEvent p $ writeRef r cir'                     invokeEvent p (f b) }  -- | Transform the circuit to a processor.-circuitProcessor :: MonadComp m => Circuit m a b -> Processor m a b+circuitProcessor :: MonadDES m => Circuit m a b -> Processor m a b+{-# INLINABLE circuitProcessor #-} circuitProcessor (Circuit cir) = Processor $ \sa ->   Cons $   do (a, xs) <- runStream sa@@ -205,7 +216,8 @@  -- | Create a simple circuit by the specified handling function -- that runs the computation for each input value to get an output.-arrCircuit :: MonadComp m => (a -> Event m b) -> Circuit m a b+arrCircuit :: MonadDES m => (a -> Event m b) -> Circuit m a b+{-# INLINABLE arrCircuit #-} arrCircuit f =   let x =         Circuit $ \a ->@@ -215,7 +227,8 @@   in x  -- | Accumulator that outputs a value determined by the supplied function.-accumCircuit :: MonadComp m => (acc -> a -> Event m (acc, b)) -> acc -> Circuit m a b+accumCircuit :: MonadDES m => (acc -> a -> Event m (acc, b)) -> acc -> Circuit m a b+{-# INLINABLE accumCircuit #-} accumCircuit f acc =   Circuit $ \a ->   Event $ \p ->@@ -224,7 +237,8 @@  -- | A circuit that adds the information about the time points at which  -- the values were received.-arrivalCircuit :: MonadComp m => Circuit m a (Arrival a)+arrivalCircuit :: MonadDES m => Circuit m a (Arrival a)+{-# INLINABLE arrivalCircuit #-} arrivalCircuit =   let loop t0 =         Circuit $ \a ->@@ -240,26 +254,29 @@   in loop Nothing  -- | Delay the input by one step using the specified initial value.-delayCircuit :: MonadComp m => a -> Circuit m a a+delayCircuit :: MonadDES m => a -> Circuit m a a+{-# INLINABLE delayCircuit #-} delayCircuit a0 =   Circuit $ \a ->   return (a0, delayCircuit a)  -- | A circuit that returns the current modeling time.-timeCircuit :: MonadComp m => Circuit m a Double+timeCircuit :: MonadDES m => Circuit m a Double+{-# INLINABLE timeCircuit #-} timeCircuit =   Circuit $ \a ->   Event $ \p ->   return (pointTime p, timeCircuit)  -- | Like '>>>' but processes only the represented events.-(>?>) :: MonadComp m+(>?>) :: MonadDES m          => Circuit m a (Maybe b)          -- ^ whether there is an event          -> Circuit m b c          -- ^ process the event if it presents          -> Circuit m a (Maybe c)          -- ^ the resulting circuit that processes only the represented events+{-# INLINABLE (>?>) #-} whether >?> process =   Circuit $ \a ->   Event $ \p ->@@ -272,23 +289,26 @@             return (Just c, whether' >?> process')  -- | Like '<<<' but processes only the represented events.-(<?<) :: MonadComp m+(<?<) :: MonadDES m          => Circuit m b c          -- ^ process the event if it presents          -> Circuit m a (Maybe b)          -- ^ whether there is an event          -> Circuit m a (Maybe c)          -- ^ the resulting circuit that processes only the represented events+{-# INLINABLE (<?<) #-} (<?<) = flip (>?>)  -- | Filter the circuit, calculating only those parts of the circuit that satisfy -- the specified predicate.-filterCircuit :: MonadComp m => (a -> Bool) -> Circuit m a b -> Circuit m a (Maybe b)+filterCircuit :: MonadDES m => (a -> Bool) -> Circuit m a b -> Circuit m a (Maybe b)+{-# INLINABLE filterCircuit #-} filterCircuit pred = filterCircuitM (return . pred)  -- | Filter the circuit within the 'Event' computation, calculating only those parts -- of the circuit that satisfy the specified predicate.-filterCircuitM :: MonadComp m => (a -> Event m Bool) -> Circuit m a b -> Circuit m a (Maybe b)+filterCircuitM :: MonadDES m => (a -> Event m Bool) -> Circuit m a b -> Circuit m a (Maybe b)+{-# INLINABLE filterCircuitM #-} filterCircuitM pred cir =   Circuit $ \a ->   Event $ \p ->@@ -299,7 +319,8 @@        else return (Nothing, filterCircuitM pred cir)  -- | The source of events that never occur.-neverCircuit :: MonadComp m => Circuit m a (Maybe b)+neverCircuit :: MonadDES m => Circuit m a (Maybe b)+{-# INLINABLE neverCircuit #-} neverCircuit =   Circuit $ \a -> return (Nothing, neverCircuit) @@ -323,11 +344,12 @@ -- Regarding the recursive equations, the both functions allow defining them -- but whithin different computations (either with help of the recursive -- do-notation or the proc-notation).-integCircuit :: MonadComp m+integCircuit :: MonadDES m                 => Double                 -- ^ the initial value                 -> Circuit m Double Double                 -- ^ map the derivative to an integral+{-# INLINABLE integCircuit #-} integCircuit init = start   where     start = @@ -345,12 +367,13 @@  -- | Like 'integCircuit' but allows either setting a new 'Left' integral value, -- or using the 'Right' derivative when integrating by Euler's method.-integCircuitEither :: MonadComp m+integCircuitEither :: MonadDES m                       => Double                       -- ^ the initial value                       -> Circuit m (Either Double Double) Double                       -- ^ map either a new 'Left' value or                       -- the 'Right' derivative to an integral+{-# INLINABLE integCircuitEither #-} integCircuitEither init = start   where     start = @@ -382,11 +405,12 @@ -- Regarding the recursive equations, the both functions allow defining them -- but whithin different computations (either with help of the recursive -- do-notation or the proc-notation).-sumCircuit :: (MonadComp m, Num a)+sumCircuit :: (MonadDES m, Num a)               => a               -- ^ the initial value               -> Circuit m a a               -- ^ map the difference to a sum+{-# INLINABLE sumCircuit #-} sumCircuit init = start   where     start = @@ -401,12 +425,13 @@  -- | Like 'sumCircuit' but allows either setting a new 'Left' value for the sum, or updating it -- by specifying the 'Right' difference.-sumCircuitEither :: (MonadComp m, Num a)+sumCircuitEither :: (MonadDES m, Num a)                     => a                     -- ^ the initial value                     -> Circuit m (Either a a) a                     -- ^ map either a new 'Left' value or                     -- the 'Right' difference to a sum+{-# INLINABLE sumCircuitEither #-} sumCircuitEither init = start   where     start = @@ -430,27 +455,29 @@ -- -- This procedure consumes memory as the underlying memoization allocates -- an array to store the calculated values.-circuitTransform :: MonadComp m => Circuit m a b -> Transform m a b+circuitTransform :: (MonadSD m, MonadDES m) => Circuit m a b -> Transform m a b+{-# INLINABLE circuitTransform #-} circuitTransform cir = Transform start   where     start m =       Simulation $ \r ->-      do let s = runSession r-         ref <- newProtoRef s cir+      do ref <- invokeSimulation r $ newRef cir          invokeSimulation r $            memo0Dynamics (next ref m)     next ref m =       Dynamics $ \p ->       do a <- invokeDynamics p m-         cir <- readProtoRef ref-         (b, cir') <--           invokeDynamics p $-           runEvent (runCircuit cir a)-         writeProtoRef ref cir'-         return b+         invokeDynamics p $+           runEvent $+           Event $ \p ->+           do cir <- invokeEvent p $ readRef ref+              (b, cir') <- invokeEvent p $ runCircuit cir a+              invokeEvent p $ writeRef ref cir'+              return b  -- | Iterate the circuit in the specified time points.-iterateCircuitInPoints_ :: MonadComp m => [Point m] -> Circuit m a a -> a -> Event m ()+iterateCircuitInPoints_ :: MonadDES m => [Point m] -> Circuit m a a -> a -> Event m ()+{-# INLINABLE iterateCircuitInPoints_ #-} iterateCircuitInPoints_ [] cir a = return () iterateCircuitInPoints_ (p : ps) cir a =   enqueueEvent (pointTime p) $@@ -460,7 +487,8 @@  -- | Iterate the circuit in the specified time points returning a task -- which completes after the final output of the circuit is received.-iterateCircuitInPoints :: MonadComp m => [Point m] -> Circuit m a a -> a -> Event m (Task m a)+iterateCircuitInPoints :: MonadDES m => [Point m] -> Circuit m a a -> a -> Event m (Task m a)+{-# INLINABLE iterateCircuitInPoints #-} iterateCircuitInPoints ps cir a =   do let loop [] cir a source = triggerSignal source a          loop (p : ps) cir a source =@@ -474,7 +502,8 @@      return task  -- | Iterate the circuit in the integration time points.-iterateCircuitInIntegTimes_ :: MonadComp m => Circuit m a a -> a -> Event m ()+iterateCircuitInIntegTimes_ :: MonadDES m => Circuit m a a -> a -> Event m ()+{-# INLINABLE iterateCircuitInIntegTimes_ #-} iterateCircuitInIntegTimes_ cir a =   Event $ \p ->   do let ps = integPointsStartingFrom p@@ -482,7 +511,8 @@        iterateCircuitInPoints_ ps cir a  -- | Iterate the circuit in the specified time points.-iterateCircuitInTimes_ :: MonadComp m => [Double] -> Circuit m a a -> a -> Event m ()+iterateCircuitInTimes_ :: MonadDES m => [Double] -> Circuit m a a -> a -> Event m ()+{-# INLINABLE iterateCircuitInTimes_ #-} iterateCircuitInTimes_ ts cir a =   Event $ \p ->   do let ps = map (pointAt $ pointRun p) ts@@ -491,7 +521,8 @@  -- | Iterate the circuit in the integration time points returning a task -- which completes after the final output of the circuit is received.-iterateCircuitInIntegTimes :: MonadComp m => Circuit m a a -> a -> Event m (Task m a)+iterateCircuitInIntegTimes :: MonadDES m => Circuit m a a -> a -> Event m (Task m a)+{-# INLINABLE iterateCircuitInIntegTimes #-} iterateCircuitInIntegTimes cir a =   Event $ \p ->   do let ps = integPointsStartingFrom p@@ -500,7 +531,8 @@  -- | Iterate the circuit in the specified time points returning a task -- which completes after the final output of the circuit is received.-iterateCircuitInTimes :: MonadComp m => [Double] -> Circuit m a a -> a -> Event m (Task m a)+iterateCircuitInTimes :: MonadDES m => [Double] -> Circuit m a a -> a -> Event m (Task m a)+{-# INLINABLE iterateCircuitInTimes #-} iterateCircuitInTimes ts cir a =   Event $ \p ->   do let ps = map (pointAt $ pointRun p) ts@@ -509,7 +541,8 @@  -- | Iterate the circuit in the specified time points, interrupting the iteration -- immediately if 'Nothing' is returned within the 'Circuit' computation.-iterateCircuitInPointsMaybe :: MonadComp m => [Point m] -> Circuit m a (Maybe a) -> a -> Event m ()+iterateCircuitInPointsMaybe :: MonadDES m => [Point m] -> Circuit m a (Maybe a) -> a -> Event m ()+{-# INLINABLE iterateCircuitInPointsMaybe #-} iterateCircuitInPointsMaybe [] cir a = return () iterateCircuitInPointsMaybe (p : ps) cir a =   enqueueEvent (pointTime p) $@@ -522,7 +555,8 @@  -- | Iterate the circuit in the integration time points, interrupting the iteration -- immediately if 'Nothing' is returned within the 'Circuit' computation.-iterateCircuitInIntegTimesMaybe :: MonadComp m => Circuit m a (Maybe a) -> a -> Event m ()+iterateCircuitInIntegTimesMaybe :: MonadDES m => Circuit m a (Maybe a) -> a -> Event m ()+{-# INLINABLE iterateCircuitInIntegTimesMaybe #-} iterateCircuitInIntegTimesMaybe cir a =   Event $ \p ->   do let ps = integPointsStartingFrom p@@ -531,7 +565,8 @@  -- | Iterate the circuit in the specified time points, interrupting the iteration -- immediately if 'Nothing' is returned within the 'Circuit' computation.-iterateCircuitInTimesMaybe :: MonadComp m => [Double] -> Circuit m a (Maybe a) -> a -> Event m ()+iterateCircuitInTimesMaybe :: MonadDES m => [Double] -> Circuit m a (Maybe a) -> a -> Event m ()+{-# INLINABLE iterateCircuitInTimesMaybe #-} iterateCircuitInTimesMaybe ts cir a =   Event $ \p ->   do let ps = map (pointAt $ pointRun p) ts@@ -542,7 +577,8 @@ -- that computes the final output of the circuit either after all points -- are exhausted, or after the 'Left' result of type @b@ is received, -- which interrupts the computation immediately.-iterateCircuitInPointsEither :: MonadComp m => [Point m] -> Circuit m a (Either b a) -> a -> Event m (Task m (Either b a))+iterateCircuitInPointsEither :: MonadDES m => [Point m] -> Circuit m a (Either b a) -> a -> Event m (Task m (Either b a))+{-# INLINABLE iterateCircuitInPointsEither #-} iterateCircuitInPointsEither ps cir a =   do let loop [] cir ba source = triggerSignal source ba          loop ps cir ba@(Left b) source = triggerSignal source ba @@ -560,7 +596,8 @@ -- that computes the final output of the circuit either after all points -- are exhausted, or after the 'Left' result of type @b@ is received, -- which interrupts the computation immediately.-iterateCircuitInIntegTimesEither :: MonadComp m => Circuit m a (Either b a) -> a -> Event m (Task m (Either b a))+iterateCircuitInIntegTimesEither :: MonadDES m => Circuit m a (Either b a) -> a -> Event m (Task m (Either b a))+{-# INLINABLE iterateCircuitInIntegTimesEither #-} iterateCircuitInIntegTimesEither cir a =   Event $ \p ->   do let ps = integPointsStartingFrom p@@ -571,7 +608,8 @@ -- that computes the final output of the circuit either after all points -- are exhausted, or after the 'Left' result of type @b@ is received, -- which interrupts the computation immediately.-iterateCircuitInTimesEither :: MonadComp m => [Double] -> Circuit m a (Either b a) -> a -> Event m (Task m (Either b a))+iterateCircuitInTimesEither :: MonadDES m => [Double] -> Circuit m a (Either b a) -> a -> Event m (Task m (Either b a))+{-# INLINABLE iterateCircuitInTimesEither #-} iterateCircuitInTimesEither ts cir a =   Event $ \p ->   do let ps = map (pointAt $ pointRun p) ts@@ -579,7 +617,7 @@        iterateCircuitInPointsEither ps cir a  -- | Show the debug messages with the current simulation time.-traceCircuit :: MonadComp m+traceCircuit :: MonadDES m                 => Maybe String                 -- ^ the request message                 -> Maybe String@@ -587,6 +625,7 @@                 -> Circuit m a b                 -- ^ a circuit                 -> Circuit m a b+{-# INLINABLE traceCircuit #-} traceCircuit request response cir = Circuit $ loop cir where   loop cir a =     do (b, cir') <-
Simulation/Aivika/Trans/Comp.hs view
@@ -1,52 +1,34 @@ -{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}  -- | -- Module     : Simulation.Aivika.Trans.Comp--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- It defines a type class of monads based on which the simulation monads can be built. -- module Simulation.Aivika.Trans.Comp-       (ProtoMonadComp(..),-        MonadComp(..),+       (MonadComp(..),         MonadCompTrans(..)) where  import Control.Monad import Control.Monad.Trans  import Simulation.Aivika.Trans.Exception-import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.ProtoArray-import Simulation.Aivika.Trans.Unboxed import Simulation.Aivika.Trans.Generator-import Simulation.Aivika.Trans.Internal.Specs---- | A prototype of the type class of monads based on which the simulation monads can be built. -class (Monad m,-       ExceptionHandling m,-       SessionMonad m,-       ProtoRefMonad m,-       ProtoArrayMonad m,-       Unboxed m Double,-       Unboxed m Float,-       Unboxed m Int,-       GeneratorMonad m) => ProtoMonadComp m+import Simulation.Aivika.Trans.Internal.Types --- | Such a prototype monad that allows enqueueing events.-class (ProtoMonadComp m, EventQueueing m) => MonadComp m+-- | A type class of monads based on which the simulation monads can be built. +class (Monad m, MonadException m, MonadGenerator m) => MonadComp m  -- | A variant of the standard 'MonadTrans' type class with one difference: -- the computation that will be lifted into another must be 'MonadComp' instead of -- more general and less restricted 'Monad'.-class MonadCompTrans t where+class MonadCompTrans t m where    -- | Lift the underlying computation into another within simulation.-  liftComp :: MonadComp m => m a -> t m a--instance ProtoMonadComp IO+  liftComp :: m a -> t m a
− Simulation/Aivika/Trans/Comp/IO.hs 
@@ -1,128 +0,0 @@--{-# LANGUAGE TypeFamilies #-}---- |--- Module     : Simulation.Aivika.Trans.Comp.IO--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.8.3------ The module defines the event queue within monad 'IO'.----module Simulation.Aivika.Trans.Comp.IO() where--import Control.Monad--import qualified Simulation.Aivika.Trans.PriorityQueue as PQ--import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp-import Simulation.Aivika.Trans.Internal.Specs--instance EventQueueing IO where--  data EventQueue IO =-    EventQueue { queuePQ :: PQ.PriorityQueue IO (Point IO -> IO ()),-                 -- ^ the underlying priority queue-                 queueBusy :: ProtoRef IO Bool,-                 -- ^ whether the queue is currently processing events-                 queueTime :: ProtoRef IO Double-                 -- ^ the actual time of the event queue-               }-  -  newEventQueue session specs = -    do f <- newProtoRef session False-       t <- newProtoRef session $ spcStartTime specs-       pq <- PQ.newQueue session-       return EventQueue { queuePQ   = pq,-                           queueBusy = f,-                           queueTime = t }--  enqueueEvent t (Event m) =-    Event $ \p ->-    let pq = queuePQ $ runEventQueue $ pointRun p-    in PQ.enqueue pq t m--  runEventWith processing (Event e) =-    Dynamics $ \p ->-    do invokeDynamics p $ processEvents processing-       e p--  eventQueueCount =-    Event $ PQ.queueCount . queuePQ . runEventQueue . pointRun--instance MonadComp IO---- | Process the pending events.-processPendingEventsCore :: Bool -> Dynamics IO ()-processPendingEventsCore includingCurrentEvents = Dynamics r where-  r p =-    do let q = runEventQueue $ pointRun p-           f = queueBusy q-       f' <- readProtoRef f-       unless f' $-         do writeProtoRef f True-            call q p-            writeProtoRef f False-  call q p =-    do let pq = queuePQ q-           r  = pointRun p-       f <- PQ.queueNull pq-       unless f $-         do (t2, c2) <- PQ.queueFront pq-            let t = queueTime q-            t' <- readProtoRef t-            when (t2 < t') $ -              error "The time value is too small: processPendingEventsCore"-            when ((t2 < pointTime p) ||-                  (includingCurrentEvents && (t2 == pointTime p))) $-              do writeProtoRef t t2-                 PQ.dequeue pq-                 let sc = pointSpecs p-                     t0 = spcStartTime sc-                     dt = spcDT sc-                     n2 = fromIntegral $ floor ((t2 - t0) / dt)-                 c2 $ p { pointTime = t2,-                          pointIteration = n2,-                          pointPhase = -1 }-                 call q p---- | Process the pending events synchronously, i.e. without past.-processPendingEvents :: Bool -> Dynamics IO ()-processPendingEvents includingCurrentEvents = Dynamics r where-  r p =-    do let q = runEventQueue $ pointRun p-           t = queueTime q-       t' <- readProtoRef t-       if pointTime p < t'-         then error $-              "The current time is less than " ++-              "the time in the queue: processPendingEvents"-         else invokeDynamics p m-  m = processPendingEventsCore includingCurrentEvents---- | A memoized value.-processEventsIncludingCurrent :: Dynamics IO ()-processEventsIncludingCurrent = processPendingEvents True---- | A memoized value.-processEventsIncludingEarlier :: Dynamics IO ()-processEventsIncludingEarlier = processPendingEvents False---- | A memoized value.-processEventsIncludingCurrentCore :: Dynamics IO ()-processEventsIncludingCurrentCore = processPendingEventsCore True---- | A memoized value.-processEventsIncludingEarlierCore :: Dynamics IO ()-processEventsIncludingEarlierCore = processPendingEventsCore True---- | Process the events.-processEvents :: EventProcessing -> Dynamics IO ()-processEvents CurrentEvents = processEventsIncludingCurrent-processEvents EarlierEvents = processEventsIncludingEarlier-processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore-processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore
− Simulation/Aivika/Trans/Comp/Template.hs 
@@ -1,130 +0,0 @@--{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}---- |--- Module     : Simulation.Aivika.Trans.Comp.Template--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.8.3------ The module defines the event queue.----module Simulation.Aivika.Trans.Comp.Template-       (TemplateEventQueueing(..)) where--import Control.Monad--import qualified Simulation.Aivika.Trans.PriorityQueue as PQ--import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp-import Simulation.Aivika.Trans.Internal.Specs---- | A template-based implementation of the 'EventQueueing' class type.-class ProtoMonadComp m => TemplateEventQueueing m --instance TemplateEventQueueing m => EventQueueing m where--  data EventQueue m =-    EventQueue { queuePQ :: PQ.PriorityQueue m (Point m -> m ()),-                 -- ^ the underlying priority queue-                 queueBusy :: ProtoRef m Bool,-                 -- ^ whether the queue is currently processing events-                 queueTime :: ProtoRef m Double-                 -- ^ the actual time of the event queue-               }-  -  newEventQueue session specs = -    do f <- newProtoRef session False-       t <- newProtoRef session $ spcStartTime specs-       pq <- PQ.newQueue session-       return EventQueue { queuePQ   = pq,-                           queueBusy = f,-                           queueTime = t }--  enqueueEvent t (Event m) =-    Event $ \p ->-    let pq = queuePQ $ runEventQueue $ pointRun p-    in PQ.enqueue pq t m--  runEventWith processing (Event e) =-    Dynamics $ \p ->-    do invokeDynamics p $ processEvents processing-       e p--  eventQueueCount =-    Event $ PQ.queueCount . queuePQ . runEventQueue . pointRun---- | Process the pending events.-processPendingEventsCore :: ProtoMonadComp m => Bool -> Dynamics m ()-processPendingEventsCore includingCurrentEvents = Dynamics r where-  r p =-    do let q = runEventQueue $ pointRun p-           f = queueBusy q-       f' <- readProtoRef f-       unless f' $-         do writeProtoRef f True-            call q p-            writeProtoRef f False-  call q p =-    do let pq = queuePQ q-           r  = pointRun p-       f <- PQ.queueNull pq-       unless f $-         do (t2, c2) <- PQ.queueFront pq-            let t = queueTime q-            t' <- readProtoRef t-            when (t2 < t') $ -              error "The time value is too small: processPendingEventsCore"-            when ((t2 < pointTime p) ||-                  (includingCurrentEvents && (t2 == pointTime p))) $-              do writeProtoRef t t2-                 PQ.dequeue pq-                 let sc = pointSpecs p-                     t0 = spcStartTime sc-                     dt = spcDT sc-                     n2 = fromIntegral $ floor ((t2 - t0) / dt)-                 c2 $ p { pointTime = t2,-                          pointIteration = n2,-                          pointPhase = -1 }-                 call q p---- | Process the pending events synchronously, i.e. without past.-processPendingEvents :: ProtoMonadComp m => Bool -> Dynamics m ()-processPendingEvents includingCurrentEvents = Dynamics r where-  r p =-    do let q = runEventQueue $ pointRun p-           t = queueTime q-       t' <- readProtoRef t-       if pointTime p < t'-         then error $-              "The current time is less than " ++-              "the time in the queue: processPendingEvents"-         else invokeDynamics p m-  m = processPendingEventsCore includingCurrentEvents---- | A memoized value.-processEventsIncludingCurrent :: ProtoMonadComp m => Dynamics m ()-processEventsIncludingCurrent = processPendingEvents True---- | A memoized value.-processEventsIncludingEarlier :: ProtoMonadComp m => Dynamics m ()-processEventsIncludingEarlier = processPendingEvents False---- | A memoized value.-processEventsIncludingCurrentCore :: ProtoMonadComp m => Dynamics m ()-processEventsIncludingCurrentCore = processPendingEventsCore True---- | A memoized value.-processEventsIncludingEarlierCore :: ProtoMonadComp m => Dynamics m ()-processEventsIncludingEarlierCore = processPendingEventsCore True---- | Process the events.-processEvents :: ProtoMonadComp m => EventProcessing -> Dynamics m ()-processEvents CurrentEvents = processEventsIncludingCurrent-processEvents EarlierEvents = processEventsIncludingEarlier-processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore-processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore
Simulation/Aivika/Trans/Cont.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Cont--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The 'Cont' monad is a variation of the standard Cont monad  -- and F# async workflow, where the result of applying
+ Simulation/Aivika/Trans/DES.hs view
@@ -0,0 +1,26 @@++{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module     : Simulation.Aivika.Trans.DES+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- It defines a type class of monads for Discrete Event Simulation (DES).+--+module Simulation.Aivika.Trans.DES (MonadDES) where++import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.Internal.Types+import Simulation.Aivika.Trans.QueueStrategy++-- | It defines a type class of monads for DES.+class (MonadComp m,+       MonadRef m,+       EventQueueing m,+       EnqueueStrategy m FCFS,+       EnqueueStrategy m LCFS) => MonadDES m
Simulation/Aivika/Trans/DoubleLinkedList.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.DoubleLinkedList--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- An imperative double-linked list. --@@ -23,138 +23,142 @@  import Control.Monad -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.Simulation+import Simulation.Aivika.Trans.Event  -- | A cell of the double-linked list. data DoubleLinkedItem m a =    DoubleLinkedItem { itemVal  :: a,-                     itemPrev :: ProtoRef m (Maybe (DoubleLinkedItem m a)),-                     itemNext :: ProtoRef m (Maybe (DoubleLinkedItem m a)) }+                     itemPrev :: Ref m (Maybe (DoubleLinkedItem m a)),+                     itemNext :: Ref m (Maybe (DoubleLinkedItem m a)) }    -- | The 'DoubleLinkedList' type represents an imperative double-linked list. data DoubleLinkedList m a =  -  DoubleLinkedList { listSession :: Session m,-                     listHead :: ProtoRef m (Maybe (DoubleLinkedItem m a)),-                     listTail :: ProtoRef m (Maybe (DoubleLinkedItem m a)), -                     listSize :: ProtoRef m Int }+  DoubleLinkedList { listHead :: Ref m (Maybe (DoubleLinkedItem m a)),+                     listTail :: Ref m (Maybe (DoubleLinkedItem m a)), +                     listSize :: Ref m Int }  -- | Test whether the list is empty.-listNull :: ProtoRefMonad m => DoubleLinkedList m a -> m Bool+listNull :: MonadRef m => DoubleLinkedList m a -> Event m Bool+{-# INLINABLE listNull #-} listNull x =-  do head <- readProtoRef (listHead x) +  do head <- readRef (listHead x)       case head of        Nothing -> return True        Just _  -> return False      -- | Return the number of elements in the list.-listCount :: ProtoRefMonad m => DoubleLinkedList m a -> m Int-listCount x = readProtoRef (listSize x)+listCount :: MonadRef m => DoubleLinkedList m a -> Event m Int+{-# INLINABLE listCount #-}+listCount x = readRef (listSize x)  -- | Create a new list.-newList :: ProtoRefMonad m => Session m -> m (DoubleLinkedList m a)-newList s =-  do head <- newProtoRef s Nothing -     tail <- newProtoRef s Nothing-     size <- newProtoRef s 0-     return DoubleLinkedList { listSession = s,-                               listHead = head,+newList :: MonadRef m => Simulation m (DoubleLinkedList m a)+{-# INLINABLE newList #-}+newList =+  do head <- newRef Nothing +     tail <- newRef Nothing+     size <- newRef 0+     return DoubleLinkedList { listHead = head,                                listTail = tail,                                listSize = size }  -- | Insert a new element in the beginning.-listInsertFirst :: ProtoRefMonad m => DoubleLinkedList m a -> a -> m ()+listInsertFirst :: MonadRef m => DoubleLinkedList m a -> a -> Event m ()+{-# INLINABLE listInsertFirst #-} listInsertFirst x v =-  do let s = listSession x-     size <- readProtoRef (listSize x)-     writeProtoRef (listSize x) (size + 1)-     head <- readProtoRef (listHead x)+  do size <- readRef (listSize x)+     writeRef (listSize x) (size + 1)+     head <- readRef (listHead x)      case head of        Nothing ->-         do prev <- newProtoRef s Nothing-            next <- newProtoRef s Nothing+         do prev <- liftSimulation $ newRef Nothing+            next <- liftSimulation $ newRef Nothing             let item = Just DoubleLinkedItem { itemVal = v,                                                 itemPrev = prev,                                                 itemNext = next }-            writeProtoRef (listHead x) item-            writeProtoRef (listTail x) item+            writeRef (listHead x) item+            writeRef (listTail x) item        Just h ->-         do prev <- newProtoRef s Nothing-            next <- newProtoRef s head+         do prev <- liftSimulation $ newRef Nothing+            next <- liftSimulation $ newRef head             let item = Just DoubleLinkedItem { itemVal = v,                                                itemPrev = prev,                                                itemNext = next }-            writeProtoRef (itemPrev h) item-            writeProtoRef (listHead x) item+            writeRef (itemPrev h) item+            writeRef (listHead x) item  -- | Add a new element to the end.-listAddLast :: ProtoRefMonad m => DoubleLinkedList m a -> a -> m ()+listAddLast :: MonadRef m => DoubleLinkedList m a -> a -> Event m ()+{-# INLINABLE listAddLast #-} listAddLast x v =-  do let s = listSession x-     size <- readProtoRef (listSize x)-     writeProtoRef (listSize x) (size + 1)-     tail <- readProtoRef (listTail x)+  do size <- readRef (listSize x)+     writeRef (listSize x) (size + 1)+     tail <- readRef (listTail x)      case tail of        Nothing ->-         do prev <- newProtoRef s Nothing-            next <- newProtoRef s Nothing+         do prev <- liftSimulation $ newRef Nothing+            next <- liftSimulation $ newRef Nothing             let item = Just DoubleLinkedItem { itemVal = v,                                                 itemPrev = prev,                                                 itemNext = next }-            writeProtoRef (listHead x) item-            writeProtoRef (listTail x) item+            writeRef (listHead x) item+            writeRef (listTail x) item        Just t ->-         do prev <- newProtoRef s tail-            next <- newProtoRef s Nothing+         do prev <- liftSimulation $ newRef tail+            next <- liftSimulation $ newRef Nothing             let item = Just DoubleLinkedItem { itemVal = v,                                                itemPrev = prev,                                                itemNext = next }-            writeProtoRef (itemNext t) item-            writeProtoRef (listTail x) item+            writeRef (itemNext t) item+            writeRef (listTail x) item  -- | Remove the first element.-listRemoveFirst :: ProtoRefMonad m => DoubleLinkedList m a -> m ()+listRemoveFirst :: MonadRef m => DoubleLinkedList m a -> Event m ()+{-# INLINABLE listRemoveFirst #-} listRemoveFirst x =-  do head <- readProtoRef (listHead x) +  do head <- readRef (listHead x)       case head of        Nothing ->          error "Empty list: listRemoveFirst"        Just h ->-         do size  <- readProtoRef (listSize x)-            writeProtoRef (listSize x) (size - 1)-            head' <- readProtoRef (itemNext h)+         do size <- readRef (listSize x)+            writeRef (listSize x) (size - 1)+            head' <- readRef (itemNext h)             case head' of               Nothing ->-                do writeProtoRef (listHead x) Nothing-                   writeProtoRef (listTail x) Nothing+                do writeRef (listHead x) Nothing+                   writeRef (listTail x) Nothing               Just h' ->-                do writeProtoRef (itemPrev h') Nothing-                   writeProtoRef (listHead x) head'+                do writeRef (itemPrev h') Nothing+                   writeRef (listHead x) head'  -- | Remove the last element.-listRemoveLast :: ProtoRefMonad m => DoubleLinkedList m a -> m ()+listRemoveLast :: MonadRef m => DoubleLinkedList m a -> Event m ()+{-# INLINABLE listRemoveLast #-} listRemoveLast x =-  do tail <- readProtoRef (listTail x) +  do tail <- readRef (listTail x)       case tail of        Nothing ->          error "Empty list: listRemoveLast"        Just t ->-         do size  <- readProtoRef (listSize x)-            writeProtoRef (listSize x) (size - 1)-            tail' <- readProtoRef (itemPrev t)+         do size <- readRef (listSize x)+            writeRef (listSize x) (size - 1)+            tail' <- readRef (itemPrev t)             case tail' of               Nothing ->-                do writeProtoRef (listHead x) Nothing-                   writeProtoRef (listTail x) Nothing+                do writeRef (listHead x) Nothing+                   writeRef (listTail x) Nothing               Just t' ->-                do writeProtoRef (itemNext t') Nothing-                   writeProtoRef (listTail x) tail'+                do writeRef (itemNext t') Nothing+                   writeRef (listTail x) tail'  -- | Return the first element.-listFirst :: ProtoRefMonad m => DoubleLinkedList m a -> m a+listFirst :: MonadRef m => DoubleLinkedList m a -> Event m a+{-# INLINABLE listFirst #-} listFirst x =-  do head <- readProtoRef (listHead x)+  do head <- readRef (listHead x)      case head of        Nothing ->          error "Empty list: listFirst"@@ -162,9 +166,10 @@          return $ itemVal h  -- | Return the last element.-listLast :: ProtoRefMonad m => DoubleLinkedList m a -> m a+listLast :: MonadRef m => DoubleLinkedList m a -> Event m a+{-# INLINABLE listLast #-} listLast x =-  do tail <- readProtoRef (listTail x)+  do tail <- readRef (listTail x)      case tail of        Nothing ->          error "Empty list: listLast"
Simulation/Aivika/Trans/Dynamics.hs view
@@ -1,13 +1,13 @@  -- | -- Module     : Simulation.Aivika.Trans.Dynamics--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 ----- The module defines the 'DynamicsT' monad tranformer representing a time varying polymorphic function. +-- The module defines the 'Dynamics' monad tranformer representing a time varying polymorphic function.  -- module Simulation.Aivika.Trans.Dynamics        (-- * Dynamics Monad@@ -30,5 +30,4 @@         -- * Debugging         traceDynamics) where -import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Dynamics
Simulation/Aivika/Trans/Dynamics/Extra.hs view
@@ -3,11 +3,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Dynamics.Extra--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines auxiliary functions such as interpolation ones -- that complement the memoization, for example. There are scan functions too.@@ -71,10 +71,11 @@ -- the integration time points. The accumulator values are transformed -- according to the second argument, which should be either function  -- 'memo0Dynamics' or its unboxed version.-scan1Dynamics :: (MonadComp m, MonadFix m)+scan1Dynamics :: MonadFix m                  => (a -> a -> a)                  -> (Dynamics m a -> Simulation m (Dynamics m a))                  -> (Dynamics m a -> Simulation m (Dynamics m a))+{-# INLINABLE scan1Dynamics #-} scan1Dynamics f tr m =   mdo y <- tr $ Dynamics $ \p ->         case pointIteration p of@@ -93,11 +94,12 @@ -- the integration time points. The accumulator values are transformed -- according to the third argument, which should be either function -- 'memo0Dynamics' or its unboxed version.-scanDynamics :: (MonadComp m, MonadFix m)+scanDynamics :: MonadFix m                 => (a -> b -> a)                 -> a                 -> (Dynamics m a -> Simulation m (Dynamics m a))                 -> (Dynamics m b -> Simulation m (Dynamics m a))+{-# INLINABLE scanDynamics #-} scanDynamics f acc tr m =   mdo y <- tr $ Dynamics $ \p ->         case pointIteration p of
Simulation/Aivika/Trans/Dynamics/Memo.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Dynamics.Memo--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines memo functions. The memoization creates such 'Dynamics' -- computations, which values are cached in the integration time points. Then@@ -13,122 +13,41 @@ --  module Simulation.Aivika.Trans.Dynamics.Memo-       (memoDynamics,-        memo0Dynamics,-        iterateDynamics,+       (MonadMemo(..),         unzipDynamics,         unzip0Dynamics) where  import Control.Monad+import Control.Monad.Trans -import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.ProtoArray-import Simulation.Aivika.Trans.Comp-import Simulation.Aivika.Trans.Internal.Specs-import Simulation.Aivika.Trans.Internal.Parameter import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Dynamics-import Simulation.Aivika.Trans.Dynamics.Extra --- | Memoize and order the computation in the integration time points using --- the interpolation that knows of the Runge-Kutta method. The values are--- calculated sequentially starting from 'starttime'.-memoDynamics :: MonadComp m => Dynamics m e -> Simulation m (Dynamics m e)-{-# INLINABLE memoDynamics #-}-memoDynamics (Dynamics m) = -  Simulation $ \r ->-  do let sc  = runSpecs r-         s   = runSession r-         phs = 1 + integPhaseHiBnd sc-         ns  = 1 + integIterationHiBnd sc-     arr   <- newProtoArray_ s (ns * phs)-     nref  <- newProtoRef s 0-     phref <- newProtoRef s 0-     let r p = -           do let n  = pointIteration p-                  ph = pointPhase p-                  i  = n * phs + ph-                  loop n' ph' = -                    if (n' > n) || ((n' == n) && (ph' > ph)) -                    then -                      readProtoArray arr i-                    else -                      let p' = p { pointIteration = n', pointPhase = ph',-                                   pointTime = basicTime sc n' ph' }-                          i' = n' * phs + ph'-                      in do a <- m p'-                            a `seq` writeProtoArray arr i' a-                            if ph' >= phs - 1 -                              then do writeProtoRef phref 0-                                      writeProtoRef nref (n' + 1)-                                      loop (n' + 1) 0-                              else do writeProtoRef phref (ph' + 1)-                                      loop n' (ph' + 1)-              n'  <- readProtoRef nref-              ph' <- readProtoRef phref-              loop n' ph'-     return $ interpolateDynamics $ Dynamics r+-- | A monad with the support of memoisation.+class Monad m => MonadMemo m where  --- | Memoize and order the computation in the integration time points using --- the 'discreteDynamics' interpolation. It consumes less memory than the 'memoDynamics'--- function but it is not aware of the Runge-Kutta method. There is a subtle--- difference when we request for values in the intermediate time points--- that are used by this method to integrate. In general case you should --- prefer the 'memo0Dynamics' function above 'memoDynamics'.-memo0Dynamics :: MonadComp m => Dynamics m e -> Simulation m (Dynamics m e)-{-# INLINABLE memo0Dynamics #-}-memo0Dynamics (Dynamics m) = -  Simulation $ \r ->-  do let sc = runSpecs r-         s  = runSession r-         ns = 1 + integIterationHiBnd sc-     arr  <- newProtoArray_ s ns-     nref <- newProtoRef s 0-     let r p =-           do let sc = pointSpecs p-                  n  = pointIteration p-                  loop n' = -                    if n' > n-                    then -                      readProtoArray arr n-                    else -                      let p' = p { pointIteration = n', pointPhase = 0,-                                   pointTime = basicTime sc n' 0 }-                      in do a <- m p'-                            a `seq` writeProtoArray arr n' a-                            writeProtoRef nref (n' + 1)-                            loop (n' + 1)-              n' <- readProtoRef nref-              loop n'-     return $ discreteDynamics $ Dynamics r+  -- | Memoize and order the computation in the integration time points using +  -- the interpolation that knows of the Runge-Kutta method. The values are+  -- calculated sequentially starting from 'starttime'.+  memoDynamics :: Dynamics m e -> Simulation m (Dynamics m e) --- | Iterate sequentially the dynamic process with side effects in --- the integration time points. It is equivalent to a call of the--- 'memo0Dynamics' function but significantly more efficient, for the array --- is not created.-iterateDynamics :: MonadComp m => Dynamics m () -> Simulation m (Dynamics m ())-{-# INLINABLE iterateDynamics #-}-iterateDynamics (Dynamics m) = -  Simulation $ \r ->-  do let sc = runSpecs r-         s  = runSession r-     nref <- newProtoRef s 0-     let r p =-           do let sc = pointSpecs p-                  n  = pointIteration p-                  loop n' = -                    unless (n' > n) $-                    let p' = p { pointIteration = n', pointPhase = 0,-                                 pointTime = basicTime sc n' 0 }-                    in do a <- m p'-                          a `seq` writeProtoRef nref (n' + 1)-                          loop (n' + 1)-              n' <- readProtoRef nref-              loop n'-     return $ discreteDynamics $ Dynamics r+  -- | Memoize and order the computation in the integration time points using +  -- the 'discreteDynamics' interpolation. It consumes less memory than the 'memoDynamics'+  -- function but it is not aware of the Runge-Kutta method. There is a subtle+  -- difference when we request for values in the intermediate time points+  -- that are used by this method to integrate. In general case you should +  -- prefer the 'memo0Dynamics' function above 'memoDynamics'.+  memo0Dynamics :: Dynamics m e -> Simulation m (Dynamics m e) +  -- | Iterate sequentially the dynamic process with side effects in +  -- the integration time points. It is equivalent to a call of the+  -- 'memo0Dynamics' function but significantly more efficient, for the array +  -- is not created.+  iterateDynamics :: Dynamics m () -> Simulation m (Dynamics m ())+ -- | Memoize and unzip the computation of pairs, applying the 'memoDynamics' function.-unzipDynamics :: MonadComp m => Dynamics m (a, b) -> Simulation m (Dynamics m a, Dynamics m b)+unzipDynamics :: MonadMemo m => Dynamics m (a, b) -> Simulation m (Dynamics m a, Dynamics m b)+{-# INLINABLE unzipDynamics #-} unzipDynamics m =   Simulation $ \r ->   do m' <- invokeSimulation r (memoDynamics m)@@ -143,7 +62,8 @@      return (ma, mb)  -- | Memoize and unzip the computation of pairs, applying the 'memo0Dynamics' function.-unzip0Dynamics :: MonadComp m => Dynamics m (a, b) -> Simulation m (Dynamics m a, Dynamics m b)+unzip0Dynamics :: MonadMemo m => Dynamics m (a, b) -> Simulation m (Dynamics m a, Dynamics m b)+{-# INLINABLE unzip0Dynamics #-} unzip0Dynamics m =   Simulation $ \r ->   do m' <- invokeSimulation r (memo0Dynamics m)
Simulation/Aivika/Trans/Dynamics/Memo/Unboxed.hs view
@@ -1,105 +1,40 @@ -{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}  -- | -- Module     : Simulation.Aivika.Trans.Dynamics.Memo.Unboxed--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 ----- This module defines the unboxed memo functions. The memoization creates such 'DynamicsT'+-- This module defines the unboxed memo functions. The memoization creates such 'Dynamics' -- computations, which values are cached in the integration time points. Then -- these values are interpolated in all other time points. --  module Simulation.Aivika.Trans.Dynamics.Memo.Unboxed-       (memoDynamics,-        memo0Dynamics) where+       (MonadMemo(..)) where  import Control.Monad+import Control.Monad.Trans -import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.ProtoArray.Unboxed-import Simulation.Aivika.Trans.Comp-import Simulation.Aivika.Trans.Comp.IO-import Simulation.Aivika.Trans.Internal.Specs-import Simulation.Aivika.Trans.Internal.Parameter import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Dynamics-import Simulation.Aivika.Trans.Dynamics.Extra-import Simulation.Aivika.Trans.Unboxed --- | Memoize and order the computation in the integration time points using --- the interpolation that knows of the Runge-Kutta method. The values are--- calculated sequentially starting from 'starttime'.-memoDynamics :: (Unboxed m e, MonadComp m) => Dynamics m e -> Simulation m (Dynamics m e)-{-# INLINABLE memoDynamics #-}-memoDynamics (Dynamics m) = -  Simulation $ \r ->-  do let sc  = runSpecs r-         s   = runSession r-         phs = 1 + integPhaseHiBnd sc-         ns  = 1 + integIterationHiBnd sc-     arr   <- newProtoArray_ s (phs * ns)-     nref  <- newProtoRef s 0-     phref <- newProtoRef s 0-     let r p =-           do let n  = pointIteration p-                  ph = pointPhase p-                  i  = n * phs + ph-                  loop n' ph' = -                    if (n' > n) || ((n' == n) && (ph' > ph)) -                    then -                      readProtoArray arr i-                    else -                      let p' = p { pointIteration = n', -                                   pointPhase = ph',-                                   pointTime = basicTime sc n' ph' }-                          i' = n' * phs + ph'-                      in do a <- m p'-                            a `seq` writeProtoArray arr i' a-                            if ph' >= phs - 1 -                              then do writeProtoRef phref 0-                                      writeProtoRef nref (n' + 1)-                                      loop (n' + 1) 0-                              else do writeProtoRef phref (ph' + 1)-                                      loop n' (ph' + 1)-              n'  <- readProtoRef nref-              ph' <- readProtoRef phref-              loop n' ph'-     return $ interpolateDynamics $ Dynamics r+-- | A monad with the support of unboxed memoisation.+class Monad m => MonadMemo m e where --- | Memoize and order the computation in the integration time points using --- the 'discreteDynamics' interpolation. It consumes less memory than the 'memoDynamics'--- function but it is not aware of the Runge-Kutta method. There is a subtle--- difference when we request for values in the intermediate time points--- that are used by this method to integrate. In general case you should --- prefer the 'memo0Dynamics' function above 'memoDynamics'.-memo0Dynamics :: (Unboxed m e, MonadComp m) => Dynamics m e -> Simulation m (Dynamics m e)-{-# INLINABLE memo0Dynamics #-}-memo0Dynamics (Dynamics m) = -  Simulation $ \r ->-  do let sc = runSpecs r-         s  = runSession r-         ns = 1 + integIterationHiBnd sc-     arr  <- newProtoArray_ s ns-     nref <- newProtoRef s 0-     let r p =-           do let sc = pointSpecs p-                  n  = pointIteration p-                  loop n' = -                    if n' > n-                    then -                      readProtoArray arr n-                    else -                      let p' = p { pointIteration = n', pointPhase = 0,-                                   pointTime = basicTime sc n' 0 }-                      in do a <- m p'-                            a `seq` writeProtoArray arr n' a-                            writeProtoRef nref (n' + 1)-                            loop (n' + 1)-              n' <- readProtoRef nref-              loop n'-     return $ discreteDynamics $ Dynamics r+  -- | Memoize and order the computation in the integration time points using +  -- the interpolation that knows of the Runge-Kutta method. The values are+  -- calculated sequentially starting from 'starttime'.+  memoDynamics :: Dynamics m e -> Simulation m (Dynamics m e)++  -- | Memoize and order the computation in the integration time points using +  -- the 'discreteDynamics' interpolation. It consumes less memory than the 'memoDynamics'+  -- function but it is not aware of the Runge-Kutta method. There is a subtle+  -- difference when we request for values in the intermediate time points+  -- that are used by this method to integrate. In general case you should +  -- prefer the 'memo0Dynamics' function above 'memoDynamics'.+  memo0Dynamics :: Dynamics m e -> Simulation m (Dynamics m e)
Simulation/Aivika/Trans/Dynamics/Random.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Dynamics.Random--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines the random functions that always return the same values -- in the integration time points within a single simulation run. The values@@ -28,24 +28,21 @@         memoRandomPoissonDynamics,         memoRandomBinomialDynamics) where -import System.Random--import Control.Monad.Trans- import Simulation.Aivika.Trans.Generator-import Simulation.Aivika.Trans.Comp import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Parameter import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Dynamics import Simulation.Aivika.Trans.Dynamics.Memo.Unboxed+import Simulation.Aivika.Trans.SD  -- | Computation that generates random numbers distributed uniformly and -- memoizes them in the integration time points.-memoRandomUniformDynamics :: MonadComp m+memoRandomUniformDynamics :: MonadSD m                              => Dynamics m Double     -- ^ minimum                              -> Dynamics m Double     -- ^ maximum                              -> Simulation m (Dynamics m Double)+{-# INLINABLE memoRandomUniformDynamics #-} memoRandomUniformDynamics min max =   memo0Dynamics $   Dynamics $ \p ->@@ -56,10 +53,11 @@  -- | Computation that generates random integer numbers distributed uniformly and -- memoizes them in the integration time points.-memoRandomUniformIntDynamics :: MonadComp m+memoRandomUniformIntDynamics :: MonadSD m                                 => Dynamics m Int     -- ^ minimum                                 -> Dynamics m Int     -- ^ maximum                                 -> Simulation m (Dynamics m Int)+{-# INLINABLE memoRandomUniformIntDynamics #-} memoRandomUniformIntDynamics min max =   memo0Dynamics $   Dynamics $ \p ->@@ -70,10 +68,11 @@  -- | Computation that generates random numbers distributed normally and -- memoizes them in the integration time points.-memoRandomNormalDynamics :: MonadComp m+memoRandomNormalDynamics :: MonadSD m                             => Dynamics m Double     -- ^ mean                             -> Dynamics m Double     -- ^ deviation                             -> Simulation m (Dynamics m Double)+{-# INLINABLE memoRandomNormalDynamics #-} memoRandomNormalDynamics mu nu =   memo0Dynamics $   Dynamics $ \p ->@@ -84,10 +83,11 @@  -- | Computation that generates exponential random numbers with the specified mean -- (the reciprocal of the rate) and memoizes them in the integration time points.-memoRandomExponentialDynamics :: MonadComp m+memoRandomExponentialDynamics :: MonadSD m                                  => Dynamics m Double                                  -- ^ the mean (the reciprocal of the rate)                                  -> Simulation m (Dynamics m Double)+{-# INLINABLE memoRandomExponentialDynamics #-} memoRandomExponentialDynamics mu =   memo0Dynamics $   Dynamics $ \p ->@@ -98,12 +98,13 @@ -- | 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 :: MonadComp m+memoRandomErlangDynamics :: MonadSD m                             => Dynamics m Double                             -- ^ the scale (the reciprocal of the rate)                             -> Dynamics m Int                             -- ^ the shape                             -> Simulation m (Dynamics m Double)+{-# INLINABLE memoRandomErlangDynamics #-} memoRandomErlangDynamics beta m =   memo0Dynamics $   Dynamics $ \p ->@@ -114,10 +115,11 @@  -- | Computation that generats the Poisson random numbers with the specified mean -- and memoizes them in the integration time points.-memoRandomPoissonDynamics :: MonadComp m+memoRandomPoissonDynamics :: MonadSD m                              => Dynamics m Double                              -- ^ the mean                              -> Simulation m (Dynamics m Int)+{-# INLINABLE memoRandomPoissonDynamics #-} memoRandomPoissonDynamics mu =   memo0Dynamics $   Dynamics $ \p ->@@ -127,10 +129,11 @@  -- | Computation that generates binomial random numbers with the specified -- probability and trials but memoizes them in the integration time points.-memoRandomBinomialDynamics :: MonadComp m+memoRandomBinomialDynamics :: MonadSD m                               => Dynamics m Double  -- ^ the probability                               -> Dynamics m Int  -- ^ the number of trials                               -> Simulation m (Dynamics m Int)+{-# INLINABLE memoRandomBinomialDynamics #-} memoRandomBinomialDynamics prob trials =   memo0Dynamics $   Dynamics $ \p ->
Simulation/Aivika/Trans/Event.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Event--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The module defines the 'Event' monad which is very similar to the 'Dynamics' -- monad but only now the computation is strongly synchronized with the event queue.@@ -40,5 +40,6 @@         -- * Debugging         traceEvent) where -import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Internal.Dynamics import Simulation.Aivika.Trans.Internal.Event+
Simulation/Aivika/Trans/Exception.hs view
@@ -1,46 +1,27 @@  -- | -- Module     : Simulation.Aivika.Trans.Exception--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 ----- It defines a type class of monads with 'IO' exception handling capabilities.+-- It defines a type class of monads with exception handling capabilities. -- module Simulation.Aivika.Trans.Exception-       (ExceptionThrowing(..),-        ExceptionHandling(..)) where+       (MonadException(..)) where -import Control.Monad.Trans import Control.Exception  -- | A computation within which we can throw an exception.-class ExceptionThrowing m where--  -- | Throw an exception.-  throwComp :: Exception e => e -> m a---- | A computation within which we can handle 'IO' exceptions--- as well as define finalisation blocks.-class (ExceptionThrowing m, MonadIO m) => ExceptionHandling m where+class Monad m => MonadException m where -  -- | Catch an 'IO' exception within the computation.-  catchComp :: (Exception e, MonadIO m) => m a -> (e -> m a) -> m a+  -- | Catch an exception within the computation.+  catchComp :: Exception e => m a -> (e -> m a) -> m a    -- | Introduce a finalisation block.-  finallyComp :: MonadIO m => m a -> m b -> m a--instance ExceptionThrowing IO where--  {-# INLINE throwComp #-}-  throwComp = throw--instance ExceptionHandling IO where--  {-# INLINE catchComp #-}-  catchComp = catch+  finallyComp :: m a -> m b -> m a -  {-# INLINE finallyComp #-}-  finallyComp = finally+  -- | Throw an exception.+  throwComp :: Exception e => e -> m a
+ Simulation/Aivika/Trans/Gate.hs view
@@ -0,0 +1,102 @@++-- |+-- Module     : Simulation.Aivika.Trans.Gate+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- The module defines a gate which can be either opened or closed.+--+module Simulation.Aivika.Trans.Gate+       (Gate,+        newGate,+        newGateOpened,+        newGateClosed,+        openGate,+        closeGate,+        gateOpened,+        gateClosed,+        awaitGateOpened,+        awaitGateClosed,+        gateChanged_) where++import Control.Monad++import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Simulation+import Simulation.Aivika.Trans.Event+import Simulation.Aivika.Trans.Process+import Simulation.Aivika.Trans.Signal+import Simulation.Aivika.Trans.Ref++-- | Represents a gate, which can be either opened or closed.+data Gate m = Gate { gateRef :: Ref m Bool }++-- | Create a new gate, specifying whether the gate is initially open.+newGate :: MonadDES m => Bool -> Simulation m (Gate m)+{-# INLINE newGate #-}+newGate opened =+  do r <- newRef opened+     return Gate { gateRef = r }++-- | Create a new initially open gate.+newGateOpened :: MonadDES m => Simulation m (Gate m)+{-# INLINE newGateOpened #-}+newGateOpened = newGate True++-- | Create a new initially close gate.+newGateClosed :: MonadDES m => Simulation m (Gate m)+{-# INLINE newGateClosed #-}+newGateClosed = newGate False++-- | Open the gate if it was closed.+openGate :: MonadDES m => Gate m -> Event m ()+{-# INLINE openGate #-}+openGate gate =+  writeRef (gateRef gate) True++-- | Close the gate if it was open.+closeGate :: MonadDES m => Gate m -> Event m ()+{-# INLINE closeGate #-}+closeGate gate =+  writeRef (gateRef gate) False++-- | Test whether the gate is open.+gateOpened :: MonadDES m => Gate m -> Event m Bool+{-# INLINE gateOpened #-}+gateOpened gate =+  readRef (gateRef gate)++-- | Test whether the gate is closed.+gateClosed :: MonadDES m => Gate m -> Event m Bool+{-# INLINE gateClosed #-}+gateClosed gate =+  fmap not $ readRef (gateRef gate)++-- | Await the gate to be opened if required. If the gate is already open+-- then the computation returns immediately.+awaitGateOpened :: MonadDES m => Gate m -> Process m ()+{-# INLINABLE awaitGateOpened #-}+awaitGateOpened gate =+  do f <- liftEvent $ readRef (gateRef gate)+     unless f $+       do processAwait $ refChanged_ (gateRef gate)+          awaitGateOpened gate++-- | Await the gate to be closed if required. If the gate is already closed+-- then the computation returns immediately.+awaitGateClosed :: MonadDES m => Gate m -> Process m ()+{-# INLINABLE awaitGateClosed #-}+awaitGateClosed gate =+  do f <- liftEvent $ readRef (gateRef gate)+     when f $+       do processAwait $ refChanged_ (gateRef gate)+          awaitGateClosed gate++-- | Signal triggered when the state of the gate changes.+gateChanged_ :: MonadDES m => Gate m -> Signal m ()+{-# INLINE gateChanged_ #-}+gateChanged_ gate =+  refChanged_ (gateRef gate)
Simulation/Aivika/Trans/Generator.hs view
@@ -3,26 +3,22 @@  -- | -- Module     : Simulation.Aivika.Trans.Generator--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- Below is defined a random number generator. -- module Simulation.Aivika.Trans.Generator -       (GeneratorMonad(..),+       (MonadGenerator(..),         GeneratorType(..)) where  import System.Random -import Data.IORef--import Simulation.Aivika.Trans.Session- -- | Defines a monad whithin which computation the random number generator can work.-class (Functor m, Monad m) => GeneratorMonad m where+class (Functor m, Monad m) => MonadGenerator m where    -- | Defines a random number generator.   data Generator m :: *@@ -55,69 +51,14 @@   -- with the specified probability and number of trials.   generateBinomial :: Generator m -> Double -> Int -> m Int   -  -- | Create a new random number generator by the specified type with current session.-  newGenerator :: Session m -> GeneratorType m -> m (Generator m)--  -- | Create a new random generator by the specified standard generator within current session.-  newRandomGenerator :: RandomGen g => Session m -> g -> m (Generator m)--  -- | Create a new random generator by the specified uniform generator of numbers-  -- from 0 to 1 within current session.-  newRandomGenerator01 :: Session m -> m Double -> m (Generator m)--instance GeneratorMonad IO where--  data Generator IO =-    Generator { generator01 :: IO Double,-                -- ^ the generator of uniform numbers from 0 to 1-                generatorNormal01 :: IO Double-                -- ^ the generator of normal numbers with mean 0 and variance 1-              }--  {-# SPECIALISE INLINE generateUniform :: Generator IO -> Double -> Double -> IO Double #-}-  generateUniform = generateUniform01 . generator01--  {-# SPECIALISE INLINE generateUniformInt :: Generator IO -> Int -> Int -> IO Int #-}-  generateUniformInt = generateUniformInt01 . generator01--  {-# SPECIALISE INLINE generateUniform :: Generator IO -> Double -> Double -> IO Double #-}-  generateNormal = generateNormal01 . generatorNormal01--  {-# SPECIALISE INLINE generateExponential :: Generator IO -> Double -> IO Double #-}-  generateExponential = generateExponential01 . generator01--  {-# SPECIALISE INLINE generateErlang :: Generator IO -> Double -> Int -> IO Double #-}-  generateErlang = generateErlang01 . generator01--  {-# SPECIALISE INLINE generatePoisson :: Generator IO -> Double -> IO Int #-}-  generatePoisson = generatePoisson01 . generator01--  {-# SPECIALISE INLINE generateBinomial :: Generator IO -> Double -> Int -> IO Int #-}-  generateBinomial = generateBinomial01 . generator01--  newGenerator session tp =-    case tp of-      SimpleGenerator ->-        newStdGen >>= newRandomGenerator session-      SimpleGeneratorWithSeed x ->-        newRandomGenerator session $ mkStdGen x-      CustomGenerator g ->-        g-      CustomGenerator01 g ->-        newRandomGenerator01 session g+  -- | Create a new random number generator.+  newGenerator :: GeneratorType m -> m (Generator m) -  newRandomGenerator session g = -    do r <- newIORef g-       let g01 = do g <- readIORef r-                    let (x, g') = random g-                    writeIORef r g'-                    return x-       newRandomGenerator01 session g01+  -- | Create a new random generator by the specified standard generator.+  newRandomGenerator :: RandomGen g => g -> m (Generator m) -  newRandomGenerator01 session g01 =-    do gNormal01 <- newNormalGenerator01 g01-       return Generator { generator01 = g01,-                          generatorNormal01 = gNormal01 }+  -- | Create a new random generator by the specified uniform generator of numbers from 0 to 1.+  newRandomGenerator01 :: m Double -> m (Generator m)  -- | Defines a type of the random number generator. data GeneratorType m = SimpleGenerator@@ -129,141 +70,3 @@                      | CustomGenerator01 (m Double)                        -- ^ The custom random number generator by the specified uniform                        -- generator of numbers from 0 to 1.---- | Generate an uniform random number with the specified minimum and maximum.-generateUniform01 :: IO Double-                     -- ^ the generator-                     -> Double-                     -- ^ minimum-                     -> Double-                     -- ^ maximum-                     -> IO Double-generateUniform01 g min max =-  do x <- g-     return $ min + x * (max - min)---- | Generate an uniform random number with the specified minimum and maximum.-generateUniformInt01 :: IO Double-                        -- ^ the generator-                        -> Int-                        -- ^ minimum-                        -> Int-                        -- ^ maximum-                        -> IO Int-generateUniformInt01 g min max =-  do x <- g-     let min' = fromIntegral min-         max' = fromIntegral max-     return $ round (min' + x * (max' - min'))---- | Generate a normal random number by the specified generator, mean and variance.-generateNormal01 :: IO Double-                    -- ^ normal random numbers with mean 0 and variance 1-                    -> Double-                    -- ^ mean-                    -> Double-                    -- ^ variance-                    -> IO Double-generateNormal01 g mu nu =-  do x <- g-     return $ mu + nu * x---- | Create a normal random number generator with mean 0 and variance 1--- by the specified generator of uniform random numbers from 0 to 1.-newNormalGenerator01 :: IO Double-                        -- ^ the generator-                        -> IO (IO Double)-newNormalGenerator01 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.-generateExponential01 :: IO Double-                         -- ^ the generator-                         -> Double-                         -- ^ the mean-                         -> IO Double-generateExponential01 g mu =-  do x <- g-     return (- log x * mu)---- | Return the Erlang random number.-generateErlang01 :: IO Double-                    -- ^ the generator-                    -> Double-                    -- ^ the scale-                    -> Int-                    -- ^ the shape-                    -> IO Double-generateErlang01 g beta m =-  do x <- loop m 1-     return (- log x * beta)-       where loop m acc-               | m < 0     = error "Negative shape: generateErlang."-               | m == 0    = return acc-               | otherwise = do x <- g-                                loop (m - 1) (x * acc)---- | Generate the Poisson random number with the specified mean.-generatePoisson01 :: IO Double-                     -- ^ the generator-                     -> Double-                     -- ^ the mean-                     -> IO Int-generatePoisson01 g mu =-  do prob0 <- g-     let loop prob prod acc-           | prob <= prod = return acc-           | otherwise    = loop-                            (prob - prod)-                            (prod * mu / fromIntegral (acc + 1))-                            (acc + 1)-     loop prob0 (exp (- mu)) 0---- | Generate a binomial random number with the specified probability and number of trials. -generateBinomial01 :: IO Double-                      -- ^ the generator-                      -> Double -                      -- ^ the probability-                      -> Int-                      -- ^ the number of trials-                      -> IO Int-generateBinomial01 g prob trials = loop trials 0 where-  loop n acc-    | n < 0     = error "Negative number of trials: generateBinomial."-    | n == 0    = return acc-    | otherwise = do x <- g-                     if x <= prob-                       then loop (n - 1) (acc + 1)-                       else loop (n - 1) acc
Simulation/Aivika/Trans/Internal/Cont.hs view
@@ -1,27 +1,38 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+ -- | -- Module     : Simulation.Aivika.Trans.Internal.Cont--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The 'Cont' monad is a variation of the standard Cont monad  -- and F# async workflow, where the result of applying  -- the continuations is the 'Event' computation. -- module Simulation.Aivika.Trans.Internal.Cont-       (ContCancellationSource,-        ContParams,+       (ContParams,         ContCancellation(..),         Cont(..),-        newContCancellationSource,+        ContId,+        ContEvent(..),+        FrozenCont,+        newContId,+        contSignal,         contCancellationInitiated,         contCancellationInitiate,         contCancellationInitiating,+        contCancellationActivated,         contCancellationBind,         contCancellationConnect,+        contPreemptionBegun,+        contPreemptionBegin,+        contPreemptionBeginning,+        contPreemptionEnd,+        contPreemptionEnding,         invokeCont,         runCont,         rerunCont,@@ -33,8 +44,12 @@         throwCont,         resumeCont,         resumeECont,+        reenterCont,+        freezeCont,+        freezeContReentering,+        unfreezeCont,+        substituteCont,         contCanceled,-        contFreeze,         contAwait,         traceCont) where @@ -48,17 +63,16 @@  import Debug.Trace (trace) -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.ProtoArray+import Simulation.Aivika.Trans.Ref.Base import Simulation.Aivika.Trans.Exception import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Parameter import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Dynamics import Simulation.Aivika.Trans.Internal.Event-import Simulation.Aivika.Trans.Internal.Signal+import Simulation.Aivika.Trans.Signal  -- | It defines how the parent and child computations should be cancelled. data ContCancellation = CancelTogether@@ -70,48 +84,73 @@                       | CancelInIsolation                         -- ^ Cancel the computations in isolation. --- | It manages the cancellation process.-data ContCancellationSource m =-  ContCancellationSource { contCancellationInitiatedRef :: ProtoRef m Bool,-                           contCancellationActivatedRef :: ProtoRef m Bool,-                           contCancellationInitiatingSource :: SignalSource m ()-                         }+-- | It identifies the 'Cont' computation.+data ContId m =+  ContId { contCancellationInitiatedRef :: Ref m Bool,+           contCancellationActivatedRef :: Ref m Bool,+           contPreemptionCountRef :: Ref m Int,+           contSignalSource :: SignalSource m ContEvent+         } --- | Create the cancellation source.-newContCancellationSource :: MonadComp m => Simulation m (ContCancellationSource m)-newContCancellationSource =+instance MonadDES m => Eq (ContId m) where+  x == y = contCancellationInitiatedRef x == contCancellationInitiatedRef y++-- | The event that occurs within the 'Cont' computation.+data ContEvent = ContCancellationInitiating+                 -- ^ Cancel the computation.+               | ContPreemptionBeginning+                 -- ^ Preempt the computation.+               | ContPreemptionEnding+                 -- ^ Proceed with the computation after if was preempted.+               deriving (Eq, Ord, Show)++-- | Create a computation identifier.+newContId :: MonadDES m => Simulation m (ContId m)+{-# INLINABLE newContId #-}+newContId =   Simulation $ \r ->-  do let sn = runSession r-     r1 <- newProtoRef sn False-     r2 <- newProtoRef sn False+  do r1 <- invokeSimulation r $ newRef False+     r2 <- invokeSimulation r $ newRef False+     r3 <- invokeSimulation r $ newRef 0      s  <- invokeSimulation r newSignalSource-     return ContCancellationSource { contCancellationInitiatedRef = r1,-                                     contCancellationActivatedRef = r2,-                                     contCancellationInitiatingSource = s-                                   }+     return ContId { contCancellationInitiatedRef = r1,+                     contCancellationActivatedRef = r2,+                     contPreemptionCountRef = r3,+                     contSignalSource = s+                   } +-- | Signal when the computation state changes.+contSignal :: ContId m -> Signal m ContEvent+{-# INLINABLE contSignal #-}+contSignal = publishSignal . contSignalSource+ -- | Signal when the cancellation is intiating.-contCancellationInitiating :: ContCancellationSource m -> Signal m ()+contCancellationInitiating :: MonadDES m => ContId m -> Signal m ()+{-# INLINABLE contCancellationInitiating #-} contCancellationInitiating =-  publishSignal . contCancellationInitiatingSource+  filterSignal_ (ContCancellationInitiating ==) . contSignal  -- | Whether the cancellation was initiated.-contCancellationInitiated :: MonadComp m => ContCancellationSource m -> (Event m Bool)-contCancellationInitiated x =-  Event $ \p -> readProtoRef (contCancellationInitiatedRef x)+contCancellationInitiated :: MonadDES m => ContId m -> Event m Bool+{-# INLINABLE contCancellationInitiated #-}+contCancellationInitiated =+  readRef . contCancellationInitiatedRef  -- | Whether the cancellation was activated.-contCancellationActivated :: MonadComp m => ContCancellationSource m -> m Bool+contCancellationActivated :: MonadDES m => ContId m -> Event m Bool+{-# INLINABLE contCancellationActivated #-} contCancellationActivated =-  readProtoRef . contCancellationActivatedRef+  readRef . contCancellationActivatedRef  -- | Deactivate the cancellation.-contCancellationDeactivate :: MonadComp m => ContCancellationSource m -> m ()+contCancellationDeactivate :: MonadDES m => ContId m -> Event m ()+{-# INLINABLE contCancellationDeactivate #-} contCancellationDeactivate x =-  writeProtoRef (contCancellationActivatedRef x) False+  writeRef (contCancellationActivatedRef x) False  -- | If the main computation is cancelled then all the nested ones will be cancelled too.-contCancellationBind :: MonadComp m => ContCancellationSource m -> [ContCancellationSource m] -> Event m (DisposableEvent m)+contCancellationBind :: MonadDES m => ContId m -> [ContId m] -> Event m (DisposableEvent m)+{-# INLINABLE contCancellationBind #-} contCancellationBind x ys =   Event $ \p ->   do hs1 <- forM ys $ \y ->@@ -125,15 +164,16 @@      return $ mconcat hs1 <> mconcat hs2  -- | Connect the parent computation to the child one.-contCancellationConnect :: MonadComp m-                           => ContCancellationSource m+contCancellationConnect :: MonadDES m+                           => ContId m                            -- ^ the parent                            -> ContCancellation                            -- ^ how to connect-                           -> ContCancellationSource m+                           -> ContId m                            -- ^ the child                            -> Event m (DisposableEvent m)                            -- ^ computation of the disposable handler+{-# INLINABLE contCancellationConnect #-} contCancellationConnect parent cancellation child =   Event $ \p ->   do let m1 =@@ -157,15 +197,64 @@      return $ h1 <> h2  -- | Initiate the cancellation.-contCancellationInitiate :: MonadComp m => ContCancellationSource m -> Event m ()+contCancellationInitiate :: MonadDES m => ContId m -> Event m ()+{-# INLINABLE contCancellationInitiate #-} contCancellationInitiate x =   Event $ \p ->-  do f <- readProtoRef (contCancellationInitiatedRef x)+  do f <- invokeEvent p $ readRef (contCancellationInitiatedRef x)      unless f $-       do writeProtoRef (contCancellationInitiatedRef x) True-          writeProtoRef (contCancellationActivatedRef x) True-          invokeEvent p $ triggerSignal (contCancellationInitiatingSource x) ()+       do invokeEvent p $ writeRef (contCancellationInitiatedRef x) True+          invokeEvent p $ writeRef (contCancellationActivatedRef x) True+          invokeEvent p $ triggerSignal (contSignalSource x) ContCancellationInitiating +-- | Preempt the computation.+contPreemptionBegin :: MonadDES m => ContId m -> Event m ()+{-# INLINABLE contPreemptionBegin #-}+contPreemptionBegin x =+  Event $ \p ->+  do f <- invokeEvent p $ readRef (contCancellationInitiatedRef x)+     unless f $+       do n <- invokeEvent p $ readRef (contPreemptionCountRef x)+          let n' = n + 1+          n' `seq` invokeEvent p $ writeRef (contPreemptionCountRef x) n'+          when (n == 0) $+            invokeEvent p $+            triggerSignal (contSignalSource x) ContPreemptionBeginning++-- | Proceed with the computation after it was preempted earlier.+contPreemptionEnd :: MonadDES m => ContId m -> Event m ()+{-# INLINABLE contPreemptionEnd #-}+contPreemptionEnd x =+  Event $ \p ->+  do f <- invokeEvent p $ readRef (contCancellationInitiatedRef x)+     unless f $+       do n <- invokeEvent p $ readRef (contPreemptionCountRef x)+          let n' = n - 1+          n' `seq` invokeEvent p $ writeRef (contPreemptionCountRef x) n'+          when (n' == 0) $+            invokeEvent p $+            triggerSignal (contSignalSource x) ContPreemptionEnding++-- | Signal when the computation is preempted.+contPreemptionBeginning :: MonadDES m => ContId m -> Signal m ()+{-# INLINABLE contPreemptionBeginning #-}+contPreemptionBeginning =+  filterSignal_ (ContPreemptionBeginning ==) . contSignal++-- | Signal when the computation is proceeded after it was preempted before.+contPreemptionEnding :: MonadDES m => ContId m -> Signal m ()+{-# INLINABLE contPreemptionEnding #-}+contPreemptionEnding =+  filterSignal_ (ContPreemptionEnding ==) . contSignal++-- | Whether the computation was preemtped.+contPreemptionBegun :: MonadDES m => ContId m -> Event m Bool+{-# INLINABLE contPreemptionBegun #-}+contPreemptionBegun x =+  Event $ \p ->+  do n <- invokeEvent p $ readRef (contPreemptionCountRef x)+     return (n > 0)+ -- | The 'Cont' type is similar to the standard Cont monad  -- and F# async workflow but only the result of applying -- the continuations return the 'Event' computation.@@ -180,33 +269,33 @@ data ContParamsAux m =   ContParamsAux { contECont :: SomeException -> Event m (),                   contCCont :: () -> Event m (),-                  contCancelSource :: ContCancellationSource m,-                  contCancelFlag :: m Bool,+                  contId :: ContId m,+                  contCancelFlag :: Event m Bool,                   contCatchFlag  :: Bool } -instance MonadComp m => Monad (Cont m) where+instance MonadDES m => Monad (Cont m) where    {-# INLINE return #-}   return a =      Cont $ \c ->     Event $ \p ->-    do z <- contCanceled c+    do z <- invokeEvent p $ contCanceled c        if z -         then cancelCont p c+         then invokeEvent p $ cancelCont c          else invokeEvent p $ contCont c a    {-# INLINE (>>=) #-}   (Cont m) >>= k =     Cont $ \c ->     Event $ \p ->-    do z <- contCanceled c+    do z <- invokeEvent p $ contCanceled c        if z -         then cancelCont p c+         then invokeEvent p $ cancelCont c          else invokeEvent p $ m $                let cont a = invokeCont c (k a)               in c { contCont = cont } -instance MonadCompTrans Cont where+instance MonadDES m => MonadCompTrans Cont m where    {-# INLINE liftComp #-}   liftComp m =@@ -216,7 +305,7 @@     then liftWithCatching m p c     else liftWithoutCatching m p c -instance ParameterLift Cont where+instance MonadDES m => ParameterLift Cont m where    {-# INLINE liftParameter #-}   liftParameter (Parameter m) = @@ -226,7 +315,7 @@     then liftWithCatching (m $ pointRun p) p c     else liftWithoutCatching (m $ pointRun p) p c -instance SimulationLift Cont where+instance MonadDES m => SimulationLift Cont m where    {-# INLINE liftSimulation #-}   liftSimulation (Simulation m) = @@ -236,7 +325,7 @@     then liftWithCatching (m $ pointRun p) p c     else liftWithoutCatching (m $ pointRun p) p c -instance DynamicsLift Cont where+instance MonadDES m => DynamicsLift Cont m where    {-# INLINE liftDynamics #-}   liftDynamics (Dynamics m) = @@ -246,7 +335,7 @@     then liftWithCatching (m p) p c     else liftWithoutCatching (m p) p c -instance EventLift Cont where+instance MonadDES m => EventLift Cont m where    {-# INLINE liftEvent #-}   liftEvent (Event m) = @@ -256,7 +345,7 @@     then liftWithCatching (m p) p c     else liftWithoutCatching (m p) p c -instance (MonadComp m, MonadIO m) => MonadIO (Cont m) where+instance (MonadDES m, MonadIO m) => MonadIO (Cont m) where    {-# INLINE liftIO #-}   liftIO m =@@ -266,12 +355,12 @@     then liftWithCatching (liftIO m) p c     else liftWithoutCatching (liftIO m) p c -instance MonadComp m => Functor (Cont m) where+instance MonadDES m => Functor (Cont m) where    {-# INLINE fmap #-}   fmap = liftM -instance MonadComp m => Applicative (Cont m) where+instance MonadDES m => Applicative (Cont m) where    {-# INLINE pure #-}   pure = return@@ -285,30 +374,33 @@ invokeCont p (Cont m) = m p  -- | Cancel the computation.-cancelCont :: MonadComp m => Point m -> ContParams m a -> m ()+cancelCont :: MonadDES m => ContParams m a -> Event m () {-# NOINLINE cancelCont #-}-cancelCont p c =-  do contCancellationDeactivate (contCancelSource $ contAux c)+cancelCont c =+  Event $ \p ->+  do invokeEvent p $ contCancellationDeactivate (contId $ contAux c)      invokeEvent p $ (contCCont $ contAux c) ()  -- | Like @return a >>= k@.-callCont :: MonadComp m => (a -> Cont m b) -> a -> ContParams m b -> Event m ()+callCont :: MonadDES m => (a -> Cont m b) -> a -> ContParams m b -> Event m ()+{-# INLINABLE callCont #-} callCont k a c =   Event $ \p ->-  do z <- contCanceled c+  do z <- invokeEvent p $ contCanceled c      if z -       then cancelCont p c+       then invokeEvent p $ cancelCont c        else invokeEvent p $ invokeCont c (k a)  -- | Exception handling within 'Cont' computations.-catchCont :: (MonadComp m, Exception e) => Cont m a -> (e -> Cont m a) -> Cont m a+catchCont :: (MonadDES m, Exception e) => Cont m a -> (e -> Cont m a) -> Cont m a+{-# INLINABLE catchCont #-} catchCont (Cont m) h =    Cont $ \c0 ->   Event $ \p ->    do let c = c0 { contAux = (contAux c0) { contCatchFlag = True } }-     z <- contCanceled c+     z <- invokeEvent p $ contCanceled c      if z -       then cancelCont p c+       then invokeEvent p $ cancelCont c        else invokeEvent p $ m $             let econt e0 =                   case fromException e0 of@@ -317,14 +409,15 @@             in c { contAux = (contAux c) { contECont = econt } }                 -- | A computation with finalization part.-finallyCont :: MonadComp m => Cont m a -> Cont m b -> Cont m a+finallyCont :: MonadDES m => Cont m a -> Cont m b -> Cont m a+{-# INLINABLE finallyCont #-} finallyCont (Cont m) (Cont m') =    Cont $ \c0 ->    Event $ \p ->   do let c = c0 { contAux = (contAux c0) { contCatchFlag = True } }-     z <- contCanceled c+     z <- invokeEvent p $ contCanceled c      if z -       then cancelCont p c+       then invokeEvent p $ cancelCont c        else invokeEvent p $ m $             let cont a   =                    Event $ \p ->@@ -354,12 +447,13 @@ -- if it will be wrapped in the 'IO' monad. Therefore, you should use specialised -- functions like the stated one that use the 'throw' function but within the 'IO' computation, -- which allows already handling the exception.-throwCont :: (MonadComp m, Exception e) => e -> Cont m a+throwCont :: (MonadDES m, Exception e) => e -> Cont m a+{-# INLINABLE throwCont #-} throwCont = liftEvent . throwEvent  -- | Run the 'Cont' computation with the specified cancelation source  -- and flag indicating whether to catch exceptions from the beginning.-runCont :: MonadComp m+runCont :: MonadDES m            => Cont m a            -- ^ the computation to run            -> (a -> Event m ())@@ -368,45 +462,46 @@            -- ^ the branch for handing exceptions            -> (() -> Event m ())            -- ^ the branch for cancellation-           -> ContCancellationSource m-           -- ^ the cancellation source+           -> ContId m+           -- ^ the computation identifier            -> Bool            -- ^ whether to support the exception handling from the beginning            -> Event m ()-runCont (Cont m) cont econt ccont cancelSource catchFlag = +{-# INLINABLE runCont #-}+runCont (Cont m) cont econt ccont cid catchFlag =    m ContParams { contCont = cont,                  contAux  =                     ContParamsAux { contECont = econt,                                    contCCont = ccont,-                                   contCancelSource = cancelSource,-                                   contCancelFlag = contCancellationActivated cancelSource, +                                   contId    = cid,+                                   contCancelFlag = contCancellationActivated cid,                                     contCatchFlag  = catchFlag } }   -liftWithoutCatching :: MonadComp m => m a -> Point m -> ContParams m a -> m ()+liftWithoutCatching :: MonadDES m => m a -> Point m -> ContParams m a -> m () {-# INLINE liftWithoutCatching #-} liftWithoutCatching m p c =-  do z <- contCanceled c+  do z <- invokeEvent p $ contCanceled c      if z-       then cancelCont p c+       then invokeEvent p $ cancelCont c        else do a <- m                invokeEvent p $ contCont c a -liftWithCatching :: MonadComp m => m a -> Point m -> ContParams m a -> m ()+liftWithCatching :: MonadDES m => m a -> Point m -> ContParams m a -> m () {-# NOINLINE liftWithCatching #-} liftWithCatching m p c =-  do z <- contCanceled c+  do z <- invokeEvent p $ contCanceled c      if z-       then cancelCont p c-       else do let s = runSession $ pointRun p-               aref <- newProtoRef s undefined-               eref <- newProtoRef s Nothing+       then invokeEvent p $ cancelCont c+       else do let r = pointRun p+               aref <- invokeSimulation r $ newRef undefined+               eref <- invokeSimulation r $ newRef Nothing                catchComp-                 (m >>= writeProtoRef aref) -                 (writeProtoRef eref . Just)-               e <- readProtoRef eref+                 (m >>= invokeEvent p . writeRef aref) +                 (invokeEvent p . writeRef eref . Just)+               e <- invokeEvent p $ readRef eref                case e of                  Nothing -> -                   do a <- readProtoRef aref+                   do a <- invokeEvent p $ readRef aref                       -- tail recursive                       invokeEvent p $ contCont c a                  Just e ->@@ -414,27 +509,27 @@                    invokeEvent p $ (contECont . contAux) c e  -- | Resume the computation by the specified parameters.-resumeCont :: MonadComp m => ContParams m a -> a -> Event m ()+resumeCont :: MonadDES m => ContParams m a -> a -> Event m () {-# INLINE resumeCont #-} resumeCont c a =    Event $ \p ->-  do z <- contCanceled c+  do z <- invokeEvent p $ contCanceled c      if z-       then cancelCont p c+       then invokeEvent p $ cancelCont c        else invokeEvent p $ contCont c a  -- | Resume the exception handling by the specified parameters.-resumeECont :: MonadComp m => ContParams m a -> SomeException -> Event m ()+resumeECont :: MonadDES m => ContParams m a -> SomeException -> Event m () {-# INLINE resumeECont #-} resumeECont c e =    Event $ \p ->-  do z <- contCanceled c+  do z <- invokeEvent p $ contCanceled c      if z-       then cancelCont p c+       then invokeEvent p $ cancelCont c        else invokeEvent p $ (contECont $ contAux c) e  -- | Test whether the computation is canceled.-contCanceled :: ContParams m a -> m Bool+contCanceled :: ContParams m a -> Event m Bool {-# INLINE contCanceled #-} contCanceled c = contCancelFlag $ contAux c @@ -448,63 +543,64 @@ -- 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 :: MonadComp m-                => [(Cont m a, ContCancellationSource m)]+contParallel :: MonadDES m+                => [(Cont m a, ContId m)]                 -- ^ the list of pairs:                 -- the nested computation,-                -- the cancellation source+                -- the computation identifier                 -> Cont m [a]+{-# INLINABLE contParallel #-} contParallel xs =   Cont $ \c ->   Event $ \p ->   do let n = length xs-         s = runSession $ pointRun p+         r = pointRun p          worker =-           do results   <- newProtoArray_ s n-              counter   <- newProtoRef s 0-              catchRef  <- newProtoRef s Nothing+           do results   <- forM [1..n] $ \i -> invokeSimulation r $ newRef undefined+              counter   <- invokeSimulation r $ newRef 0+              catchRef  <- invokeSimulation r $ newRef Nothing               hs <- invokeEvent p $-                    contCancellationBind (contCancelSource $ contAux c) $+                    contCancellationBind (contId $ contAux c) $                     map snd xs               let propagate =                     Event $ \p ->-                    do n' <- readProtoRef counter+                    do n' <- invokeEvent p $ readRef counter                        when (n' == n) $                          do invokeEvent p $ disposeEvent hs  -- unbind the cancellation sources-                            f1 <- contCanceled c-                            f2 <- readProtoRef catchRef+                            f1 <- invokeEvent p $ contCanceled c+                            f2 <- invokeEvent p $ readRef catchRef                             case (f1, f2) of                               (False, Nothing) ->-                                do rs <- protoArrayToList results+                                do rs <- forM results $ invokeEvent p . readRef                                    invokeEvent p $ resumeCont c rs                               (False, Just e) ->                                 invokeEvent p $ resumeECont c e                               (True, _) ->-                                cancelCont p c-                  cont i a =+                                invokeEvent p $ cancelCont c+                  cont result a =                     Event $ \p ->-                    do modifyProtoRef counter (+ 1)-                       writeProtoArray results i a+                    do invokeEvent p $ modifyRef counter (+ 1)+                       invokeEvent p $ writeRef result a                        invokeEvent p propagate                   econt e =                     Event $ \p ->-                    do modifyProtoRef counter (+ 1)-                       r <- readProtoRef catchRef+                    do invokeEvent p $ modifyRef counter (+ 1)+                       r <- invokeEvent p $ readRef catchRef                        case r of-                         Nothing -> writeProtoRef catchRef $ Just e+                         Nothing -> invokeEvent p $ writeRef catchRef $ Just e                          Just e' -> return ()  -- ignore the next error                        invokeEvent p propagate                   ccont e =                     Event $ \p ->-                    do modifyProtoRef counter (+ 1)+                    do invokeEvent p $ modifyRef counter (+ 1)                        -- the main computation was automatically canceled                        invokeEvent p propagate-              forM_ (zip [0..n-1] xs) $ \(i, (x, cancelSource)) ->+              forM_ (zip results xs) $ \(result, (x, cid)) ->                 invokeEvent p $-                runCont x (cont i) econt ccont cancelSource (contCatchFlag $ contAux c)-     z <- contCanceled c+                runCont x (cont result) econt ccont cid (contCatchFlag $ contAux c)+     z <- invokeEvent p $ contCanceled c      if z-       then cancelCont p c+       then invokeEvent p $ cancelCont c        else if n == 0             then invokeEvent p $ contCont c []             else worker@@ -512,73 +608,75 @@ -- | 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_ :: MonadComp m-                 => [(Cont m a, ContCancellationSource m)]+contParallel_ :: MonadDES m+                 => [(Cont m a, ContId m)]                  -- ^ the list of pairs:                  -- the nested computation,-                 -- the cancellation source+                 -- the computation identifier                  -> Cont m ()+{-# INLINABLE contParallel_ #-} contParallel_ xs =   Cont $ \c ->   Event $ \p ->   do let n = length xs-         s = runSession $ pointRun p+         r = pointRun p          worker =-           do counter   <- newProtoRef s 0-              catchRef  <- newProtoRef s Nothing+           do counter  <- invokeSimulation r $ newRef 0+              catchRef <- invokeSimulation r $ newRef Nothing               hs <- invokeEvent p $-                    contCancellationBind (contCancelSource $ contAux c) $+                    contCancellationBind (contId $ contAux c) $                     map snd xs               let propagate =                     Event $ \p ->-                    do n' <- readProtoRef counter+                    do n' <- invokeEvent p $ readRef counter                        when (n' == n) $                          do invokeEvent p $ disposeEvent hs  -- unbind the cancellation sources-                            f1 <- contCanceled c-                            f2 <- readProtoRef catchRef+                            f1 <- invokeEvent p $ contCanceled c+                            f2 <- invokeEvent p $ readRef 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 =+                                invokeEvent p $ cancelCont c+                  cont a =                     Event $ \p ->-                    do modifyProtoRef counter (+ 1)+                    do invokeEvent p $ modifyRef counter (+ 1)                        -- ignore the result                        invokeEvent p propagate                   econt e =                     Event $ \p ->-                    do modifyProtoRef counter (+ 1)-                       r <- readProtoRef catchRef+                    do invokeEvent p $ modifyRef counter (+ 1)+                       r <- invokeEvent p $ readRef catchRef                        case r of-                         Nothing -> writeProtoRef catchRef $ Just e+                         Nothing -> invokeEvent p $ writeRef catchRef $ Just e                          Just e' -> return ()  -- ignore the next error                        invokeEvent p propagate                   ccont e =                     Event $ \p ->-                    do modifyProtoRef counter (+ 1)+                    do invokeEvent p $ modifyRef counter (+ 1)                        -- the main computation was automatically canceled                        invokeEvent p propagate-              forM_ (zip [0..n-1] xs) $ \(i, (x, cancelSource)) ->+              forM_ (zip [0..n-1] xs) $ \(i, (x, cid)) ->                 invokeEvent p $-                runCont x (cont i) econt ccont cancelSource (contCatchFlag $ contAux c)-     z <- contCanceled c+                runCont x cont econt ccont cid (contCatchFlag $ contAux c)+     z <- invokeEvent p $ contCanceled c      if z-       then cancelCont p c+       then invokeEvent p $ cancelCont c        else if n == 0             then invokeEvent p $ contCont c ()             else worker --- | Rerun the 'Cont' computation with the specified cancellation source.-rerunCont :: MonadComp m => Cont m a -> ContCancellationSource m -> Cont m a-rerunCont x cancelSource =+-- | Rerun the 'Cont' computation with the specified identifier.+rerunCont :: MonadDES m => Cont m a -> ContId m -> Cont m a+{-# INLINABLE rerunCont #-}+rerunCont x cid =   Cont $ \c ->   Event $ \p ->   do let worker =            do hs <- invokeEvent p $-                    contCancellationBind (contCancelSource $ contAux c) [cancelSource]+                    contCancellationBind (contId $ contAux c) [cid]               let cont a  =                     Event $ \p ->                     do invokeEvent p $ disposeEvent hs  -- unbind the cancellation source@@ -590,23 +688,24 @@                   ccont e =                     Event $ \p ->                     do invokeEvent p $ disposeEvent hs  -- unbind the cancellation source-                       cancelCont p c+                       invokeEvent p $ cancelCont c               invokeEvent p $-                runCont x cont econt ccont cancelSource (contCatchFlag $ contAux c)-     z <- contCanceled c+                runCont x cont econt ccont cid (contCatchFlag $ contAux c)+     z <- invokeEvent p $ contCanceled c      if z-       then cancelCont p c+       then invokeEvent p $ cancelCont c        else worker --- | Run the 'Cont' computation in parallel but connect the cancellation sources.-spawnCont :: MonadComp m => ContCancellation -> Cont m () -> ContCancellationSource m -> Cont m ()-spawnCont cancellation x cancelSource =+-- | Run the 'Cont' computation in parallel but connect the computations.+spawnCont :: MonadDES m => ContCancellation -> Cont m () -> ContId m -> Cont m ()+{-# INLINABLE spawnCont #-}+spawnCont cancellation x cid =   Cont $ \c ->   Event $ \p ->   do let worker =            do hs <- invokeEvent p $                     contCancellationConnect-                    (contCancelSource $ contAux c) cancellation cancelSource+                    (contId $ contAux c) cancellation cid               let cont a  =                     Event $ \p ->                     do invokeEvent p $ disposeEvent hs  -- unbind the cancellation source@@ -621,81 +720,190 @@                        -- do nothing and it will finish the computation               invokeEvent p $                 enqueueEvent (pointTime p) $-                runCont x cont econt ccont cancelSource False+                runCont x cont econt ccont cid False               invokeEvent p $                 resumeCont c ()-     z <- contCanceled c+     z <- invokeEvent p $ contCanceled c      if z-       then cancelCont p c+       then invokeEvent p $ cancelCont c        else worker +-- | Represents a temporarily frozen computation.+newtype FrozenCont m a =+  FrozenCont { unfreezeCont :: Event m (Maybe (ContParams m a))+               -- ^ Unfreeze the computation.+             }+ -- | Freeze the computation parameters temporarily.-contFreeze :: MonadComp m => ContParams m a -> Event m (Event m (Maybe (ContParams m a)))-contFreeze c =+freezeCont :: MonadDES m => ContParams m a -> Event m (FrozenCont m a)+{-# INLINABLE freezeCont #-}+freezeCont c =   Event $ \p ->-  do let s = runSession $ pointRun p-     rh <- newProtoRef s Nothing-     rc <- newProtoRef s $ Just c+  do let r = pointRun p+     rh <- invokeSimulation r $ newRef Nothing+     rc <- invokeSimulation r $ newRef $ Just c      h <- invokeEvent p $           handleSignal (contCancellationInitiating $-                        contCancelSource $-                        contAux c) $ \a ->+                        contId $+                        contAux c) $ \e ->           Event $ \p ->-          do h <- readProtoRef rh+          do h <- invokeEvent p $ readRef rh              case h of                Nothing ->-                 error "The handler was lost: contFreeze."+                 error "The handler was lost: freezeCont."                Just h ->                  do invokeEvent p $ disposeEvent h-                    c <- readProtoRef rc+                    c <- invokeEvent p $ readRef rc                     case c of                       Nothing -> return ()                       Just c  ->-                        do writeProtoRef rc Nothing+                        do invokeEvent p $ writeRef rc Nothing                            invokeEvent p $                              enqueueEvent (pointTime p) $                              Event $ \p ->-                             do z <- contCanceled c-                                when z $ cancelCont p c-     writeProtoRef rh (Just h)+                             do z <- invokeEvent p $ contCanceled c+                                when z $ invokeEvent p $ cancelCont c+     invokeEvent p $ writeRef rh (Just h)      return $+       FrozenCont $        Event $ \p ->        do invokeEvent p $ disposeEvent h-          c <- readProtoRef rc-          writeProtoRef rc Nothing+          c <- invokeEvent p $ readRef rc+          invokeEvent p $ writeRef rc Nothing           return c++-- | Freeze the computation parameters specifying what should be done when reentering the computation.+freezeContReentering :: MonadDES m => ContParams m a -> a -> Event m () -> Event m (FrozenCont m a)+{-# INLINABLE freezeContReentering #-}+freezeContReentering c a m =+  Event $ \p ->+  do let r = pointRun p+     rh <- invokeSimulation r $ newRef Nothing+     rc <- invokeSimulation r $ newRef $ Just c+     h <- invokeEvent p $+          handleSignal (contCancellationInitiating $+                        contId $ contAux c) $ \e ->+          Event $ \p ->+          do h <- invokeEvent p $ readRef rh+             case h of+               Nothing ->+                 error "The handler was lost: freezeContReentering."+               Just h ->+                 do invokeEvent p $ disposeEvent h+                    c <- invokeEvent p $ readRef rc+                    case c of+                      Nothing -> return ()+                      Just c  ->+                        do invokeEvent p $ writeRef rc Nothing+                           invokeEvent p $+                             enqueueEvent (pointTime p) $+                             Event $ \p ->+                             do z <- invokeEvent p $ contCanceled c+                                when z $ invokeEvent p $ cancelCont c+     invokeEvent p $ writeRef rh (Just h)+     return $+       FrozenCont $+       Event $ \p ->+       do invokeEvent p $ disposeEvent h+          c <- invokeEvent p $ readRef rc+          invokeEvent p $ writeRef rc Nothing+          case c of+            Nothing -> return Nothing+            z @ (Just c) ->+              do f <- invokeEvent p $+                      contPreemptionBegun $+                      contId $ contAux c+                 if not f+                   then return z+                   else do let c = c { contCont = \a -> m }+                           invokeEvent p $ sleepCont c a+                           return Nothing      +-- | Reenter the computation parameters when needed.+reenterCont :: MonadDES m => ContParams m a -> a -> Event m ()+{-# INLINE reenterCont #-}+reenterCont c a =+  Event $ \p ->+  do f <- invokeEvent p $+          contPreemptionBegun $+          contId $ contAux c+     if not f+       then invokeEvent p $+            enqueueEvent (pointTime p) $+            resumeCont c a+       else invokeEvent p $+            sleepCont c a++-- | Sleep until the preempted computation will be reentered.+sleepCont :: MonadDES m => ContParams m a -> a -> Event m ()+{-# INLINABLE sleepCont #-}+sleepCont c a =+  Event $ \p ->+  do let r = pointRun p+     rh <- invokeSimulation r $ newRef Nothing+     h  <- invokeEvent p $+           handleSignal (contSignal $+                         contId $ contAux c) $ \e ->+           Event $ \p ->+           do h <- invokeEvent p $ readRef rh+              case h of+                Nothing ->+                  error "The handler was lost: sleepCont."+                Just h ->+                  do invokeEvent p $ disposeEvent h+                     case e of+                       ContCancellationInitiating ->+                         invokeEvent p $+                         enqueueEvent (pointTime p) $+                         Event $ \p ->+                         do z <- invokeEvent p $ contCanceled c+                            when z $ invokeEvent p $ cancelCont c+                       ContPreemptionEnding ->+                         invokeEvent p $+                         enqueueEvent (pointTime p) $+                         resumeCont c a+                       ContPreemptionBeginning ->+                         error "The computation was already preempted: sleepCont."+     invokeEvent p $ writeRef rh (Just h)++-- | Substitute the continuation.+substituteCont :: MonadDES m => ContParams m a -> (a -> Event m ()) -> ContParams m a+{-# INLINE substituteCont #-}+substituteCont c m = c { contCont = m }+ -- | Await the signal.-contAwait :: MonadComp m => Signal m a -> Cont m a+contAwait :: MonadDES m => Signal m a -> Cont m a+{-# INLINABLE contAwait #-} contAwait signal =   Cont $ \c ->   Event $ \p ->-  do let s = runSession $ pointRun p-     c <- invokeEvent p $ contFreeze c-     r <- newProtoRef s Nothing+  do let r = pointRun p+     c <- invokeEvent p $ freezeCont c+     rh <- invokeSimulation r $ newRef Nothing      h <- invokeEvent p $           handleSignal signal $            \a -> Event $ -                \p -> do x <- readProtoRef r+                \p -> do x <- invokeEvent p $ readRef rh                          case x of                            Nothing ->                              error "The signal was lost: contAwait."                            Just x ->                              do invokeEvent p $ disposeEvent x-                                c <- invokeEvent p c+                                c <- invokeEvent p $ unfreezeCont c                                 case c of                                   Nothing -> return ()                                   Just c  ->-                                    invokeEvent p $ resumeCont c a-     writeProtoRef r $ Just h          +                                    invokeEvent p $ reenterCont c a+     invokeEvent p $ writeRef rh $ Just h            -- | Show the debug message with the current simulation time.-traceCont :: MonadComp m => String -> Cont m a -> Cont m a+traceCont :: MonadDES m => String -> Cont m a -> Cont m a+{-# INLINABLE traceCont #-} traceCont message (Cont m) =   Cont $ \c ->   Event $ \p ->-  do z <- contCanceled c+  do z <- invokeEvent p $ contCanceled c      if z-       then cancelCont p c+       then invokeEvent p $ cancelCont c        else trace ("t = " ++ show (pointTime p) ++ ": " ++ message) $             invokeEvent p $ m c
Simulation/Aivika/Trans/Internal/Dynamics.hs view
@@ -1,19 +1,21 @@ -{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE RecursiveDo, MultiParamTypeClasses, FlexibleInstances #-}  -- | -- Module     : Simulation.Aivika.Trans.Internal.Dynamics--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The module defines the 'Dynamics' monad transformer representing a time varying polymorphic function.  -- module Simulation.Aivika.Trans.Internal.Dynamics        (-- * Dynamics+        Dynamics(..),         DynamicsLift(..),+        invokeDynamics,         runDynamicsInStartTime,         runDynamicsInStopTime,         runDynamicsInIntegTimes,@@ -41,6 +43,7 @@  import Simulation.Aivika.Trans.Exception import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Internal.Types import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Parameter import Simulation.Aivika.Trans.Internal.Simulation@@ -59,26 +62,31 @@  -- | Run the 'Dynamics' computation in the initial time point. runDynamicsInStartTime :: Dynamics m a -> Simulation m a+{-# INLINABLE runDynamicsInStartTime #-} runDynamicsInStartTime (Dynamics m) =   Simulation $ m . integStartPoint  -- | Run the 'Dynamics' computation in the final time point. runDynamicsInStopTime :: Dynamics m a -> Simulation m a+{-# INLINABLE runDynamicsInStopTime #-} runDynamicsInStopTime (Dynamics m) =   Simulation $ m . integStopPoint  -- | Run the 'Dynamics' computation in all integration time points. runDynamicsInIntegTimes :: Monad m => Dynamics m a -> Simulation m [m a]+{-# INLINABLE runDynamicsInIntegTimes #-} runDynamicsInIntegTimes (Dynamics m) =   Simulation $ return . map m . integPoints  -- | Run the 'Dynamics' computation in the specified time point. runDynamicsInTime :: Double -> Dynamics m a -> Simulation m a+{-# INLINABLE runDynamicsInTime #-} runDynamicsInTime t (Dynamics m) =   Simulation $ \r -> m $ pointAt r t  -- | Run the 'Dynamics' computation in the specified time points. runDynamicsInTimes :: Monad m => [Double] -> Dynamics m a -> Simulation m [m a]+{-# INLINABLE runDynamicsInTimes #-} runDynamicsInTimes ts (Dynamics m) =   Simulation $ \r -> return $ map (m . pointAt r) ts  @@ -202,48 +210,53 @@   {-# INLINE liftIO #-}   liftIO = Dynamics . const . liftIO -instance MonadCompTrans Dynamics where+instance Monad m => MonadCompTrans Dynamics m where    {-# INLINE liftComp #-}   liftComp = Dynamics . const  -- | A type class to lift the 'Dynamics' computations into other computations.-class DynamicsLift t where+class DynamicsLift t m where      -- | Lift the specified 'Dynamics' computation into another computation.-  liftDynamics :: MonadComp m => Dynamics m a -> t m a+  liftDynamics :: Dynamics m a -> t m a -instance DynamicsLift Dynamics where+instance Monad m => DynamicsLift Dynamics m where      {-# INLINE liftDynamics #-}   liftDynamics = id -instance SimulationLift Dynamics where+instance Monad m => SimulationLift Dynamics m where    {-# INLINE liftSimulation #-}   liftSimulation (Simulation x) = Dynamics $ x . pointRun  -instance ParameterLift Dynamics where+instance Monad m => ParameterLift Dynamics m where    {-# INLINE liftParameter #-}   liftParameter (Parameter x) = Dynamics $ x . pointRun    -- | Exception handling within 'Dynamics' computations.-catchDynamics :: (MonadComp m, Exception e) => Dynamics m a -> (e -> Dynamics m a) -> Dynamics m a+catchDynamics :: (MonadException m, Exception e) => Dynamics m a -> (e -> Dynamics m a) -> Dynamics m a+{-# INLINABLE catchDynamics #-} catchDynamics (Dynamics m) h =   Dynamics $ \p ->    catchComp (m p) $ \e ->   let Dynamics m' = h e in m' p                             -- | A computation with finalization part like the 'finally' function.-finallyDynamics :: MonadComp m => Dynamics m a -> Dynamics m b -> Dynamics m a+finallyDynamics :: MonadException m => Dynamics m a -> Dynamics m b -> Dynamics m a+{-# INLINABLE finallyDynamics #-} finallyDynamics (Dynamics m) (Dynamics m') =   Dynamics $ \p ->   finallyComp (m p) (m' p)  -- | Like the standard 'throw' function.-throwDynamics :: (MonadComp m, Exception e) => e -> Dynamics m a-throwDynamics = throw+throwDynamics :: (MonadException m, Exception e) => e -> Dynamics m a+{-# INLINABLE throwDynamics #-}+throwDynamics e =+  Dynamics $ \p ->+  throwComp e  instance MonadFix m => MonadFix (Dynamics m) where @@ -275,6 +288,7 @@  -- | Show the debug message with the current simulation time. traceDynamics :: Monad m => String -> Dynamics m a -> Dynamics m a+{-# INLINABLE traceDynamics #-} traceDynamics message m =   Dynamics $ \p ->   trace ("t = " ++ show (pointTime p) ++ ": " ++ message) $
Simulation/Aivika/Trans/Internal/Event.hs view
@@ -1,23 +1,27 @@ -{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE RecursiveDo, MultiParamTypeClasses, FlexibleInstances #-}  -- | -- Module     : Simulation.Aivika.Trans.Internal.Event--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The module defines the 'Event' monad transformer which is very similar to the 'Dynamics' -- monad transformer but only now the computation is strongly synchronized with the event queue. -- module Simulation.Aivika.Trans.Internal.Event        (-- * Event Monad+        Event(..),         EventLift(..),+        EventProcessing(..),+        invokeEvent,         runEventInStartTime,         runEventInStopTime,         -- * Event Queue+        EventQueueing(..),         enqueueEventWithCancellation,         enqueueEventWithTimes,         enqueueEventWithPoints,@@ -51,9 +55,10 @@ import Debug.Trace (trace)  import Simulation.Aivika.Trans.Exception-import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef+import Simulation.Aivika.Trans.Ref.Base import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Internal.Types import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Parameter import Simulation.Aivika.Trans.Internal.Simulation@@ -94,53 +99,58 @@   {-# INLINE liftIO #-}   liftIO = Event . const . liftIO -instance MonadCompTrans Event where+instance Monad m => MonadCompTrans Event m where    {-# INLINE liftComp #-}   liftComp = Event . const  -- | A type class to lift the 'Event' computations into other computations.-class EventLift t where+class EventLift t m where      -- | Lift the specified 'Event' computation into another computation.-  liftEvent :: MonadComp m => Event m a -> t m a+  liftEvent :: Event m a -> t m a -instance EventLift Event where+instance Monad m => EventLift Event m where      {-# INLINE liftEvent #-}   liftEvent = id -instance DynamicsLift Event where+instance Monad m => DynamicsLift Event m where      {-# INLINE liftDynamics #-}   liftDynamics (Dynamics x) = Event x -instance SimulationLift Event where+instance Monad m => SimulationLift Event m where    {-# INLINE liftSimulation #-}   liftSimulation (Simulation x) = Event $ x . pointRun  -instance ParameterLift Event where+instance Monad m => ParameterLift Event m where    {-# INLINE liftParameter #-}   liftParameter (Parameter x) = Event $ x . pointRun  -- | Exception handling within 'Event' computations.-catchEvent :: (MonadComp m, Exception e) => Event m a -> (e -> Event m a) -> Event m a+catchEvent :: (MonadException m, Exception e) => Event m a -> (e -> Event m a) -> Event m a+{-# INLINABLE catchEvent #-} catchEvent (Event m) h =   Event $ \p ->    catchComp (m p) $ \e ->   let Event m' = h e in m' p                             -- | A computation with finalization part like the 'finally' function.-finallyEvent :: MonadComp m => Event m a -> Event m b -> Event m a+finallyEvent :: MonadException m => Event m a -> Event m b -> Event m a+{-# INLINABLE finallyEvent #-} finallyEvent (Event m) (Event m') =   Event $ \p ->   finallyComp (m p) (m' p)  -- | Like the standard 'throw' function.-throwEvent :: (MonadComp m, Exception e) => e -> Event m a-throwEvent = throw+throwEvent :: (MonadException m, Exception e) => e -> Event m a+{-# INLINABLE throwEvent #-}+throwEvent e =+  Event $ \p ->+  throwComp e  instance MonadFix m => MonadFix (Event m) where @@ -151,22 +161,26 @@  -- | Run the 'Event' computation in the start time involving all -- pending 'CurrentEvents' in the processing too.-runEventInStartTime :: MonadComp m => Event m a -> Simulation m a+runEventInStartTime :: MonadDES m => Event m a -> Simulation m a+{-# INLINE runEventInStartTime #-} runEventInStartTime = runDynamicsInStartTime . runEvent  -- | Run the 'Event' computation in the stop time involving all -- pending 'CurrentEvents' in the processing too.-runEventInStopTime :: MonadComp m => Event m a -> Simulation m a+runEventInStopTime :: MonadDES m => Event m a -> Simulation m a+{-# INLINE runEventInStopTime #-} runEventInStopTime = runDynamicsInStopTime . runEvent  -- | Actuate the event handler in the specified time points.-enqueueEventWithTimes :: MonadComp m => [Double] -> Event m () -> Event m ()+enqueueEventWithTimes :: MonadDES m => [Double] -> Event m () -> Event m ()+{-# INLINABLE enqueueEventWithTimes #-} enqueueEventWithTimes ts e = loop ts   where loop []       = return ()         loop (t : ts) = enqueueEvent t $ e >> loop ts         -- | Actuate the event handler in the specified time points.-enqueueEventWithPoints :: MonadComp m => [Point m] -> Event m () -> Event m ()+enqueueEventWithPoints :: MonadDES m => [Point m] -> Event m () -> Event m ()+{-# INLINABLE enqueueEventWithPoints #-} enqueueEventWithPoints xs (Event e) = loop xs   where loop []       = return ()         loop (x : xs) = enqueueEvent (pointTime x) $ @@ -175,7 +189,8 @@                            invokeEvent p $ loop xs                             -- | Actuate the event handler in the integration time points.-enqueueEventWithIntegTimes :: MonadComp m => Event m () -> Event m ()+enqueueEventWithIntegTimes :: MonadDES m => Event m () -> Event m ()+{-# INLINABLE enqueueEventWithIntegTimes #-} enqueueEventWithIntegTimes e =   Event $ \p ->   let points = integPointsStartingFrom p@@ -192,48 +207,49 @@                     }  -- | Enqueue the event with an ability to cancel it.-enqueueEventWithCancellation :: MonadComp m => Double -> Event m () -> Event m (EventCancellation m)+enqueueEventWithCancellation :: MonadDES m => Double -> Event m () -> Event m (EventCancellation m)+{-# INLINABLE enqueueEventWithCancellation #-} enqueueEventWithCancellation t e =   Event $ \p ->-  do let s = runSession $ pointRun p-     cancelledRef <- newProtoRef s False-     cancellableRef <- newProtoRef s True-     finishedRef <- newProtoRef s False+  do let r = pointRun p+     cancelledRef <- invokeSimulation r $ newRef False+     cancellableRef <- invokeSimulation r $ newRef True+     finishedRef <- invokeSimulation r $ newRef False      let cancel =            Event $ \p ->-           do x <- readProtoRef cancellableRef+           do x <- invokeEvent p $ readRef cancellableRef               when x $-                writeProtoRef cancelledRef True+                invokeEvent p $ writeRef cancelledRef True          cancelled =-           Event $ \p -> readProtoRef cancelledRef+           readRef cancelledRef          finished =-           Event $ \p -> readProtoRef finishedRef+           readRef finishedRef      invokeEvent p $        enqueueEvent t $        Event $ \p ->-       do writeProtoRef cancellableRef False-          x <- readProtoRef cancelledRef+       do invokeEvent p $ writeRef cancellableRef False+          x <- invokeEvent p $ readRef cancelledRef           unless x $             do invokeEvent p e-               writeProtoRef finishedRef True+               invokeEvent p $ writeRef finishedRef True      return EventCancellation { cancelEvent   = cancel,                                 eventCancelled = cancelled,                                 eventFinished = finished }  -- | Memoize the 'Event' computation, always returning the same value -- within a simulation run.-memoEvent :: MonadComp m => Event m a -> Simulation m (Event m a)+memoEvent :: MonadDES m => Event m a -> Simulation m (Event m a)+{-# INLINABLE memoEvent #-} memoEvent m =   Simulation $ \r ->-  do let s = runSession r-     ref <- newProtoRef s Nothing+  do ref <- invokeSimulation r $ newRef Nothing      return $ Event $ \p ->-       do x <- readProtoRef ref+       do x <- invokeEvent p $ readRef ref           case x of             Just v -> return v             Nothing ->               do v <- invokeEvent p m-                 writeProtoRef ref (Just v)+                 invokeEvent p $ writeRef ref (Just v)                  return v  -- | Memoize the 'Event' computation, always returning the same value@@ -244,23 +260,24 @@ -- computation is always synchronized with the event queue which time -- flows in one direction only. This synchronization is a key difference -- between the 'Event' and 'Dynamics' computations.-memoEventInTime :: MonadComp m => Event m a -> Simulation m (Event m a)+memoEventInTime :: MonadDES m => Event m a -> Simulation m (Event m a)+{-# INLINABLE memoEventInTime #-} memoEventInTime m =   Simulation $ \r ->-  do let s = runSession r-     ref <- newProtoRef s Nothing+  do ref <- invokeSimulation r $ newRef Nothing      return $ Event $ \p ->-       do x <- readProtoRef ref+       do x <- invokeEvent p $ readRef ref           case x of             Just (t, v) | t == pointTime p ->               return v             _ ->               do v <- invokeEvent p m-                 writeProtoRef ref (Just (pointTime p, v))+                 invokeEvent p $ writeRef ref (Just (pointTime p, v))                  return v  -- | Enqueue the event which must be actuated with the current modeling time but later.-yieldEvent :: MonadComp m => Event m () -> Event m ()+yieldEvent :: MonadDES m => Event m () -> Event m ()+{-# INLINABLE yieldEvent #-} yieldEvent m =   Event $ \p ->   invokeEvent p $@@ -281,7 +298,8 @@   mappend (DisposableEvent x) (DisposableEvent y) = DisposableEvent $ x >> y  -- | Show the debug message with the current simulation time.-traceEvent :: MonadComp m => String -> Event m a -> Event m a+traceEvent :: MonadDES m => String -> Event m a -> Event m a+{-# INLINABLE traceEvent #-} traceEvent message m =   Event $ \p ->   trace ("t = " ++ show (pointTime p) ++ ": " ++ message) $
Simulation/Aivika/Trans/Internal/Parameter.hs view
@@ -3,11 +3,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Internal.Parameter--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The module defines the 'Parameter' monad transformer that allows representing the model -- parameters. For example, they can be used when running the Monte-Carlo simulation.@@ -17,7 +17,9 @@ -- module Simulation.Aivika.Trans.Internal.Parameter        (-- * Parameter+        Parameter(..),         ParameterLift(..),+        invokeParameter,         runParameter,         runParameters,         -- * Error Handling@@ -28,7 +30,6 @@         simulationIndex,         simulationCount,         simulationSpecs,-        simulationSession,         simulationEventQueue,         starttime,         stoptime,@@ -51,10 +52,10 @@ import Data.Array  import Simulation.Aivika.Trans.Exception-import Simulation.Aivika.Trans.Session import Simulation.Aivika.Trans.Generator import Simulation.Aivika.Trans.Comp-import Simulation.Aivika.Trans.Comp.IO+import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Internal.Types import Simulation.Aivika.Trans.Internal.Specs  instance Monad m => Monad (Parameter m) where@@ -70,13 +71,12 @@        m' r  -- | Run the parameter using the specified specs.-runParameter :: MonadComp m => Parameter m a -> Specs m -> m a+runParameter :: MonadDES m => Parameter m a -> Specs m -> m a+{-# INLINABLE runParameter #-} runParameter (Parameter m) sc =-  do s <- newSession-     q <- newEventQueue s sc-     g <- newGenerator s $ spcGeneratorType sc+  do q <- newEventQueue sc+     g <- newGenerator $ spcGeneratorType sc      m Run { runSpecs = sc,-             runSession = s,              runIndex = 1,              runCount = 1,              runEventQueue = q,@@ -84,13 +84,12 @@  -- | Run the given number of parameters using the specified specs,  --   where each parameter is distinguished by its index 'parameterIndex'.-runParameters :: MonadComp m => Parameter m a -> Specs m -> Int -> [m a]+runParameters :: MonadDES m => Parameter m a -> Specs m -> Int -> [m a]+{-# INLINABLE runParameters #-} runParameters (Parameter m) sc runs = map f [1 .. runs]-  where f i = do s <- newSession-                 q <- newEventQueue s sc-                 g <- newGenerator s $ spcGeneratorType sc+  where f i = do q <- newEventQueue sc+                 g <- newGenerator $ spcGeneratorType sc                  m Run { runSpecs = sc,-                         runSession = s,                          runIndex = i,                          runCount = runs,                          runEventQueue = q,@@ -236,38 +235,43 @@   {-# INLINE liftIO #-}   liftIO = Parameter . const . liftIO -instance MonadCompTrans Parameter where+instance Monad m => MonadCompTrans Parameter m where    {-# INLINE liftComp #-}   liftComp = Parameter . const  -- | A type class to lift the parameters into other computations.-class ParameterLift t where+class ParameterLift t m where      -- | Lift the specified 'Parameter' computation into another computation.-  liftParameter :: MonadComp m => Parameter m a -> t m a+  liftParameter :: Parameter m a -> t m a -instance ParameterLift Parameter where+instance Monad m => ParameterLift Parameter m where      {-# INLINE liftParameter #-}   liftParameter = id      -- | Exception handling within 'Parameter' computations.-catchParameter :: (MonadComp m, Exception e) => Parameter m a -> (e -> Parameter m a) -> Parameter m a+catchParameter :: (MonadException m, Exception e) => Parameter m a -> (e -> Parameter m a) -> Parameter m a+{-# INLINABLE catchParameter #-} catchParameter (Parameter m) h =   Parameter $ \r ->    catchComp (m r) $ \e ->   let Parameter m' = h e in m' r                             -- | A computation with finalization part like the 'finally' function.-finallyParameter :: MonadComp m => Parameter m a -> Parameter m b -> Parameter m a+finallyParameter :: MonadException m => Parameter m a -> Parameter m b -> Parameter m a+{-# INLINABLE finallyParameter #-} finallyParameter (Parameter m) (Parameter m') =   Parameter $ \r ->   finallyComp (m r) (m' r)  -- | Like the standard 'throw' function.-throwParameter :: (MonadComp m, Exception e) => e -> Parameter m a-throwParameter = throw+throwParameter :: (MonadException m, Exception e) => e -> Parameter m a+{-# INLINABLE throwParameter #-}+throwParameter e =+  Parameter $ \r ->+  throwComp e  instance MonadFix m => MonadFix (Parameter m) where @@ -304,6 +308,7 @@ -- values from the table are used, it takes again the first value of the table, -- then the second one and so on. tableParameter :: Monad m => Array Int a -> Parameter m a+{-# INLINABLE tableParameter #-} tableParameter t =   do i <- simulationIndex      return $ t ! (((i - i1) `mod` n) + i1)@@ -333,9 +338,3 @@ {-# INLINE simulationEventQueue #-} simulationEventQueue =   Parameter $ return . runEventQueue---- | Return the simulation session.-simulationSession :: Monad m => Parameter m (Session m)-{-# INLINE simulationSession #-}-simulationSession =-  Parameter $ return . runSession
Simulation/Aivika/Trans/Internal/Process.hs view
@@ -1,11 +1,13 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+ -- | -- Module     : Simulation.Aivika.Trans.Internal.Process--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- A value in the 'Process' monad represents a discontinuous process that  -- can suspend in any simulation time point and then resume later in the same @@ -56,6 +58,11 @@         whenCancellingProcess,         -- * Awaiting Signal         processAwait,+        -- * Preemption+        processPreemptionBegin,+        processPreemptionEnd,+        processPreemptionBeginning,+        processPreemptionEnding,         -- * Yield of Process         processYield,         -- * Process Timeout@@ -88,36 +95,36 @@ import Control.Monad.Trans import Control.Applicative -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef+import Simulation.Aivika.Trans.Ref.Base import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Parameter import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Dynamics import Simulation.Aivika.Trans.Internal.Event import Simulation.Aivika.Trans.Internal.Cont-import Simulation.Aivika.Trans.Internal.Signal+import Simulation.Aivika.Trans.Signal  -- | Represents a process identifier. data ProcessId m = -  ProcessId { processStarted :: ProtoRef m Bool,-              processMarker  :: SessionMarker m,-              processReactCont     :: ProtoRef m (Maybe (ContParams m ())), -              processCancelSource  :: ContCancellationSource m,-              processInterruptRef  :: ProtoRef m Bool, -              processInterruptCont :: ProtoRef m (Maybe (ContParams m ())), -              processInterruptVersion :: ProtoRef m Int }+  ProcessId { processStarted :: Ref m Bool,+              processReactCont     :: Ref m (Maybe (ContParams m ())), +              processContId  :: ContId m,+              processInterruptRef  :: Ref m Bool, +              processInterruptCont :: Ref m (Maybe (ContParams m ())),+              processInterruptTime :: Ref m Double,+              processInterruptVersion :: Ref m Int }  -- | Specifies a discontinuous process that can suspend at any time -- and then resume later. newtype Process m a = Process (ProcessId m -> Cont m a)  -- | A type class to lift the 'Process' computation into other computations.-class ProcessLift t where+class ProcessLift t m where      -- | Lift the specified 'Process' computation into another computation.-  liftProcess :: MonadComp m => Process m a -> t m a+  liftProcess :: Process m a -> t m a  -- | Invoke the process computation. invokeProcess :: ProcessId m -> Process m a -> Cont m a@@ -125,99 +132,152 @@ invokeProcess pid (Process m) = m pid  -- | Hold the process for the specified time period.-holdProcess :: MonadComp m => Double -> Process m ()+holdProcess :: MonadDES m => Double -> Process m ()+{-# INLINABLE holdProcess #-} holdProcess dt =   Process $ \pid ->   Cont $ \c ->   Event $ \p ->-  do let x = processInterruptCont pid-     writeProtoRef x $ Just c-     writeProtoRef (processInterruptRef pid) False-     v <- readProtoRef (processInterruptVersion pid)+  do when (dt < 0) $+       error "Time period dt < 0: holdProcess"+     let x = processInterruptCont pid+         t = pointTime p + dt+     invokeEvent p $ writeRef x $ Just c+     invokeEvent p $ writeRef (processInterruptRef pid) False+     invokeEvent p $ writeRef (processInterruptTime pid) t+     v <- invokeEvent p $ readRef (processInterruptVersion pid)      invokeEvent p $-       enqueueEvent (pointTime p + dt) $+       enqueueEvent t $        Event $ \p ->-       do v' <- readProtoRef (processInterruptVersion pid)+       do v' <- invokeEvent p $ readRef (processInterruptVersion pid)           when (v == v') $ -            do writeProtoRef x Nothing+            do invokeEvent p $ writeRef x Nothing                invokeEvent p $ resumeCont c ()  -- | Interrupt a process with the specified identifier if the process -- is held by computation 'holdProcess'.-interruptProcess :: MonadComp m => ProcessId m -> Event m ()+interruptProcess :: MonadDES m => ProcessId m -> Event m ()+{-# INLINABLE interruptProcess #-} interruptProcess pid =   Event $ \p ->   do let x = processInterruptCont pid-     a <- readProtoRef x+     a <- invokeEvent p $ readRef x      case a of        Nothing -> return ()        Just c ->-         do writeProtoRef x Nothing-            writeProtoRef (processInterruptRef pid) True-            modifyProtoRef (processInterruptVersion pid) $ (+) 1+         do invokeEvent p $ writeRef x Nothing+            invokeEvent p $ writeRef (processInterruptRef pid) True+            invokeEvent p $ modifyRef (processInterruptVersion pid) $ (+) 1             invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c ()              -- | Test whether the process with the specified identifier was interrupted.-processInterrupted :: MonadComp m => ProcessId m -> Event m Bool+processInterrupted :: MonadDES m => ProcessId m -> Event m Bool+{-# INLINABLE processInterrupted #-} processInterrupted pid =   Event $ \p ->-  readProtoRef (processInterruptRef pid)+  invokeEvent p $ readRef (processInterruptRef pid) +-- | Define a reaction when the process with the specified identifier is preempted.+processPreempted :: MonadDES m => ProcessId m -> Event m ()+{-# INLINABLE processPreempted #-}+processPreempted pid =+  Event $ \p ->+  do let x = processInterruptCont pid+     a <- invokeEvent p $ readRef x+     case a of+       Just c ->+         do invokeEvent p $ writeRef x Nothing+            invokeEvent p $ writeRef (processInterruptRef pid) True+            invokeEvent p $ modifyRef (processInterruptVersion pid) $ (+) 1+            t <- invokeEvent p $ readRef (processInterruptTime pid)+            let dt = t - pointTime p+                c' = substituteCont c $ \a ->+                  Event $ \p ->+                  invokeEvent p $+                  invokeCont c $+                  invokeProcess pid $+                  holdProcess dt+            invokeEvent p $+              reenterCont c' ()+       Nothing ->+         do let x = processReactCont pid+            a <- invokeEvent p $ readRef x+            case a of+              Nothing ->+                return ()+              Just c ->+                do let c' = substituteCont c $ reenterCont c+                   invokeEvent p $ writeRef x $ Just c'+ -- | Passivate the process.-passivateProcess :: MonadComp m => Process m ()+passivateProcess :: MonadDES m => Process m ()+{-# INLINABLE passivateProcess #-} passivateProcess =   Process $ \pid ->   Cont $ \c ->   Event $ \p ->   do let x = processReactCont pid-     a <- readProtoRef x+     a <- invokeEvent p $ readRef x      case a of-       Nothing -> writeProtoRef x $ Just c+       Nothing -> invokeEvent p $ writeRef x $ Just c        Just _  -> error "Cannot passivate the process twice: passivateProcess"  -- | Test whether the process with the specified identifier is passivated.-processPassive :: MonadComp m => ProcessId m -> Event m Bool+processPassive :: MonadDES m => ProcessId m -> Event m Bool+{-# INLINABLE processPassive #-} processPassive pid =   Event $ \p ->   do let x = processReactCont pid-     a <- readProtoRef x+     a <- invokeEvent p $ readRef x      return $ isJust a  -- | Reactivate a process with the specified identifier.-reactivateProcess :: MonadComp m => ProcessId m -> Event m ()+reactivateProcess :: MonadDES m => ProcessId m -> Event m ()+{-# INLINABLE reactivateProcess #-} reactivateProcess pid =   Event $ \p ->   do let x = processReactCont pid-     a <- readProtoRef x+     a <- invokeEvent p $ readRef x      case a of        Nothing ->           return ()        Just c ->-         do writeProtoRef x Nothing+         do invokeEvent p $ writeRef x Nothing             invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c ()  -- | Prepare the processes identifier for running.-processIdPrepare :: MonadComp m => ProcessId m -> Event m ()+processIdPrepare :: MonadDES m => ProcessId m -> Event m ()+{-# INLINABLE processIdPrepare #-} processIdPrepare pid =   Event $ \p ->-  do y <- readProtoRef (processStarted pid)+  do y <- invokeEvent p $ readRef (processStarted pid)      if y        then error $             "Another process with the specified identifier " ++             "has been started already: processIdPrepare"-       else writeProtoRef (processStarted pid) True-     let signal = processCancelling pid+       else invokeEvent p $ writeRef (processStarted pid) True+     let signal = contSignal $ processContId pid      invokeEvent p $-       handleSignal_ signal $ \_ ->-       do interruptProcess pid-          reactivateProcess pid+       handleSignal_ signal $ \e ->+       Event $ \p ->+       case e of+         ContCancellationInitiating ->+           do z <- invokeEvent p $ contCancellationActivated $ processContId pid+              when z $+                do invokeEvent p $ interruptProcess pid+                   invokeEvent p $ reactivateProcess pid+         ContPreemptionBeginning ->+           invokeEvent p $ processPreempted pid+         ContPreemptionEnding ->+           return ()  -- | Run immediately the process. A new 'ProcessId' identifier will be -- assigned to the process. --             -- To run the process at the specified time, you can use -- the 'enqueueProcess' function.-runProcess :: MonadComp m => Process m () -> Event m ()+runProcess :: MonadDES m => Process m () -> Event m ()+{-# INLINABLE runProcess #-} runProcess p =   do pid <- liftSimulation newProcessId      runProcessUsingId pid p@@ -228,10 +288,11 @@ --             -- To run the process at the specified time, you can use -- the 'enqueueProcessUsingId' function.-runProcessUsingId :: MonadComp m => ProcessId m -> Process m () -> Event m ()+runProcessUsingId :: MonadDES m => ProcessId m -> Process m () -> Event m ()+{-# INLINABLE runProcessUsingId #-} runProcessUsingId pid p =   do processIdPrepare pid-     runCont m cont econt ccont (processCancelSource pid) False+     runCont m cont econt ccont (processContId pid) False        where cont  = return              econt = throwEvent              ccont = return@@ -239,69 +300,78 @@  -- | Run the process in the start time immediately involving all pending -- 'CurrentEvents' in the computation too.-runProcessInStartTime :: MonadComp m => Process m () -> Simulation m ()+runProcessInStartTime :: MonadDES m => Process m () -> Simulation m ()+{-# INLINABLE runProcessInStartTime #-} runProcessInStartTime = runEventInStartTime . runProcess  -- | Run the process in the start time immediately using the specified identifier -- and involving all pending 'CurrentEvents' in the computation too.-runProcessInStartTimeUsingId :: MonadComp m => ProcessId m -> Process m () -> Simulation m ()+runProcessInStartTimeUsingId :: MonadDES m => ProcessId m -> Process m () -> Simulation m ()+{-# INLINABLE runProcessInStartTimeUsingId #-} runProcessInStartTimeUsingId pid p =   runEventInStartTime $ runProcessUsingId pid p  -- | Run the process in the final simulation time immediately involving all -- pending 'CurrentEvents' in the computation too.-runProcessInStopTime :: MonadComp m => Process m () -> Simulation m ()+runProcessInStopTime :: MonadDES m => Process m () -> Simulation m ()+{-# INLINABLE runProcessInStopTime #-} runProcessInStopTime = runEventInStopTime . runProcess  -- | Run the process in the final simulation time immediately using  -- the specified identifier and involving all pending 'CurrentEvents' -- in the computation too.-runProcessInStopTimeUsingId :: MonadComp m => ProcessId m -> Process m () -> Simulation m ()+runProcessInStopTimeUsingId :: MonadDES m => ProcessId m -> Process m () -> Simulation m ()+{-# INLINABLE runProcessInStopTimeUsingId #-} runProcessInStopTimeUsingId pid p =   runEventInStopTime $ runProcessUsingId pid p  -- | Enqueue the process that will be then started at the specified time -- from the event queue.-enqueueProcess :: MonadComp m => Double -> Process m () -> Event m ()+enqueueProcess :: MonadDES m => Double -> Process m () -> Event m ()+{-# INLINABLE enqueueProcess #-} enqueueProcess t p =   enqueueEvent t $ runProcess p  -- | Enqueue the process that will be then started at the specified time -- from the event queue.-enqueueProcessUsingId :: MonadComp m => Double -> ProcessId m -> Process m () -> Event m ()+enqueueProcessUsingId :: MonadDES m => Double -> ProcessId m -> Process m () -> Event m ()+{-# INLINABLE enqueueProcessUsingId #-} enqueueProcessUsingId t pid p =   enqueueEvent t $ runProcessUsingId pid p  -- | Return the current process identifier.-processId :: MonadComp m => Process m (ProcessId m)+processId :: MonadDES m => Process m (ProcessId m)+{-# INLINABLE processId #-} processId = Process return  -- | Create a new process identifier.-newProcessId :: MonadComp m => Simulation m (ProcessId m)+newProcessId :: MonadDES m => Simulation m (ProcessId m)+{-# INLINABLE newProcessId #-} newProcessId =   Simulation $ \r ->-  do let s = runSession r-     m <- newSessionMarker s       -     x <- newProtoRef s Nothing-     y <- newProtoRef s False-     c <- invokeSimulation r newContCancellationSource-     i <- newProtoRef s False-     z <- newProtoRef s Nothing-     v <- newProtoRef s 0+  do x <- invokeSimulation r $ newRef Nothing+     y <- invokeSimulation r $ newRef False+     c <- invokeSimulation r $ newContId+     i <- invokeSimulation r $ newRef False+     z <- invokeSimulation r $ newRef Nothing+     t <- invokeSimulation r $ newRef 0+     v <- invokeSimulation r $ newRef 0      return ProcessId { processStarted = y,-                        processMarker  = m,                         processReactCont     = x, -                        processCancelSource  = c, +                        processContId  = c,                          processInterruptRef  = i,-                        processInterruptCont = z, +                        processInterruptCont = z,+                        processInterruptTime = t,                         processInterruptVersion = v }  -- | Cancel a process with the specified identifier, interrupting it if needed.-cancelProcessWithId :: MonadComp m => ProcessId m -> Event m ()-cancelProcessWithId pid = contCancellationInitiate (processCancelSource pid)+cancelProcessWithId :: MonadDES m => ProcessId m -> Event m ()+{-# INLINABLE cancelProcessWithId #-}+cancelProcessWithId pid = contCancellationInitiate (processContId pid)  -- | The process cancels itself.-cancelProcess :: (MonadComp m, MonadIO m) => Process m a+cancelProcess :: MonadDES m => Process m a+{-# INLINABLE cancelProcess #-} cancelProcess =   do pid <- processId      liftEvent $ cancelProcessWithId pid@@ -309,27 +379,46 @@        (error "The process must be cancelled already: cancelProcess." :: SomeException)  -- | Test whether the process with the specified identifier was cancelled.-processCancelled :: MonadComp m => ProcessId m -> Event m Bool-processCancelled pid = contCancellationInitiated (processCancelSource pid)+processCancelled :: MonadDES m => ProcessId m -> Event m Bool+{-# INLINABLE processCancelled #-}+processCancelled pid = contCancellationInitiated (processContId pid)  -- | Return a signal that notifies about cancelling the process with  -- the specified identifier.-processCancelling :: ProcessId m -> Signal m ()-processCancelling pid = contCancellationInitiating (processCancelSource pid)+processCancelling :: MonadDES m => ProcessId m -> Signal m ()+{-# INLINABLE processCancelling #-}+processCancelling pid = contCancellationInitiating (processContId pid)  -- | Register a handler that will be invoked in case of cancelling the current process.-whenCancellingProcess :: MonadComp m => Event m () -> Process m ()+whenCancellingProcess :: MonadDES m => Event m () -> Process m ()+{-# INLINABLE whenCancellingProcess #-} whenCancellingProcess h =   Process $ \pid ->   liftEvent $   handleSignal_ (processCancelling pid) $ \() -> h -instance MonadComp m => Eq (ProcessId m) where+-- | Preempt a process with the specified identifier.+processPreemptionBegin :: MonadDES m => ProcessId m -> Event m ()+processPreemptionBegin pid = contPreemptionBegin (processContId pid) +-- | Proceed with the process with the specified identifier after it was preempted with help of 'preemptProcessBegin'.+processPreemptionEnd :: MonadDES m => ProcessId m -> Event m ()+processPreemptionEnd pid = contPreemptionEnd (processContId pid)++-- | Return a signal when the process is preempted.+processPreemptionBeginning :: MonadDES m => ProcessId m -> Signal m ()+processPreemptionBeginning pid = contPreemptionBeginning (processContId pid)++-- | Return a signal when the process is proceeded after it was preempted earlier.+processPreemptionEnding :: MonadDES m => ProcessId m -> Signal m ()+processPreemptionEnding pid = contPreemptionEnding (processContId pid)++instance MonadDES m => Eq (ProcessId m) where+   {-# INLINE (==) #-}-  x == y = processMarker x == processMarker y+  x == y = processStarted x == processStarted y -instance MonadComp m => Monad (Process m) where+instance MonadDES m => Monad (Process m) where    {-# INLINE return #-}   return a = Process $ \pid -> return a@@ -341,17 +430,17 @@        let Process m' = k a        m' pid -instance MonadCompTrans Process where+instance MonadDES m => MonadCompTrans Process m where    {-# INLINE liftComp #-}   liftComp = Process . const . liftComp -instance MonadComp m => Functor (Process m) where+instance MonadDES m => Functor (Process m) where      {-# INLINE fmap #-}   fmap f (Process x) = Process $ \pid -> fmap f $ x pid -instance MonadComp m => Applicative (Process m) where+instance MonadDES m => Applicative (Process m) where      {-# INLINE pure #-}   pure = Process . const . pure@@ -359,45 +448,47 @@   {-# INLINE (<*>) #-}   (Process x) <*> (Process y) = Process $ \pid -> x pid <*> y pid -instance (MonadComp m, MonadIO m) => MonadIO (Process m) where+instance (MonadDES m, MonadIO m) => MonadIO (Process m) where      {-# INLINE liftIO #-}   liftIO = Process . const . liftIO -instance ParameterLift Process where+instance MonadDES m => ParameterLift Process m where    {-# INLINE liftParameter #-}   liftParameter = Process . const . liftParameter -instance SimulationLift Process where+instance MonadDES m => SimulationLift Process m where    {-# INLINE liftSimulation #-}   liftSimulation = Process . const . liftSimulation   -instance DynamicsLift Process where+instance MonadDES m => DynamicsLift Process m where    {-# INLINE liftDynamics #-}   liftDynamics = Process . const . liftDynamics   -instance EventLift Process where+instance MonadDES m => EventLift Process m where    {-# INLINE liftEvent #-}   liftEvent = Process . const . liftEvent -instance ProcessLift Process where+instance MonadDES m => ProcessLift Process m where    {-# INLINE liftProcess #-}   liftProcess = id  -- | Exception handling within 'Process' computations.-catchProcess :: (MonadComp m, Exception e) => Process m a -> (e -> Process m a) -> Process m a+catchProcess :: (MonadDES m, Exception e) => Process m a -> (e -> Process m a) -> Process m a+{-# INLINABLE catchProcess #-} catchProcess (Process m) h =   Process $ \pid ->   catchCont (m pid) $ \e ->   let Process m' = h e in m' pid                             -- | A computation with finalization part.-finallyProcess :: MonadComp m => Process m a -> Process m b -> Process m a+finallyProcess :: MonadDES m => Process m a -> Process m b -> Process m a+{-# INLINABLE finallyProcess #-} finallyProcess (Process m) (Process m') =   Process $ \pid ->   finallyCont (m pid) (m' pid)@@ -409,8 +500,9 @@ -- if it will be wrapped in the 'IO' monad. Therefore, you should use specialised -- functions like the stated one that use the 'throw' function but within the 'IO' computation, -- which allows already handling the exception.-throwProcess :: (MonadComp m, Exception e) => e -> Process m a-throwProcess = liftIO . throw+throwProcess :: (MonadDES m, Exception e) => e -> Process m a+{-# INLINABLE throwProcess #-}+throwProcess = liftEvent . throwEvent  -- | Execute the specified computations in parallel within -- the current computation and return their results. The cancellation@@ -423,43 +515,49 @@ -- they are processed simultaneously by the event queue. -- -- New 'ProcessId' identifiers will be assigned to the started processes.-processParallel :: MonadComp m => [Process m a] -> Process m [a]+processParallel :: MonadDES m => [Process m a] -> Process m [a]+{-# INLINABLE processParallel #-} 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 :: MonadComp m => [(ProcessId m, Process m a)] -> Process m [a]+processParallelUsingIds :: MonadDES m => [(ProcessId m, Process m a)] -> Process m [a]+{-# INLINABLE processParallelUsingIds #-} processParallelUsingIds xs =   Process $ \pid ->   do liftEvent $ processParallelPrepare xs      contParallel $        flip map xs $ \(pid, m) ->-       (invokeProcess pid m, processCancelSource pid)+       (invokeProcess pid m, processContId pid)  -- | Like 'processParallel' but ignores the result.-processParallel_ :: MonadComp m => [Process m a] -> Process m ()+processParallel_ :: MonadDES m => [Process m a] -> Process m ()+{-# INLINABLE processParallel_ #-} processParallel_ xs =   liftSimulation (processParallelCreateIds xs) >>= processParallelUsingIds_   -- | Like 'processParallelUsingIds' but ignores the result.-processParallelUsingIds_ :: MonadComp m => [(ProcessId m, Process m a)] -> Process m ()+processParallelUsingIds_ :: MonadDES m => [(ProcessId m, Process m a)] -> Process m ()+{-# INLINABLE processParallelUsingIds_ #-} processParallelUsingIds_ xs =   Process $ \pid ->   do liftEvent $ processParallelPrepare xs      contParallel_ $        flip map xs $ \(pid, m) ->-       (invokeProcess pid m, processCancelSource pid)+       (invokeProcess pid m, processContId pid)  -- | Create the new process identifiers.-processParallelCreateIds :: MonadComp m => [Process m a] -> Simulation m [(ProcessId m, Process m a)]+processParallelCreateIds :: MonadDES m => [Process m a] -> Simulation m [(ProcessId m, Process m a)]+{-# INLINABLE processParallelCreateIds #-} processParallelCreateIds xs =   do pids <- liftSimulation $ forM xs $ const newProcessId      return $ zip pids xs  -- | Prepare the processes for parallel execution.-processParallelPrepare :: MonadComp m => [(ProcessId m, Process m a)] -> Event m ()+processParallelPrepare :: MonadDES m => [(ProcessId m, Process m a)] -> Event m ()+{-# INLINABLE processParallelPrepare #-} processParallelPrepare xs =   Event $ \p ->   forM_ xs $ invokeEvent p . processIdPrepare . fst@@ -472,39 +570,45 @@ -- 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 :: MonadComp m => ProcessId m -> Process m a -> Process m a+processUsingId :: MonadDES m => ProcessId m -> Process m a -> Process m a+{-# INLINABLE processUsingId #-} processUsingId pid x =   Process $ \pid' ->   do liftEvent $ processIdPrepare pid-     rerunCont (invokeProcess pid x) (processCancelSource pid)+     rerunCont (invokeProcess pid x) (processContId pid)  -- | Spawn the child process. In case of cancelling one of the processes, -- other process will be cancelled too.-spawnProcess :: MonadComp m => Process m () -> Process m ()+spawnProcess :: MonadDES m => Process m () -> Process m ()+{-# INLINABLE spawnProcess #-} spawnProcess = spawnProcessWith CancelTogether  -- | Spawn the child process specifying the process identifier. -- In case of cancelling one of the processes, other process will be cancelled too.-spawnProcessUsingId :: MonadComp m => ProcessId m -> Process m () -> Process m ()+spawnProcessUsingId :: MonadDES m => ProcessId m -> Process m () -> Process m ()+{-# INLINABLE spawnProcessUsingId #-} spawnProcessUsingId = spawnProcessUsingIdWith CancelTogether  -- | Spawn the child process specifying how the child and parent processes -- should be cancelled in case of need.-spawnProcessWith :: MonadComp m => ContCancellation -> Process m () -> Process m ()+spawnProcessWith :: MonadDES m => ContCancellation -> Process m () -> Process m ()+{-# INLINABLE spawnProcessWith #-} spawnProcessWith cancellation x =   do pid <- liftSimulation newProcessId      spawnProcessUsingIdWith cancellation pid x  -- | Spawn the child process specifying how the child and parent processes -- should be cancelled in case of need.-spawnProcessUsingIdWith :: MonadComp m => ContCancellation -> ProcessId m -> Process m () -> Process m ()+spawnProcessUsingIdWith :: MonadDES m => ContCancellation -> ProcessId m -> Process m () -> Process m ()+{-# INLINABLE spawnProcessUsingIdWith #-} spawnProcessUsingIdWith cancellation pid x =   Process $ \pid' ->   do liftEvent $ processIdPrepare pid-     spawnCont cancellation (invokeProcess pid x) (processCancelSource pid)+     spawnCont cancellation (invokeProcess pid x) (processContId pid)  -- | Await the signal.-processAwait :: MonadComp m => Signal m a -> Process m a+processAwait :: MonadDES m => Signal m a -> Process m a+{-# INLINABLE processAwait #-} processAwait signal =   Process $ \pid -> contAwait signal @@ -515,53 +619,54 @@  -- | Memoize the process so that it would always return the same value -- within the simulation run.-memoProcess :: MonadComp m => Process m a -> Simulation m (Process m a)+memoProcess :: MonadDES m => Process m a -> Simulation m (Process m a)+{-# INLINABLE memoProcess #-} memoProcess x =   Simulation $ \r ->-  do let s = runSession r-     started  <- newProtoRef s False+  do started  <- invokeSimulation r $ newRef False      computed <- invokeSimulation r newSignalSource-     value    <- newProtoRef s Nothing+     value    <- invokeSimulation r $ newRef Nothing      let result =-           do Just x <- liftComp $ readProtoRef value+           do Just x <- liftEvent $ readRef value               case x of                 MemoComputed a -> return a                 MemoError e    -> throwProcess e                 MemoCancelled  -> cancelProcess      return $-       do v <- liftComp $ readProtoRef value+       do v <- liftEvent $ readRef value           case v of             Just _ -> result             Nothing ->-              do f <- liftComp $ readProtoRef started+              do f <- liftEvent $ readRef started                  case f of                    True ->                      do processAwait $ publishSignal computed                         result                    False ->-                     do liftComp $ writeProtoRef started True-                        r <- liftComp $ newProtoRef s MemoCancelled+                     do liftEvent $ writeRef started True+                        r <- liftSimulation $ newRef MemoCancelled                         finallyProcess                           (catchProcess                            (do a <- x    -- compute only once!-                               liftComp $ writeProtoRef r (MemoComputed a))+                               liftEvent $ writeRef r (MemoComputed a))                            (\e ->-                             liftComp $ writeProtoRef r (MemoError e)))+                             liftEvent $ writeRef r (MemoError e)))                           (liftEvent $-                           do liftComp $-                                do x <- readProtoRef r-                                   writeProtoRef value (Just x)+                           do x <- readRef r+                              writeRef value (Just x)                               triggerSignal computed ())                         result  -- | Zip two parallel processes waiting for the both.-zipProcessParallel :: MonadComp m => Process m a -> Process m b -> Process m (a, b)+zipProcessParallel :: MonadDES m => Process m a -> Process m b -> Process m (a, b)+{-# INLINABLE zipProcessParallel #-} 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 :: MonadComp m => Process m a -> Process m b -> Process m c -> Process m (a, b, c)+zip3ProcessParallel :: MonadDES m => Process m a -> Process m b -> Process m c -> Process m (a, b, c)+{-# INLINABLE zip3ProcessParallel #-} zip3ProcessParallel x y z =   do [Left a,       Right (Left b),@@ -574,7 +679,8 @@ -- | 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 :: (MonadComp m, MonadIO m) => Process m (a, b) -> Simulation m (Process m a, Process m b)+unzipProcess :: MonadDES m => Process m (a, b) -> Simulation m (Process m a, Process m b)+{-# INLINABLE unzipProcess #-} unzipProcess xy =   do xy' <- memoProcess xy      return (fmap fst xy', fmap snd xy')@@ -589,7 +695,8 @@ -- -- A cancellation of the child process doesn't lead to cancelling the parent process. -- Then 'Nothing' is returned within the computation.-timeoutProcess :: (MonadComp m, MonadIO m) => Double -> Process m a -> Process m (Maybe a)+timeoutProcess :: MonadDES m => Double -> Process m a -> Process m (Maybe a)+{-# INLINABLE timeoutProcess #-} timeoutProcess timeout p =   do pid <- liftSimulation newProcessId      timeoutProcessUsingId timeout pid p@@ -604,26 +711,26 @@ -- -- A cancellation of the child process doesn't lead to cancelling the parent process. -- Then 'Nothing' is returned within the computation.-timeoutProcessUsingId :: (MonadComp m, MonadIO m) => Double -> ProcessId m -> Process m a -> Process m (Maybe a)+timeoutProcessUsingId :: MonadDES m => Double -> ProcessId m -> Process m a -> Process m (Maybe a)+{-# INLINABLE timeoutProcessUsingId #-} timeoutProcessUsingId timeout pid p =   do s <- liftSimulation newSignalSource      timeoutPid <- liftSimulation newProcessId      spawnProcessUsingIdWith CancelChildAfterParent timeoutPid $-       finallyProcess-       (holdProcess timeout)-       (liftEvent $-        cancelProcessWithId pid)+       do holdProcess timeout+          liftEvent $+            cancelProcessWithId pid      spawnProcessUsingIdWith CancelChildAfterParent pid $-       do sn <- liftParameter simulationSession-          r <- liftComp $ newProtoRef sn Nothing+       do r <- liftSimulation $ newRef Nothing           finallyProcess             (catchProcess              (do a <- p-                 liftComp $ writeProtoRef r $ Just (Right a))+                 liftEvent $ writeRef r $ Just (Right a))              (\e ->-               liftComp $ writeProtoRef r $ Just (Left e)))+               liftEvent $ writeRef r $ Just (Left e)))             (liftEvent $-             do x <- liftComp $ readProtoRef r+             do cancelProcessWithId timeoutPid+                x <- readRef r                 triggerSignal s x)      x <- processAwait $ publishSignal s      case x of@@ -633,7 +740,8 @@  -- | Yield to allow other 'Process' and 'Event' computations to run -- at the current simulation time point.-processYield :: MonadComp m => Process m ()+processYield :: MonadDES m => Process m ()+{-# INLINABLE processYield #-} processYield =   Process $ \pid ->   Cont $ \c ->@@ -646,7 +754,8 @@ -- the discontinuous process, although such a process can still be canceled outside -- (see 'cancelProcessWithId'), but then only its finalization parts (see 'finallyProcess') -- will be called, usually, to release the resources acquired before.-neverProcess :: MonadComp m => Process m a+neverProcess :: MonadDES m => Process m a+{-# INLINABLE neverProcess #-} neverProcess =   Process $ \pid ->   Cont $ \c ->@@ -655,7 +764,8 @@      resumeCont c $ error "It must never be computed: neverProcess"  -- | Show the debug message with the current simulation time.-traceProcess :: MonadComp m => String -> Process m a -> Process m a+traceProcess :: MonadDES m => String -> Process m a -> Process m a+{-# INLINABLE traceProcess #-} traceProcess message m =   Process $ \pid ->   traceCont message $
− Simulation/Aivika/Trans/Internal/Signal.hs 
@@ -1,404 +0,0 @@---- |--- Module     : Simulation.Aivika.Trans.Internal.Signal--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.8.3------ This module defines the signal which we can subscribe handlers to. --- These handlers can be disposed. The signal is triggered in the --- current time point actuating the corresponded computations from --- the handlers. -----module Simulation.Aivika.Trans.Internal.Signal-       (-- * Handling and Triggering Signal-        Signal(..),-        handleSignal_,-        SignalSource,-        newSignalSource,-        publishSignal,-        triggerSignal,-        -- * Useful Combinators-        mapSignal,-        mapSignalM,-        apSignal,-        filterSignal,-        filterSignalM,-        emptySignal,-        merge2Signals,-        merge3Signals,-        merge4Signals,-        merge5Signals,-        -- * Signal Arriving-        arrivalSignal,-        -- * Creating Signal in Time Points-        newSignalInTimes,-        newSignalInIntegTimes,-        newSignalInStartTime,-        newSignalInStopTime,-        -- * Signal History-        SignalHistory,-        signalHistorySignal,-        newSignalHistory,-        newSignalHistoryStartingWith,-        readSignalHistory,-        -- * Signalable Computations-        Signalable(..),-        signalableChanged,-        emptySignalable,-        appendSignalable,-        -- * Debugging-        traceSignal) where--import Data.Monoid-import Data.List-import Data.Array--import Control.Monad-import Control.Monad.Trans--import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import qualified Simulation.Aivika.Trans.Vector as V-import qualified Simulation.Aivika.Trans.Vector.Unboxed as UV-import Simulation.Aivika.Trans.Comp-import Simulation.Aivika.Trans.Internal.Specs-import Simulation.Aivika.Trans.Internal.Parameter-import Simulation.Aivika.Trans.Internal.Simulation-import Simulation.Aivika.Trans.Internal.Event-import Simulation.Aivika.Arrival (Arrival(..))---- | The signal source that can publish its signal.-data SignalSource m a =-  SignalSource { publishSignal :: Signal m a,-                                  -- ^ Publish the signal.-                 triggerSignal :: a -> Event m ()-                                  -- ^ Trigger the signal actuating -                                  -- all its handlers at the current -                                  -- simulation time point.-               }-  --- | The signal that can have disposable handlers.  -data Signal m a =-  Signal { handleSignal :: (a -> Event m ()) -> Event m (DisposableEvent m)-           -- ^ Subscribe the handler to the specified -           -- signal and return a nested computation-           -- within a disposable object that, being applied,-           -- unsubscribes the handler from this signal.-         }---- | The queue of signal handlers.-data SignalHandlerQueue m a =-  SignalHandlerQueue { queueList :: ProtoRef m [SignalHandler m a] }-  --- | It contains the information about the disposable queue handler.-data SignalHandler m a =-  SignalHandler { handlerComp   :: a -> Event m (),-                  handlerMarker :: SessionMarker m }--instance SessionMonad m => Eq (SignalHandler m a) where--  {-# INLINE (==) #-}-  x == y = (handlerMarker x) == (handlerMarker y)---- | Subscribe the handler to the specified signal forever.--- To subscribe the disposable handlers, use function 'handleSignal'.-handleSignal_ :: MonadComp m => Signal m a -> (a -> Event m ()) -> Event m ()-{-# INLINE handleSignal_ #-}-handleSignal_ signal h = -  do x <- handleSignal signal h-     return ()-     --- | Create a new signal source.-newSignalSource :: MonadComp m => Simulation m (SignalSource m a)-newSignalSource =-  Simulation $ \r ->-  do let s = runSession r-     list <- newProtoRef s []-     let queue  = SignalHandlerQueue { queueList = list }-         signal = Signal { handleSignal = handle }-         source = SignalSource { publishSignal = signal, -                                 triggerSignal = trigger }-         handle h =-           Event $ \p ->-           do m <- newSessionMarker s-              x <- enqueueSignalHandler queue h m-              return $-                DisposableEvent $-                Event $ \p -> dequeueSignalHandler queue x-         trigger a =-           Event $ \p -> triggerSignalHandlers queue a p-     return source---- | Trigger all next signal handlers.-triggerSignalHandlers :: MonadComp m => SignalHandlerQueue m a -> a -> Point m -> m ()-triggerSignalHandlers q a p =-  do hs <- readProtoRef (queueList q)-     forM_ hs $ \h ->-       invokeEvent p $ handlerComp h a-            --- | Enqueue the handler and return its representative in the queue.            -enqueueSignalHandler :: MonadComp m => SignalHandlerQueue m a -> (a -> Event m ()) -> SessionMarker m -> m (SignalHandler m a)-enqueueSignalHandler q h m = -  do let handler = SignalHandler { handlerComp   = h,-                                   handlerMarker = m }-     modifyProtoRef (queueList q) (handler :)-     return handler---- | Dequeue the handler representative.-dequeueSignalHandler :: MonadComp m => SignalHandlerQueue m a -> SignalHandler m a -> m ()-dequeueSignalHandler q h = -  modifyProtoRef (queueList q) (delete h)--instance MonadComp m => Functor (Signal m) where--  {-# INLINE fmap #-}-  fmap = mapSignal-  -instance MonadComp m => Monoid (Signal m a) where --  {-# INLINE mempty #-}-  mempty = emptySignal--  {-# INLINE mappend #-}-  mappend = merge2Signals--  {-# INLINE mconcat #-}-  mconcat [] = emptySignal-  mconcat [x1] = x1-  mconcat [x1, x2] = merge2Signals x1 x2-  mconcat [x1, x2, x3] = merge3Signals x1 x2 x3-  mconcat [x1, x2, x3, x4] = merge4Signals x1 x2 x3 x4-  mconcat [x1, x2, x3, x4, x5] = merge5Signals x1 x2 x3 x4 x5-  mconcat (x1 : x2 : x3 : x4 : x5 : xs) = -    mconcat $ merge5Signals x1 x2 x3 x4 x5 : xs-  --- | Map the signal according the specified function.-mapSignal :: MonadComp m => (a -> b) -> Signal m a -> Signal m b-mapSignal f m =-  Signal { handleSignal = \h -> -            handleSignal m $ h . f }---- | Filter only those signal values that satisfy to --- the specified predicate.-filterSignal :: MonadComp m => (a -> Bool) -> Signal m a -> Signal m a-filterSignal p m =-  Signal { handleSignal = \h ->-            handleSignal m $ \a ->-            when (p a) $ h a }-  --- | Filter only those signal values that satisfy to --- the specified predicate.-filterSignalM :: MonadComp m => (a -> Event m Bool) -> Signal m a -> Signal m a-filterSignalM p m =-  Signal { handleSignal = \h ->-            handleSignal m $ \a ->-            do x <- p a-               when x $ h a }-  --- | Merge two signals.-merge2Signals :: MonadComp m => Signal m a -> Signal m a -> Signal m a-merge2Signals m1 m2 =-  Signal { handleSignal = \h ->-            do x1 <- handleSignal m1 h-               x2 <- handleSignal m2 h-               return $ x1 <> x2 }---- | Merge three signals.-merge3Signals :: MonadComp m => Signal m a -> Signal m a -> Signal m a -> Signal m a-merge3Signals m1 m2 m3 =-  Signal { handleSignal = \h ->-            do x1 <- handleSignal m1 h-               x2 <- handleSignal m2 h-               x3 <- handleSignal m3 h-               return $ x1 <> x2 <> x3 }---- | Merge four signals.-merge4Signals :: MonadComp m-                 => Signal m a -> Signal m a -> Signal m a-                 -> Signal m a -> Signal m a-merge4Signals m1 m2 m3 m4 =-  Signal { handleSignal = \h ->-            do x1 <- handleSignal m1 h-               x2 <- handleSignal m2 h-               x3 <- handleSignal m3 h-               x4 <- handleSignal m4 h-               return $ x1 <> x2 <> x3 <> x4 }-           --- | Merge five signals.-merge5Signals :: MonadComp m-                 => Signal m a -> Signal m a -> Signal m a-                 -> Signal m a -> Signal m a -> Signal m a-merge5Signals m1 m2 m3 m4 m5 =-  Signal { handleSignal = \h ->-            do x1 <- handleSignal m1 h-               x2 <- handleSignal m2 h-               x3 <- handleSignal m3 h-               x4 <- handleSignal m4 h-               x5 <- handleSignal m5 h-               return $ x1 <> x2 <> x3 <> x4 <> x5 }---- | Compose the signal.-mapSignalM :: MonadComp m => (a -> Event m b) -> Signal m a -> Signal m b-mapSignalM f m =-  Signal { handleSignal = \h ->-            handleSignal m (f >=> h) }-  --- | Transform the signal.-apSignal :: MonadComp m => Event m (a -> b) -> Signal m a -> Signal m b-apSignal f m =-  Signal { handleSignal = \h ->-            handleSignal m $ \a -> do { x <- f; h (x a) } }---- | An empty signal which is never triggered.-emptySignal :: MonadComp m => Signal m a-emptySignal =-  Signal { handleSignal = \h -> return mempty }-                                    --- | Represents the history of the signal values.-data SignalHistory m a =-  SignalHistory { signalHistorySignal :: Signal m a,  -                  -- ^ The signal for which the history is created.-                  signalHistoryTimes  :: UV.Vector m Double,-                  signalHistoryValues :: V.Vector m a }---- | Create a history of the signal values.-newSignalHistory :: MonadComp m => Signal m a -> Event m (SignalHistory m a)-newSignalHistory =-  newSignalHistoryStartingWith Nothing---- | Create a history of the signal values starting with--- the optional initial value.-newSignalHistoryStartingWith :: MonadComp m => Maybe a -> Signal m a -> Event m (SignalHistory m a)-newSignalHistoryStartingWith init signal =-  Event $ \p ->-  do let s = runSession $ pointRun p-     ts <- UV.newVector s-     xs <- V.newVector s-     case init of-       Nothing -> return ()-       Just a ->-         do UV.appendVector ts (pointTime p)-            V.appendVector xs a-     invokeEvent p $-       handleSignal_ signal $ \a ->-       Event $ \p ->-       do UV.appendVector ts (pointTime p)-          V.appendVector xs a-     return SignalHistory { signalHistorySignal = signal,-                            signalHistoryTimes  = ts,-                            signalHistoryValues = xs }-       --- | Read the history of signal values.-readSignalHistory :: MonadComp m => SignalHistory m a -> Event m (Array Int Double, Array Int a)-readSignalHistory history =-  Event $ \p ->-  do xs <- UV.freezeVector (signalHistoryTimes history)-     ys <- V.freezeVector (signalHistoryValues history)-     return (xs, ys)     -     --- | Trigger the signal with the current time.-triggerSignalWithCurrentTime :: MonadComp m => SignalSource m Double -> Event m ()-triggerSignalWithCurrentTime s =-  Event $ \p -> invokeEvent p $ triggerSignal s (pointTime p)---- | Return a signal that is triggered in the specified time points.-newSignalInTimes :: MonadComp m => [Double] -> Event m (Signal m 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 :: MonadComp m => Event m (Signal m 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 :: MonadComp m => Event m (Signal m 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 :: MonadComp m => Event m (Signal m 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 m a =-  Signalable { readSignalable :: Event m a,-               -- ^ Return a computation of the value.-               signalableChanged_ :: Signal m ()-               -- ^ 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 :: MonadComp m => Signalable m a -> Signal m a-signalableChanged x = mapSignalM (const $ readSignalable x) $ signalableChanged_ x--instance Functor m => Functor (Signalable m) where--  {-# INLINE fmap #-}-  fmap f x = x { readSignalable = fmap f (readSignalable x) }--instance (MonadComp m, Monoid a) => Monoid (Signalable m a) where--  {-# INLINE mempty #-}-  mempty = emptySignalable--  {-# INLINE mappend #-}-  mappend = appendSignalable---- | Return an identity.-emptySignalable :: (MonadComp m, Monoid a) => Signalable m a-emptySignalable =-  Signalable { readSignalable = return mempty,-               signalableChanged_ = mempty }---- | An associative operation.-appendSignalable :: (MonadComp m, Monoid a) => Signalable m a -> Signalable m a -> Signalable m a-appendSignalable m1 m2 =-  Signalable { readSignalable = liftM2 (<>) (readSignalable m1) (readSignalable m2),-               signalableChanged_ = (signalableChanged_ m1) <> (signalableChanged_ m2) }---- | Transform a signal so that the resulting signal returns a sequence of arrivals--- saving the information about the time points at which the original signal was received.-arrivalSignal :: MonadComp m => Signal m a -> Signal m (Arrival a)-arrivalSignal m = -  Signal { handleSignal = \h ->-             Event $ \p ->-             do let s = runSession $ pointRun p-                r <- newProtoRef s Nothing-                invokeEvent p $-                  handleSignal m $ \a ->-                  Event $ \p ->-                  do t0 <- readProtoRef r-                     let t = pointTime p-                     writeProtoRef r (Just t)-                     invokeEvent p $-                       h Arrival { arrivalValue = a,-                                   arrivalTime  = t,-                                   arrivalDelay =-                                     case t0 of-                                       Nothing -> Nothing-                                       Just t0 -> Just (t - t0) } }---- | Show the debug message with the current simulation time.-traceSignal :: MonadComp m => String -> Signal m a -> Signal m a -traceSignal message m =-  Signal { handleSignal = \h ->-            handleSignal m $ traceEvent message . h }
Simulation/Aivika/Trans/Internal/Simulation.hs view
@@ -1,28 +1,29 @@ -{-# LANGUAGE RecursiveDo, TypeSynonymInstances #-}+{-# LANGUAGE RecursiveDo, TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances #-}  -- | -- Module     : Simulation.Aivika.Trans.Internal.Simulation--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The module defines the 'Simulation' monad transformer that represents a computation -- within the simulation run. --  module Simulation.Aivika.Trans.Internal.Simulation        (-- * Simulation+        Simulation(..),         SimulationLift(..),+        invokeSimulation,         runSimulation,         runSimulations,+        runSimulationByIndex,         -- * Error Handling         catchSimulation,         finallySimulation,         throwSimulation,-        -- * Memoization-        memoSimulation,         -- * Exceptions         SimulationException(..),         SimulationAbort(..)) where@@ -34,10 +35,10 @@ import Control.Applicative  import Simulation.Aivika.Trans.Exception-import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef import Simulation.Aivika.Trans.Generator import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Internal.Types import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Parameter @@ -56,27 +57,46 @@        m' r  -- | Run the simulation using the specified specs.-runSimulation :: MonadComp m => Simulation m a -> Specs m -> m a+runSimulation :: MonadDES m => Simulation m a -> Specs m -> m a+{-# INLINABLE runSimulation #-} runSimulation (Simulation m) sc =-  do s <- newSession-     q <- newEventQueue s sc-     g <- newGenerator s $ spcGeneratorType sc+  do q <- newEventQueue sc+     g <- newGenerator $ spcGeneratorType sc      m Run { runSpecs = sc,-             runSession = s,              runIndex = 1,              runCount = 1,              runEventQueue = q,              runGenerator = g } +-- | Run the simulation by the specified specs and run index in series.+runSimulationByIndex :: MonadDES m+                        => Simulation m a+                        -- ^ the simulation model+                        -> Specs m+                        -- ^ the simulation specs+                        -> Int+                        -- ^ the number of runs in series+                        -> Int+                        -- ^ the index of the current run (started from 1)+                        -> m a+{-# INLINABLE runSimulationByIndex #-}+runSimulationByIndex (Simulation m) sc runs index =+  do q <- newEventQueue sc+     g <- newGenerator $ spcGeneratorType sc+     m Run { runSpecs = sc,+             runIndex = index,+             runCount = runs,+             runEventQueue = q,+             runGenerator = g }+ -- | Run the given number of simulations using the specified specs,  --   where each simulation is distinguished by its index 'simulationIndex'.-runSimulations :: MonadComp m => Simulation m a -> Specs m -> Int -> [m a]+runSimulations :: MonadDES m => Simulation m a -> Specs m -> Int -> [m a]+{-# INLINABLE runSimulations #-} runSimulations (Simulation m) sc runs = map f [1 .. runs]-  where f i = do s <- newSession-                 q <- newEventQueue s sc-                 g <- newGenerator s $ spcGeneratorType sc+  where f i = do q <- newEventQueue sc+                 g <- newGenerator $ spcGeneratorType sc                  m Run { runSpecs = sc,-                         runSession = s,                          runIndex = i,                          runCount = runs,                          runEventQueue = q,@@ -105,7 +125,7 @@   {-# INLINE lift #-}   lift = Simulation . const -instance MonadCompTrans Simulation where+instance Monad m => MonadCompTrans Simulation m where    {-# INLINE liftComp #-}   liftComp = Simulation . const@@ -116,37 +136,42 @@   liftIO = Simulation . const . liftIO  -- | A type class to lift the simulation computations into other computations.-class SimulationLift t where+class SimulationLift t m where      -- | Lift the specified 'Simulation' computation into another computation.-  liftSimulation :: MonadComp m => Simulation m a -> t m a+  liftSimulation :: Simulation m a -> t m a -instance SimulationLift Simulation where+instance Monad m => SimulationLift Simulation m where      {-# INLINE liftSimulation #-}   liftSimulation = id -instance ParameterLift Simulation where+instance Monad m => ParameterLift Simulation m where    {-# INLINE liftParameter #-}   liftParameter (Parameter x) = Simulation x      -- | Exception handling within 'Simulation' computations.-catchSimulation :: (MonadComp m, Exception e) => Simulation m a -> (e -> Simulation m a) -> Simulation m a+catchSimulation :: (MonadException m, Exception e) => Simulation m a -> (e -> Simulation m a) -> Simulation m a+{-# INLINABLE catchSimulation #-} catchSimulation (Simulation m) h =   Simulation $ \r ->    catchComp (m r) $ \e ->   let Simulation m' = h e in m' r                             -- | A computation with finalization part like the 'finally' function.-finallySimulation :: MonadComp m => Simulation m a -> Simulation m b -> Simulation m a+finallySimulation :: MonadException m => Simulation m a -> Simulation m b -> Simulation m a+{-# INLINABLE finallySimulation #-} finallySimulation (Simulation m) (Simulation m') =   Simulation $ \r ->   finallyComp (m r) (m' r)  -- | Like the standard 'throw' function.-throwSimulation :: (MonadComp m, Exception e) => e -> Simulation m a-throwSimulation = throw+throwSimulation :: (MonadException m, Exception e) => e -> Simulation m a+{-# INLINABLE throwSimulation #-}+throwSimulation e =+  Simulation $ \r ->+  throwComp e  instance MonadFix m => MonadFix (Simulation m) where @@ -154,19 +179,3 @@   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 :: MonadComp m => Simulation m a -> Simulation m (Simulation m a)-memoSimulation m =-  Simulation $ \r ->-  do let s = runSession r-     ref <- newProtoRef s Nothing-     return $ Simulation $ \r ->-       do x <- readProtoRef ref-          case x of-            Just v -> return v-            Nothing ->-              do v <- invokeSimulation r m-                 writeProtoRef ref (Just v)-                 return v
Simulation/Aivika/Trans/Internal/Specs.hs view
@@ -3,11 +3,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Internal.Specs--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- It defines the simulation specs and related stuff. module Simulation.Aivika.Trans.Internal.Specs@@ -15,16 +15,6 @@         Method(..),         Run(..),         Point(..),-        Parameter(..),-        Simulation(..),-        Dynamics(..),-        Event(..),-        EventProcessing(..),-        EventQueueing(..),-        invokeParameter,-        invokeSimulation,-        invokeDynamics,-        invokeEvent,         basicTime,         integIterationBnds,         integIterationHiBnd,@@ -39,132 +29,7 @@         integStopPoint,         pointAt) where -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.Generator---- | It defines the simulation specs.-data Specs m = Specs { spcStartTime :: Double,    -- ^ the start time-                       spcStopTime :: Double,     -- ^ the stop time-                       spcDT :: Double,           -- ^ the integration time step-                       spcMethod :: Method,       -- ^ the integration method-                       spcGeneratorType :: GeneratorType m-                       -- ^ the type of the random number generator-                     }---- | It defines the integration method.-data Method = Euler          -- ^ Euler's method-            | RungeKutta2    -- ^ the 2nd order Runge-Kutta method-            | RungeKutta4    -- ^ the 4th order Runge-Kutta method-            deriving (Eq, Ord, Show)---- | It indentifies the simulation run.-data Run m = Run { runSpecs :: Specs m,            -- ^ the simulation specs-                   runSession :: Session m,        -- ^ the simulation session-                   runIndex :: Int,       -- ^ the current simulation run index-                   runCount :: Int,       -- ^ the total number of runs in this experiment-                   runEventQueue :: EventQueue m,  -- ^ the event queue-                   runGenerator :: Generator m     -- ^ the random number generator-                 }---- | It defines the simulation point appended with the additional information.-data Point m = Point { pointSpecs :: Specs m,      -- ^ the simulation specs-                       pointRun :: Run m,          -- ^ the simulation run-                       pointTime :: Double,        -- ^ the current time-                       pointIteration :: Int,      -- ^ the current iteration-                       pointPhase :: Int           -- ^ the current phase-                     }---- | The 'Parameter' monad that allows specifying the model parameters.--- For example, they can be used when running the Monte-Carlo simulation.--- --- In general, this monad is very useful for representing a computation which is external--- relative to the model itself.-newtype Parameter m a = Parameter (Run m -> m a)---- | A value in the 'Simulation' monad represents a computation--- within the simulation run.-newtype Simulation m a = Simulation (Run m -> m a)---- | A value in the 'Dynamics' monad represents a polymorphic time varying function--- defined in the whole spectrum of time values as a single entity. It is ideal for--- numerical approximating integrals.-newtype Dynamics m a = Dynamics (Point m -> m a)---- | A value in the 'Event' monad transformer represents a polymorphic time varying--- function which is strongly synchronized with the event queue.-newtype Event m a = Event (Point m -> m a)---- | Invoke the 'Parameter' computation.-invokeParameter :: Run m -> Parameter m a -> m a-{-# INLINE invokeParameter #-}-invokeParameter r (Parameter m) = m r---- | Invoke the 'Simulation' computation.-invokeSimulation :: Run m -> Simulation m a -> m a-{-# INLINE invokeSimulation #-}-invokeSimulation r (Simulation m) = m r---- | Invoke the 'Dynamics' computation.-invokeDynamics :: Point m -> Dynamics m a -> m a-{-# INLINE invokeDynamics #-}-invokeDynamics p (Dynamics m) = m p---- | Invoke the 'Event' computation.-invokeEvent :: Point m -> Event m a -> m a-{-# INLINE invokeEvent #-}-invokeEvent p (Event m) = m p---- | Defines how the events are processed.-data EventProcessing = CurrentEvents-                       -- ^ either process all earlier and then current events,-                       -- or raise an error if the current simulation time is less-                       -- than the actual time of the event queue (safe within-                       -- the 'Event' computation as this is protected by the type system)-                     | EarlierEvents-                       -- ^ either process all earlier events not affecting-                       -- the events at the current simulation time,-                       -- or raise an error if the current simulation time is less-                       -- than the actual time of the event queue (safe within-                       -- the 'Event' computation as this is protected by the type system)-                     | CurrentEventsOrFromPast-                       -- ^ either process all earlier and then current events,-                       -- or do nothing if the current simulation time is less-                       -- than the actual time of the event queue-                       -- (do not use unless the documentation states the opposite)-                     | EarlierEventsOrFromPast-                       -- ^ either process all earlier events,-                       -- or do nothing if the current simulation time is less-                       -- than the actual time of the event queue-                       -- (do not use unless the documentation states the opposite)-                     deriving (Eq, Ord, Show)---- | A type class of monads that allow enqueueing the events.-class EventQueueing m where--  -- | It represents the event queue.-  data EventQueue m :: *--  -- | Create a new event queue by the specified specs with simulation session.-  newEventQueue :: Session m -> Specs m -> m (EventQueue m)--  -- | Enqueue the event which must be actuated at the specified time.-  enqueueEvent :: Double -> Event m () -> Event m ()--  -- | Run the 'EventT' computation in the current simulation time-  -- within the 'DynamicsT' computation involving all pending-  -- 'CurrentEvents' in the processing too.-  runEvent :: Event m a -> Dynamics m a-  {-# INLINE runEvent #-}-  runEvent = runEventWith CurrentEvents--  -- | Run the 'EventT' computation in the current simulation time-  -- within the 'DynamicsT' computation specifying what pending events -  -- should be involved in the processing.-  runEventWith :: EventProcessing -> Event m a -> Dynamics m a--  -- | Return the number of pending events that should-  -- be yet actuated.-  eventQueueCount :: Event m Int+import Simulation.Aivika.Trans.Internal.Types  -- | Returns the integration iterations starting from zero. integIterations :: Specs m -> [Int]
+ Simulation/Aivika/Trans/Internal/Types.hs view
@@ -0,0 +1,155 @@++{-# LANGUAGE TypeFamilies #-}++-- |+-- Module     : Simulation.Aivika.Trans.Internal.Types+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- It defines the implementation details of some types. You should never+-- use it in ordinary simulation models. The module is destined for those+-- who will extend the library.+--+module Simulation.Aivika.Trans.Internal.Types+       (Specs(..),+        Method(..),+        Run(..),+        Point(..),+        Parameter(..),+        Simulation(..),+        Dynamics(..),+        Event(..),+        EventProcessing(..),+        EventQueueing(..),+        invokeParameter,+        invokeSimulation,+        invokeDynamics,+        invokeEvent) where++import Simulation.Aivika.Trans.Generator++-- | It defines the simulation specs.+data Specs m = Specs { spcStartTime :: Double,    -- ^ the start time+                       spcStopTime :: Double,     -- ^ the stop time+                       spcDT :: Double,           -- ^ the integration time step+                       spcMethod :: Method,       -- ^ the integration method+                       spcGeneratorType :: GeneratorType m+                       -- ^ the type of random number generator+                     }++-- | It defines the integration method.+data Method = Euler          -- ^ Euler's method+            | RungeKutta2    -- ^ the 2nd order Runge-Kutta method+            | RungeKutta4    -- ^ the 4th order Runge-Kutta method+            deriving (Eq, Ord, Show)++-- | It indentifies the simulation run.+data Run m = Run { runSpecs :: Specs m,            -- ^ the simulation specs+                   runIndex :: Int,       -- ^ the current simulation run index+                   runCount :: Int,       -- ^ the total number of runs within the experiment+                   runEventQueue :: EventQueue m,  -- ^ the event queue+                   runGenerator :: Generator m     -- ^ the random number generator+                 }++-- | It defines the simulation point appended with the additional information.+data Point m = Point { pointSpecs :: Specs m,      -- ^ the simulation specs+                       pointRun :: Run m,          -- ^ the simulation run+                       pointTime :: Double,        -- ^ the current time+                       pointIteration :: Int,      -- ^ the current iteration+                       pointPhase :: Int           -- ^ the current phase+                     }++-- | The 'Parameter' monad that allows specifying the model parameters.+-- For example, they can be used when running the Monte-Carlo simulation.+-- +-- In general, this monad is very useful for representing a computation which is external+-- relative to the model itself.+newtype Parameter m a = Parameter (Run m -> m a)++-- | A value in the 'Simulation' monad represents a computation+-- within the simulation run.+newtype Simulation m a = Simulation (Run m -> m a)++-- | A value in the 'Dynamics' monad represents a polymorphic time varying function+-- defined in the whole spectrum of time values as a single entity. It is ideal for+-- numerical approximating integrals.+newtype Dynamics m a = Dynamics (Point m -> m a)++-- | A value in the 'Event' monad transformer represents a polymorphic time varying+-- function which is strongly synchronized with the event queue.+newtype Event m a = Event (Point m -> m a)++-- | Invoke the 'Parameter' computation.+invokeParameter :: Run m -> Parameter m a -> m a+{-# INLINE invokeParameter #-}+invokeParameter r (Parameter m) = m r++-- | Invoke the 'Simulation' computation.+invokeSimulation :: Run m -> Simulation m a -> m a+{-# INLINE invokeSimulation #-}+invokeSimulation r (Simulation m) = m r++-- | Invoke the 'Dynamics' computation.+invokeDynamics :: Point m -> Dynamics m a -> m a+{-# INLINE invokeDynamics #-}+invokeDynamics p (Dynamics m) = m p++-- | Invoke the 'Event' computation.+invokeEvent :: Point m -> Event m a -> m a+{-# INLINE invokeEvent #-}+invokeEvent p (Event m) = m p++-- | Defines how the events are processed.+data EventProcessing = CurrentEvents+                       -- ^ either process all earlier and then current events,+                       -- or raise an error if the current simulation time is less+                       -- than the actual time of the event queue (safe within+                       -- the 'Event' computation as this is protected by the type system)+                     | EarlierEvents+                       -- ^ either process all earlier events not affecting+                       -- the events at the current simulation time,+                       -- or raise an error if the current simulation time is less+                       -- than the actual time of the event queue (safe within+                       -- the 'Event' computation as this is protected by the type system)+                     | CurrentEventsOrFromPast+                       -- ^ either process all earlier and then current events,+                       -- or do nothing if the current simulation time is less+                       -- than the actual time of the event queue+                       -- (do not use unless the documentation states the opposite)+                     | EarlierEventsOrFromPast+                       -- ^ either process all earlier events,+                       -- or do nothing if the current simulation time is less+                       -- than the actual time of the event queue+                       -- (do not use unless the documentation states the opposite)+                     deriving (Eq, Ord, Show)++-- | A type class of monads that allow enqueueing the events.+class EventQueueing m where++  -- | It represents the event queue.+  data EventQueue m :: *++  -- | Create a new event queue by the specified specs with simulation session.+  newEventQueue :: Specs m -> m (EventQueue m)++  -- | Enqueue the event which must be actuated at the specified time.+  enqueueEvent :: Double -> Event m () -> Event m ()++  -- | Run the 'EventT' computation in the current simulation time+  -- within the 'DynamicsT' computation involving all pending+  -- 'CurrentEvents' in the processing too.+  runEvent :: Event m a -> Dynamics m a+  {-# INLINE runEvent #-}+  runEvent = runEventWith CurrentEvents++  -- | Run the 'EventT' computation in the current simulation time+  -- within the 'DynamicsT' computation specifying what pending events +  -- should be involved in the processing.+  runEventWith :: EventProcessing -> Event m a -> Dynamics m a++  -- | Return the number of pending events that should+  -- be yet actuated.+  eventQueueCount :: Event m Int
Simulation/Aivika/Trans/Net.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Net--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The module defines a 'Net' arrow that can be applied to modeling the queue networks -- like the 'Processor' arrow from another module. Only the former has a more efficient@@ -34,6 +34,7 @@         emptyNet,         arrNet,         accumNet,+        withinNet,         -- * Specifying Identifier         netUsingId,         -- * Arrival Net@@ -50,9 +51,8 @@ import Control.Arrow import Control.Monad.Trans -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Parameter import Simulation.Aivika.Trans.Simulation import Simulation.Aivika.Trans.Dynamics@@ -63,7 +63,6 @@ import Simulation.Aivika.Trans.QueueStrategy import Simulation.Aivika.Trans.Resource import Simulation.Aivika.Trans.Processor-import Simulation.Aivika.Trans.Ref import Simulation.Aivika.Trans.Circuit import Simulation.Aivika.Arrival (Arrival(..)) @@ -73,10 +72,12 @@         -- ^ Run the net.       } -instance MonadComp m => C.Category (Net m) where+instance MonadDES m => C.Category (Net m) where +  {-# INLINABLE id #-}   id = Net $ \a -> return (a, C.id) +  {-# INLINABLE (.) #-}   (.) = dot     where        (Net g) `dot` (Net f) =@@ -85,34 +86,40 @@            (c, p2) <- g b            return (c, p2 `dot` p1) -instance MonadComp m => Arrow (Net m) where+instance MonadDES m => Arrow (Net m) where +  {-# INLINABLE arr #-}   arr f = Net $ \a -> return (f a, arr f) +  {-# INLINABLE first #-}   first (Net f) =     Net $ \(b, d) ->     do (c, p) <- f b        return ((c, d), first p) +  {-# INLINABLE second #-}   second (Net f) =     Net $ \(d, b) ->     do (c, p) <- f b        return ((d, c), second p) +  {-# INLINABLE (***) #-}   (Net f) *** (Net g) =     Net $ \(b, b') ->     do (c, p1) <- f b        (c', p2) <- g b'        return ((c, c'), p1 *** p2)        +  {-# INLINABLE (&&&) #-}   (Net f) &&& (Net g) =     Net $ \b ->     do (c, p1) <- f b        (c', p2) <- g b        return ((c, c'), p1 &&& p2) -instance MonadComp m => ArrowChoice (Net m) where+instance MonadDES m => ArrowChoice (Net m) where +  {-# INLINABLE left #-}   left x@(Net f) =     Net $ \ebd ->     case ebd of@@ -122,6 +129,7 @@       Right d ->         return (Right d, left x) +  {-# INLINABLE right #-}   right x@(Net f) =     Net $ \edb ->     case edb of@@ -131,6 +139,7 @@       Left d ->         return (Left d, right x) +  {-# INLINABLE (+++) #-}   x@(Net f) +++ y@(Net g) =     Net $ \ebb' ->     case ebb' of@@ -141,6 +150,7 @@         do (c', p2) <- g b'            return (Right c', x +++ p2) +  {-# INLINABLE (|||) #-}   x@(Net f) ||| y@(Net g) =     Net $ \ebc ->     case ebc of@@ -152,12 +162,14 @@            return (d, x ||| p2)  -- | A net that never finishes its work.-emptyNet :: MonadComp m => Net m a b+emptyNet :: MonadDES m => Net m a b+{-# INLINABLE emptyNet #-} emptyNet = Net $ const neverProcess  -- | Create a simple net by the specified handling function -- that runs the discontinuous process for each input value to get an output.-arrNet :: MonadComp m => (a -> Process m b) -> Net m a b+arrNet :: MonadDES m => (a -> Process m b) -> Net m a b+{-# INLINABLE arrNet #-} arrNet f =   let x =         Net $ \a ->@@ -166,22 +178,32 @@   in x  -- | Accumulator that outputs a value determined by the supplied function.-accumNet :: MonadComp m => (acc -> a -> Process m (acc, b)) -> acc -> Net m a b+accumNet :: MonadDES m => (acc -> a -> Process m (acc, b)) -> acc -> Net m a b+{-# INLINABLE accumNet #-} accumNet f acc =   Net $ \a ->   do (acc', b) <- f acc a      return (b, accumNet f acc')  +-- | Involve the computation with side effect when processing the input.+withinNet :: MonadDES m => Process m () -> Net m a a+{-# INLINABLE withinNet #-}+withinNet m =+  Net $ \a ->+  do { m; return (a, withinNet m) }+ -- | Create a net that will use the specified process identifier. -- It can be useful to refer to the underlying 'Process' computation which -- can be passivated, interrupted, canceled and so on. See also the -- 'processUsingId' function for more details.-netUsingId :: MonadComp m => ProcessId m -> Net m a b -> Net m a b+netUsingId :: MonadDES m => ProcessId m -> Net m a b -> Net m a b+{-# INLINABLE netUsingId #-} netUsingId pid (Net f) =   Net $ processUsingId pid . f  -- | Transform the net to an equivalent processor (a rather cheap transformation).-netProcessor :: MonadComp m => Net m a b -> Processor m a b+netProcessor :: MonadDES m => Net m a b -> Processor m a b+{-# INLINABLE netProcessor #-} netProcessor = Processor . loop   where loop x as =           Cons $@@ -190,7 +212,8 @@              return (b, loop x' as')  -- | Transform the processor to a similar net (a more costly transformation).-processorNet :: MonadComp m => Processor m a b -> Net m a b+processorNet :: MonadDES m => Processor m a b -> Net m a b+{-# INLINABLE processorNet #-} processorNet x =   Net $ \a ->   do readingA <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1)@@ -198,29 +221,28 @@      readingB <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1)      writingB <- liftSimulation $ newResourceWithMaxCount FCFS 1 (Just 1)      conting  <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1)-     sn <- liftParameter simulationSession-     refA <- liftComp $ newProtoRef sn Nothing-     refB <- liftComp $ newProtoRef sn Nothing+     refA <- liftSimulation $ newRef Nothing+     refB <- liftSimulation $ newRef Nothing      let input =            do requestResource readingA-              Just a <- liftComp $ readProtoRef refA-              liftComp $ writeProtoRef refA Nothing+              Just a <- liftEvent $ readRef refA+              liftEvent $ writeRef refA Nothing               releaseResource writingA               return (a, Cons input)          consume bs =            do (b, bs') <- runStream bs               requestResource writingB-              liftComp $ writeProtoRef refB (Just b)+              liftEvent $ writeRef refB (Just b)               releaseResource readingB               requestResource conting               consume bs'          loop a =            do requestResource writingA-              liftComp $ writeProtoRef refA (Just a)+              liftEvent $ writeRef refA (Just a)               releaseResource readingA               requestResource readingB-              Just b <- liftComp $ readProtoRef refB-              liftComp $ writeProtoRef refB Nothing+              Just b <- liftEvent $ readRef refB+              liftEvent $ writeRef refB Nothing               releaseResource writingB               return (b, Net $ \a -> releaseResource conting >> loop a)      spawnProcess $@@ -229,7 +251,8 @@  -- | A net that adds the information about the time points at which  -- the values were received.-arrivalNet :: MonadComp m => Net m a (Arrival a)+arrivalNet :: MonadDES m => Net m a (Arrival a)+{-# INLINABLE arrivalNet #-} arrivalNet =   let loop t0 =         Net $ \a ->@@ -244,20 +267,23 @@   in loop Nothing  -- | Delay the input by one step using the specified initial value.-delayNet :: MonadComp m => a -> Net m a a+delayNet :: MonadDES m => a -> Net m a a+{-# INLINABLE delayNet #-} delayNet a0 =   Net $ \a ->   return (a0, delayNet a)  -- | Iterate infinitely using the specified initial value.-iterateNet :: MonadComp m => Net m a a -> a -> Process m ()+iterateNet :: MonadDES m => Net m a a -> a -> Process m ()+{-# INLINABLE iterateNet #-} iterateNet (Net f) a =   do (a', x) <- f a      iterateNet x a'  -- | Iterate the net using the specified initial value -- until 'Nothing' is returned within the 'Net' computation.-iterateNetMaybe :: MonadComp m => Net m a (Maybe a) -> a -> Process m ()+iterateNetMaybe :: MonadDES m => Net m a (Maybe a) -> a -> Process m ()+{-# INLINABLE iterateNetMaybe #-} iterateNetMaybe (Net f) a =   do (a', x) <- f a      case a' of@@ -266,7 +292,8 @@  -- | Iterate the net using the specified initial value -- until the 'Left' result is returned within the 'Net' computation.-iterateNetEither :: MonadComp m => Net m a (Either b a) -> a -> Process m b+iterateNetEither :: MonadDES m => Net m a (Either b a) -> a -> Process m b+{-# INLINABLE iterateNetEither #-} iterateNetEither (Net f) a =   do (ba', x) <- f a      case ba' of@@ -274,7 +301,7 @@        Right a' -> iterateNetEither x a'  -- | Show the debug messages with the current simulation time.-traceNet :: MonadComp m+traceNet :: MonadDES m             => Maybe String             -- ^ the request message             -> Maybe String@@ -282,6 +309,7 @@             -> Net m a b             -- ^ a net             -> Net m a b+{-# INLINABLE traceNet #-} traceNet request response x = Net $ loop x where   loop x a =     do (b, x') <-
+ Simulation/Aivika/Trans/Net/Random.hs view
@@ -0,0 +1,118 @@++-- |+-- Module     : Simulation.Aivika.Trans.Net.Random+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- This module defines some useful random network computations that+-- hold the current process for the corresponding time interval,+-- when processing every input element.+--++module Simulation.Aivika.Trans.Net.Random+       (randomUniformNet,+        randomUniformIntNet,+        randomNormalNet,+        randomExponentialNet,+        randomErlangNet,+        randomPoissonNet,+        randomBinomialNet) where++import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Process+import Simulation.Aivika.Trans.Process.Random+import Simulation.Aivika.Trans.Net++-- | When processing every input element, hold the process+-- for a random time interval distributed uniformly.+randomUniformNet :: MonadDES m+                    => Double+                    -- ^ the minimum time interval+                    -> Double+                    -- ^ the maximum time interval+                    -> Net m a a+{-# INLINABLE randomUniformNet #-}+randomUniformNet min max =+  withinNet $+  randomUniformProcess_ min max++-- | When processing every input element, hold the process+-- for a random time interval distributed uniformly.+randomUniformIntNet :: MonadDES m+                       => Int+                       -- ^ the minimum time interval+                       -> Int+                       -- ^ the maximum time interval+                       -> Net m a a+{-# INLINABLE randomUniformIntNet #-}+randomUniformIntNet min max =+  withinNet $+  randomUniformIntProcess_ min max++-- | When processing every input element, hold the process+-- for a random time interval distributed normally.+randomNormalNet :: MonadDES m+                   => Double+                   -- ^ the mean time interval+                   -> Double+                   -- ^ the time interval deviation+                   -> Net m a a+{-# INLINABLE randomNormalNet #-}+randomNormalNet mu nu =+  withinNet $+  randomNormalProcess_ mu nu+         +-- | When processing every input element, hold the process+-- for a random time interval distributed exponentially+-- with the specified mean (the reciprocal of the rate).+randomExponentialNet :: MonadDES m+                        => Double+                        -- ^ the mean time interval (the reciprocal of the rate)+                        -> Net m a a+{-# INLINABLE randomExponentialNet #-}+randomExponentialNet mu =+  withinNet $+  randomExponentialProcess_ mu+         +-- | When processing every input element, hold the process+-- for a random time interval having the Erlang distribution with+-- the specified scale (the reciprocal of the rate) and shape parameters.+randomErlangNet :: MonadDES m+                   => Double+                   -- ^ the scale (the reciprocal of the rate)+                   -> Int+                   -- ^ the shape+                   -> Net m a a+{-# INLINABLE randomErlangNet #-}+randomErlangNet beta m =+  withinNet $+  randomErlangProcess_ beta m++-- | When processing every input element, hold the process+-- for a random time interval having the Poisson distribution+-- with the specified mean.+randomPoissonNet :: MonadDES m+                    => Double+                    -- ^ the mean time interval+                    -> Net m a a+{-# INLINABLE randomPoissonNet #-}+randomPoissonNet mu =+  withinNet $+  randomPoissonProcess_ mu++-- | When processing every input element, hold the process+-- for a random time interval having the binomial distribution+-- with the specified probability and trials.+randomBinomialNet :: MonadDES m+                     => Double+                     -- ^ the probability+                     -> Int+                     -- ^ the number of trials+                     -> Net m a a+{-# INLINABLE randomBinomialNet #-}+randomBinomialNet prob trials =+  withinNet $+  randomBinomialProcess_ prob trials
Simulation/Aivika/Trans/Parameter.hs view
@@ -1,12 +1,12 @@ -- | -- Module     : Simulation.Aivika.Trans.Parameter--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 ----- The module defines the 'ParameterT' monad transformer that allows representing the model+-- The module defines the 'Parameter' monad transformer that allows representing the model -- parameters. For example, they can be used when running the Monte-Carlo simulation. -- -- In general, this monad tranformer is very useful for representing a computation which is external@@ -26,7 +26,6 @@         simulationIndex,         simulationCount,         simulationSpecs,-        simulationSession,         generatorParameter,         starttime,         stoptime,@@ -36,5 +35,4 @@         -- * Utilities         tableParameter) where -import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Parameter
Simulation/Aivika/Trans/Parameter/Random.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Parameter.Random--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines the random parameters of simulation experiments. --
− Simulation/Aivika/Trans/PriorityQueue.hs 
@@ -1,186 +0,0 @@---- |--- Module     : Simulation.Aivika.Trans.PriorityQueue--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.8.3------ An imperative heap-based priority queue.----module Simulation.Aivika.Trans.PriorityQueue -       (PriorityQueue,-        queueNull, -        queueCount,-        newQueue, -        enqueue, -        dequeue, -        queueFront) where --import Control.Monad--import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp--import qualified Simulation.Aivika.Trans.ProtoArray as A-import qualified Simulation.Aivika.Trans.ProtoArray.Unboxed as UA---- | The 'PriorityQueue' type represents an imperative heap-based --- priority queue.-data PriorityQueue m a = -  PriorityQueue { pqSession  :: Session m,-                  pqKeys     :: ProtoRef m (UA.ProtoArray m Double),-                  pqVals     :: ProtoRef m (A.ProtoArray m a),-                  pqSize     :: ProtoRef m Int,-                  pqCapacity :: ProtoRef m Int }--increase :: ProtoMonadComp m => PriorityQueue m a -> m ()-increase pq = -  do let s = pqSession pq-         keyRef = pqKeys pq-         valRef = pqVals pq-         capacityRef = pqCapacity pq-     keys <- readProtoRef keyRef-     vals <- readProtoRef valRef-     len  <- readProtoRef capacityRef-     let capacity' | len < 64  = 2 * len-                   | otherwise = (len `div` 2) * 3-     keys' <- UA.newProtoArray_ s capacity'-     vals' <- A.newProtoArray_ s capacity'-     mapM_ (\i -> do { k <- UA.readProtoArray keys i; UA.writeProtoArray keys' i k }) [0 .. len - 1]-     mapM_ (\i -> do { v <- A.readProtoArray vals i; A.writeProtoArray vals' i v }) [0 .. len - 1]-     writeProtoRef keyRef keys'-     writeProtoRef valRef vals'-     writeProtoRef capacityRef capacity'--siftUp :: ProtoMonadComp m -          => UA.ProtoArray m Double-          -- ^ keys-          -> A.ProtoArray m a-          -- ^ values-          -> Int-          -- ^ index-          -> Double-          -- ^ key-          -> a-          -- ^ value-          -> m ()-siftUp keys vals i k v =-  if i == 0 -  then do UA.writeProtoArray keys i k-          A.writeProtoArray vals i v-  else do let n = (i - 1) `div` 2-          kn <- UA.readProtoArray keys n-          if k >= kn -            then do UA.writeProtoArray keys i k-                    A.writeProtoArray vals i v-            else do vn <- A.readProtoArray vals n-                    UA.writeProtoArray keys i kn-                    A.writeProtoArray vals i vn-                    siftUp keys vals n k v--siftDown :: ProtoMonadComp m -            => UA.ProtoArray m Double-            -- ^ keys-            -> A.ProtoArray m a-            -- ^ values-            -> Int-            -- ^ size-            -> Int-            -- ^ index-            -> Double-            -- ^ key-            -> a-            -- ^ value-            -> m ()-siftDown keys vals size i k v =-  if i >= (size `div` 2)-  then do UA.writeProtoArray keys i k-          A.writeProtoArray vals i v-  else do let n  = 2 * i + 1-              n' = n + 1-          kn  <- UA.readProtoArray keys n-          if n' >= size -            then if k <= kn-                 then do UA.writeProtoArray keys i k-                         A.writeProtoArray vals i v-                 else do vn <- A.readProtoArray vals n-                         UA.writeProtoArray keys i kn-                         A.writeProtoArray vals i vn-                         siftDown keys vals size n k v-            else do kn' <- UA.readProtoArray keys n'-                    let n''  = if kn > kn' then n' else n-                        kn'' = min kn' kn-                    if k <= kn''-                      then do UA.writeProtoArray keys i k-                              A.writeProtoArray vals i v-                      else do vn'' <- A.readProtoArray vals n''-                              UA.writeProtoArray keys i kn''-                              A.writeProtoArray vals i vn''-                              siftDown keys vals size n'' k v---- | Test whether the priority queue is empty.-queueNull :: ProtoMonadComp m => PriorityQueue m a -> m Bool-queueNull pq =-  do size <- readProtoRef (pqSize pq)-     return $ size == 0---- | Return the number of elements in the priority queue.-queueCount :: ProtoMonadComp m => PriorityQueue m a -> m Int-queueCount pq = readProtoRef (pqSize pq)---- | Create a new priority queue.-newQueue :: ProtoMonadComp m => Session m -> m (PriorityQueue m a)-newQueue session =-  do keys        <- UA.newProtoArray_ session 11-     vals        <- A.newProtoArray_ session 11-     keyRef      <- newProtoRef session keys-     valRef      <- newProtoRef session vals-     sizeRef     <- newProtoRef session 0-     capacityRef <- newProtoRef session 11-     return PriorityQueue { pqSession = session,-                            pqKeys = keyRef, -                            pqVals = valRef, -                            pqSize = sizeRef,-                            pqCapacity = capacityRef }---- | Enqueue a new element with the specified priority.-enqueue :: ProtoMonadComp m => PriorityQueue m a -> Double -> a -> m ()-enqueue pq k v =-  do i <- readProtoRef (pqSize pq)-     n <- readProtoRef (pqCapacity pq)-     when (i >= n - 1) $ increase pq-     writeProtoRef (pqSize pq) (i + 1)-     keys <- readProtoRef (pqKeys pq)-     vals <- readProtoRef (pqVals pq)-     siftUp keys vals i k v---- | Dequeue the element with the minimal priority.-dequeue :: ProtoMonadComp m => PriorityQueue m a -> m ()-dequeue pq =-  do size <- readProtoRef (pqSize pq)-     when (size == 0) $ error "Empty priority queue: dequeue"-     let i = size - 1-     writeProtoRef (pqSize pq) i-     keys <- readProtoRef (pqKeys pq)-     vals <- readProtoRef (pqVals pq)-     k  <- UA.readProtoArray keys i-     v  <- A.readProtoArray vals i-     let k0 = 0.0-         v0 = undefined-     UA.writeProtoArray keys i k0-     A.writeProtoArray vals i v0-     siftDown keys vals i 0 k v---- | Return the element with the minimal priority.-queueFront :: ProtoMonadComp m => PriorityQueue m a -> m (Double, a)-queueFront pq =-  do size <- readProtoRef (pqSize pq)-     when (size == 0) $ error "Empty priority queue: queueFront"-     keys <- readProtoRef (pqKeys pq)-     vals <- readProtoRef (pqVals pq)-     k <- UA.readProtoArray keys 0-     v <- A.readProtoArray vals 0-     return (k, v)
Simulation/Aivika/Trans/Process.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Process--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- A value in the 'Process' monad represents a discontinuous process that  -- can suspend in any simulation time point and then resume later in the same @@ -58,6 +58,9 @@         whenCancellingProcess,         -- * Awaiting Signal         processAwait,+        -- * Preemption+        processPreemptionBeginning,+        processPreemptionEnding,         -- * Yield of Process         processYield,         -- * Process Timeout@@ -83,4 +86,7 @@         -- * Debugging         traceProcess) where +import Simulation.Aivika.Trans.Internal.Simulation+import Simulation.Aivika.Trans.Internal.Dynamics+import Simulation.Aivika.Trans.Internal.Event import Simulation.Aivika.Trans.Internal.Process
+ Simulation/Aivika/Trans/Process/Random.hs view
@@ -0,0 +1,228 @@++-- |+-- Module     : Simulation.Aivika.Trans.Process.Random+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- This module defines helper functions, which are useful to hold +-- the 'Process' computation for a time interval according to some+-- random distribution.+--++module Simulation.Aivika.Trans.Process.Random+       (randomUniformProcess,+        randomUniformProcess_,+        randomUniformIntProcess,+        randomUniformIntProcess_,+        randomNormalProcess,+        randomNormalProcess_,+        randomExponentialProcess,+        randomExponentialProcess_,+        randomErlangProcess,+        randomErlangProcess_,+        randomPoissonProcess,+        randomPoissonProcess_,+        randomBinomialProcess,+        randomBinomialProcess_) where++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Parameter+import Simulation.Aivika.Trans.Parameter.Random+import Simulation.Aivika.Trans.Process++-- | Hold the process for a random time interval distributed uniformly.+randomUniformProcess :: MonadDES m+                        => Double+                        -- ^ the minimum time interval+                        -> Double+                        -- ^ the maximum time interval+                        -> Process m Double+                        -- ^ a computation of the time interval+                        -- for which the process was actually held+{-# INLINABLE randomUniformProcess #-}+randomUniformProcess min max =+  do t <- liftParameter $ randomUniform min max+     holdProcess t+     return t++-- | Hold the process for a random time interval distributed uniformly.+randomUniformProcess_ :: MonadDES m+                         => Double+                         -- ^ the minimum time interval+                         -> Double+                         -- ^ the maximum time interval+                         -> Process m ()+{-# INLINABLE randomUniformProcess_ #-}+randomUniformProcess_ min max =+  do t <- liftParameter $ randomUniform min max+     holdProcess t++-- | Hold the process for a random time interval distributed uniformly.+randomUniformIntProcess :: MonadDES m+                           => Int+                           -- ^ the minimum time interval+                           -> Int+                           -- ^ the maximum time interval+                           -> Process m Int+                           -- ^ a computation of the time interval+                           -- for which the process was actually held+{-# INLINABLE randomUniformIntProcess #-}+randomUniformIntProcess min max =+  do t <- liftParameter $ randomUniformInt min max+     holdProcess $ fromIntegral t+     return t++-- | Hold the process for a random time interval distributed uniformly.+randomUniformIntProcess_ :: MonadDES m+                            => Int+                            -- ^ the minimum time interval+                            -> Int+                            -- ^ the maximum time interval+                            -> Process m ()+{-# INLINABLE randomUniformIntProcess_ #-}+randomUniformIntProcess_ min max =+  do t <- liftParameter $ randomUniformInt min max+     holdProcess $ fromIntegral t++-- | Hold the process for a random time interval distributed normally.+randomNormalProcess :: MonadDES m+                       => Double+                       -- ^ the mean time interval+                       -> Double+                       -- ^ the time interval deviation+                       -> Process m Double+                       -- ^ a computation of the time interval+                       -- for which the process was actually held+{-# INLINABLE randomNormalProcess #-}+randomNormalProcess mu nu =+  do t <- liftParameter $ randomNormal mu nu+     when (t > 0) $+       holdProcess t+     return t+         +-- | Hold the process for a random time interval distributed normally.+randomNormalProcess_ :: MonadDES m+                        => Double+                        -- ^ the mean time interval+                        -> Double+                        -- ^ the time interval deviation+                        -> Process m ()+{-# INLINABLE randomNormalProcess_ #-}+randomNormalProcess_ mu nu =+  do t <- liftParameter $ randomNormal mu nu+     when (t > 0) $+       holdProcess t+         +-- | Hold the process for a random time interval distributed exponentially+-- with the specified mean (the reciprocal of the rate).+randomExponentialProcess :: MonadDES m+                            => Double+                            -- ^ the mean time interval (the reciprocal of the rate)+                            -> Process m Double+                            -- ^ a computation of the time interval+                            -- for which the process was actually held+{-# INLINABLE randomExponentialProcess #-}+randomExponentialProcess mu =+  do t <- liftParameter $ randomExponential mu+     holdProcess t+     return t+         +-- | Hold the process for a random time interval distributed exponentially+-- with the specified mean (the reciprocal of the rate).+randomExponentialProcess_ :: MonadDES m+                             => Double+                             -- ^ the mean time interval (the reciprocal of the rate)+                             -> Process m ()+{-# INLINABLE randomExponentialProcess_ #-}+randomExponentialProcess_ mu =+  do t <- liftParameter $ randomExponential mu+     holdProcess t+         +-- | Hold the process for a random time interval having the Erlang distribution with+-- the specified scale (the reciprocal of the rate) and shape parameters.+randomErlangProcess :: MonadDES m+                       => Double+                       -- ^ the scale (the reciprocal of the rate)+                       -> Int+                       -- ^ the shape+                       -> Process m Double+                       -- ^ a computation of the time interval+                       -- for which the process was actually held+{-# INLINABLE randomErlangProcess #-}+randomErlangProcess beta m =+  do t <- liftParameter $ randomErlang beta m+     holdProcess t+     return t++-- | Hold the process for a random time interval having the Erlang distribution with+-- the specified scale (the reciprocal of the rate) and shape parameters.+randomErlangProcess_ :: MonadDES m+                        => Double+                        -- ^ the scale (the reciprocal of the rate)+                        -> Int+                        -- ^ the shape+                        -> Process m ()+{-# INLINABLE randomErlangProcess_ #-}+randomErlangProcess_ beta m =+  do t <- liftParameter $ randomErlang beta m+     holdProcess t++-- | Hold the process for a random time interval having the Poisson distribution with+-- the specified mean.+randomPoissonProcess :: MonadDES m+                        => Double+                        -- ^ the mean time interval+                        -> Process m Int+                        -- ^ a computation of the time interval+                        -- for which the process was actually held+{-# INLINABLE randomPoissonProcess #-}+randomPoissonProcess mu =+  do t <- liftParameter $ randomPoisson mu+     holdProcess $ fromIntegral t+     return t++-- | Hold the process for a random time interval having the Poisson distribution with+-- the specified mean.+randomPoissonProcess_ :: MonadDES m+                         => Double+                         -- ^ the mean time interval+                         -> Process m ()+{-# INLINABLE randomPoissonProcess_ #-}+randomPoissonProcess_ mu =+  do t <- liftParameter $ randomPoisson mu+     holdProcess $ fromIntegral t++-- | Hold the process for a random time interval having the binomial distribution+-- with the specified probability and trials.+randomBinomialProcess :: MonadDES m+                         => Double+                         -- ^ the probability+                         -> Int+                         -- ^ the number of trials+                         -> Process m Int+                         -- ^ a computation of the time interval+                         -- for which the process was actually held+{-# INLINABLE randomBinomialProcess #-}+randomBinomialProcess prob trials =+  do t <- liftParameter $ randomBinomial prob trials+     holdProcess $ fromIntegral t+     return t++-- | Hold the process for a random time interval having the binomial distribution+-- with the specified probability and trials.+randomBinomialProcess_ :: MonadDES m+                          =>Double+                          -- ^ the probability+                          -> Int+                          -- ^ the number of trials+                          -> Process m ()+{-# INLINABLE randomBinomialProcess_ #-}+randomBinomialProcess_ prob trials =+  do t <- liftParameter $ randomBinomial prob trials+     holdProcess $ fromIntegral t
Simulation/Aivika/Trans/Processor.hs view
@@ -3,11 +3,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Processor--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The processor of simulation data. --@@ -18,6 +18,7 @@         emptyProcessor,         arrProcessor,         accumProcessor,+        withinProcessor,         -- * Specifying Identifier         processorUsingId,         -- * Prefetch and Delay Processors@@ -41,6 +42,10 @@         processorPrioritisingInputOutputParallel,         -- * Arrival Processor         arrivalProcessor,+        -- * Utilities+        joinProcessor,+        -- * Failover+        failoverProcessor,         -- * Integrating with Signals         signalProcessor,         processorSignaling,@@ -50,7 +55,7 @@ import qualified Control.Category as C import Control.Arrow -import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Simulation import Simulation.Aivika.Trans.Dynamics import Simulation.Aivika.Trans.Event@@ -69,8 +74,10 @@  instance C.Category (Processor m) where +  {-# INLINE id #-}   id  = Processor id +  {-# INLINE (.) #-}   Processor x . Processor y = Processor (x . y)  -- The implementation is based on article@@ -80,51 +87,60 @@ -- while the pure streams were considered in the -- mentioned article.   -instance MonadComp m => Arrow (Processor m) where+instance MonadDES m => Arrow (Processor m) where +  {-# INLINABLE arr #-}   arr = Processor . mapStream +  {-# INLINABLE first #-}   first (Processor f) =     Processor $ \xys ->     Cons $     do (xs, ys) <- liftSimulation $ unzipStream xys        runStream $ zipStreamSeq (f xs) ys +  {-# INLINABLE second #-}   second (Processor f) =     Processor $ \xys ->     Cons $     do (xs, ys) <- liftSimulation $ unzipStream xys        runStream $ zipStreamSeq xs (f ys) +  {-# INLINABLE (***) #-}   Processor f *** Processor g =     Processor $ \xys ->     Cons $     do (xs, ys) <- liftSimulation $ unzipStream xys        runStream $ zipStreamSeq (f xs) (g ys) +  {-# INLINABLE (&&&) #-}   Processor f &&& Processor g =     Processor $ \xs -> zipStreamSeq (f xs) (g xs) -instance MonadComp m => ArrowChoice (Processor m) where+instance MonadDES m => ArrowChoice (Processor m) where +  {-# INLINABLE left #-}   left (Processor f) =     Processor $ \xs ->     Cons $     do ys <- liftSimulation $ memoStream xs        runStream $ replaceLeftStream ys (f $ leftStream ys) +  {-# INLINABLE right #-}   right (Processor f) =     Processor $ \xs ->     Cons $     do ys <- liftSimulation $ memoStream xs        runStream $ replaceRightStream ys (f $ rightStream ys) -instance MonadComp m => ArrowZero (Processor m) where+instance MonadDES m => ArrowZero (Processor m) where +  {-# INLINE zeroArrow #-}   zeroArrow = emptyProcessor -instance MonadComp m => ArrowPlus (Processor m) where+instance MonadDES m => ArrowPlus (Processor m) where +  {-# INLINABLE (<+>) #-}   (Processor f) <+> (Processor g) =     Processor $ \xs ->     Cons $@@ -132,16 +148,19 @@        runStream $ mergeStreams (f xs1) (g xs2)  -- | A processor that never finishes its work producing an 'emptyStream'.-emptyProcessor :: MonadComp m => Processor m a b+emptyProcessor :: MonadDES m => Processor m a b+{-# INLINABLE emptyProcessor #-} emptyProcessor = Processor $ const emptyStream  -- | Create a simple processor by the specified handling function -- that runs the discontinuous process for each input value to get the output.-arrProcessor :: MonadComp m => (a -> Process m b) -> Processor m a b+arrProcessor :: MonadDES m => (a -> Process m b) -> Processor m a b+{-# INLINABLE arrProcessor #-} arrProcessor = Processor . mapStreamM  -- | Accumulator that outputs a value determined by the supplied function.-accumProcessor :: MonadComp m => (acc -> a -> Process m (acc, b)) -> acc -> Processor m a b+accumProcessor :: MonadDES m => (acc -> a -> Process m (acc, b)) -> acc -> Processor m a b+{-# INLINABLE accumProcessor #-} accumProcessor f acc =   Processor $ \xs -> Cons $ loop xs acc where     loop xs acc =@@ -149,11 +168,20 @@          (acc', b) <- f acc a          return (b, Cons $ loop xs' acc')  +-- | Involve the computation with side effect when processing a stream of data.+withinProcessor :: MonadDES m => Process m () -> Processor m a a+{-# INLINABLE withinProcessor #-}+withinProcessor m =+  Processor $+  mapStreamM $ \a ->+  do { m; return a }+ -- | Create a processor that will use the specified process identifier. -- It can be useful to refer to the underlying 'Process' computation which -- can be passivated, interrupted, canceled and so on. See also the -- 'processUsingId' function for more details.-processorUsingId :: MonadComp m => ProcessId m -> Processor m a b -> Processor m a b+processorUsingId :: MonadDES m => ProcessId m -> Processor m a b -> Processor m a b+{-# INLINABLE processorUsingId #-} processorUsingId pid (Processor f) =   Processor $ Cons . processUsingId pid . runStream . f @@ -163,7 +191,7 @@ -- 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 :: (MonadComp m,+processorQueuedParallel :: (MonadDES m,                             EnqueueStrategy m si,                             EnqueueStrategy m so)                            => si@@ -174,6 +202,7 @@                            -- ^ the processors to parallelize                            -> Processor m a b                            -- ^ the parallelized processor+{-# INLINABLE processorQueuedParallel #-} processorQueuedParallel si so ps =   Processor $ \xs ->   Cons $@@ -185,7 +214,7 @@      runStream output  -- | Launches the specified processors in parallel using priorities for combining the output.-processorPrioritisingOutputParallel :: (MonadComp m,+processorPrioritisingOutputParallel :: (MonadDES m,                                         EnqueueStrategy m si,                                         PriorityQueueStrategy m so po)                                        => si@@ -196,6 +225,7 @@                                        -- ^ the processors to parallelize                                        -> Processor m a b                                        -- ^ the parallelized processor+{-# INLINABLE processorPrioritisingOutputParallel #-} processorPrioritisingOutputParallel si so ps =   Processor $ \xs ->   Cons $@@ -207,7 +237,7 @@      runStream output  -- | Launches the specified processors in parallel using priorities for consuming the intput.-processorPrioritisingInputParallel :: (MonadComp m,+processorPrioritisingInputParallel :: (MonadDES m,                                        PriorityQueueStrategy m si pi,                                        EnqueueStrategy m so)                                       => si@@ -219,6 +249,7 @@                                       -- to parallelize                                       -> Processor m a b                                       -- ^ the parallelized processor+{-# INLINABLE processorPrioritisingInputParallel #-} processorPrioritisingInputParallel si so ps =   Processor $ \xs ->   Cons $@@ -230,7 +261,7 @@  -- | Launches the specified processors in parallel using priorities for consuming -- the input and combining the output.-processorPrioritisingInputOutputParallel :: (MonadComp m,+processorPrioritisingInputOutputParallel :: (MonadDES m,                                              PriorityQueueStrategy m si pi,                                              PriorityQueueStrategy m so po)                                             => si@@ -242,6 +273,7 @@                                             -- to parallelize                                             -> Processor m a b                                             -- ^ the parallelized processor+{-# INLINABLE processorPrioritisingInputOutputParallel #-} processorPrioritisingInputOutputParallel si so ps =   Processor $ \xs ->   Cons $@@ -254,12 +286,14 @@ -- | 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 :: MonadComp m => [Processor m a b] -> Processor m a b+processorParallel :: MonadDES m => [Processor m a b] -> Processor m a b+{-# INLINABLE processorParallel #-} processorParallel = processorQueuedParallel FCFS FCFS  -- | Launches the processors sequentially using the 'prefetchProcessor' between them -- to model an autonomous work of each of the processors specified.-processorSeq :: MonadComp m => [Processor m a a] -> Processor m a a+processorSeq :: MonadDES m => [Processor m a a] -> Processor m a a+{-# INLINABLE processorSeq #-} processorSeq []  = emptyProcessor processorSeq [p] = p processorSeq (p : ps) = p >>> prefetchProcessor >>> processorSeq ps@@ -268,12 +302,13 @@ -- 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 :: MonadComp m+bufferProcessor :: MonadDES m                    => (Stream m a -> Process m ())                    -- ^ a separate process to consume the input                     -> Stream m b                    -- ^ the resulting stream of data                    -> Processor m a b+{-# INLINABLE bufferProcessor #-} bufferProcessor consume output =   Processor $ \xs ->   Cons $@@ -283,7 +318,7 @@ -- | Like 'bufferProcessor' but allows creating a loop when some items -- can be processed repeatedly. It is very useful for modeling the processors  -- with queues and loop-backs.-bufferProcessorLoop :: MonadComp m+bufferProcessorLoop :: MonadDES m                        => (Stream m a -> Stream m c -> Process m ())                        -- ^ consume two streams: the input values of type @a@                        -- and the values of type @c@ returned by the loop@@ -296,6 +331,7 @@                        -- ^ process in the loop and then return a value                        -- of type @c@ to the input again (this is a loop body)                        -> Processor m a b+{-# INLINABLE bufferProcessorLoop #-} bufferProcessorLoop consume preoutput cond body =   Processor $ \xs ->   Cons $@@ -327,7 +363,7 @@ -- 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 :: MonadComp m =>+queueProcessor :: MonadDES m =>                   (a -> Process m ())                   -- ^ enqueue the input item and wait                   -- while the queue is full if required@@ -336,6 +372,7 @@                   -- ^ dequeue an output item                   -> Processor m a b                   -- ^ the buffering processor+{-# INLINABLE queueProcessor #-} queueProcessor enqueue dequeue =   bufferProcessor   (consumeStream enqueue)@@ -344,7 +381,7 @@ -- | Like 'queueProcessor' creates a queue processor but with a loop when some items  -- can be processed and then added to the queue again. Also it allows specifying  -- how two input streams of data can be merged.-queueProcessorLoopMerging :: MonadComp m+queueProcessorLoopMerging :: MonadDES m                              => (Stream m a -> Stream m d -> Stream m e)                              -- ^ merge two streams: the input values of type @a@                              -- and the values of type @d@ returned by the loop@@ -362,6 +399,7 @@                              -- of type @d@ to the queue again (this is a loop body)                              -> Processor m a b                              -- ^ the buffering processor+{-# INLINABLE queueProcessorLoopMerging #-} queueProcessorLoopMerging merge enqueue dequeue =   bufferProcessorLoop   (\bs cs ->@@ -374,7 +412,7 @@ -- 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 :: MonadComp m+queueProcessorLoopSeq :: MonadDES m                          => (a -> Process m ())                          -- ^ enqueue the input item and wait                          -- while the queue is full if required@@ -389,6 +427,7 @@                          -- of type @a@ to the queue again (this is a loop body)                          -> Processor m a b                          -- ^ the buffering processor+{-# INLINABLE queueProcessorLoopSeq #-} queueProcessorLoopSeq =   queueProcessorLoopMerging mergeStreams @@ -396,7 +435,7 @@ -- some items can be processed and then 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 :: MonadComp m+queueProcessorLoopParallel :: MonadDES m                               => (a -> Process m ())                               -- ^ enqueue the input item and wait                               -- while the queue is full if required@@ -411,6 +450,7 @@                               -- of type @a@ to the queue again (this is a loop body)                               -> Processor m a b                               -- ^ the buffering processor+{-# INLINABLE queueProcessorLoopParallel #-} queueProcessorLoopParallel enqueue dequeue =   bufferProcessorLoop   (\bs cs ->@@ -427,7 +467,8 @@ -- You can think of this as the prefetched processor could place its latest  -- data item in some temporary space for later use, which is very useful  -- for modeling a sequence of separate and independent work places.-prefetchProcessor :: MonadComp m => Processor m a a+prefetchProcessor :: MonadDES m => Processor m a a+{-# INLINABLE prefetchProcessor #-} prefetchProcessor = Processor prefetchStream  -- | Convert the specified signal transform to a processor.@@ -441,7 +482,8 @@ -- The former is passive, while the latter is active. -- -- Cancel the processor's process to unsubscribe from the signals provided.-signalProcessor :: MonadComp m => (Signal m a -> Signal m b) -> Processor m a b+signalProcessor :: MonadDES m => (Signal m a -> Signal m b) -> Processor m a b+{-# INLINABLE signalProcessor #-} signalProcessor f =   Processor $ \xs ->   Cons $@@ -460,7 +502,8 @@ -- The former is passive, while the latter is active. -- -- Cancel the returned process to unsubscribe from the signal specified.-processorSignaling :: MonadComp m => Processor m a b -> Signal m a -> Process m (Signal m b)+processorSignaling :: MonadDES m => Processor m a b -> Signal m a -> Process m (Signal m b)+{-# INLINABLE processorSignaling #-} processorSignaling (Processor f) sa =   do xs <- signalStream sa      let ys = f xs@@ -468,15 +511,32 @@  -- | A processor that adds the information about the time points at which  -- the original stream items were received by demand.-arrivalProcessor :: MonadComp m => Processor m a (Arrival a)+arrivalProcessor :: MonadDES m => Processor m a (Arrival a)+{-# INLINABLE arrivalProcessor #-} arrivalProcessor = Processor arrivalStream  -- | A processor that delays the input stream by one step using the specified initial value.-delayProcessor :: MonadComp m => a -> Processor m a a+delayProcessor :: MonadDES m => a -> Processor m a a+{-# INLINABLE delayProcessor #-} delayProcessor a0 = Processor $ delayStream a0 +-- | Removes one level of the computation, projecting its bound processor into the outer level.+joinProcessor :: MonadDES m => Process m (Processor m a b) -> Processor m a b+{-# INLINABLE joinProcessor #-}+joinProcessor m =+  Processor $ \xs ->+  Cons $+  do Processor f <- m+     runStream $ f xs++-- | Takes the next processor from the list after the current processor fails because of cancelling the underlying process.+failoverProcessor :: MonadDES m => [Processor m a b] -> Processor m a b+{-# INLINABLE failoverProcessor #-}+failoverProcessor ps =+  Processor $ \xs -> failoverStream [runProcessor p xs | p <- ps]+ -- | Show the debug messages with the current simulation time.-traceProcessor :: MonadComp m+traceProcessor :: MonadDES m                   => Maybe String                   -- ^ the request message                   -> Maybe String@@ -484,5 +544,6 @@                   -> Processor m a b                   -- ^ a processor                   -> Processor m a b+{-# INLINABLE traceProcessor #-} traceProcessor request response (Processor f) =   Processor $ traceStream request response . f
+ Simulation/Aivika/Trans/Processor/Random.hs view
@@ -0,0 +1,118 @@++-- |+-- Module     : Simulation.Aivika.Trans.Processor.Random+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- This module defines some useful random processors that+-- hold the current process for the corresponding time interval,+-- when processing every input element.+--++module Simulation.Aivika.Trans.Processor.Random+       (randomUniformProcessor,+        randomUniformIntProcessor,+        randomNormalProcessor,+        randomExponentialProcessor,+        randomErlangProcessor,+        randomPoissonProcessor,+        randomBinomialProcessor) where++import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Process+import Simulation.Aivika.Trans.Process.Random+import Simulation.Aivika.Trans.Processor++-- | When processing every input element, hold the process+-- for a random time interval distributed uniformly.+randomUniformProcessor :: MonadDES m+                          => Double+                          -- ^ the minimum time interval+                          -> Double+                          -- ^ the maximum time interval+                          -> Processor m a a+{-# INLINABLE randomUniformProcessor #-}+randomUniformProcessor min max =+  withinProcessor $+  randomUniformProcess_ min max++-- | When processing every input element, hold the process+-- for a random time interval distributed uniformly.+randomUniformIntProcessor :: MonadDES m+                             => Int+                             -- ^ the minimum time interval+                             -> Int+                             -- ^ the maximum time interval+                             -> Processor m a a+{-# INLINABLE randomUniformIntProcessor #-}+randomUniformIntProcessor min max =+  withinProcessor $+  randomUniformIntProcess_ min max++-- | When processing every input element, hold the process+-- for a random time interval distributed normally.+randomNormalProcessor :: MonadDES m+                         => Double+                         -- ^ the mean time interval+                         -> Double+                         -- ^ the time interval deviation+                         -> Processor m a a+{-# INLINABLE randomNormalProcessor #-}+randomNormalProcessor mu nu =+  withinProcessor $+  randomNormalProcess_ mu nu+         +-- | When processing every input element, hold the process+-- for a random time interval distributed exponentially+-- with the specified mean (the reciprocal of the rate).+randomExponentialProcessor :: MonadDES m+                              => Double+                              -- ^ the mean time interval (the reciprocal of the rate)+                              -> Processor m a a+{-# INLINABLE randomExponentialProcessor #-}+randomExponentialProcessor mu =+  withinProcessor $+  randomExponentialProcess_ mu+         +-- | When processing every input element, hold the process+-- for a random time interval having the Erlang distribution with+-- the specified scale (the reciprocal of the rate) and shape parameters.+randomErlangProcessor :: MonadDES m+                         => Double+                         -- ^ the scale (the reciprocal of the rate)+                         -> Int+                         -- ^ the shape+                         -> Processor m a a+{-# INLINABLE randomErlangProcessor #-}+randomErlangProcessor beta m =+  withinProcessor $+  randomErlangProcess_ beta m++-- | When processing every input element, hold the process+-- for a random time interval having the Poisson distribution+-- with the specified mean.+randomPoissonProcessor :: MonadDES m+                          => Double+                          -- ^ the mean time interval+                          -> Processor m a a+{-# INLINABLE randomPoissonProcessor #-}+randomPoissonProcessor mu =+  withinProcessor $+  randomPoissonProcess_ mu++-- | When processing every input element, hold the process+-- for a random time interval having the binomial distribution+-- with the specified probability and trials.+randomBinomialProcessor :: MonadDES m+                           => Double+                           -- ^ the probability+                           -> Int+                           -- ^ the number of trials+                           -> Processor m a a+{-# INLINABLE randomBinomialProcessor #-}+randomBinomialProcessor prob trials =+  withinProcessor $+  randomBinomialProcess_ prob trials
Simulation/Aivika/Trans/Processor/RoundRobbin.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Processor.RoundRobbin--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The module defines the Round-Robbin processor. --@@ -15,7 +15,7 @@  import Control.Monad -import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Simulation import Simulation.Aivika.Trans.Event import Simulation.Aivika.Trans.Process@@ -26,7 +26,8 @@ -- | 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 :: MonadComp m => Processor m (Process m Double, Process m a) a+roundRobbinProcessor :: MonadDES m => Processor m (Process m Double, Process m a) a+{-# INLINABLE roundRobbinProcessor #-} roundRobbinProcessor =   Processor $   runProcessor roundRobbinProcessorUsingIds . mapStreamM f where@@ -38,7 +39,8 @@  -- | 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 :: MonadComp m => Processor m (Process m (Double, ProcessId m), Process m a) a+roundRobbinProcessorUsingIds :: MonadDES m => Processor m (Process m (Double, ProcessId m), Process m a) a+{-# INLINABLE roundRobbinProcessorUsingIds #-} roundRobbinProcessorUsingIds =   Processor $ \xs ->   Cons $
− Simulation/Aivika/Trans/ProtoArray.hs 
@@ -1,82 +0,0 @@--{-# LANGUAGE TypeFamilies #-}---- |--- Module     : Simulation.Aivika.Trans.ProtoArray--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.8.3------ It defines a prototype of all mutable arrays.----module Simulation.Aivika.Trans.ProtoArray-       (ProtoArrayMonad(..)) where--import Data.Array-import Data.Array.IO.Safe--import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef---- | A monad within which computation we can create and work with--- the prototype of mutable arrays.-class ProtoRefMonad m => ProtoArrayMonad m where-  -  -- | A prototype of mutable array.-  data ProtoArray m :: * -> *--  -- | Return the array size.-  protoArrayCount :: ProtoArray m a -> m Int--  -- | Create a new ptototype of mutable array by the specified session,-  -- size and initial value.-  newProtoArray :: Session m -> Int -> a -> m (ProtoArray m a)--  -- | Create a new ptototype of mutable array by the specified session-  -- and size with every element initialised to an undefined value.-  newProtoArray_ :: Session m -> Int -> m (ProtoArray m a)--  -- | Read an element from the mutable array.-  readProtoArray :: ProtoArray m a -> Int -> m a--  -- | Write the element in the mutable array.-  writeProtoArray :: ProtoArray m a -> Int -> a -> m ()--  -- | Return a list of the elements.-  protoArrayToList :: ProtoArray m a -> m [a]--  -- | Create an array by the specified list of elements.-  protoArrayFromList :: [a] -> m (ProtoArray m a)--  -- | Return the elements of the mutable array in an immutable array.-  freezeProtoArray :: ProtoArray m a -> m (Array Int a)--instance ProtoArrayMonad IO where--  newtype ProtoArray IO a = ProtoArray (IOArray Int a)--  {-# SPECIALISE INLINE protoArrayCount :: ProtoArray IO a -> IO Int #-}-  protoArrayCount (ProtoArray a) = do { (0, n') <- getBounds a; return $ n' + 1 }--  {-# SPECIALISE INLINE newProtoArray :: Session IO -> Int -> a -> IO (ProtoArray IO a) #-}-  newProtoArray s n a = fmap ProtoArray $ newArray (0, n - 1) a--  {-# SPECIALISE INLINE newProtoArray_ :: Session IO -> Int -> IO (ProtoArray IO a) #-}-  newProtoArray_ s n = fmap ProtoArray $ newArray_ (0, n - 1)--  {-# SPECIALISE INLINE readProtoArray :: ProtoArray IO a -> Int -> IO a #-}-  readProtoArray (ProtoArray a) = readArray a--  {-# SPECIALISE INLINE writeProtoArray :: ProtoArray IO a -> Int -> a -> IO () #-}-  writeProtoArray (ProtoArray a) = writeArray a--  {-# SPECIALISE INLINE protoArrayToList :: ProtoArray IO a -> IO [a] #-}-  protoArrayToList (ProtoArray a) = getElems a--  {-# SPECIALISE INLINE protoArrayFromList :: [a] -> IO (ProtoArray IO a) #-}-  protoArrayFromList xs = fmap ProtoArray $ newListArray (0, length xs - 1) xs--  {-# SPECIALISE INLINE freezeProtoArray :: ProtoArray IO a -> IO (Array Int a) #-}-  freezeProtoArray (ProtoArray a) = freeze a
− Simulation/Aivika/Trans/ProtoArray/Unboxed.hs 
@@ -1,98 +0,0 @@--{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}---- |--- Module     : Simulation.Aivika.Trans.ProtoArray.Unboxed--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.8.3------ It defines a prototype of all mutable unboxed arrays.----module Simulation.Aivika.Trans.ProtoArray.Unboxed-       (ProtoArrayMonad(..)) where--import Data.Array-import Data.Array.IO.Safe--import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef---- | A monad within which computation we can create and work with--- the prototype of mutable unboxed arrays.-class ProtoRefMonad m => ProtoArrayMonad m a where-  -  -- | A prototype of mutable unboxed array.-  data ProtoArray m :: * -> *--  -- | Return the array size.-  protoArrayCount :: ProtoArray m a -> m Int--  -- | Create a new ptototype of mutable array by the specified session,-  -- size and initial value.-  newProtoArray :: Session m -> Int -> a -> m (ProtoArray m a)--  -- | Create a new ptototype of mutable array by the specified session-  -- and size with every element initialised to an undefined value.-  newProtoArray_ :: Session m -> Int -> m (ProtoArray m a)--  -- | Read an element from the mutable array.-  readProtoArray :: ProtoArray m a -> Int -> m a--  -- | Write the element in the mutable array.-  writeProtoArray :: ProtoArray m a -> Int -> a -> m ()--  -- | Return a list of the elements.-  protoArrayToList :: ProtoArray m a -> m [a]--  -- | Create an array by the specified list of elements.-  protoArrayFromList :: [a] -> m (ProtoArray m a)--  -- | Return the elements of the mutable array in an immutable array.-  freezeProtoArray :: ProtoArray m a -> m (Array Int a)--instance MArray IOUArray a IO => ProtoArrayMonad IO a where--  newtype ProtoArray IO a = ProtoArray (IOUArray Int a)--  {-# SPECIALISE INLINE protoArrayCount :: MArray IOUArray Double IO => ProtoArray IO Double -> IO Int #-}-  {-# SPECIALISE INLINE protoArrayCount :: MArray IOUArray Float IO => ProtoArray IO Float -> IO Int #-}-  {-# SPECIALISE INLINE protoArrayCount :: MArray IOUArray Int IO => ProtoArray IO Int -> IO Int #-}-  protoArrayCount (ProtoArray a) = do { (0, n') <- getBounds a; return $ n' + 1 }--  {-# SPECIALISE INLINE newProtoArray :: MArray IOUArray Double IO => Session IO -> Int -> Double -> IO (ProtoArray IO Double) #-}-  {-# SPECIALISE INLINE newProtoArray :: MArray IOUArray Float IO => Session IO -> Int -> Float -> IO (ProtoArray IO Float) #-}-  {-# SPECIALISE INLINE newProtoArray :: MArray IOUArray Int IO => Session IO -> Int -> Int -> IO (ProtoArray IO Int) #-}-  newProtoArray s n a = fmap ProtoArray $ newArray (0, n - 1) a--  {-# SPECIALISE INLINE newProtoArray_ :: MArray IOUArray Double IO => Session IO -> Int -> IO (ProtoArray IO Double) #-}-  {-# SPECIALISE INLINE newProtoArray_ :: MArray IOUArray Float IO => Session IO -> Int -> IO (ProtoArray IO Float) #-}-  {-# SPECIALISE INLINE newProtoArray_ :: MArray IOUArray Int IO => Session IO -> Int -> IO (ProtoArray IO Int) #-}-  newProtoArray_ s n = fmap ProtoArray $ newArray_ (0, n - 1)--  {-# SPECIALISE INLINE readProtoArray :: MArray IOUArray Double IO => ProtoArray IO Double -> Int -> IO Double #-}-  {-# SPECIALISE INLINE readProtoArray :: MArray IOUArray Float IO => ProtoArray IO Float -> Int -> IO Float #-}-  {-# SPECIALISE INLINE readProtoArray :: MArray IOUArray Int IO => ProtoArray IO Int -> Int -> IO Int #-}-  readProtoArray (ProtoArray a) = readArray a--  {-# SPECIALISE INLINE writeProtoArray :: MArray IOUArray Double IO => ProtoArray IO Double -> Int -> Double -> IO () #-}-  {-# SPECIALISE INLINE writeProtoArray :: MArray IOUArray Float IO => ProtoArray IO Float -> Int -> Float -> IO () #-}-  {-# SPECIALISE INLINE writeProtoArray :: MArray IOUArray Int IO => ProtoArray IO Int -> Int -> Int -> IO () #-}-  writeProtoArray (ProtoArray a) = writeArray a--  {-# SPECIALISE INLINE protoArrayToList :: MArray IOUArray Double IO => ProtoArray IO Double -> IO [Double] #-}-  {-# SPECIALISE INLINE protoArrayToList :: MArray IOUArray Float IO => ProtoArray IO Float -> IO [Float] #-}-  {-# SPECIALISE INLINE protoArrayToList :: MArray IOUArray Int IO => ProtoArray IO Int -> IO [Int] #-}-  protoArrayToList (ProtoArray a) = getElems a--  {-# SPECIALISE INLINE protoArrayFromList :: MArray IOUArray Double IO => [Double] -> IO (ProtoArray IO Double) #-}-  {-# SPECIALISE INLINE protoArrayFromList :: MArray IOUArray Float IO => [Float] -> IO (ProtoArray IO Float) #-}-  {-# SPECIALISE INLINE protoArrayFromList :: MArray IOUArray Int IO => [Int] -> IO (ProtoArray IO Int) #-}-  protoArrayFromList xs = fmap ProtoArray $ newListArray (0, length xs - 1) xs--  {-# SPECIALISE INLINE freezeProtoArray :: MArray IOUArray Double IO => ProtoArray IO Double -> IO (Array Int Double) #-}-  {-# SPECIALISE INLINE freezeProtoArray :: MArray IOUArray Float IO => ProtoArray IO Float -> IO (Array Int Float) #-}-  {-# SPECIALISE INLINE freezeProtoArray :: MArray IOUArray Int IO => ProtoArray IO Int -> IO (Array Int Int) #-}-  freezeProtoArray (ProtoArray a) = freeze a
− Simulation/Aivika/Trans/ProtoRef.hs 
@@ -1,61 +0,0 @@--{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleInstances #-}---- |--- Module     : Simulation.Aivika.Trans.ProtoRef--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.8.3------ It defines a prototype of mutable references.----module Simulation.Aivika.Trans.ProtoRef-       (ProtoRefMonad(..),-        ProtoRef(..)) where--import Data.IORef--import Simulation.Aivika.Trans.Session---- | A monad within which computation we can create and work with--- the prototype of mutable reference.-class (Functor m, Monad m) => ProtoRefMonad m where-  -  -- | A prototype of mutable reference.-  data ProtoRef m :: * -> *--  -- | Create a new ptototype of mutable reference by the specified session and initial value.-  newProtoRef :: Session m -> a -> m (ProtoRef m a)--  -- | Read the contents of the prototype of mutable reference.-  readProtoRef :: ProtoRef m a -> m a--  -- | Write a new value in the prototype of mutable reference.-  writeProtoRef :: ProtoRef m a -> a -> m ()--  -- | Modify a value stored in the prototype of mutable reference.-  modifyProtoRef :: ProtoRef m a -> (a -> a) -> m ()--  -- | A strict version of 'modifyProtoRef'.-  modifyProtoRef' :: ProtoRef m a -> (a -> a) -> m ()--instance ProtoRefMonad IO where--  newtype ProtoRef IO a = ProtoRef (IORef a)--  {-# SPECIALIZE INLINE newProtoRef :: Session IO -> a -> IO (ProtoRef IO a) #-}-  newProtoRef session = fmap ProtoRef . newIORef--  {-# SPECIALIZE INLINE readProtoRef :: ProtoRef IO a -> IO a #-}-  readProtoRef (ProtoRef x) = readIORef x--  {-# SPECIALIZE INLINE writeProtoRef :: ProtoRef IO a -> a -> IO () #-}-  writeProtoRef (ProtoRef x) = writeIORef x--  {-# SPECIALIZE INLINE modifyProtoRef :: ProtoRef IO a -> (a -> a) -> IO () #-}-  modifyProtoRef (ProtoRef x) = modifyIORef x--  {-# SPECIALIZE INLINE modifyProtoRef' :: ProtoRef IO a -> (a -> a) -> IO () #-}-  modifyProtoRef' (ProtoRef x) = modifyIORef' x
Simulation/Aivika/Trans/Queue.hs view
@@ -3,11 +3,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Queue--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines a queue that can use the specified strategies. So, having only -- the 'FCFS', 'LCFS', 'SIRO' and 'StaticPriorities' strategies, you can build@@ -112,16 +112,14 @@ import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Parameter import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Dynamics import Simulation.Aivika.Trans.Internal.Event import Simulation.Aivika.Trans.Internal.Process-import Simulation.Aivika.Trans.Internal.Signal import Simulation.Aivika.Trans.Signal import Simulation.Aivika.Trans.Resource import Simulation.Aivika.Trans.QueueStrategy@@ -158,17 +156,17 @@           enqueueRes :: Resource m si,           queueStore :: StrategyQueue m sm (QueueItem a),           dequeueRes :: Resource m so,-          queueCountRef :: ProtoRef m Int,-          queueCountStatsRef :: ProtoRef m (TimingStats Int),-          enqueueCountRef :: ProtoRef m Int,-          enqueueLostCountRef :: ProtoRef m Int,-          enqueueStoreCountRef :: ProtoRef m Int,-          dequeueCountRef :: ProtoRef m Int,-          dequeueExtractCountRef :: ProtoRef m Int,-          queueWaitTimeRef :: ProtoRef m (SamplingStats Double),-          queueTotalWaitTimeRef :: ProtoRef m (SamplingStats Double),-          enqueueWaitTimeRef :: ProtoRef m (SamplingStats Double),-          dequeueWaitTimeRef :: ProtoRef m (SamplingStats Double),+          queueCountRef :: Ref m Int,+          queueCountStatsRef :: Ref m (TimingStats Int),+          enqueueCountRef :: Ref m Int,+          enqueueLostCountRef :: Ref m Int,+          enqueueStoreCountRef :: Ref m Int,+          dequeueCountRef :: Ref m Int,+          dequeueExtractCountRef :: Ref m Int,+          queueWaitTimeRef :: Ref m (SamplingStats Double),+          queueTotalWaitTimeRef :: Ref m (SamplingStats Double),+          enqueueWaitTimeRef :: Ref m (SamplingStats Double),+          dequeueWaitTimeRef :: Ref m (SamplingStats Double),           enqueueInitiatedSource :: SignalSource m a,           enqueueLostSource :: SignalSource m a,           enqueueStoredSource :: SignalSource m a,@@ -188,23 +186,27 @@             }    -- | Create a new FCFS queue with the specified capacity.  -newFCFSQueue :: MonadComp m => Int -> Event m (FCFSQueue m a)+newFCFSQueue :: MonadDES m => Int -> Event m (FCFSQueue m a)+{-# INLINABLE newFCFSQueue #-} newFCFSQueue = newQueue FCFS FCFS FCFS    -- | Create a new LCFS queue with the specified capacity.  -newLCFSQueue :: MonadComp m => Int -> Event m (LCFSQueue m a)  +newLCFSQueue :: MonadDES m => Int -> Event m (LCFSQueue m a)  +{-# INLINABLE newLCFSQueue #-} newLCFSQueue = newQueue FCFS LCFS FCFS    -- | Create a new SIRO queue with the specified capacity.  -newSIROQueue :: MonadComp m => Int -> Event m (SIROQueue m a)  +newSIROQueue :: (MonadDES m, QueueStrategy m SIRO) => Int -> Event m (SIROQueue m a)  +{-# INLINABLE newSIROQueue #-} newSIROQueue = newQueue FCFS SIRO FCFS    -- | Create a new priority queue with the specified capacity.  -newPriorityQueue :: MonadComp m => Int -> Event m (PriorityQueue m a)  +newPriorityQueue :: (MonadDES m, QueueStrategy m StaticPriorities) => Int -> Event m (PriorityQueue m a)  +{-# INLINABLE newPriorityQueue #-} newPriorityQueue = newQueue FCFS StaticPriorities FCFS    -- | Create a new queue with the specified strategies and capacity.  -newQueue :: (MonadComp m,+newQueue :: (MonadDES m,              QueueStrategy m si,              QueueStrategy m sm,              QueueStrategy m so) =>@@ -217,23 +219,23 @@             -> Int             -- ^ the queue capacity             -> Event m (Queue m si sm so a)  +{-# INLINABLE newQueue #-} newQueue si sm so count =   do t  <- liftDynamics time-     sn <- liftParameter simulationSession-     i  <- liftComp $ newProtoRef sn 0-     is <- liftComp $ newProtoRef sn $ returnTimingStats t 0-     ci <- liftComp $ newProtoRef sn 0-     cl <- liftComp $ newProtoRef sn 0-     cm <- liftComp $ newProtoRef sn 0-     cr <- liftComp $ newProtoRef sn 0-     co <- liftComp $ newProtoRef sn 0+     i  <- liftSimulation $ newRef 0+     is <- liftSimulation $ newRef $ returnTimingStats t 0+     ci <- liftSimulation $ newRef 0+     cl <- liftSimulation $ newRef 0+     cm <- liftSimulation $ newRef 0+     cr <- liftSimulation $ newRef 0+     co <- liftSimulation $ newRef 0      ri <- liftSimulation $ newResourceWithMaxCount si count (Just count)      qm <- liftSimulation $ newStrategyQueue sm      ro <- liftSimulation $ newResourceWithMaxCount so 0 (Just count)-     w  <- liftComp $ newProtoRef sn mempty-     wt <- liftComp $ newProtoRef sn mempty-     wi <- liftComp $ newProtoRef sn mempty-     wo <- liftComp $ newProtoRef sn mempty +     w  <- liftSimulation $ newRef mempty+     wt <- liftSimulation $ newRef mempty+     wi <- liftSimulation $ newRef mempty+     wo <- liftSimulation $ newRef mempty       s1 <- liftSimulation $ newSignalSource      s2 <- liftSimulation $ newSignalSource      s3 <- liftSimulation $ newSignalSource@@ -266,58 +268,68 @@ -- | Test whether the queue is empty. -- -- See also 'queueNullChanged' and 'queueNullChanged_'.-queueNull :: MonadComp m => Queue m si sm so a -> Event m Bool+queueNull :: MonadDES m => Queue m si sm so a -> Event m Bool+{-# INLINABLE queueNull #-} queueNull q =   Event $ \p ->-  do n <- readProtoRef (queueCountRef q)+  do n <- invokeEvent p $ readRef (queueCountRef q)      return (n == 0)    -- | Signal when the 'queueNull' property value has changed.-queueNullChanged :: MonadComp m => Queue m si sm so a -> Signal m Bool+queueNullChanged :: MonadDES m => Queue m si sm so a -> Signal m Bool+{-# INLINABLE queueNullChanged #-} queueNullChanged q =   mapSignalM (const $ queueNull q) (queueNullChanged_ q)    -- | Signal when the 'queueNull' property value has changed.-queueNullChanged_ :: MonadComp m => Queue m si sm so a -> Signal m ()+queueNullChanged_ :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE queueNullChanged_ #-} queueNullChanged_ = queueCountChanged_  -- | Test whether the queue is full. -- -- See also 'queueFullChanged' and 'queueFullChanged_'.-queueFull :: MonadComp m => Queue m si sm so a -> Event m Bool+queueFull :: MonadDES m => Queue m si sm so a -> Event m Bool+{-# INLINABLE queueFull #-} queueFull q =   Event $ \p ->-  do n <- readProtoRef (queueCountRef q)+  do n <- invokeEvent p $ readRef (queueCountRef q)      return (n == queueMaxCount q)    -- | Signal when the 'queueFull' property value has changed.-queueFullChanged :: MonadComp m => Queue m si sm so a -> Signal m Bool+queueFullChanged :: MonadDES m => Queue m si sm so a -> Signal m Bool+{-# INLINABLE queueFullChanged #-} queueFullChanged q =   mapSignalM (const $ queueFull q) (queueFullChanged_ q)    -- | Signal when the 'queueFull' property value has changed.-queueFullChanged_ :: MonadComp m => Queue m si sm so a -> Signal m ()+queueFullChanged_ :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE queueFullChanged_ #-} queueFullChanged_ = queueCountChanged_  -- | Return the current queue size. -- -- See also 'queueCountStats', 'queueCountChanged' and 'queueCountChanged_'.-queueCount :: MonadComp m => Queue m si sm so a -> Event m Int+queueCount :: MonadDES m => Queue m si sm so a -> Event m Int+{-# INLINABLE queueCount #-} queueCount q =-  Event $ \p -> readProtoRef (queueCountRef q)+  Event $ \p -> invokeEvent p $ readRef (queueCountRef q)  -- | Return the queue size statistics.-queueCountStats :: MonadComp m => Queue m si sm so a -> Event m (TimingStats Int)+queueCountStats :: MonadDES m => Queue m si sm so a -> Event m (TimingStats Int)+{-# INLINABLE queueCountStats #-} queueCountStats q =-  Event $ \p -> readProtoRef (queueCountStatsRef q)+  Event $ \p -> invokeEvent p $ readRef (queueCountStatsRef q)    -- | Signal when the 'queueCount' property value has changed.-queueCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int+queueCountChanged :: MonadDES m => Queue m si sm so a -> Signal m Int+{-# INLINABLE queueCountChanged #-} queueCountChanged q =   mapSignalM (const $ queueCount q) (queueCountChanged_ q)    -- | Signal when the 'queueCount' property value has changed.-queueCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m ()+queueCountChanged_ :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE queueCountChanged_ #-} queueCountChanged_ q =   mapSignal (const ()) (enqueueStored q) <>   mapSignal (const ()) (dequeueExtracted q)@@ -325,51 +337,60 @@ -- | Return the total number of input items that were enqueued. -- -- See also 'enqueueCountChanged' and 'enqueueCountChanged_'.-enqueueCount :: MonadComp m => Queue m si sm so a -> Event m Int+enqueueCount :: MonadDES m => Queue m si sm so a -> Event m Int+{-# INLINABLE enqueueCount #-} enqueueCount q =-  Event $ \p -> readProtoRef (enqueueCountRef q)+  Event $ \p -> invokeEvent p $ readRef (enqueueCountRef q)    -- | Signal when the 'enqueueCount' property value has changed.-enqueueCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int+enqueueCountChanged :: MonadDES m => Queue m si sm so a -> Signal m Int+{-# INLINABLE enqueueCountChanged #-} enqueueCountChanged q =   mapSignalM (const $ enqueueCount q) (enqueueCountChanged_ q)    -- | Signal when the 'enqueueCount' property value has changed.-enqueueCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m ()+enqueueCountChanged_ :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE enqueueCountChanged_ #-} enqueueCountChanged_ q =   mapSignal (const ()) (enqueueInitiated q)    -- | Return the number of lost items. -- -- See also 'enqueueLostCountChanged' and 'enqueueLostCountChanged_'.-enqueueLostCount :: MonadComp m => Queue m si sm so a -> Event m Int+enqueueLostCount :: MonadDES m => Queue m si sm so a -> Event m Int+{-# INLINABLE enqueueLostCount #-} enqueueLostCount q =-  Event $ \p -> readProtoRef (enqueueLostCountRef q)+  Event $ \p -> invokeEvent p $ readRef (enqueueLostCountRef q)    -- | Signal when the 'enqueueLostCount' property value has changed.-enqueueLostCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int+enqueueLostCountChanged :: MonadDES m => Queue m si sm so a -> Signal m Int+{-# INLINABLE enqueueLostCountChanged #-} enqueueLostCountChanged q =   mapSignalM (const $ enqueueLostCount q) (enqueueLostCountChanged_ q)    -- | Signal when the 'enqueueLostCount' property value has changed.-enqueueLostCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m ()+enqueueLostCountChanged_ :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE enqueueLostCountChanged_ #-} enqueueLostCountChanged_ q =   mapSignal (const ()) (enqueueLost q)        -- | Return the total number of input items that were stored. -- -- See also 'enqueueStoreCountChanged' and 'enqueueStoreCountChanged_'.-enqueueStoreCount :: MonadComp m => Queue m si sm so a -> Event m Int+enqueueStoreCount :: MonadDES m => Queue m si sm so a -> Event m Int+{-# INLINABLE enqueueStoreCount #-} enqueueStoreCount q =-  Event $ \p -> readProtoRef (enqueueStoreCountRef q)+  Event $ \p -> invokeEvent p $ readRef (enqueueStoreCountRef q)    -- | Signal when the 'enqueueStoreCount' property value has changed.-enqueueStoreCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int+enqueueStoreCountChanged :: MonadDES m => Queue m si sm so a -> Signal m Int+{-# INLINABLE enqueueStoreCountChanged #-} enqueueStoreCountChanged q =   mapSignalM (const $ enqueueStoreCount q) (enqueueStoreCountChanged_ q)    -- | Signal when the 'enqueueStoreCount' property value has changed.-enqueueStoreCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m ()+enqueueStoreCountChanged_ :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE enqueueStoreCountChanged_ #-} enqueueStoreCountChanged_ q =   mapSignal (const ()) (enqueueStored q)       @@ -378,74 +399,85 @@ -- without suspension. -- -- See also 'dequeueCountChanged' and 'dequeueCountChanged_'.-dequeueCount :: MonadComp m => Queue m si sm so a -> Event m Int+dequeueCount :: MonadDES m => Queue m si sm so a -> Event m Int+{-# INLINABLE dequeueCount #-} dequeueCount q =-  Event $ \p -> readProtoRef (dequeueCountRef q)+  Event $ \p -> invokeEvent p $ readRef (dequeueCountRef q)        -- | Signal when the 'dequeueCount' property value has changed.-dequeueCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int+dequeueCountChanged :: MonadDES m => Queue m si sm so a -> Signal m Int+{-# INLINABLE dequeueCountChanged #-} dequeueCountChanged q =   mapSignalM (const $ dequeueCount q) (dequeueCountChanged_ q)    -- | Signal when the 'dequeueCount' property value has changed.-dequeueCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m ()+dequeueCountChanged_ :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE dequeueCountChanged_ #-} dequeueCountChanged_ q =   mapSignal (const ()) (dequeueRequested q)        -- | Return the total number of output items that were actually dequeued. -- -- See also 'dequeueExtractCountChanged' and 'dequeueExtractCountChanged_'.-dequeueExtractCount :: MonadComp m => Queue m si sm so a -> Event m Int+dequeueExtractCount :: MonadDES m => Queue m si sm so a -> Event m Int+{-# INLINABLE dequeueExtractCount #-} dequeueExtractCount q =-  Event $ \p -> readProtoRef (dequeueExtractCountRef q)+  Event $ \p -> invokeEvent p $ readRef (dequeueExtractCountRef q)        -- | Signal when the 'dequeueExtractCount' property value has changed.-dequeueExtractCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int+dequeueExtractCountChanged :: MonadDES m => Queue m si sm so a -> Signal m Int+{-# INLINABLE dequeueExtractCountChanged #-} dequeueExtractCountChanged q =   mapSignalM (const $ dequeueExtractCount q) (dequeueExtractCountChanged_ q)    -- | Signal when the 'dequeueExtractCount' property value has changed.-dequeueExtractCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m ()+dequeueExtractCountChanged_ :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE dequeueExtractCountChanged_ #-} dequeueExtractCountChanged_ q =   mapSignal (const ()) (dequeueExtracted q)  -- | Return the load factor: the queue size divided by its maximum size. -- -- See also 'queueLoadFactorChanged' and 'queueLoadFactorChanged_'.-queueLoadFactor :: MonadComp m => Queue m si sm so a -> Event m Double+queueLoadFactor :: MonadDES m => Queue m si sm so a -> Event m Double+{-# INLINABLE queueLoadFactor #-} queueLoadFactor q =   Event $ \p ->-  do x <- readProtoRef (queueCountRef q)+  do x <- invokeEvent p $ readRef (queueCountRef q)      let y = queueMaxCount q      return (fromIntegral x / fromIntegral y)        -- | Signal when the 'queueLoadFactor' property value has changed.-queueLoadFactorChanged :: MonadComp m => Queue m si sm so a -> Signal m Double+queueLoadFactorChanged :: MonadDES m => Queue m si sm so a -> Signal m Double+{-# INLINABLE queueLoadFactorChanged #-} queueLoadFactorChanged q =   mapSignalM (const $ queueLoadFactor q) (queueLoadFactorChanged_ q)    -- | Signal when the 'queueLoadFactor' property value has changed.-queueLoadFactorChanged_ :: MonadComp m => Queue m si sm so a -> Signal m ()+queueLoadFactorChanged_ :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE queueLoadFactorChanged_ #-} 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.-enqueueRate :: MonadComp m => Queue m si sm so a -> Event m Double+enqueueRate :: MonadDES m => Queue m si sm so a -> Event m Double+{-# INLINABLE enqueueRate #-} enqueueRate q =   Event $ \p ->-  do x <- readProtoRef (enqueueCountRef q)+  do x <- invokeEvent p $ readRef (enqueueCountRef 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.-enqueueStoreRate :: MonadComp m => Queue m si sm so a -> Event m Double+enqueueStoreRate :: MonadDES m => Queue m si sm so a -> Event m Double+{-# INLINABLE enqueueStoreRate #-} enqueueStoreRate q =   Event $ \p ->-  do x <- readProtoRef (enqueueStoreCountRef q)+  do x <- invokeEvent p $ readRef (enqueueStoreCountRef q)      let t0 = spcStartTime $ pointSpecs p          t  = pointTime p      return (fromIntegral x / (t - t0))@@ -453,20 +485,22 @@ -- | Return the rate of the requests for dequeueing the items: how many requests -- per time. It does not include the failed attempts to dequeue immediately -- without suspension.-dequeueRate :: MonadComp m => Queue m si sm so a -> Event m Double+dequeueRate :: MonadDES m => Queue m si sm so a -> Event m Double+{-# INLINABLE dequeueRate #-} dequeueRate q =   Event $ \p ->-  do x <- readProtoRef (dequeueCountRef q)+  do x <- invokeEvent p $ readRef (dequeueCountRef q)      let t0 = spcStartTime $ pointSpecs p          t  = pointTime p      return (fromIntegral x / (t - t0))        -- | Return the rate of the output items that were actually dequeued: how many items -- per time.-dequeueExtractRate :: MonadComp m => Queue m si sm so a -> Event m Double+dequeueExtractRate :: MonadDES m => Queue m si sm so a -> Event m Double+{-# INLINABLE dequeueExtractRate #-} dequeueExtractRate q =   Event $ \p ->-  do x <- readProtoRef (dequeueExtractCountRef q)+  do x <- invokeEvent p $ readRef (dequeueExtractCountRef q)      let t0 = spcStartTime $ pointSpecs p          t  = pointTime p      return (fromIntegral x / (t - t0))@@ -475,37 +509,43 @@ -- the time at which it was dequeued. -- -- See also 'queueWaitTimeChanged' and 'queueWaitTimeChanged_'.-queueWaitTime :: MonadComp m => Queue m si sm so a -> Event m (SamplingStats Double)+queueWaitTime :: MonadDES m => Queue m si sm so a -> Event m (SamplingStats Double)+{-# INLINABLE queueWaitTime #-} queueWaitTime q =-  Event $ \p -> readProtoRef (queueWaitTimeRef q)+  Event $ \p -> invokeEvent p $ readRef (queueWaitTimeRef q)        -- | Signal when the 'queueWaitTime' property value has changed.-queueWaitTimeChanged :: MonadComp m => Queue m si sm so a -> Signal m (SamplingStats Double)+queueWaitTimeChanged :: MonadDES m => Queue m si sm so a -> Signal m (SamplingStats Double)+{-# INLINABLE queueWaitTimeChanged #-} queueWaitTimeChanged q =   mapSignalM (const $ queueWaitTime q) (queueWaitTimeChanged_ q)    -- | Signal when the 'queueWaitTime' property value has changed.-queueWaitTimeChanged_ :: MonadComp m => Queue m si sm so a -> Signal m ()+queueWaitTimeChanged_ :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE queueWaitTimeChanged_ #-} 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@.+-- In some sense, @queueTotalWaitTime == enqueueWaitTime + queueWaitTime@. -- -- See also 'queueTotalWaitTimeChanged' and 'queueTotalWaitTimeChanged_'.-queueTotalWaitTime :: MonadComp m => Queue m si sm so a -> Event m (SamplingStats Double)+queueTotalWaitTime :: MonadDES m => Queue m si sm so a -> Event m (SamplingStats Double)+{-# INLINABLE queueTotalWaitTime #-} queueTotalWaitTime q =-  Event $ \p -> readProtoRef (queueTotalWaitTimeRef q)+  Event $ \p -> invokeEvent p $ readRef (queueTotalWaitTimeRef q)        -- | Signal when the 'queueTotalWaitTime' property value has changed.-queueTotalWaitTimeChanged :: MonadComp m => Queue m si sm so a -> Signal m (SamplingStats Double)+queueTotalWaitTimeChanged :: MonadDES m => Queue m si sm so a -> Signal m (SamplingStats Double)+{-# INLINABLE queueTotalWaitTimeChanged #-} queueTotalWaitTimeChanged q =   mapSignalM (const $ queueTotalWaitTime q) (queueTotalWaitTimeChanged_ q)    -- | Signal when the 'queueTotalWaitTime' property value has changed.-queueTotalWaitTimeChanged_ :: MonadComp m => Queue m si sm so a -> Signal m ()+queueTotalWaitTimeChanged_ :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE queueTotalWaitTimeChanged_ #-} queueTotalWaitTimeChanged_ q =   mapSignal (const ()) (dequeueExtracted q)       @@ -513,17 +553,20 @@ -- was initiated to the time at which the item was stored in the queue. -- -- See also 'enqueueWaitTimeChanged' and 'enqueueWaitTimeChanged_'.-enqueueWaitTime :: MonadComp m => Queue m si sm so a -> Event m (SamplingStats Double)+enqueueWaitTime :: MonadDES m => Queue m si sm so a -> Event m (SamplingStats Double)+{-# INLINABLE enqueueWaitTime #-} enqueueWaitTime q =-  Event $ \p -> readProtoRef (enqueueWaitTimeRef q)+  Event $ \p -> invokeEvent p $ readRef (enqueueWaitTimeRef q)        -- | Signal when the 'enqueueWaitTime' property value has changed.-enqueueWaitTimeChanged :: MonadComp m => Queue m si sm so a -> Signal m (SamplingStats Double)+enqueueWaitTimeChanged :: MonadDES m => Queue m si sm so a -> Signal m (SamplingStats Double)+{-# INLINABLE enqueueWaitTimeChanged #-} enqueueWaitTimeChanged q =   mapSignalM (const $ enqueueWaitTime q) (enqueueWaitTimeChanged_ q)    -- | Signal when the 'enqueueWaitTime' property value has changed.-enqueueWaitTimeChanged_ :: MonadComp m => Queue m si sm so a -> Signal m ()+enqueueWaitTimeChanged_ :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE enqueueWaitTimeChanged_ #-} enqueueWaitTimeChanged_ q =   mapSignal (const ()) (enqueueStored q)       @@ -531,17 +574,20 @@ -- for dequeueing to the time at which it was actually dequeued. -- -- See also 'dequeueWaitTimeChanged' and 'dequeueWaitTimeChanged_'.-dequeueWaitTime :: MonadComp m => Queue m si sm so a -> Event m (SamplingStats Double)+dequeueWaitTime :: MonadDES m => Queue m si sm so a -> Event m (SamplingStats Double)+{-# INLINABLE dequeueWaitTime #-} dequeueWaitTime q =-  Event $ \p -> readProtoRef (dequeueWaitTimeRef q)+  Event $ \p -> invokeEvent p $ readRef (dequeueWaitTimeRef q)        -- | Signal when the 'dequeueWaitTime' property value has changed.-dequeueWaitTimeChanged :: MonadComp m => Queue m si sm so a -> Signal m (SamplingStats Double)+dequeueWaitTimeChanged :: MonadDES m => Queue m si sm so a -> Signal m (SamplingStats Double)+{-# INLINABLE dequeueWaitTimeChanged #-} dequeueWaitTimeChanged q =   mapSignalM (const $ dequeueWaitTime q) (dequeueWaitTimeChanged_ q)    -- | Signal when the 'dequeueWaitTime' property value has changed.-dequeueWaitTimeChanged_ :: MonadComp m => Queue m si sm so a -> Signal m ()+dequeueWaitTimeChanged_ :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE dequeueWaitTimeChanged_ #-} dequeueWaitTimeChanged_ q =   mapSignal (const ()) (dequeueExtracted q) @@ -552,26 +598,29 @@ -- finite and new arrivals may be locked while the queue remains full. -- -- See also 'queueRateChanged' and 'queueRateChanged_'.-queueRate :: MonadComp m => Queue m si sm so a -> Event m Double+queueRate :: MonadDES m => Queue m si sm so a -> Event m Double+{-# INLINABLE queueRate #-} queueRate q =   Event $ \p ->-  do x <- readProtoRef (queueCountStatsRef q)-     y <- readProtoRef (queueWaitTimeRef q)+  do x <- invokeEvent p $ readRef (queueCountStatsRef q)+     y <- invokeEvent p $ readRef (queueWaitTimeRef q)      return (timingStatsMean x / samplingStatsMean y)         -- | Signal when the 'queueRate' property value has changed.-queueRateChanged :: MonadComp m => Queue m si sm so a -> Signal m Double+queueRateChanged :: MonadDES m => Queue m si sm so a -> Signal m Double+{-# INLINABLE queueRateChanged #-} queueRateChanged q =   mapSignalM (const $ queueRate q) (queueRateChanged_ q)        -- | Signal when the 'queueRate' property value has changed.-queueRateChanged_ :: MonadComp m => Queue m si sm so a -> Signal m ()+queueRateChanged_ :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE queueRateChanged_ #-} queueRateChanged_ q =   mapSignal (const ()) (enqueueStored q) <>   mapSignal (const ()) (dequeueExtracted q)  -- | Dequeue suspending the process if the queue is empty.-dequeue :: (MonadComp m,+dequeue :: (MonadDES m,             DequeueStrategy m si,             DequeueStrategy m sm,             EnqueueStrategy m so)@@ -579,13 +628,14 @@            -- ^ the queue            -> Process m a            -- ^ the dequeued value+{-# INLINABLE dequeue #-} dequeue q =   do t <- liftEvent $ dequeueRequest q      requestResource (dequeueRes q)      liftEvent $ dequeueExtract q t    -- | Dequeue with the output priority suspending the process if the queue is empty.-dequeueWithOutputPriority :: (MonadComp m,+dequeueWithOutputPriority :: (MonadDES m,                               DequeueStrategy m si,                               DequeueStrategy m sm,                               PriorityQueueStrategy m so po)@@ -595,19 +645,21 @@                              -- ^ the priority for output                              -> Process m a                              -- ^ the dequeued value+{-# INLINABLE dequeueWithOutputPriority #-} dequeueWithOutputPriority q po =   do t <- liftEvent $ dequeueRequest q      requestResourceWithPriority (dequeueRes q) po      liftEvent $ dequeueExtract q t    -- | Try to dequeue immediately.-tryDequeue :: (MonadComp m,+tryDequeue :: (MonadDES m,                DequeueStrategy m si,                DequeueStrategy m sm)               => Queue m si sm so a               -- ^ the queue               -> Event m (Maybe a)               -- ^ the dequeued value of 'Nothing'+{-# INLINABLE tryDequeue #-} tryDequeue q =   do x <- tryRequestResourceWithinEvent (dequeueRes q)      if x @@ -616,7 +668,7 @@        else return Nothing  -- | Enqueue the item suspending the process if the queue is full.  -enqueue :: (MonadComp m,+enqueue :: (MonadDES m,             EnqueueStrategy m si,             EnqueueStrategy m sm,             DequeueStrategy m so)@@ -625,13 +677,14 @@            -> a            -- ^ the item to enqueue            -> Process m ()+{-# INLINABLE enqueue #-} enqueue q a =   do i <- liftEvent $ enqueueInitiate q a      requestResource (enqueueRes q)      liftEvent $ enqueueStore q i       -- | Enqueue with the input priority the item suspending the process if the queue is full.  -enqueueWithInputPriority :: (MonadComp m,+enqueueWithInputPriority :: (MonadDES m,                              PriorityQueueStrategy m si pi,                              EnqueueStrategy m sm,                              DequeueStrategy m so)@@ -642,13 +695,14 @@                             -> a                             -- ^ the item to enqueue                             -> Process m ()+{-# INLINABLE enqueueWithInputPriority #-} enqueueWithInputPriority q pi a =   do i <- liftEvent $ enqueueInitiate q a      requestResourceWithPriority (enqueueRes q) pi      liftEvent $ enqueueStore q i       -- | Enqueue with the storing priority the item suspending the process if the queue is full.  -enqueueWithStoringPriority :: (MonadComp m,+enqueueWithStoringPriority :: (MonadDES m,                                EnqueueStrategy m si,                                PriorityQueueStrategy m sm pm,                                DequeueStrategy m so)@@ -659,13 +713,14 @@                               -> a                               -- ^ the item to enqueue                               -> Process m ()+{-# INLINABLE enqueueWithStoringPriority #-} enqueueWithStoringPriority q pm a =   do i <- liftEvent $ enqueueInitiate q a      requestResource (enqueueRes q)      liftEvent $ enqueueStoreWithPriority q pm i       -- | Enqueue with the input and storing priorities the item suspending the process if the queue is full.  -enqueueWithInputStoringPriorities :: (MonadComp m,+enqueueWithInputStoringPriorities :: (MonadDES m,                                       PriorityQueueStrategy m si pi,                                       PriorityQueueStrategy m sm pm,                                       DequeueStrategy m so)@@ -678,13 +733,14 @@                                      -> a                                      -- ^ the item to enqueue                                      -> Process m ()+{-# INLINABLE enqueueWithInputStoringPriorities #-} enqueueWithInputStoringPriorities q pi pm a =   do i <- liftEvent $ enqueueInitiate q a      requestResourceWithPriority (enqueueRes q) pi      liftEvent $ enqueueStoreWithPriority q pm i       -- | Try to enqueue the item. Return 'False' in the monad if the queue is full.-tryEnqueue :: (MonadComp m,+tryEnqueue :: (MonadDES m,                EnqueueStrategy m sm,                DequeueStrategy m so)               => Queue m si sm so a@@ -692,6 +748,7 @@               -> a               -- ^ the item which we try to enqueue               -> Event m Bool+{-# INLINABLE tryEnqueue #-} tryEnqueue q a =   do x <- tryRequestResourceWithinEvent (enqueueRes q)      if x @@ -701,7 +758,7 @@  -- | Try to enqueue with the storing priority the item. Return 'False' in -- the monad if the queue is full.-tryEnqueueWithStoringPriority :: (MonadComp m,+tryEnqueueWithStoringPriority :: (MonadDES m,                                   PriorityQueueStrategy m sm pm,                                   DequeueStrategy m so)                                  => Queue m si sm so a@@ -711,6 +768,7 @@                                  -> a                                  -- ^ the item which we try to enqueue                                  -> Event m Bool+{-# INLINABLE tryEnqueueWithStoringPriority #-} tryEnqueueWithStoringPriority q pm a =   do x <- tryRequestResourceWithinEvent (enqueueRes q)      if x @@ -720,7 +778,7 @@  -- | Try to enqueue the item. If the queue is full then the item will be lost -- and 'False' will be returned.-enqueueOrLost :: (MonadComp m,+enqueueOrLost :: (MonadDES m,                   EnqueueStrategy m sm,                   DequeueStrategy m so)                  => Queue m si sm so a@@ -728,6 +786,7 @@                  -> a                  -- ^ the item which we try to enqueue                  -> Event m Bool+{-# INLINABLE enqueueOrLost #-} enqueueOrLost q a =   do x <- tryRequestResourceWithinEvent (enqueueRes q)      if x@@ -738,7 +797,7 @@  -- | 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 :: (MonadComp m,+enqueueWithStoringPriorityOrLost :: (MonadDES m,                                      PriorityQueueStrategy m sm pm,                                      DequeueStrategy m so)                                     => Queue m si sm so a@@ -748,6 +807,7 @@                                     -> a                                     -- ^ the item which we try to enqueue                                     -> Event m Bool+{-# INLINABLE enqueueWithStoringPriorityOrLost #-} enqueueWithStoringPriorityOrLost q pm a =   do x <- tryRequestResourceWithinEvent (enqueueRes q)      if x@@ -757,7 +817,7 @@                return False  -- | Try to enqueue the item. If the queue is full then the item will be lost.-enqueueOrLost_ :: (MonadComp m,+enqueueOrLost_ :: (MonadDES m,                    EnqueueStrategy m sm,                    DequeueStrategy m so)                   => Queue m si sm so a@@ -765,13 +825,14 @@                   -> a                   -- ^ the item which we try to enqueue                   -> Event m ()+{-# INLINABLE enqueueOrLost_ #-} enqueueOrLost_ q a =   do x <- enqueueOrLost q a      return ()  -- | Try to enqueue with the storing priority the item. If the queue is full -- then the item will be lost.-enqueueWithStoringPriorityOrLost_ :: (MonadComp m,+enqueueWithStoringPriorityOrLost_ :: (MonadDES m,                                       PriorityQueueStrategy m sm pm,                                       DequeueStrategy m so)                                      => Queue m si sm so a@@ -781,17 +842,20 @@                                      -> a                                      -- ^ the item which we try to enqueue                                      -> Event m ()+{-# INLINABLE enqueueWithStoringPriorityOrLost_ #-} enqueueWithStoringPriorityOrLost_ q pm a =   do x <- enqueueWithStoringPriorityOrLost q pm a      return ()  -- | Return a signal that notifies when the enqueuing operation is initiated.-enqueueInitiated :: MonadComp m => Queue m si sm so a -> Signal m a+enqueueInitiated :: MonadDES m => Queue m si sm so a -> Signal m a+{-# INLINABLE enqueueInitiated #-} 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 :: MonadComp m => Queue m si sm so a -> Signal m a+enqueueStored :: MonadDES m => Queue m si sm so a -> Signal m a+{-# INLINABLE enqueueStored #-} enqueueStored q = publishSignal (enqueueStoredSource q)  -- | Return a signal which notifies that the item was lost when @@ -805,30 +869,35 @@ -- 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 :: MonadComp m => Queue m si sm so a -> Signal m a+enqueueLost :: MonadDES m => Queue m si sm so a -> Signal m a+{-# INLINABLE enqueueLost #-} enqueueLost q = publishSignal (enqueueLostSource q)  -- | Return a signal that notifies when the dequeuing operation was requested.-dequeueRequested :: MonadComp m => Queue m si sm so a -> Signal m ()+dequeueRequested :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE dequeueRequested #-} 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 :: MonadComp m => Queue m si sm so a -> Signal m a+dequeueExtracted :: MonadDES m => Queue m si sm so a -> Signal m a+{-# INLINABLE dequeueExtracted #-} dequeueExtracted q = publishSignal (dequeueExtractedSource q)  -- | Initiate the process of enqueuing the item.-enqueueInitiate :: MonadComp m+enqueueInitiate :: MonadDES m                    => Queue m si sm so a                    -- ^ the queue                    -> a                    -- ^ the item to be enqueued                    -> Event m (QueueItem a)+{-# INLINE enqueueInitiate #-} enqueueInitiate q a =   Event $ \p ->   do let t = pointTime p-     modifyProtoRef' (enqueueCountRef q) (+ 1)      invokeEvent p $+       modifyRef (enqueueCountRef q) (+ 1)+     invokeEvent p $        triggerSignal (enqueueInitiatedSource q) a      return QueueItem { itemValue = a,                         itemInputTime = t,@@ -836,7 +905,7 @@                       }  -- | Store the item.-enqueueStore :: (MonadComp m,+enqueueStore :: (MonadDES m,                  EnqueueStrategy m sm,                  DequeueStrategy m so)                 => Queue m si sm so a@@ -844,18 +913,23 @@                 -> QueueItem a                 -- ^ the item to be stored                 -> Event m ()+{-# INLINE enqueueStore #-} enqueueStore q i =   Event $ \p ->   do let i' = i { itemStoringTime = pointTime p }  -- now we have the actual time of storing      invokeEvent p $        strategyEnqueue (queueStore q) i'-     c <- readProtoRef (queueCountRef q)+     c <- invokeEvent p $+          readRef (queueCountRef q)      let c' = c + 1          t  = pointTime p -     c' `seq` writeProtoRef (queueCountRef q) c'-     modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c')-     modifyProtoRef' (enqueueStoreCountRef q) (+ 1)+     c' `seq` invokeEvent p $+       writeRef (queueCountRef q) c'      invokeEvent p $+       modifyRef (queueCountStatsRef q) (addTimingStats t c')+     invokeEvent p $+       modifyRef (enqueueStoreCountRef q) (+ 1)+     invokeEvent p $        enqueueStat q i'      invokeEvent p $        releaseResourceWithinEvent (dequeueRes q)@@ -863,7 +937,7 @@        triggerSignal (enqueueStoredSource q) (itemValue i')  -- | Store with the priority the item.-enqueueStoreWithPriority :: (MonadComp m,+enqueueStoreWithPriority :: (MonadDES m,                              PriorityQueueStrategy m sm pm,                              DequeueStrategy m so)                             => Queue m si sm so a@@ -873,18 +947,23 @@                             -> QueueItem a                             -- ^ the item to be enqueued                             -> Event m ()+{-# INLINE enqueueStoreWithPriority #-} enqueueStoreWithPriority q pm i =   Event $ \p ->   do let i' = i { itemStoringTime = pointTime p }  -- now we have the actual time of storing      invokeEvent p $        strategyEnqueueWithPriority (queueStore q) pm i'-     c <- readProtoRef (queueCountRef q)+     c <- invokeEvent p $+          readRef (queueCountRef q)      let c' = c + 1          t  = pointTime p-     c' `seq` writeProtoRef (queueCountRef q) c'-     modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c')-     modifyProtoRef' (enqueueStoreCountRef q) (+ 1)+     c' `seq` invokeEvent p $+       writeRef (queueCountRef q) c'      invokeEvent p $+       modifyRef (queueCountStatsRef q) (addTimingStats t c')+     invokeEvent p $+       modifyRef (enqueueStoreCountRef q) (+ 1)+     invokeEvent p $        enqueueStat q i'      invokeEvent p $        releaseResourceWithinEvent (dequeueRes q)@@ -892,48 +971,54 @@        triggerSignal (enqueueStoredSource q) (itemValue i')  -- | Deny the enqueuing.-enqueueDeny :: MonadComp m+enqueueDeny :: MonadDES m                => Queue m si sm so a                -- ^ the queue                -> a                -- ^ the item to be denied                -> Event m ()+{-# INLINE enqueueDeny #-} enqueueDeny q a =   Event $ \p ->-  do modifyProtoRef' (enqueueLostCountRef q) $ (+) 1+  do invokeEvent p $+       modifyRef (enqueueLostCountRef q) $ (+) 1      invokeEvent p $        triggerSignal (enqueueLostSource q) a  -- | Update the statistics for the input wait time of the enqueuing operation.-enqueueStat :: MonadComp m+enqueueStat :: MonadDES m                => Queue m si sm so a                -- ^ the queue                -> QueueItem a                -- ^ the item and its input time                -> Event m ()                -- ^ the action of updating the statistics+{-# INLINE enqueueStat #-} enqueueStat q i =   Event $ \p ->   do let t0 = itemInputTime i          t1 = itemStoringTime i-     modifyProtoRef' (enqueueWaitTimeRef q) $+     invokeEvent p $+       modifyRef (enqueueWaitTimeRef q) $        addSamplingStats (t1 - t0)  -- | Accept the dequeuing request and return the current simulation time.-dequeueRequest :: MonadComp m+dequeueRequest :: MonadDES m                   => Queue m si sm so a                   -- ^ the queue                   -> Event m Double                   -- ^ the current time+{-# INLINE dequeueRequest #-} dequeueRequest q =   Event $ \p ->-  do modifyProtoRef' (dequeueCountRef q) (+ 1)+  do invokeEvent p $+       modifyRef (dequeueCountRef q) (+ 1)      invokeEvent p $        triggerSignal (dequeueRequestedSource q) ()      return $ pointTime p   -- | Extract an item for the dequeuing request.  -dequeueExtract :: (MonadComp m,+dequeueExtract :: (MonadDES m,                    DequeueStrategy m si,                    DequeueStrategy m sm)                   => Queue m si sm so a@@ -942,17 +1027,22 @@                   -- ^ the time of the dequeuing request                   -> Event m a                   -- ^ the dequeued value+{-# INLINE dequeueExtract #-} dequeueExtract q t' =   Event $ \p ->   do i <- invokeEvent p $           strategyDequeue (queueStore q)-     c <- readProtoRef (queueCountRef q)+     c <- invokeEvent p $+          readRef (queueCountRef q)      let c' = c - 1          t  = pointTime p-     c' `seq` writeProtoRef (queueCountRef q) c'-     modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c')-     modifyProtoRef' (dequeueExtractCountRef q) (+ 1)+     c' `seq` invokeEvent p $+       writeRef (queueCountRef q) c'      invokeEvent p $+       modifyRef (queueCountStatsRef q) (addTimingStats t c')+     invokeEvent p $+       modifyRef (dequeueExtractCountRef q) (+ 1)+     invokeEvent p $        dequeueStat q t' i      invokeEvent p $        releaseResourceWithinEvent (enqueueRes q)@@ -962,7 +1052,7 @@  -- | Update the statistics for the output wait time of the dequeuing operation -- and the wait time of storing in the queue.-dequeueStat :: MonadComp m+dequeueStat :: MonadDES m                => Queue m si sm so a                -- ^ the queue                -> Double@@ -971,20 +1061,25 @@                -- ^ the item and its input time                -> Event m ()                -- ^ the action of updating the statistics+{-# INLINE dequeueStat #-} dequeueStat q t' i =   Event $ \p ->   do let t0 = itemInputTime i          t1 = itemStoringTime i          t  = pointTime p-     modifyProtoRef' (dequeueWaitTimeRef q) $+     invokeEvent p $+       modifyRef (dequeueWaitTimeRef q) $        addSamplingStats (t - t')-     modifyProtoRef' (queueTotalWaitTimeRef q) $+     invokeEvent p $+       modifyRef (queueTotalWaitTimeRef q) $        addSamplingStats (t - t0)-     modifyProtoRef' (queueWaitTimeRef q) $+     invokeEvent p $+       modifyRef (queueWaitTimeRef q) $        addSamplingStats (t - t1)  -- | Wait while the queue is full.-waitWhileFullQueue :: MonadComp m => Queue m si sm so a -> Process m ()+waitWhileFullQueue :: MonadDES m => Queue m si sm so a -> Process m ()+{-# INLINABLE waitWhileFullQueue #-} waitWhileFullQueue q =   do x <- liftEvent (queueFull q)      when x $@@ -997,7 +1092,8 @@ -- 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_ :: MonadComp m => Queue m si sm so a -> Signal m ()+queueChanged_ :: MonadDES m => Queue m si sm so a -> Signal m ()+{-# INLINABLE queueChanged_ #-} queueChanged_ q =   mapSignal (const ()) (enqueueInitiated q) <>   mapSignal (const ()) (enqueueStored q) <>@@ -1007,7 +1103,8 @@  -- | Return the summary for the queue with desciption of its -- properties and activities using the specified indent.-queueSummary :: (MonadComp m, Show si, Show sm, Show so) => Queue m si sm so a -> Int -> Event m ShowS+queueSummary :: (MonadDES m, Show si, Show sm, Show so) => Queue m si sm so a -> Int -> Event m ShowS+{-# INLINABLE queueSummary #-} queueSummary q indent =   do let si = enqueueStrategy q          sm = enqueueStoringStrategy q
Simulation/Aivika/Trans/Queue/Infinite.hs view
@@ -3,11 +3,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Queue.Infinite--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines an infinite queue that can use the specified strategies. --@@ -76,16 +76,14 @@ import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Parameter import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Dynamics import Simulation.Aivika.Trans.Internal.Event import Simulation.Aivika.Trans.Internal.Process-import Simulation.Aivika.Trans.Internal.Signal import Simulation.Aivika.Trans.Signal import Simulation.Aivika.Trans.Resource import Simulation.Aivika.Trans.QueueStrategy@@ -117,13 +115,13 @@           -- ^ The strategy applied to the dequeueing (output) processes.           queueStore :: StrategyQueue m sm (QueueItem a),           dequeueRes :: Resource m so,-          queueCountRef :: ProtoRef m Int,-          queueCountStatsRef :: ProtoRef m (TimingStats Int),-          enqueueStoreCountRef :: ProtoRef m Int,-          dequeueCountRef :: ProtoRef m Int,-          dequeueExtractCountRef :: ProtoRef m Int,-          queueWaitTimeRef :: ProtoRef m (SamplingStats Double),-          dequeueWaitTimeRef :: ProtoRef m (SamplingStats Double),+          queueCountRef :: Ref m Int,+          queueCountStatsRef :: Ref m (TimingStats Int),+          enqueueStoreCountRef :: Ref m Int,+          dequeueCountRef :: Ref m Int,+          dequeueExtractCountRef :: Ref m Int,+          queueWaitTimeRef :: Ref m (SamplingStats Double),+          dequeueWaitTimeRef :: Ref m (SamplingStats Double),           enqueueStoredSource :: SignalSource m a,           dequeueRequestedSource :: SignalSource m (),           dequeueExtractedSource :: SignalSource m a }@@ -137,23 +135,27 @@             }    -- | Create a new infinite FCFS queue.  -newFCFSQueue :: MonadComp m => Event m (FCFSQueue m a)+newFCFSQueue :: MonadDES m => Event m (FCFSQueue m a)+{-# INLINABLE newFCFSQueue #-} newFCFSQueue = newQueue FCFS FCFS    -- | Create a new infinite LCFS queue.  -newLCFSQueue :: MonadComp m => Event m (LCFSQueue m a)  +newLCFSQueue :: MonadDES m => Event m (LCFSQueue m a)  +{-# INLINABLE newLCFSQueue #-} newLCFSQueue = newQueue LCFS FCFS    -- | Create a new infinite SIRO queue.  -newSIROQueue :: MonadComp m => Event m (SIROQueue m a)  +newSIROQueue :: (MonadDES m, QueueStrategy m SIRO) => Event m (SIROQueue m a)  +{-# INLINABLE newSIROQueue #-} newSIROQueue = newQueue SIRO FCFS   --- | Create a new infinite priority queue.  -newPriorityQueue :: MonadComp m => Event m (PriorityQueue m a)  +-- | Create a new infinite priority queue.+newPriorityQueue :: (MonadDES m, QueueStrategy m StaticPriorities) => Event m (PriorityQueue m a)  +{-# INLINABLE newPriorityQueue #-} newPriorityQueue = newQueue StaticPriorities FCFS    -- | Create a new infinite queue with the specified strategies.  -newQueue :: (MonadComp m,+newQueue :: (MonadDES m,              QueueStrategy m sm,              QueueStrategy m so) =>             sm@@ -161,18 +163,18 @@             -> so             -- ^ the strategy applied to the dequeueing (output) processes when the queue is empty             -> Event m (Queue m sm so a)  +{-# INLINABLE newQueue #-} newQueue sm so =   do t  <- liftDynamics time-     sn <- liftParameter simulationSession -     i  <- liftComp $ newProtoRef sn 0-     is <- liftComp $ newProtoRef sn $ returnTimingStats t 0-     cm <- liftComp $ newProtoRef sn 0-     cr <- liftComp $ newProtoRef sn 0-     co <- liftComp $ newProtoRef sn 0+     i  <- liftSimulation $ newRef 0+     is <- liftSimulation $ newRef $ returnTimingStats t 0+     cm <- liftSimulation $ newRef 0+     cr <- liftSimulation $ newRef 0+     co <- liftSimulation $ newRef 0      qm <- liftSimulation $ newStrategyQueue sm      ro <- liftSimulation $ newResourceWithMaxCount so 0 Nothing-     w  <- liftComp $ newProtoRef sn mempty-     wo <- liftComp $ newProtoRef sn mempty +     w  <- liftSimulation $ newRef mempty+     wo <- liftSimulation $ newRef mempty       s3 <- liftSimulation newSignalSource      s4 <- liftSimulation newSignalSource      s5 <- liftSimulation newSignalSource@@ -194,40 +196,47 @@ -- | Test whether the queue is empty. -- -- See also 'queueNullChanged' and 'queueNullChanged_'.-queueNull :: MonadComp m => Queue m sm so a -> Event m Bool+queueNull :: MonadDES m => Queue m sm so a -> Event m Bool+{-# INLINABLE queueNull #-} queueNull q =   Event $ \p ->-  do n <- readProtoRef (queueCountRef q)+  do n <- invokeEvent p $ readRef (queueCountRef q)      return (n == 0)    -- | Signal when the 'queueNull' property value has changed.-queueNullChanged :: MonadComp m => Queue m sm so a -> Signal m Bool+queueNullChanged :: MonadDES m => Queue m sm so a -> Signal m Bool+{-# INLINABLE queueNullChanged #-} queueNullChanged q =   mapSignalM (const $ queueNull q) (queueNullChanged_ q)    -- | Signal when the 'queueNull' property value has changed.-queueNullChanged_ :: MonadComp m => Queue m sm so a -> Signal m ()+queueNullChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()+{-# INLINABLE queueNullChanged_ #-} queueNullChanged_ = queueCountChanged_  -- | Return the current queue size. -- -- See also 'queueCountStats', 'queueCountChanged' and 'queueCountChanged_'.-queueCount :: MonadComp m => Queue m sm so a -> Event m Int+queueCount :: MonadDES m => Queue m sm so a -> Event m Int+{-# INLINABLE queueCount #-} queueCount q =-  Event $ \p -> readProtoRef (queueCountRef q)+  Event $ \p -> invokeEvent p $ readRef (queueCountRef q)  -- | Return the queue size statistics.-queueCountStats :: MonadComp m => Queue m sm so a -> Event m (TimingStats Int)+queueCountStats :: MonadDES m => Queue m sm so a -> Event m (TimingStats Int)+{-# INLINABLE queueCountStats #-} queueCountStats q =-  Event $ \p -> readProtoRef (queueCountStatsRef q)+  Event $ \p -> invokeEvent p $ readRef (queueCountStatsRef q)    -- | Signal when the 'queueCount' property value has changed.-queueCountChanged :: MonadComp m => Queue m sm so a -> Signal m Int+queueCountChanged :: MonadDES m => Queue m sm so a -> Signal m Int+{-# INLINABLE queueCountChanged #-} queueCountChanged q =   mapSignalM (const $ queueCount q) (queueCountChanged_ q)    -- | Signal when the 'queueCount' property value has changed.-queueCountChanged_ :: MonadComp m => Queue m sm so a -> Signal m ()+queueCountChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()+{-# INLINABLE queueCountChanged_ #-} queueCountChanged_ q =   mapSignal (const ()) (enqueueStored q) <>   mapSignal (const ()) (dequeueExtracted q)@@ -235,17 +244,20 @@ -- | Return the total number of input items that were stored. -- -- See also 'enqueueStoreCountChanged' and 'enqueueStoreCountChanged_'.-enqueueStoreCount :: MonadComp m => Queue m sm so a -> Event m Int+enqueueStoreCount :: MonadDES m => Queue m sm so a -> Event m Int+{-# INLINABLE enqueueStoreCount #-} enqueueStoreCount q =-  Event $ \p -> readProtoRef (enqueueStoreCountRef q)+  Event $ \p -> invokeEvent p $ readRef (enqueueStoreCountRef q)    -- | Signal when the 'enqueueStoreCount' property value has changed.-enqueueStoreCountChanged :: MonadComp m => Queue m sm so a -> Signal m Int+enqueueStoreCountChanged :: MonadDES m => Queue m sm so a -> Signal m Int+{-# INLINABLE enqueueStoreCountChanged #-} enqueueStoreCountChanged q =   mapSignalM (const $ enqueueStoreCount q) (enqueueStoreCountChanged_ q)    -- | Signal when the 'enqueueStoreCount' property value has changed.-enqueueStoreCountChanged_ :: MonadComp m => Queue m sm so a -> Signal m ()+enqueueStoreCountChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()+{-# INLINABLE enqueueStoreCountChanged_ #-} enqueueStoreCountChanged_ q =   mapSignal (const ()) (enqueueStored q)       @@ -254,43 +266,50 @@ -- without suspension. -- -- See also 'dequeueCountChanged' and 'dequeueCountChanged_'.-dequeueCount :: MonadComp m => Queue m sm so a -> Event m Int+dequeueCount :: MonadDES m => Queue m sm so a -> Event m Int+{-# INLINABLE dequeueCount #-} dequeueCount q =-  Event $ \p -> readProtoRef (dequeueCountRef q)+  Event $ \p -> invokeEvent p $ readRef (dequeueCountRef q)        -- | Signal when the 'dequeueCount' property value has changed.-dequeueCountChanged :: MonadComp m => Queue m sm so a -> Signal m Int+dequeueCountChanged :: MonadDES m => Queue m sm so a -> Signal m Int+{-# INLINABLE dequeueCountChanged #-} dequeueCountChanged q =   mapSignalM (const $ dequeueCount q) (dequeueCountChanged_ q)    -- | Signal when the 'dequeueCount' property value has changed.-dequeueCountChanged_ :: MonadComp m => Queue m sm so a -> Signal m ()+dequeueCountChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()+{-# INLINABLE dequeueCountChanged_ #-} dequeueCountChanged_ q =   mapSignal (const ()) (dequeueRequested q)        -- | Return the total number of output items that were actually dequeued. -- -- See also 'dequeueExtractCountChanged' and 'dequeueExtractCountChanged_'.-dequeueExtractCount :: MonadComp m => Queue m sm so a -> Event m Int+dequeueExtractCount :: MonadDES m => Queue m sm so a -> Event m Int+{-# INLINABLE dequeueExtractCount #-} dequeueExtractCount q =-  Event $ \p -> readProtoRef (dequeueExtractCountRef q)+  Event $ \p -> invokeEvent p $ readRef (dequeueExtractCountRef q)        -- | Signal when the 'dequeueExtractCount' property value has changed.-dequeueExtractCountChanged :: MonadComp m => Queue m sm so a -> Signal m Int+dequeueExtractCountChanged :: MonadDES m => Queue m sm so a -> Signal m Int+{-# INLINABLE dequeueExtractCountChanged #-} dequeueExtractCountChanged q =   mapSignalM (const $ dequeueExtractCount q) (dequeueExtractCountChanged_ q)    -- | Signal when the 'dequeueExtractCount' property value has changed.-dequeueExtractCountChanged_ :: MonadComp m => Queue m sm so a -> Signal m ()+dequeueExtractCountChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()+{-# INLINABLE dequeueExtractCountChanged_ #-} dequeueExtractCountChanged_ q =   mapSignal (const ()) (dequeueExtracted q)  -- | Return the rate of the items that were stored: how many items -- per time.-enqueueStoreRate :: MonadComp m => Queue m sm so a -> Event m Double+enqueueStoreRate :: MonadDES m => Queue m sm so a -> Event m Double+{-# INLINABLE enqueueStoreRate #-} enqueueStoreRate q =   Event $ \p ->-  do x <- readProtoRef (enqueueStoreCountRef q)+  do x <- invokeEvent p $ readRef (enqueueStoreCountRef q)      let t0 = spcStartTime $ pointSpecs p          t  = pointTime p      return (fromIntegral x / (t - t0))@@ -298,20 +317,22 @@ -- | Return the rate of the requests for dequeueing the items: how many requests -- per time. It does not include the failed attempts to dequeue immediately -- without suspension.-dequeueRate :: MonadComp m => Queue m sm so a -> Event m Double+dequeueRate :: MonadDES m => Queue m sm so a -> Event m Double+{-# INLINABLE dequeueRate #-} dequeueRate q =   Event $ \p ->-  do x <- readProtoRef (dequeueCountRef q)+  do x <- invokeEvent p $ readRef (dequeueCountRef 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.-dequeueExtractRate :: MonadComp m => Queue m sm so a -> Event m Double+dequeueExtractRate :: MonadDES m => Queue m sm so a -> Event m Double+{-# INLINABLE dequeueExtractRate #-} dequeueExtractRate q =   Event $ \p ->-  do x <- readProtoRef (dequeueExtractCountRef q)+  do x <- invokeEvent p $ readRef (dequeueExtractCountRef q)      let t0 = spcStartTime $ pointSpecs p          t  = pointTime p      return (fromIntegral x / (t - t0))@@ -320,17 +341,20 @@ -- the time at which it was dequeued. -- -- See also 'queueWaitTimeChanged' and 'queueWaitTimeChanged_'.-queueWaitTime :: MonadComp m => Queue m sm so a -> Event m (SamplingStats Double)+queueWaitTime :: MonadDES m => Queue m sm so a -> Event m (SamplingStats Double)+{-# INLINABLE queueWaitTime #-} queueWaitTime q =-  Event $ \p -> readProtoRef (queueWaitTimeRef q)+  Event $ \p -> invokeEvent p $ readRef (queueWaitTimeRef q)        -- | Signal when the 'queueWaitTime' property value has changed.-queueWaitTimeChanged :: MonadComp m => Queue m sm so a -> Signal m (SamplingStats Double)+queueWaitTimeChanged :: MonadDES m => Queue m sm so a -> Signal m (SamplingStats Double)+{-# INLINABLE queueWaitTimeChanged #-} queueWaitTimeChanged q =   mapSignalM (const $ queueWaitTime q) (queueWaitTimeChanged_ q)    -- | Signal when the 'queueWaitTime' property value has changed.-queueWaitTimeChanged_ :: MonadComp m => Queue m sm so a -> Signal m ()+queueWaitTimeChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()+{-# INLINABLE queueWaitTimeChanged_ #-} queueWaitTimeChanged_ q =   mapSignal (const ()) (dequeueExtracted q)       @@ -338,57 +362,66 @@ -- for dequeueing to the time at which it was actually dequeued. -- -- See also 'dequeueWaitTimeChanged' and 'dequeueWaitTimeChanged_'.-dequeueWaitTime :: MonadComp m => Queue m sm so a -> Event m (SamplingStats Double)+dequeueWaitTime :: MonadDES m => Queue m sm so a -> Event m (SamplingStats Double)+{-# INLINABLE dequeueWaitTime #-} dequeueWaitTime q =-  Event $ \p -> readProtoRef (dequeueWaitTimeRef q)+  Event $ \p -> invokeEvent p $ readRef (dequeueWaitTimeRef q)        -- | Signal when the 'dequeueWaitTime' property value has changed.-dequeueWaitTimeChanged :: MonadComp m => Queue m sm so a -> Signal m (SamplingStats Double)+dequeueWaitTimeChanged :: MonadDES m => Queue m sm so a -> Signal m (SamplingStats Double)+{-# INLINABLE dequeueWaitTimeChanged #-} dequeueWaitTimeChanged q =   mapSignalM (const $ dequeueWaitTime q) (dequeueWaitTimeChanged_ q)    -- | Signal when the 'dequeueWaitTime' property value has changed.-dequeueWaitTimeChanged_ :: MonadComp m => Queue m sm so a -> Signal m ()+dequeueWaitTimeChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()+{-# INLINABLE dequeueWaitTimeChanged_ #-} dequeueWaitTimeChanged_ q =   mapSignal (const ()) (dequeueExtracted q)  -- | Return a long-term average queue rate calculated as -- the average queue size divided by the average wait time. --+-- It should conform with Little's rule.+-- -- See also 'queueRateChanged' and 'queueRateChanged_'.-queueRate :: MonadComp m => Queue m sm so a -> Event m Double+queueRate :: MonadDES m => Queue m sm so a -> Event m Double+{-# INLINABLE queueRate #-} queueRate q =   Event $ \p ->-  do x <- readProtoRef (queueCountStatsRef q)-     y <- readProtoRef (queueWaitTimeRef q)+  do x <- invokeEvent p $ readRef (queueCountStatsRef q)+     y <- invokeEvent p $ readRef (queueWaitTimeRef q)      return (timingStatsMean x / samplingStatsMean y)   -- | Signal when the 'queueRate' property value has changed.-queueRateChanged :: MonadComp m => Queue m sm so a -> Signal m Double+queueRateChanged :: MonadDES m => Queue m sm so a -> Signal m Double+{-# INLINABLE queueRateChanged #-} queueRateChanged q =   mapSignalM (const $ queueRate q) (queueRateChanged_ q)  -- | Signal when the 'queueRate' property value has changed.-queueRateChanged_ :: MonadComp m => Queue m sm so a -> Signal m ()+queueRateChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()+{-# INLINABLE queueRateChanged_ #-} queueRateChanged_ q =   mapSignal (const ()) (enqueueStored q) <>   mapSignal (const ()) (dequeueExtracted q)    -- | Dequeue suspending the process if the queue is empty.-dequeue :: (MonadComp m,+dequeue :: (MonadDES m,             DequeueStrategy m sm,             EnqueueStrategy m so)            => Queue m sm so a            -- ^ the queue            -> Process m a            -- ^ the dequeued value+{-# INLINABLE dequeue #-} dequeue q =   do t <- liftEvent $ dequeueRequest q      requestResource (dequeueRes q)      liftEvent $ dequeueExtract q t    -- | Dequeue with the output priority suspending the process if the queue is empty.-dequeueWithOutputPriority :: (MonadComp m,+dequeueWithOutputPriority :: (MonadDES m,                               DequeueStrategy m sm,                               PriorityQueueStrategy m so po)                              => Queue m sm so a@@ -397,17 +430,19 @@                              -- ^ the priority for output                              -> Process m a                              -- ^ the dequeued value+{-# INLINABLE dequeueWithOutputPriority #-} dequeueWithOutputPriority q po =   do t <- liftEvent $ dequeueRequest q      requestResourceWithPriority (dequeueRes q) po      liftEvent $ dequeueExtract q t    -- | Try to dequeue immediately.-tryDequeue :: (MonadComp m, DequeueStrategy m sm)+tryDequeue :: (MonadDES m, DequeueStrategy m sm)               => Queue m sm so a               -- ^ the queue               -> Event m (Maybe a)               -- ^ the dequeued value of 'Nothing'+{-# INLINABLE tryDequeue #-} tryDequeue q =   do x <- tryRequestResourceWithinEvent (dequeueRes q)      if x @@ -416,7 +451,7 @@        else return Nothing  -- | Enqueue the item.  -enqueue :: (MonadComp m,+enqueue :: (MonadDES m,             EnqueueStrategy m sm,             DequeueStrategy m so)            => Queue m sm so a@@ -424,10 +459,11 @@            -> a            -- ^ the item to enqueue            -> Event m ()+{-# INLINABLE enqueue #-} enqueue = enqueueStore       -- | Enqueue with the storing priority the item.  -enqueueWithStoringPriority :: (MonadComp m,+enqueueWithStoringPriority :: (MonadDES m,                                PriorityQueueStrategy m sm pm,                                DequeueStrategy m so)                               => Queue m sm so a@@ -437,24 +473,28 @@                               -> a                               -- ^ the item to enqueue                               -> Event m ()+{-# INLINABLE enqueueWithStoringPriority #-} enqueueWithStoringPriority = enqueueStoreWithPriority  -- | Return a signal that notifies when the enqueued item -- is stored in the internal memory of the queue.-enqueueStored :: MonadComp m => Queue m sm so a -> Signal m a+enqueueStored :: MonadDES m => Queue m sm so a -> Signal m a+{-# INLINABLE enqueueStored #-} enqueueStored q = publishSignal (enqueueStoredSource q)  -- | Return a signal that notifies when the dequeuing operation was requested.-dequeueRequested :: MonadComp m => Queue m sm so a -> Signal m ()+dequeueRequested :: MonadDES m => Queue m sm so a -> Signal m ()+{-# INLINABLE dequeueRequested #-} 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 :: MonadComp m => Queue m sm so a -> Signal m a+dequeueExtracted :: MonadDES m => Queue m sm so a -> Signal m a+{-# INLINABLE dequeueExtracted #-} dequeueExtracted q = publishSignal (dequeueExtractedSource q)  -- | Store the item.-enqueueStore :: (MonadComp m,+enqueueStore :: (MonadDES m,                  EnqueueStrategy m sm,                  DequeueStrategy m so)                 => Queue m sm so a@@ -462,25 +502,30 @@                 -> a                 -- ^ the item to be stored                 -> Event m ()+{-# INLINE enqueueStore #-} enqueueStore q a =   Event $ \p ->   do let i = QueueItem { itemValue = a,                          itemStoringTime = pointTime p }      invokeEvent p $        strategyEnqueue (queueStore q) i-     c <- readProtoRef (queueCountRef q)+     c <- invokeEvent p $+          readRef (queueCountRef q)      let c' = c + 1          t  = pointTime p-     c' `seq` writeProtoRef (queueCountRef q) c'-     modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c')-     modifyProtoRef' (enqueueStoreCountRef q) (+ 1)+     c' `seq` invokeEvent p $+       writeRef (queueCountRef q) c'      invokeEvent p $+       modifyRef (queueCountStatsRef q) (addTimingStats t c')+     invokeEvent p $+       modifyRef (enqueueStoreCountRef q) (+ 1)+     invokeEvent p $        releaseResourceWithinEvent (dequeueRes q)      invokeEvent p $        triggerSignal (enqueueStoredSource q) (itemValue i)  -- | Store with the priority the item.-enqueueStoreWithPriority :: (MonadComp m,+enqueueStoreWithPriority :: (MonadDES m,                              PriorityQueueStrategy m sm pm,                              DequeueStrategy m so)                             => Queue m sm so a@@ -490,55 +535,67 @@                             -> a                             -- ^ the item to be enqueued                             -> Event m ()+{-# INLINE enqueueStoreWithPriority #-} enqueueStoreWithPriority q pm a =   Event $ \p ->   do let i = QueueItem { itemValue = a,                          itemStoringTime = pointTime p }      invokeEvent p $        strategyEnqueueWithPriority (queueStore q) pm i-     c <- readProtoRef (queueCountRef q)+     c <- invokeEvent p $+          readRef (queueCountRef q)      let c' = c + 1          t  = pointTime p-     c' `seq` writeProtoRef (queueCountRef q) c'-     modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c')-     modifyProtoRef' (enqueueStoreCountRef q) (+ 1)+     c' `seq` invokeEvent p $+       writeRef (queueCountRef q) c'      invokeEvent p $+       modifyRef (queueCountStatsRef q) (addTimingStats t c')+     invokeEvent p $+       modifyRef (enqueueStoreCountRef q) (+ 1)+     invokeEvent p $        releaseResourceWithinEvent (dequeueRes q)      invokeEvent p $        triggerSignal (enqueueStoredSource q) (itemValue i)  -- | Accept the dequeuing request and return the current simulation time.-dequeueRequest :: MonadComp m+dequeueRequest :: MonadDES m                   => Queue m sm so a                   -- ^ the queue                   -> Event m Double                   -- ^ the current time+{-# INLINE dequeueRequest #-} dequeueRequest q =   Event $ \p ->-  do modifyProtoRef' (dequeueCountRef q) (+ 1)+  do invokeEvent p $+       modifyRef (dequeueCountRef q) (+ 1)      invokeEvent p $        triggerSignal (dequeueRequestedSource q) ()      return $ pointTime p   -- | Extract an item for the dequeuing request.  -dequeueExtract :: (MonadComp m, DequeueStrategy m sm)+dequeueExtract :: (MonadDES m, DequeueStrategy m sm)                   => Queue m sm so a                   -- ^ the queue                   -> Double                   -- ^ the time of the dequeuing request                   -> Event m a                   -- ^ the dequeued value+{-# INLINE dequeueExtract #-} dequeueExtract q t' =   Event $ \p ->   do i <- invokeEvent p $           strategyDequeue (queueStore q)-     c <- readProtoRef (queueCountRef q)+     c <- invokeEvent p $+          readRef (queueCountRef q)      let c' = c - 1          t  = pointTime p-     c' `seq` writeProtoRef (queueCountRef q) c'-     modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c')-     modifyProtoRef' (dequeueExtractCountRef q) (+ 1)+     c' `seq` invokeEvent p $+       writeRef (queueCountRef q) c'      invokeEvent p $+       modifyRef (queueCountStatsRef q) (addTimingStats t c')+     invokeEvent p $+       modifyRef (dequeueExtractCountRef q) (+ 1)+     invokeEvent p $        dequeueStat q t' i      invokeEvent p $        triggerSignal (dequeueExtractedSource q) (itemValue i)@@ -546,7 +603,7 @@  -- | Update the statistics for the output wait time of the dequeuing operation -- and the wait time of storing in the queue.-dequeueStat :: MonadComp m+dequeueStat :: MonadDES m                => Queue m sm so a                -- ^ the queue                -> Double@@ -555,13 +612,16 @@                -- ^ the item and its input time                -> Event m ()                -- ^ the action of updating the statistics+{-# INLINE dequeueStat #-} dequeueStat q t' i =   Event $ \p ->   do let t1 = itemStoringTime i          t  = pointTime p-     modifyProtoRef' (dequeueWaitTimeRef q) $+     invokeEvent p $+       modifyRef (dequeueWaitTimeRef q) $        addSamplingStats (t - t')-     modifyProtoRef' (queueWaitTimeRef q) $+     invokeEvent p $+       modifyRef (queueWaitTimeRef q) $        addSamplingStats (t - t1)  -- | Signal whenever any property of the queue changes.@@ -570,7 +630,8 @@ -- 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_ :: MonadComp m => Queue m sm so a -> Signal m ()+queueChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()+{-# INLINABLE queueChanged_ #-} queueChanged_ q =   mapSignal (const ()) (enqueueStored q) <>   dequeueRequested q <>@@ -578,7 +639,8 @@  -- | Return the summary for the queue with desciption of its -- properties and activities using the specified indent.-queueSummary :: (MonadComp m, Show sm, Show so) => Queue m sm so a -> Int -> Event m ShowS+queueSummary :: (MonadDES m, Show sm, Show so) => Queue m sm so a -> Int -> Event m ShowS+{-# INLINABLE queueSummary #-} queueSummary q indent =   do let sm = enqueueStoringStrategy q          so = dequeueStrategy q
Simulation/Aivika/Trans/QueueStrategy.hs view
@@ -3,31 +3,22 @@  -- | -- Module     : Simulation.Aivika.Trans.QueueStrategy--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines the queue strategies. -- module Simulation.Aivika.Trans.QueueStrategy where -import Control.Monad.Trans--import Simulation.Aivika.Trans.Comp-import Simulation.Aivika.Trans.Comp.Template-import Simulation.Aivika.Trans.Parameter-import Simulation.Aivika.Trans.Parameter.Random-import Simulation.Aivika.Trans.Simulation-import Simulation.Aivika.Trans.Event+import Control.Monad -import qualified Simulation.Aivika.Trans.DoubleLinkedList as LL-import qualified Simulation.Aivika.Trans.PriorityQueue as PQ-import qualified Simulation.Aivika.Trans.Vector as V+import Simulation.Aivika.Trans.Internal.Types  -- | Defines the basic queue strategy.-class MonadComp m => QueueStrategy m s where+class Monad m => QueueStrategy m s where    -- | The strategy queue.   data StrategyQueue m s :: * -> *@@ -88,115 +79,3 @@  -- | Strategy: Static Priorities. It uses the priority queue. data StaticPriorities = StaticPriorities deriving (Eq, Ord, Show)---- | An implementation of the 'FCFS' queue strategy.-instance MonadComp m => QueueStrategy m FCFS where--  -- | A queue used by the 'FCFS' strategy.-  newtype StrategyQueue m FCFS a = FCFSQueue (LL.DoubleLinkedList m a)--  newStrategyQueue s =-    fmap FCFSQueue $-    do session <- liftParameter simulationSession-       liftComp $ LL.newList session--  strategyQueueNull (FCFSQueue q) = liftComp $ LL.listNull q---- | An implementation of the 'FCFS' queue strategy.-instance QueueStrategy m FCFS => DequeueStrategy m FCFS where--  strategyDequeue (FCFSQueue q) =-    liftComp $-    do i <- LL.listFirst q-       LL.listRemoveFirst q-       return i---- | An implementation of the 'FCFS' queue strategy.-instance DequeueStrategy m FCFS => EnqueueStrategy m FCFS where--  strategyEnqueue (FCFSQueue q) i = liftComp $ LL.listAddLast q i---- | An implementation of the 'LCFS' queue strategy.-instance MonadComp m => QueueStrategy m LCFS where--  -- | A queue used by the 'LCFS' strategy.-  newtype StrategyQueue m LCFS a = LCFSQueue (LL.DoubleLinkedList m a)--  newStrategyQueue s =-    fmap LCFSQueue $-    do session <- liftParameter simulationSession-       liftComp $ LL.newList session-       -  strategyQueueNull (LCFSQueue q) = liftComp $ LL.listNull q---- | An implementation of the 'LCFS' queue strategy.-instance QueueStrategy m LCFS => DequeueStrategy m LCFS where--  strategyDequeue (LCFSQueue q) =-    liftComp $-    do i <- LL.listFirst q-       LL.listRemoveFirst q-       return i---- | An implementation of the 'LCFS' queue strategy.-instance DequeueStrategy m LCFS => EnqueueStrategy m LCFS where--  strategyEnqueue (LCFSQueue q) i = liftComp $ LL.listInsertFirst q i---- | An implementation of the 'StaticPriorities' queue strategy.-instance MonadComp m => QueueStrategy m StaticPriorities where--  -- | A queue used by the 'StaticPriorities' strategy.-  newtype StrategyQueue m StaticPriorities a = StaticPriorityQueue (PQ.PriorityQueue m a)--  newStrategyQueue s =-    fmap StaticPriorityQueue $-    do session <- liftParameter simulationSession-       liftComp $ PQ.newQueue session--  strategyQueueNull (StaticPriorityQueue q) = liftComp $ PQ.queueNull q---- | An implementation of the 'StaticPriorities' queue strategy.-instance QueueStrategy m StaticPriorities => DequeueStrategy m StaticPriorities where--  strategyDequeue (StaticPriorityQueue q) =-    liftComp $-    do (_, i) <- PQ.queueFront q-       PQ.dequeue q-       return i---- | An implementation of the 'StaticPriorities' queue strategy.-instance DequeueStrategy m StaticPriorities => PriorityQueueStrategy m StaticPriorities Double where--  strategyEnqueueWithPriority (StaticPriorityQueue q) p i = liftComp $ PQ.enqueue q p i---- | An implementation of the 'SIRO' queue strategy.-instance MonadComp m => QueueStrategy m SIRO where--  -- | A queue used by the 'SIRO' strategy.-  newtype StrategyQueue m SIRO a = SIROQueue (V.Vector m a)-  -  newStrategyQueue s =-    fmap SIROQueue $-    do session <- liftParameter simulationSession-       liftComp $ V.newVector session--  strategyQueueNull (SIROQueue q) =-    liftComp $-    do n <- V.vectorCount q-       return (n == 0)---- | An implementation of the 'SIRO' queue strategy.-instance QueueStrategy m SIRO => DequeueStrategy m SIRO where--  strategyDequeue (SIROQueue q) =-    do n <- liftComp $ V.vectorCount q-       i <- liftParameter $ randomUniformInt 0 (n - 1)-       x <- liftComp $ V.readVector q i-       liftComp $ V.vectorDeleteAt q i-       return x---- | An implementation of the 'SIRO' queue strategy.-instance DequeueStrategy m SIRO => EnqueueStrategy m SIRO where--  strategyEnqueue (SIROQueue q) i = liftComp $ V.appendVector q i
Simulation/Aivika/Trans/Ref.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Ref--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines an updatable reference that depends on the event queue. --@@ -14,6 +14,7 @@         refChanged,         refChanged_,         newRef,+        newRef0,         readRef,         writeRef,         modifyRef) where@@ -23,54 +24,70 @@ import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp-import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Event-import Simulation.Aivika.Trans.Internal.Signal import Simulation.Aivika.Trans.Signal+import qualified Simulation.Aivika.Trans.Ref.Base as B+import Simulation.Aivika.Trans.DES  -- | The 'Ref' type represents a mutable variable similar to the 'IORef' variable  -- but only dependent on the event queue, which allows synchronizing the reference -- with the model explicitly through the 'Event' monad. data Ref m a = -  Ref { refValue :: ProtoRef m a, +  Ref { refValue :: B.Ref m a,          refChangedSource :: SignalSource m a }  -- | Create a new reference.-newRef :: MonadComp m => a -> Simulation m (Ref m a)+newRef :: MonadDES m => a -> Simulation m (Ref m a)+{-# INLINABLE newRef #-} newRef a =   Simulation $ \r ->-  do let s = runSession r-     x <- newProtoRef s a+  do x <- invokeSimulation r $ B.newRef a      s <- invokeSimulation r newSignalSource      return Ref { refValue = x,                    refChangedSource = s }++-- | Create a new reference within more low level computation than 'Simulation'.+newRef0 :: (MonadDES m, B.MonadRef0 m) => a -> m (Ref m a)+{-# INLINABLE newRef0 #-}+newRef0 a =+  do x <- B.newRef0 a+     s <- newSignalSource0+     return Ref { refValue = x, +                  refChangedSource = s }       -- | Read the value of a reference.-readRef :: MonadComp m => Ref m a -> Event m a-readRef r = Event $ \p -> readProtoRef (refValue r)+readRef :: MonadDES m => Ref m a -> Event m a+{-# INLINE readRef #-}+readRef r = B.readRef (refValue r)  -- | Write a new value into the reference.-writeRef :: MonadComp m => Ref m a -> a -> Event m ()+writeRef :: MonadDES m => Ref m a -> a -> Event m ()+{-# INLINABLE writeRef #-} writeRef r a = Event $ \p -> -  do a `seq` writeProtoRef (refValue r) a+  do a `seq` invokeEvent p $ B.writeRef (refValue r) a      invokeEvent p $ triggerSignal (refChangedSource r) a  -- | Mutate the contents of the reference.-modifyRef :: MonadComp m => Ref m a -> (a -> a) -> Event m ()+modifyRef :: MonadDES m => Ref m a -> (a -> a) -> Event m ()+{-# INLINABLE modifyRef #-} modifyRef r f = Event $ \p -> -  do a <- readProtoRef (refValue r)+  do a <- invokeEvent p $ B.readRef (refValue r)      let b = f a-     b `seq` writeProtoRef (refValue r) b+     b `seq` invokeEvent p $ B.writeRef (refValue r) b      invokeEvent p $ triggerSignal (refChangedSource r) b  -- | Return a signal that notifies about every change of the reference state.-refChanged :: MonadComp m => Ref m a -> Signal m a-refChanged v = publishSignal (refChangedSource v)+refChanged :: Ref m a -> Signal m a+{-# INLINE refChanged #-}+refChanged r = publishSignal (refChangedSource r)  -- | Return a signal that notifies about every change of the reference state.-refChanged_ :: MonadComp m => Ref m a -> Signal m ()+refChanged_ :: MonadDES m => Ref m a -> Signal m ()+{-# INLINABLE refChanged_ #-} refChanged_ r = mapSignal (const ()) $ refChanged r++instance MonadDES m => Eq (Ref m a) where++  {-# INLINE (==) #-}+  r1 == r2 = (refValue r1) == (refValue r2)
+ Simulation/Aivika/Trans/Ref/Base.hs view
@@ -0,0 +1,58 @@++{-# LANGUAGE TypeFamilies #-}++-- |+-- Module     : Simulation.Aivika.Trans.Ref.Base+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- This module defines a plain and more fast version of an updatable reference+-- that depends on the event queue but that doesn't supply with the signal notification.+--+module Simulation.Aivika.Trans.Ref.Base+       (MonadRef(..),+        MonadRef0(..)) where++import Data.IORef++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Trans.Internal.Types++-- | A monad within which we can create mutable references.+class Monad m => MonadRef m where++  -- | The 'ProtoRef' type represents a mutable variable similar to the 'IORef' variable +  -- but only dependent on the event queue, which allows synchronizing the reference+  -- with the model explicitly through the 'Event' monad.+  data Ref m a++  -- | Create a new reference.+  newRef :: a -> Simulation m (Ref m a)+     +  -- | Read the value of a reference.+  readRef :: Ref m a -> Event m a++  -- | Write a new value into the reference.+  writeRef :: Ref m a -> a -> Event m ()++  -- | Mutate the contents of the reference.+  modifyRef :: Ref m a -> (a -> a) -> Event m ()++  -- | Compare two references for equality.+  equalRef :: Ref m a -> Ref m a -> Bool++instance MonadRef m => Eq (Ref m a) where++  {-# INLINE (==) #-}+  (==) = equalRef++-- | A kind of reference that can be created within more low level computation than 'Simulation'.+class MonadRef m => MonadRef0 m where++  -- | Create a new reference within more low level computation than 'Simulation'.+  newRef0 :: a -> m (Ref m a)
− Simulation/Aivika/Trans/Ref/Plain.hs 
@@ -1,60 +0,0 @@---- |--- Module     : Simulation.Aivika.Trans.Ref.Plain--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.8.3------ This module defines a plain and more fast version of an updatable reference--- that depends on the event queue but that doesn't supply with the signal notification.----module Simulation.Aivika.Trans.Ref.Plain-       (Ref,-        newRef,-        readRef,-        writeRef,-        modifyRef) where--import Data.IORef--import Control.Monad-import Control.Monad.Trans--import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp-import Simulation.Aivika.Trans.Internal.Specs-import Simulation.Aivika.Trans.Internal.Simulation-import Simulation.Aivika.Trans.Internal.Event---- | The 'Ref' type represents a mutable variable similar to the 'IORef' variable --- but only dependent on the event queue, which allows synchronizing the reference--- with the model explicitly through the 'Event' monad.-newtype Ref m a = -  Ref { refValue :: ProtoRef m a }---- | Create a new reference.-newRef :: MonadComp m => a -> Simulation m (Ref m a)-newRef a =-  Simulation $ \r ->-  do let s = runSession r-     x <- newProtoRef s a-     return Ref { refValue = x }-     --- | Read the value of a reference.-readRef :: MonadComp m => Ref m a -> Event m a-readRef r = Event $ \p -> readProtoRef (refValue r)---- | Write a new value into the reference.-writeRef :: MonadComp m => Ref m a -> a -> Event m ()-writeRef r a = Event $ \p -> -  a `seq` writeProtoRef (refValue r) a---- | Mutate the contents of the reference.-modifyRef :: MonadComp m => Ref m a -> (a -> a) -> Event m ()-modifyRef r f = Event $ \p -> -  do a <- readProtoRef (refValue r)-     let b = f a-     b `seq` writeProtoRef (refValue r) b
Simulation/Aivika/Trans/Resource.hs view
@@ -3,11 +3,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Resource--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines the resource which can be acquired and  -- then released by the discontinuous process 'Process'.@@ -44,15 +44,16 @@         releaseResource,         releaseResourceWithinEvent,         usingResource,-        usingResourceWithPriority) where+        usingResourceWithPriority,+        -- * Altering Resource+        incResourceCount) where  import Control.Monad import Control.Monad.Trans import Control.Exception -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Event@@ -60,10 +61,6 @@ import Simulation.Aivika.Trans.Internal.Process import Simulation.Aivika.Trans.QueueStrategy -import qualified Simulation.Aivika.Trans.DoubleLinkedList as DLL -import qualified Simulation.Aivika.Trans.Vector as V-import qualified Simulation.Aivika.Trans.PriorityQueue as PQ- -- | The ordinary FCFS (First Come - First Serviced) resource. type FCFSResource m = Resource m FCFS @@ -83,97 +80,105 @@              resourceMaxCount :: Maybe Int,              -- ^ Return the maximum count of the resource, where 'Nothing'              -- means that the resource has no upper bound.-             resourceCountRef :: ProtoRef m Int, -             resourceWaitList :: StrategyQueue m s (Event m (Maybe (ContParams m ()))) }+             resourceCountRef :: Ref m Int, +             resourceWaitList :: StrategyQueue m s (FrozenCont m ()) }  -- | Create a new FCFS resource with the specified initial count which value becomes -- the upper bound as well.-newFCFSResource :: MonadComp m+newFCFSResource :: MonadDES m                    => Int                    -- ^ the initial count (and maximal count too) of the resource                    -> Simulation m (FCFSResource m)+{-# INLINABLE newFCFSResource #-} newFCFSResource = newResource FCFS  -- | Create a new FCFS resource with the specified initial and maximum counts, -- where 'Nothing' means that the resource has no upper bound.-newFCFSResourceWithMaxCount :: MonadComp m+newFCFSResourceWithMaxCount :: MonadDES m                                => Int                                -- ^ the initial count of the resource                                -> Maybe Int                                -- ^ the maximum count of the resource, which can be indefinite                                -> Simulation m (FCFSResource m)+{-# INLINABLE newFCFSResourceWithMaxCount #-} newFCFSResourceWithMaxCount = newResourceWithMaxCount FCFS  -- | Create a new LCFS resource with the specified initial count which value becomes -- the upper bound as well.-newLCFSResource :: MonadComp m+newLCFSResource :: MonadDES m                    => Int                    -- ^ the initial count (and maximal count too) of the resource                    -> Simulation m (LCFSResource m)+{-# INLINABLE newLCFSResource #-} newLCFSResource = newResource LCFS  -- | Create a new LCFS resource with the specified initial and maximum counts, -- where 'Nothing' means that the resource has no upper bound.-newLCFSResourceWithMaxCount :: MonadComp m+newLCFSResourceWithMaxCount :: MonadDES m                                => Int                                -- ^ the initial count of the resource                                -> Maybe Int                                -- ^ the maximum count of the resource, which can be indefinite                                -> Simulation m (LCFSResource m)+{-# INLINABLE newLCFSResourceWithMaxCount #-} newLCFSResourceWithMaxCount = newResourceWithMaxCount LCFS  -- | Create a new SIRO resource with the specified initial count which value becomes -- the upper bound as well.-newSIROResource :: MonadComp m+newSIROResource :: (MonadDES m, QueueStrategy m SIRO)                    => Int                    -- ^ the initial count (and maximal count too) of the resource                    -> Simulation m (SIROResource m)+{-# INLINABLE newSIROResource #-} newSIROResource = newResource SIRO  -- | Create a new SIRO resource with the specified initial and maximum counts, -- where 'Nothing' means that the resource has no upper bound.-newSIROResourceWithMaxCount :: MonadComp m+newSIROResourceWithMaxCount :: (MonadDES m, QueueStrategy m SIRO)                                => Int                                -- ^ the initial count of the resource                                -> Maybe Int                                -- ^ the maximum count of the resource, which can be indefinite                                -> Simulation m (SIROResource m)+{-# INLINABLE newSIROResourceWithMaxCount #-} newSIROResourceWithMaxCount = newResourceWithMaxCount SIRO  -- | Create a new priority resource with the specified initial count which value becomes -- the upper bound as well.-newPriorityResource :: MonadComp m+newPriorityResource :: (MonadDES m, QueueStrategy m StaticPriorities)                        => Int                        -- ^ the initial count (and maximal count too) of the resource                        -> Simulation m (PriorityResource m)+{-# INLINABLE newPriorityResource #-} newPriorityResource = newResource StaticPriorities  -- | Create a new priority resource with the specified initial and maximum counts, -- where 'Nothing' means that the resource has no upper bound.-newPriorityResourceWithMaxCount :: MonadComp m+newPriorityResourceWithMaxCount :: (MonadDES m, QueueStrategy m StaticPriorities)                                    => Int                                    -- ^ the initial count of the resource                                    -> Maybe Int                                    -- ^ the maximum count of the resource, which can be indefinite                                    -> Simulation m (PriorityResource m)+{-# INLINABLE newPriorityResourceWithMaxCount #-} newPriorityResourceWithMaxCount = newResourceWithMaxCount StaticPriorities  -- | Create a new resource with the specified queue strategy and initial count. -- The last value becomes the upper bound as well.-newResource :: (MonadComp m, QueueStrategy m s)+newResource :: (MonadDES m, QueueStrategy m s)                => s                -- ^ the strategy for managing the queuing requests                -> Int                -- ^ the initial count (and maximal count too) of the resource                -> Simulation m (Resource m s)+{-# INLINABLE newResource #-} newResource s count =   Simulation $ \r ->   do when (count < 0) $        error $        "The resource count cannot be negative: " ++        "newResource."-     let session = runSession r -     countRef <- newProtoRef session count+     countRef <- invokeSimulation r $ newRef count      waitList <- invokeSimulation r $ newStrategyQueue s      return Resource { resourceStrategy = s,                        resourceMaxCount = Just count,@@ -182,7 +187,7 @@  -- | Create a new resource with the specified queue strategy, initial and maximum counts, -- where 'Nothing' means that the resource has no upper bound.-newResourceWithMaxCount :: (MonadComp m, QueueStrategy m s)+newResourceWithMaxCount :: (MonadDES m, QueueStrategy m s)                            => s                            -- ^ the strategy for managing the queuing requests                            -> Int@@ -190,6 +195,7 @@                            -> Maybe Int                            -- ^ the maximum count of the resource, which can be indefinite                            -> Simulation m (Resource m s)+{-# INLINABLE newResourceWithMaxCount #-} newResourceWithMaxCount s count maxCount =   Simulation $ \r ->   do when (count < 0) $@@ -203,8 +209,7 @@          "its maximum value: newResourceWithMaxCount."        _ ->          return ()-     let session = runSession r-     countRef <- newProtoRef session count+     countRef <- invokeSimulation r $ newRef count      waitList <- invokeSimulation r $ newStrategyQueue s      return Resource { resourceStrategy = s,                        resourceMaxCount = maxCount,@@ -212,58 +217,70 @@                        resourceWaitList = waitList }  -- | Return the current count of the resource.-resourceCount :: MonadComp m => Resource m s -> Event m Int+resourceCount :: MonadDES m => Resource m s -> Event m Int+{-# INLINABLE resourceCount #-} resourceCount r =-  Event $ \p -> readProtoRef (resourceCountRef r)+  Event $ \p -> invokeEvent p $ readRef (resourceCountRef r)  -- | Request for the resource decreasing its count in case of success, -- otherwise suspending the discontinuous process until some other  -- process releases the resource.-requestResource :: (MonadComp m, EnqueueStrategy m s)+requestResource :: (MonadDES m, EnqueueStrategy m s)                    => Resource m s                     -- ^ the requested resource                    -> Process m ()+{-# INLINABLE requestResource #-} requestResource r =   Process $ \pid ->   Cont $ \c ->   Event $ \p ->-  do a <- readProtoRef (resourceCountRef r)+  do a <- invokeEvent p $ readRef (resourceCountRef r)      if a == 0 -       then do c <- invokeEvent p $ contFreeze c+       then do c <- invokeEvent p $+                    freezeContReentering c () $+                    invokeCont c $+                    invokeProcess pid $+                    requestResource r                invokeEvent p $                  strategyEnqueue (resourceWaitList r) c        else do let a' = a - 1-               a' `seq` writeProtoRef (resourceCountRef r) a'+               a' `seq` invokeEvent p $ writeRef (resourceCountRef r) a'                invokeEvent p $ resumeCont c ()  -- | Request with the priority for the resource decreasing its count -- in case of success, otherwise suspending the discontinuous process -- until some other process releases the resource.-requestResourceWithPriority :: (MonadComp m, PriorityQueueStrategy m s p)+requestResourceWithPriority :: (MonadDES m, PriorityQueueStrategy m s p)                                => Resource m s                                -- ^ the requested resource                                -> p                                -- ^ the priority                                -> Process m ()+{-# INLINABLE requestResourceWithPriority #-} requestResourceWithPriority r priority =   Process $ \pid ->   Cont $ \c ->   Event $ \p ->-  do a <- readProtoRef (resourceCountRef r)+  do a <- invokeEvent p $ readRef (resourceCountRef r)      if a == 0 -       then do c <- invokeEvent p $ contFreeze c+       then do c <- invokeEvent p $+                    freezeContReentering c () $+                    invokeCont c $+                    invokeProcess pid $+                    requestResourceWithPriority r priority                invokeEvent p $                  strategyEnqueueWithPriority (resourceWaitList r) priority c        else do let a' = a - 1-               a' `seq` writeProtoRef (resourceCountRef r) a'+               a' `seq` invokeEvent p $ writeRef (resourceCountRef r) a'                invokeEvent p $ resumeCont c ()  -- | Release the resource increasing its count and resuming one of the -- previously suspended processes as possible.-releaseResource :: (MonadComp m, DequeueStrategy m s)+releaseResource :: (MonadDES m, DequeueStrategy m s)                    => Resource m s                    -- ^ the resource to release                    -> Process m ()+{-# INLINABLE releaseResource #-} releaseResource r =    Process $ \_ ->   Cont $ \c ->@@ -273,13 +290,14 @@  -- | Release the resource increasing its count and resuming one of the -- previously suspended processes as possible.-releaseResourceWithinEvent :: (MonadComp m, DequeueStrategy m s)+releaseResourceWithinEvent :: (MonadDES m, DequeueStrategy m s)                               => Resource m s                               -- ^ the resource to release                               -> Event m ()+{-# INLINABLE releaseResourceWithinEvent #-} releaseResourceWithinEvent r =   Event $ \p ->-  do a <- readProtoRef (resourceCountRef r)+  do a <- invokeEvent p $ readRef (resourceCountRef r)      let a' = a + 1      case resourceMaxCount r of        Just maxCount | a' > maxCount ->@@ -291,10 +309,10 @@      f <- invokeEvent p $           strategyQueueNull (resourceWaitList r)      if f -       then a' `seq` writeProtoRef (resourceCountRef r) a'+       then a' `seq` invokeEvent p $ writeRef (resourceCountRef r) a'        else do c <- invokeEvent p $                     strategyDequeue (resourceWaitList r)-               c <- invokeEvent p c+               c <- invokeEvent p $ unfreezeCont c                case c of                  Nothing ->                    invokeEvent p $ releaseResourceWithinEvent r@@ -303,28 +321,30 @@  -- | Try to request for the resource decreasing its count in case of success -- and returning 'True' in the 'Event' monad; otherwise, returning 'False'.-tryRequestResourceWithinEvent :: MonadComp m+tryRequestResourceWithinEvent :: MonadDES m                                  => Resource m s                                  -- ^ the resource which we try to request for                                  -> Event m Bool+{-# INLINABLE tryRequestResourceWithinEvent #-} tryRequestResourceWithinEvent r =   Event $ \p ->-  do a <- readProtoRef (resourceCountRef r)+  do a <- invokeEvent p $ readRef (resourceCountRef r)      if a == 0         then return False        else do let a' = a - 1-               a' `seq` writeProtoRef (resourceCountRef r) a'+               a' `seq` invokeEvent p $ writeRef (resourceCountRef r) a'                return True                 -- | Acquire the resource, perform some action and safely release the resource                -- in the end, even if the 'IOException' was raised within the action. -usingResource :: (MonadComp m, EnqueueStrategy m s)+usingResource :: (MonadDES m, EnqueueStrategy m s)                  => Resource m s                  -- ^ the resource we are going to request for and then release in the end                  -> Process m a                  -- ^ the action we are going to apply having the resource                  -> Process m a                  -- ^ the result of the action+{-# INLINABLE usingResource #-} usingResource r m =   do requestResource r      finallyProcess m $ releaseResource r@@ -332,7 +352,7 @@ -- | Acquire the resource with the specified priority, perform some action and -- safely release the resource in the end, even if the 'IOException' was raised -- within the action.-usingResourceWithPriority :: (MonadComp m, PriorityQueueStrategy m s p)+usingResourceWithPriority :: (MonadDES m, PriorityQueueStrategy m s p)                              => Resource m s                              -- ^ the resource we are going to request for and then                              -- release in the end@@ -342,6 +362,39 @@                              -- ^ the action we are going to apply having the resource                              -> Process m a                              -- ^ the result of the action+{-# INLINABLE usingResourceWithPriority #-} usingResourceWithPriority r priority m =   do requestResourceWithPriority r priority      finallyProcess m $ releaseResource r++-- | Increase the count of available resource by the specified number,+-- invoking the awaiting processes as needed.+incResourceCount :: (MonadDES m, DequeueStrategy m s)+                    => Resource m s+                    -- ^ the resource+                    -> Int+                    -- ^ the increment for the resource count+                    -> Event m ()+{-# INLINABLE incResourceCount #-}+incResourceCount r n+  | n < 0     = error "The increment cannot be negative: incResourceCount"+  | n == 0    = return ()+  | otherwise =+    do releaseResourceWithinEvent r+       incResourceCount r (n - 1)++-- | Decrease the count of available resource by the specified number,+-- waiting for the processes capturing the resource as needed.+decResourceCount :: (MonadDES m, EnqueueStrategy m s)+                    => Resource m s+                    -- ^ the resource+                    -> Int+                    -- ^ the decrement for the resource count+                    -> Process m ()+{-# INLINABLE decResourceCount #-}+decResourceCount r n+  | n < 0     = error "The decrement cannot be negative: decResourceCount"+  | n == 0    = return ()+  | otherwise =+    do requestResource r+       decResourceCount r (n - 1)
+ Simulation/Aivika/Trans/Resource/Preemption.hs view
@@ -0,0 +1,105 @@++{-# LANGUAGE TypeFamilies #-}++-- |+-- Module     : Simulation.Aivika.Trans.Resource.Preemption+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- This module defines the preemptible resource.+--+module Simulation.Aivika.Trans.Resource.Preemption (MonadResource(..)) where++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Internal.Simulation+import Simulation.Aivika.Trans.Internal.Event+import Simulation.Aivika.Trans.Internal.Process++-- | A type class of monads whithin which we can create preemptible resources.+class MonadDES m => MonadResource m where++  -- | Represents a preemptible resource.+  data Resource m ++  -- | Create a new resource with the specified initial count that becomes the upper bound as well.+  newResource :: Int+                 -- ^ the initial count (and maximal count too) of the resource+                 -> Simulation m (Resource m)++  -- | Create a new resource with the specified initial and maximum counts,+  -- where 'Nothing' means that the resource has no upper bound.+  newResourceWithMaxCount :: Int+                             -- ^ the initial count of the resource+                             -> Maybe Int+                             -- ^ the maximum count of the resource, which can be indefinite+                             -> Simulation m (Resource m)++  -- | Return the current count of the resource.+  resourceCount :: Resource m -> Event m Int+  +  -- | Return the maximum count of the resource, where 'Nothing'+  -- means that the resource has no upper bound.+  resourceMaxCount :: Resource m -> Maybe Int+             +  -- | Request with the priority for the resource decreasing its count+  -- in case of success, otherwise suspending the discontinuous process+  -- until some other process releases the resource.+  --+  -- It may preempt another process if the latter aquired the resource before+  -- but had a lower priority. Then the current process takes an ownership of+  -- the resource.+  requestResourceWithPriority :: Resource m+                                 -- ^ the requested resource+                                 -> Double+                                 -- ^ the priority (the less value has a higher priority)+                                 -> Process m ()++  -- | Release the resource increasing its count and resuming one of the+  -- previously suspended or preempted processes as possible.+  releaseResource :: Resource m+                     -- ^ the resource to release+                     -> Process m ()++  -- | Acquire the resource with the specified priority, perform some action and+  -- safely release the resource in the end, even if the 'IOException' was raised+  -- within the action.+  usingResourceWithPriority :: Resource m+                               -- ^ the resource we are going to request for and then+                               -- release in the end+                               -> Double+                               -- ^ the priority (the less value has a higher priority)+                               -> Process m a+                               -- ^ the action we are going to apply having the resource+                               -> Process m a+                               -- ^ the result of the action++  -- | Increase the count of available resource by the specified number,+  -- invoking the awaiting and preempted processes according to their priorities+  -- as needed.+  incResourceCount :: Resource m+                      -- ^ the resource+                      -> Int+                      -- ^ the increment for the resource count+                      -> Event m ()++  -- | Decrease the count of available resource by the specified number,+  -- preempting the processes according to their priorities as needed.+  decResourceCount :: Resource m+                      -- ^ the resource+                      -> Int+                      -- ^ the decrement for the resource count+                      -> Event m ()++  -- | Alter the resource count either increasing or decreasing it by calling+  -- 'incResourceCount' or 'decResourceCount' respectively. +  alterResourceCount :: Resource m+                        -- ^ the resource+                        -> Int+                        -- ^ a change of the resource count+                        -> Event m ()
Simulation/Aivika/Trans/Results.hs view
@@ -3,11 +3,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Results--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The module allows exporting the simulation results from the model. --@@ -32,18 +32,18 @@         ResultVectorWithSubscript(..), #endif         -- * Definitions Focused on Using the Library-        ResultExtract(..),-        extractIntResults,-        extractIntListResults,-        extractIntStatsResults,-        extractIntStatsEitherResults,-        extractIntTimingStatsResults,-        extractDoubleResults,-        extractDoubleListResults,-        extractDoubleStatsResults,-        extractDoubleStatsEitherResults,-        extractDoubleTimingStatsResults,-        extractStringResults,+        ResultValue(..),+        resultsToIntValues,+        resultsToIntListValues,+        resultsToIntStatsValues,+        resultsToIntStatsEitherValues,+        resultsToIntTimingStatsValues,+        resultsToDoubleValues,+        resultsToDoubleListValues,+        resultsToDoubleStatsValues,+        resultsToDoubleStatsEitherValues,+        resultsToDoubleTimingStatsValues,+        resultsToStringValues,         ResultPredefinedSignals(..),         newResultPredefinedSignals,         resultSignal,@@ -53,16 +53,25 @@         ResultSource(..),         ResultItem(..),         ResultItemable(..),+        resultItemAsIntStatsEitherValue,+        resultItemAsDoubleStatsEitherValue,+        resultItemToIntValue,+        resultItemToIntListValue,+        resultItemToIntStatsValue,         resultItemToIntStatsEitherValue,+        resultItemToIntTimingStatsValue,+        resultItemToDoubleValue,+        resultItemToDoubleListValue,+        resultItemToDoubleStatsValue,         resultItemToDoubleStatsEitherValue,+        resultItemToDoubleTimingStatsValue,+        resultItemToStringValue,         ResultObject(..),         ResultProperty(..),         ResultVector(..),         memoResultVectorSignal,         memoResultVectorSummary,         ResultSeparator(..),-        ResultValue(..),-        voidResultValue,         ResultContainer(..),         resultContainerPropertySource,         resultContainerConstProperty,@@ -89,17 +98,6 @@         resultSourceToStringValues,         resultSourceMap,         resultSourceList,-        resultsToIntValues,-        resultsToIntListValues,-        resultsToIntStatsValues,-        resultsToIntStatsEitherValues,-        resultsToIntTimingStatsValues,-        resultsToDoubleValues,-        resultsToDoubleListValues,-        resultsToDoubleStatsValues,-        resultsToDoubleStatsEitherValues,-        resultsToDoubleTimingStatsValues,-        resultsToStringValues,         composeResults,         computeResultValue) where @@ -117,7 +115,6 @@ import Data.Maybe import Data.Monoid -import Simulation.Aivika.Trans.Comp import Simulation.Aivika.Trans.Parameter import Simulation.Aivika.Trans.Simulation import Simulation.Aivika.Trans.Dynamics@@ -126,7 +123,7 @@ import Simulation.Aivika.Trans.Statistics import Simulation.Aivika.Trans.Statistics.Accumulator import Simulation.Aivika.Trans.Ref-import qualified Simulation.Aivika.Trans.Ref.Plain as LR+import qualified Simulation.Aivika.Trans.Ref.Base as B import Simulation.Aivika.Trans.Var import Simulation.Aivika.Trans.QueueStrategy import qualified Simulation.Aivika.Trans.Queue as Q@@ -135,13 +132,15 @@ import Simulation.Aivika.Trans.Server import Simulation.Aivika.Trans.Activity import Simulation.Aivika.Trans.Results.Locale+import Simulation.Aivika.Trans.SD+import Simulation.Aivika.Trans.DES  -- | A name used for indentifying the results when generating output. type ResultName = String  -- | Represents a provider of the simulation results. It is usually something, or -- an array of something, or a list of such values which can be simulated to get data.-class MonadComp m => ResultProvider p m | p -> m where+class MonadDES m => ResultProvider p m | p -> m where      -- | Return the source of simulation results by the specified name, description and provider.    resultSource :: ResultName -> ResultDescription -> p -> ResultSource m@@ -176,73 +175,183 @@   resultItemId :: a m -> ResultId    -- | Whether the item emits a signal.-  resultItemSignal :: MonadComp m => a m -> ResultSignal m+  resultItemSignal :: MonadDES m => a m -> ResultSignal m    -- | Return an expanded version of the item, for example,   -- when the statistics item is exanded to an object   -- having the corresponded properties for count, average,   -- deviation, minimum, maximum and so on.-  resultItemExpansion :: MonadComp m => a m -> ResultSource m+  resultItemExpansion :: MonadDES m => a m -> ResultSource m      -- | Return usually a short version of the item, i.e. its summary,   -- but values of some data types such as statistics can be   -- implicitly expanded to an object with the corresponded   -- properties.-  resultItemSummary :: MonadComp m => a m -> ResultSource m+  resultItemSummary :: MonadDES m => a m -> ResultSource m   -  -- | Return integer numbers in time points.-  resultItemToIntValue :: MonadComp m => a m -> ResultValue Int m+  -- | Try to return integer numbers in time points.+  resultItemAsIntValue :: MonadDES m => a m -> Maybe (ResultValue Int m) -  -- | Return lists of integer numbers in time points. -  resultItemToIntListValue :: MonadComp m => a m -> ResultValue [Int] m+  -- | Try to return lists of integer numbers in time points. +  resultItemAsIntListValue :: MonadDES m => a m -> Maybe (ResultValue [Int] m) -  -- | Return statistics based on integer numbers.-  resultItemToIntStatsValue :: MonadComp m => a m -> ResultValue (SamplingStats Int) m+  -- | Try to return statistics based on integer numbers.+  resultItemAsIntStatsValue :: MonadDES m => a m -> Maybe (ResultValue (SamplingStats Int) m) -  -- | Return timing statistics based on integer numbers.-  resultItemToIntTimingStatsValue :: MonadComp m => a m -> ResultValue (TimingStats Int) m+  -- | Try to return timing statistics based on integer numbers.+  resultItemAsIntTimingStatsValue :: MonadDES m => a m -> Maybe (ResultValue (TimingStats Int) m) -  -- | Return double numbers in time points.-  resultItemToDoubleValue :: MonadComp m => a m -> ResultValue Double m+  -- | Try to return double numbers in time points.+  resultItemAsDoubleValue :: MonadDES m => a m -> Maybe (ResultValue Double m)   -  -- | Return lists of double numbers in time points. -  resultItemToDoubleListValue :: MonadComp m => a m -> ResultValue [Double] m+  -- | Try to return lists of double numbers in time points. +  resultItemAsDoubleListValue :: MonadDES m => a m -> Maybe (ResultValue [Double] m) -  -- | Return statistics based on double numbers.-  resultItemToDoubleStatsValue :: MonadComp m => a m -> ResultValue (SamplingStats Double) m+  -- | Try to return statistics based on double numbers.+  resultItemAsDoubleStatsValue :: MonadDES m => a m -> Maybe (ResultValue (SamplingStats Double) m) -  -- | Return timing statistics based on integer numbers.-  resultItemToDoubleTimingStatsValue :: MonadComp m => a m -> ResultValue (TimingStats Double) m+  -- | Try to return timing statistics based on integer numbers.+  resultItemAsDoubleTimingStatsValue :: MonadDES m => a m -> Maybe (ResultValue (TimingStats Double) m) -  -- | Return string representations in time points.-  resultItemToStringValue :: MonadComp m => a m -> ResultValue String m+  -- | Try to return string representations in time points.+  resultItemAsStringValue :: MonadDES m => a m -> Maybe (ResultValue String m) +-- | Try to return a version optimised for fast aggregation of the statistics based on integer numbers.+resultItemAsIntStatsEitherValue :: (MonadDES m, ResultItemable a) => a m -> Maybe (ResultValue (Either Int (SamplingStats Int)) m)+resultItemAsIntStatsEitherValue x =+  case x1 of+    Just a1 -> Just $ mapResultValue Left a1+    Nothing ->+      case x2 of+        Just a2 -> Just $ mapResultValue Right a2+        Nothing -> Nothing+  where+    x1 = resultItemAsIntValue x+    x2 = resultItemAsIntStatsValue x++-- | Try to return a version optimised for fast aggregation of the statistics based on double floating point numbers.+resultItemAsDoubleStatsEitherValue :: (MonadDES m, ResultItemable a) => a m -> Maybe (ResultValue (Either Double (SamplingStats Double)) m)+resultItemAsDoubleStatsEitherValue x =+  case x1 of+    Just a1 -> Just $ mapResultValue Left a1+    Nothing ->+      case x2 of+        Just a2 -> Just $ mapResultValue Right a2+        Nothing -> Nothing+  where+    x1 = resultItemAsDoubleValue x+    x2 = resultItemAsDoubleStatsValue x++-- | Return integer numbers in time points.+resultItemToIntValue :: (MonadDES m, ResultItemable a) => a m -> ResultValue Int m+resultItemToIntValue x =+  case resultItemAsIntValue x of+    Just a -> a+    Nothing ->+      error $+      "Cannot represent " ++ resultItemName x +++      " as a source of integer numbers: resultItemToIntValue"++-- | Return lists of integer numbers in time points. +resultItemToIntListValue :: (MonadDES m, ResultItemable a) => a m -> ResultValue [Int] m+resultItemToIntListValue x =+  case resultItemAsIntListValue x of+    Just a -> a+    Nothing ->+      error $+      "Cannot represent " ++ resultItemName x +++      " as a source of lists of integer numbers: resultItemToIntListValue"++-- | Return statistics based on integer numbers.+resultItemToIntStatsValue :: (MonadDES m, ResultItemable a) => a m -> ResultValue (SamplingStats Int) m+resultItemToIntStatsValue x =+  case resultItemAsIntStatsValue x of+    Just a -> a+    Nothing ->+      error $+      "Cannot represent " ++ resultItemName x +++      " as a source of statistics based on integer numbers: resultItemToIntStatsValue"+ -- | Return a version optimised for fast aggregation of the statistics based on integer numbers.-resultItemToIntStatsEitherValue :: (MonadComp m, ResultItemable a) => a m -> ResultValue (Either Int (SamplingStats Int)) m+resultItemToIntStatsEitherValue :: (MonadDES m, ResultItemable a) => a m -> ResultValue (Either Int (SamplingStats Int)) m resultItemToIntStatsEitherValue x =-  case resultValueData x1 of-    Just a1 -> mapResultValue Left x1+  case resultItemAsIntStatsEitherValue x of+    Just a -> a     Nothing ->-      case resultValueData x2 of-        Just a2 -> mapResultValue Right x2-        Nothing -> voidResultValue x2-  where-    x1 = resultItemToIntValue x-    x2 = resultItemToIntStatsValue x+      error $+      "Cannot represent " ++ resultItemName x +++      " as an optimised source of statistics based on integer numbers: resultItemToIntStatsEitherValue" +-- | Return timing statistics based on integer numbers.+resultItemToIntTimingStatsValue :: (MonadDES m, ResultItemable a) => a m -> ResultValue (TimingStats Int) m+resultItemToIntTimingStatsValue x =+  case resultItemAsIntTimingStatsValue x of+    Just a -> a+    Nothing ->+      error $+      "Cannot represent " ++ resultItemName x +++      " as a source of timing statistics based on integer numbers: resultItemToIntTimingStatsValue"++-- | Return double numbers in time points.+resultItemToDoubleValue :: (MonadDES m, ResultItemable a) => a m -> ResultValue Double m+resultItemToDoubleValue x =+  case resultItemAsDoubleValue x of+    Just a -> a+    Nothing ->+      error $+      "Cannot represent " ++ resultItemName x +++      " as a source of double-precision floating-point numbers: resultItemToDoubleValue"+  +-- | Return lists of double numbers in time points. +resultItemToDoubleListValue :: (MonadDES m, ResultItemable a) => a m -> ResultValue [Double] m+resultItemToDoubleListValue x =+  case resultItemAsDoubleListValue x of+    Just a -> a+    Nothing ->+      error $+      "Cannot represent " ++ resultItemName x +++      " as a source of lists of double-precision floating-point numbers: resultItemToDoubleListValue"++-- | Return statistics based on double numbers.+resultItemToDoubleStatsValue :: (MonadDES m, ResultItemable a) => a m -> ResultValue (SamplingStats Double) m+resultItemToDoubleStatsValue x =+  case resultItemAsDoubleStatsValue x of+    Just a -> a+    Nothing ->+      error $+      "Cannot represent " ++ resultItemName x +++      " as a source of statistics based on double-precision floating-point numbers: resultItemToDoubleStatsValue"+ -- | Return a version optimised for fast aggregation of the statistics based on double floating point numbers.-resultItemToDoubleStatsEitherValue :: (MonadComp m, ResultItemable a) => a m -> ResultValue (Either Double (SamplingStats Double)) m+resultItemToDoubleStatsEitherValue :: (MonadDES m, ResultItemable a) => a m -> ResultValue (Either Double (SamplingStats Double)) m resultItemToDoubleStatsEitherValue x =-  case resultValueData x1 of-    Just a1 -> mapResultValue Left x1+  case resultItemAsDoubleStatsEitherValue x of+    Just a -> a     Nothing ->-      case resultValueData x2 of-        Just a2 -> mapResultValue Right x2-        Nothing -> voidResultValue x2-  where-    x1 = resultItemToDoubleValue x-    x2 = resultItemToDoubleStatsValue x+      error $+      "Cannot represent " ++ resultItemName x +++      " as an optimised source of statistics based on double-precision floating-point numbers: resultItemToDoubleStatsEitherValue" +-- | Return timing statistics based on integer numbers.+resultItemToDoubleTimingStatsValue :: (MonadDES m, ResultItemable a) => a m -> ResultValue (TimingStats Double) m+resultItemToDoubleTimingStatsValue x =+  case resultItemAsDoubleTimingStatsValue x of+    Just a -> a+    Nothing ->+      error $+      "Cannot represent " ++ resultItemName x +++      " as a source of timing statistics based on double-precision floating-point numbers: resultItemToDoubleTimingStatsValue"++-- | Return string representations in time points.+resultItemToStringValue :: (MonadDES m, ResultItemable a) => a m -> ResultValue String m+resultItemToStringValue x =+  case resultItemAsStringValue x of+    Just a -> a+    Nothing ->+      error $+      "Cannot represent " ++ resultItemName x +++      " as a source of strings: resultItemToStringValue"+ -- | The simulation results represented by an object having properties. data ResultObject m =   ResultObject { resultObjectName :: ResultName,@@ -286,13 +395,13 @@                }  -- | Calculate the result vector signal and memoize it in a new vector.-memoResultVectorSignal :: MonadComp m => ResultVector m -> ResultVector m+memoResultVectorSignal :: MonadDES m => ResultVector m -> ResultVector m memoResultVectorSignal x =   x { resultVectorSignal =          foldr (<>) mempty $ map resultSourceSignal $ A.elems $ resultVectorItems x }  -- | Calculate the result vector summary and memoize it in a new vector.-memoResultVectorSummary :: MonadComp m => ResultVector m -> ResultVector m+memoResultVectorSummary :: MonadDES m => ResultVector m -> ResultVector m memoResultVectorSummary x =   x { resultVectorSummary =          ResultVectorSource $@@ -321,12 +430,13 @@                 -- ^ Whether the value emits a signal when changing simulation data.               } -mapResultValue :: MonadComp m => (a -> b) -> ResultValue a m -> ResultValue b m-mapResultValue f x = x { resultValueData = fmap (fmap f) (resultValueData x) }+-- | Map the result value according the specfied function.+mapResultValue :: MonadDES m => (a -> b) -> ResultValue a m -> ResultValue b m+mapResultValue f x = x { resultValueData = fmap f (resultValueData x) } --- | Return a new value with the discarded simulation results.-voidResultValue :: ResultValue a m -> ResultValue b m-voidResultValue x = x { resultValueData = Nothing }+-- | Transform the result value.+apResultValue :: MonadDES m => ResultData (a -> b) m -> ResultValue a m -> ResultValue b m+apResultValue f x = x { resultValueData = ap f (resultValueData x) }  -- | A container of the simulation results such as queue, server or array. data ResultContainer e m =@@ -366,7 +476,7 @@     resultValueSignal = g (resultContainerData cont) }  -- | Create a constant property by the specified container.-resultContainerConstProperty :: (MonadComp m,+resultContainerConstProperty :: (MonadDES m,                                  ResultItemable (ResultValue b))                                 => ResultContainer a m                                 -- ^ the container@@ -382,10 +492,10 @@     resultPropertyLabel = name,     resultPropertyId = i,     resultPropertySource =-      resultContainerPropertySource cont name i (Just . return . f) (const EmptyResultSignal) }+      resultContainerPropertySource cont name i (return . f) (const EmptyResultSignal) }    -- | Create by the specified container a property that changes in the integration time points, or it is supposed to be such one.-resultContainerIntegProperty :: (MonadComp m,+resultContainerIntegProperty :: (MonadDES m,                                  ResultItemable (ResultValue b))                                 => ResultContainer a m                                 -- ^ the container@@ -401,10 +511,10 @@     resultPropertyLabel = name,     resultPropertyId = i,     resultPropertySource =-      resultContainerPropertySource cont name i (Just . f) (const UnknownResultSignal) }+      resultContainerPropertySource cont name i f (const UnknownResultSignal) }    -- | Create a property by the specified container.-resultContainerProperty :: (MonadComp m,+resultContainerProperty :: (MonadDES m,                             ResultItemable (ResultValue b))                            => ResultContainer a m                            -- ^ the container@@ -422,10 +532,10 @@     resultPropertyLabel = name,     resultPropertyId = i,     resultPropertySource =-      resultContainerPropertySource cont name i (Just . f) (ResultSignal . g) }+      resultContainerPropertySource cont name i f (ResultSignal . g) }  -- | Create by the specified container a mapped property which is recomputed each time again and again.-resultContainerMapProperty :: (MonadComp m,+resultContainerMapProperty :: (MonadDES m,                                ResultItemable (ResultValue b))                               => ResultContainer (ResultData a m) m                               -- ^ the container@@ -441,7 +551,7 @@     resultPropertyLabel = name,     resultPropertyId = i,     resultPropertySource =-      resultContainerPropertySource cont name i (fmap $ fmap f) (const $ resultContainerSignal cont) }+      resultContainerPropertySource cont name i (fmap f) (const $ resultContainerSignal cont) }  -- | Convert the result value to a container with the specified object identifier.  resultValueToContainer :: ResultValue a m -> ResultContainer (ResultData a m) m@@ -462,8 +572,14 @@     resultValueSignal = resultContainerSignal x }  -- | Represents the very simulation results.-type ResultData e m = Maybe (Event m e)+type ResultData e m = Event m e +-- | Convert the timing statistics data to its normalised sampling-based representation.+normTimingStatsData :: (TimingData a, Monad m) => ResultData (TimingStats a -> SamplingStats a) m+normTimingStatsData =+  do n <- liftDynamics integIteration+     return $ normTimingStats (fromIntegral n)+ -- | Whether an object containing the results emits a signal notifying about change of data. data ResultSignal m = EmptyResultSignal                       -- ^ There is no signal at all.@@ -474,7 +590,7 @@                     | ResultSignalMix (Signal m ())                       -- ^ When the specified signal was combined with unknown signal. -instance MonadComp m => Monoid (ResultSignal m) where+instance MonadDES m => Monoid (ResultSignal m) where    mempty = EmptyResultSignal @@ -506,17 +622,17 @@   resultItemId = resultValueId   resultItemSignal = resultValueSignal   -  resultItemToIntValue = id-  resultItemToIntListValue = mapResultValue return-  resultItemToIntStatsValue = mapResultValue returnSamplingStats-  resultItemToIntTimingStatsValue = voidResultValue+  resultItemAsIntValue = Just+  resultItemAsIntListValue = Just . mapResultValue return+  resultItemAsIntStatsValue = Just . mapResultValue returnSamplingStats+  resultItemAsIntTimingStatsValue = const Nothing -  resultItemToDoubleValue = mapResultValue fromIntegral-  resultItemToDoubleListValue = mapResultValue (return . fromIntegral)-  resultItemToDoubleStatsValue = mapResultValue (returnSamplingStats . fromIntegral)-  resultItemToDoubleTimingStatsValue = voidResultValue+  resultItemAsDoubleValue = Just . mapResultValue fromIntegral+  resultItemAsDoubleListValue = Just . mapResultValue (return . fromIntegral)+  resultItemAsDoubleStatsValue = Just . mapResultValue (returnSamplingStats . fromIntegral)+  resultItemAsDoubleTimingStatsValue = const Nothing -  resultItemToStringValue = mapResultValue show+  resultItemAsStringValue = Just . mapResultValue show    resultItemExpansion = ResultItemSource . ResultItem   resultItemSummary = ResultItemSource . ResultItem@@ -527,17 +643,17 @@   resultItemId = resultValueId   resultItemSignal = resultValueSignal   -  resultItemToIntValue = voidResultValue-  resultItemToIntListValue = voidResultValue-  resultItemToIntStatsValue = voidResultValue-  resultItemToIntTimingStatsValue = voidResultValue+  resultItemAsIntValue = const Nothing+  resultItemAsIntListValue = const Nothing+  resultItemAsIntStatsValue = const Nothing+  resultItemAsIntTimingStatsValue = const Nothing   -  resultItemToDoubleValue = id-  resultItemToDoubleListValue = mapResultValue return-  resultItemToDoubleStatsValue = mapResultValue returnSamplingStats-  resultItemToDoubleTimingStatsValue = voidResultValue+  resultItemAsDoubleValue = Just+  resultItemAsDoubleListValue = Just . mapResultValue return+  resultItemAsDoubleStatsValue = Just . mapResultValue returnSamplingStats+  resultItemAsDoubleTimingStatsValue = const Nothing -  resultItemToStringValue = mapResultValue show+  resultItemAsStringValue = Just . mapResultValue show      resultItemExpansion = ResultItemSource . ResultItem   resultItemSummary = ResultItemSource . ResultItem@@ -548,17 +664,17 @@   resultItemId = resultValueId   resultItemSignal = resultValueSignal   -  resultItemToIntValue = voidResultValue-  resultItemToIntListValue = id-  resultItemToIntStatsValue = mapResultValue listSamplingStats-  resultItemToIntTimingStatsValue = voidResultValue+  resultItemAsIntValue = const Nothing+  resultItemAsIntListValue = Just+  resultItemAsIntStatsValue = Just . mapResultValue listSamplingStats+  resultItemAsIntTimingStatsValue = const Nothing -  resultItemToDoubleValue = voidResultValue-  resultItemToDoubleListValue = mapResultValue (map fromIntegral)-  resultItemToDoubleStatsValue = mapResultValue (fromIntSamplingStats . listSamplingStats)-  resultItemToDoubleTimingStatsValue = voidResultValue+  resultItemAsDoubleValue = const Nothing+  resultItemAsDoubleListValue = Just . mapResultValue (map fromIntegral)+  resultItemAsDoubleStatsValue = Just . mapResultValue (fromIntSamplingStats . listSamplingStats)+  resultItemAsDoubleTimingStatsValue = const Nothing -  resultItemToStringValue = mapResultValue show+  resultItemAsStringValue = Just . mapResultValue show      resultItemExpansion = ResultItemSource . ResultItem   resultItemSummary = ResultItemSource . ResultItem@@ -569,17 +685,17 @@   resultItemId = resultValueId   resultItemSignal = resultValueSignal   -  resultItemToIntValue = voidResultValue-  resultItemToIntListValue = voidResultValue-  resultItemToIntStatsValue = voidResultValue-  resultItemToIntTimingStatsValue = voidResultValue+  resultItemAsIntValue = const Nothing+  resultItemAsIntListValue = const Nothing+  resultItemAsIntStatsValue = const Nothing+  resultItemAsIntTimingStatsValue = const Nothing   -  resultItemToDoubleValue = voidResultValue-  resultItemToDoubleListValue = id-  resultItemToDoubleStatsValue = mapResultValue listSamplingStats-  resultItemToDoubleTimingStatsValue = voidResultValue+  resultItemAsDoubleValue = const Nothing+  resultItemAsDoubleListValue = Just+  resultItemAsDoubleStatsValue = Just . mapResultValue listSamplingStats+  resultItemAsDoubleTimingStatsValue = const Nothing -  resultItemToStringValue = mapResultValue show+  resultItemAsStringValue = Just . mapResultValue show      resultItemExpansion = ResultItemSource . ResultItem   resultItemSummary = ResultItemSource . ResultItem@@ -590,17 +706,17 @@   resultItemId = resultValueId   resultItemSignal = resultValueSignal   -  resultItemToIntValue = voidResultValue-  resultItemToIntListValue = voidResultValue-  resultItemToIntStatsValue = id-  resultItemToIntTimingStatsValue = voidResultValue+  resultItemAsIntValue = const Nothing+  resultItemAsIntListValue = const Nothing+  resultItemAsIntStatsValue = Just+  resultItemAsIntTimingStatsValue = const Nothing -  resultItemToDoubleValue = voidResultValue-  resultItemToDoubleListValue = voidResultValue-  resultItemToDoubleStatsValue = mapResultValue fromIntSamplingStats-  resultItemToDoubleTimingStatsValue = voidResultValue+  resultItemAsDoubleValue = const Nothing+  resultItemAsDoubleListValue = const Nothing+  resultItemAsDoubleStatsValue = Just . mapResultValue fromIntSamplingStats+  resultItemAsDoubleTimingStatsValue = const Nothing -  resultItemToStringValue = mapResultValue show+  resultItemAsStringValue = Just . mapResultValue show      resultItemExpansion = samplingStatsResultSource   resultItemSummary = samplingStatsResultSummary@@ -611,17 +727,17 @@   resultItemId = resultValueId   resultItemSignal = resultValueSignal   -  resultItemToIntValue = voidResultValue-  resultItemToIntListValue = voidResultValue-  resultItemToIntStatsValue = voidResultValue-  resultItemToIntTimingStatsValue = voidResultValue+  resultItemAsIntValue = const Nothing+  resultItemAsIntListValue = const Nothing+  resultItemAsIntStatsValue = const Nothing+  resultItemAsIntTimingStatsValue = const Nothing   -  resultItemToDoubleValue = voidResultValue-  resultItemToDoubleListValue = voidResultValue-  resultItemToDoubleStatsValue = id-  resultItemToDoubleTimingStatsValue = voidResultValue+  resultItemAsDoubleValue = const Nothing+  resultItemAsDoubleListValue = const Nothing+  resultItemAsDoubleStatsValue = Just+  resultItemAsDoubleTimingStatsValue = const Nothing -  resultItemToStringValue = mapResultValue show+  resultItemAsStringValue = Just . mapResultValue show      resultItemExpansion = samplingStatsResultSource   resultItemSummary = samplingStatsResultSummary@@ -632,17 +748,17 @@   resultItemId = resultValueId   resultItemSignal = resultValueSignal   -  resultItemToIntValue = voidResultValue-  resultItemToIntListValue = voidResultValue-  resultItemToIntStatsValue = voidResultValue-  resultItemToIntTimingStatsValue = id+  resultItemAsIntValue = const Nothing+  resultItemAsIntListValue = const Nothing+  resultItemAsIntStatsValue = Just . apResultValue normTimingStatsData+  resultItemAsIntTimingStatsValue = Just -  resultItemToDoubleValue = voidResultValue-  resultItemToDoubleListValue = voidResultValue-  resultItemToDoubleStatsValue = voidResultValue-  resultItemToDoubleTimingStatsValue = mapResultValue fromIntTimingStats+  resultItemAsDoubleValue = const Nothing+  resultItemAsDoubleListValue = const Nothing+  resultItemAsDoubleStatsValue = Just . mapResultValue fromIntSamplingStats . apResultValue normTimingStatsData+  resultItemAsDoubleTimingStatsValue = Just . mapResultValue fromIntTimingStats -  resultItemToStringValue = mapResultValue show+  resultItemAsStringValue = Just . mapResultValue show      resultItemExpansion = timingStatsResultSource   resultItemSummary = timingStatsResultSummary@@ -653,17 +769,17 @@   resultItemId = resultValueId   resultItemSignal = resultValueSignal   -  resultItemToIntValue = voidResultValue-  resultItemToIntListValue = voidResultValue-  resultItemToIntStatsValue = voidResultValue-  resultItemToIntTimingStatsValue = voidResultValue+  resultItemAsIntValue = const Nothing+  resultItemAsIntListValue = const Nothing+  resultItemAsIntStatsValue = const Nothing+  resultItemAsIntTimingStatsValue = const Nothing -  resultItemToDoubleValue = voidResultValue-  resultItemToDoubleListValue = voidResultValue-  resultItemToDoubleStatsValue = voidResultValue-  resultItemToDoubleTimingStatsValue = id+  resultItemAsDoubleValue = const Nothing+  resultItemAsDoubleListValue = const Nothing+  resultItemAsDoubleStatsValue = Just . apResultValue normTimingStatsData+  resultItemAsDoubleTimingStatsValue = Just -  resultItemToStringValue = mapResultValue show+  resultItemAsStringValue = Just . mapResultValue show      resultItemExpansion = timingStatsResultSource   resultItemSummary = timingStatsResultSummary@@ -674,17 +790,17 @@   resultItemId = resultValueId   resultItemSignal = resultValueSignal   -  resultItemToIntValue = voidResultValue-  resultItemToIntListValue = voidResultValue-  resultItemToIntStatsValue = voidResultValue-  resultItemToIntTimingStatsValue = voidResultValue+  resultItemAsIntValue = const Nothing+  resultItemAsIntListValue = const Nothing+  resultItemAsIntStatsValue = const Nothing+  resultItemAsIntTimingStatsValue = const Nothing -  resultItemToDoubleValue = voidResultValue-  resultItemToDoubleListValue = voidResultValue-  resultItemToDoubleStatsValue = voidResultValue-  resultItemToDoubleTimingStatsValue = voidResultValue+  resultItemAsDoubleValue = const Nothing+  resultItemAsDoubleListValue = const Nothing+  resultItemAsDoubleStatsValue = const Nothing+  resultItemAsDoubleTimingStatsValue = const Nothing -  resultItemToStringValue = mapResultValue show+  resultItemAsStringValue = Just . mapResultValue show    resultItemExpansion = ResultItemSource . ResultItem   resultItemSummary = ResultItemSource . ResultItem@@ -695,17 +811,17 @@   resultItemId = resultValueId   resultItemSignal = resultValueSignal   -  resultItemToIntValue = voidResultValue-  resultItemToIntListValue = voidResultValue-  resultItemToIntStatsValue = voidResultValue-  resultItemToIntTimingStatsValue = voidResultValue+  resultItemAsIntValue = const Nothing+  resultItemAsIntListValue = const Nothing+  resultItemAsIntStatsValue = const Nothing+  resultItemAsIntTimingStatsValue = const Nothing -  resultItemToDoubleValue = voidResultValue-  resultItemToDoubleListValue = voidResultValue-  resultItemToDoubleStatsValue = voidResultValue-  resultItemToDoubleTimingStatsValue = voidResultValue+  resultItemAsDoubleValue = const Nothing+  resultItemAsDoubleListValue = const Nothing+  resultItemAsDoubleStatsValue = const Nothing+  resultItemAsDoubleTimingStatsValue = const Nothing -  resultItemToStringValue = id+  resultItemAsStringValue = Just    resultItemExpansion = ResultItemSource . ResultItem   resultItemSummary = ResultItemSource . ResultItem@@ -716,17 +832,17 @@   resultItemId = resultValueId   resultItemSignal = resultValueSignal   -  resultItemToIntValue = voidResultValue-  resultItemToIntListValue = voidResultValue-  resultItemToIntStatsValue = voidResultValue-  resultItemToIntTimingStatsValue = voidResultValue+  resultItemAsIntValue = const Nothing+  resultItemAsIntListValue = const Nothing+  resultItemAsIntStatsValue = const Nothing+  resultItemAsIntTimingStatsValue = const Nothing -  resultItemToDoubleValue = voidResultValue-  resultItemToDoubleListValue = voidResultValue-  resultItemToDoubleStatsValue = voidResultValue-  resultItemToDoubleTimingStatsValue = voidResultValue+  resultItemAsDoubleValue = const Nothing+  resultItemAsDoubleListValue = const Nothing+  resultItemAsDoubleStatsValue = const Nothing+  resultItemAsDoubleTimingStatsValue = const Nothing -  resultItemToStringValue = mapResultValue show+  resultItemAsStringValue = Just . mapResultValue show    resultItemExpansion = ResultItemSource . ResultItem   resultItemSummary = ResultItemSource . ResultItem@@ -737,17 +853,17 @@   resultItemId = resultValueId   resultItemSignal = resultValueSignal   -  resultItemToIntValue = voidResultValue-  resultItemToIntListValue = voidResultValue-  resultItemToIntStatsValue = voidResultValue-  resultItemToIntTimingStatsValue = voidResultValue+  resultItemAsIntValue = const Nothing+  resultItemAsIntListValue = const Nothing+  resultItemAsIntStatsValue = const Nothing+  resultItemAsIntTimingStatsValue = const Nothing -  resultItemToDoubleValue = voidResultValue-  resultItemToDoubleListValue = voidResultValue-  resultItemToDoubleStatsValue = voidResultValue-  resultItemToDoubleTimingStatsValue = voidResultValue+  resultItemAsDoubleValue = const Nothing+  resultItemAsDoubleListValue = const Nothing+  resultItemAsDoubleStatsValue = const Nothing+  resultItemAsDoubleTimingStatsValue = const Nothing -  resultItemToStringValue = mapResultValue show+  resultItemAsStringValue = Just . mapResultValue show    resultItemExpansion = ResultItemSource . ResultItem   resultItemSummary = ResultItemSource . ResultItem@@ -758,17 +874,17 @@   resultItemId = resultValueId   resultItemSignal = resultValueSignal   -  resultItemToIntValue = voidResultValue-  resultItemToIntListValue = voidResultValue-  resultItemToIntStatsValue = voidResultValue-  resultItemToIntTimingStatsValue = voidResultValue+  resultItemAsIntValue = const Nothing+  resultItemAsIntListValue = const Nothing+  resultItemAsIntStatsValue = const Nothing+  resultItemAsIntTimingStatsValue = const Nothing -  resultItemToDoubleValue = voidResultValue-  resultItemToDoubleListValue = voidResultValue-  resultItemToDoubleStatsValue = voidResultValue-  resultItemToDoubleTimingStatsValue = voidResultValue+  resultItemAsDoubleValue = const Nothing+  resultItemAsDoubleListValue = const Nothing+  resultItemAsDoubleStatsValue = const Nothing+  resultItemAsDoubleTimingStatsValue = const Nothing -  resultItemToStringValue = mapResultValue show+  resultItemAsStringValue = Just . mapResultValue show    resultItemExpansion = ResultItemSource . ResultItem   resultItemSummary = ResultItemSource . ResultItem@@ -779,17 +895,17 @@   resultItemId = resultValueId   resultItemSignal = resultValueSignal   -  resultItemToIntValue = voidResultValue-  resultItemToIntListValue = voidResultValue-  resultItemToIntStatsValue = voidResultValue-  resultItemToIntTimingStatsValue = voidResultValue+  resultItemAsIntValue = const Nothing+  resultItemAsIntListValue = const Nothing+  resultItemAsIntStatsValue = const Nothing+  resultItemAsIntTimingStatsValue = const Nothing -  resultItemToDoubleValue = voidResultValue-  resultItemToDoubleListValue = voidResultValue-  resultItemToDoubleStatsValue = voidResultValue-  resultItemToDoubleTimingStatsValue = voidResultValue+  resultItemAsDoubleValue = const Nothing+  resultItemAsDoubleListValue = const Nothing+  resultItemAsDoubleStatsValue = const Nothing+  resultItemAsDoubleTimingStatsValue = const Nothing -  resultItemToStringValue = mapResultValue show+  resultItemAsStringValue = Just . mapResultValue show    resultItemExpansion = ResultItemSource . ResultItem   resultItemSummary = ResultItemSource . ResultItem@@ -800,17 +916,17 @@   resultItemId = resultValueId   resultItemSignal = resultValueSignal   -  resultItemToIntValue = voidResultValue-  resultItemToIntListValue = voidResultValue-  resultItemToIntStatsValue = voidResultValue-  resultItemToIntTimingStatsValue = voidResultValue+  resultItemAsIntValue = const Nothing+  resultItemAsIntListValue = const Nothing+  resultItemAsIntStatsValue = const Nothing+  resultItemAsIntTimingStatsValue = const Nothing -  resultItemToDoubleValue = voidResultValue-  resultItemToDoubleListValue = voidResultValue-  resultItemToDoubleStatsValue = voidResultValue-  resultItemToDoubleTimingStatsValue = voidResultValue+  resultItemAsDoubleValue = const Nothing+  resultItemAsDoubleListValue = const Nothing+  resultItemAsDoubleStatsValue = const Nothing+  resultItemAsDoubleTimingStatsValue = const Nothing -  resultItemToStringValue = mapResultValue show+  resultItemAsStringValue = Just . mapResultValue show    resultItemExpansion = ResultItemSource . ResultItem   resultItemSummary = ResultItemSource . ResultItem@@ -832,7 +948,7 @@ resultSourceName (ResultSeparatorSource x) = []  -- | Expand the result source returning a more detailed version expanding the properties as possible.-expandResultSource :: MonadComp m => ResultSource m -> ResultSource m+expandResultSource :: MonadDES m => ResultSource m -> ResultSource m expandResultSource (ResultItemSource (ResultItem x)) = resultItemExpansion x expandResultSource (ResultObjectSource x) =   ResultObjectSource $@@ -849,61 +965,61 @@ expandResultSource z@(ResultSeparatorSource x) = z  -- | Return a summarised and usually more short version of the result source expanding the main properties or excluding auxiliary properties if required.-resultSourceSummary :: MonadComp m => ResultSource m -> ResultSource m+resultSourceSummary :: MonadDES m => ResultSource m -> ResultSource m resultSourceSummary (ResultItemSource (ResultItem x)) = resultItemSummary x resultSourceSummary (ResultObjectSource x) = resultObjectSummary x resultSourceSummary (ResultVectorSource x) = resultVectorSummary x resultSourceSummary z@(ResultSeparatorSource x) = z  -- | Return a signal emitted by the source.-resultSourceSignal :: MonadComp m => ResultSource m -> ResultSignal m+resultSourceSignal :: MonadDES m => ResultSource m -> ResultSignal m resultSourceSignal (ResultItemSource (ResultItem x)) = resultItemSignal x resultSourceSignal (ResultObjectSource x) = resultObjectSignal x resultSourceSignal (ResultVectorSource x) = resultVectorSignal x resultSourceSignal (ResultSeparatorSource x) = EmptyResultSignal  -- | Represent the result source as integer numbers.-resultSourceToIntValues :: MonadComp m => ResultSource m -> [ResultValue Int m]+resultSourceToIntValues :: MonadDES m => ResultSource m -> [ResultValue Int m] resultSourceToIntValues = map (\(ResultItem x) -> resultItemToIntValue x) . flattenResultSource  -- | Represent the result source as lists of integer numbers.-resultSourceToIntListValues :: MonadComp m => ResultSource m -> [ResultValue [Int] m]+resultSourceToIntListValues :: MonadDES m => ResultSource m -> [ResultValue [Int] m] resultSourceToIntListValues = map (\(ResultItem x) -> resultItemToIntListValue x) . flattenResultSource  -- | Represent the result source as statistics based on integer numbers.-resultSourceToIntStatsValues :: MonadComp m => ResultSource m -> [ResultValue (SamplingStats Int) m]+resultSourceToIntStatsValues :: MonadDES m => ResultSource m -> [ResultValue (SamplingStats Int) m] resultSourceToIntStatsValues = map (\(ResultItem x) -> resultItemToIntStatsValue x) . flattenResultSource  -- | Represent the result source as statistics based on integer numbers and optimised for fast aggregation.-resultSourceToIntStatsEitherValues :: MonadComp m => ResultSource m -> [ResultValue (Either Int (SamplingStats Int)) m]+resultSourceToIntStatsEitherValues :: MonadDES m => ResultSource m -> [ResultValue (Either Int (SamplingStats Int)) m] resultSourceToIntStatsEitherValues = map (\(ResultItem x) -> resultItemToIntStatsEitherValue x) . flattenResultSource  -- | Represent the result source as timing statistics based on integer numbers.-resultSourceToIntTimingStatsValues :: MonadComp m => ResultSource m -> [ResultValue (TimingStats Int) m]+resultSourceToIntTimingStatsValues :: MonadDES m => ResultSource m -> [ResultValue (TimingStats Int) m] resultSourceToIntTimingStatsValues = map (\(ResultItem x) -> resultItemToIntTimingStatsValue x) . flattenResultSource  -- | Represent the result source as double floating point numbers.-resultSourceToDoubleValues :: MonadComp m => ResultSource m -> [ResultValue Double m]+resultSourceToDoubleValues :: MonadDES m => ResultSource m -> [ResultValue Double m] resultSourceToDoubleValues = map (\(ResultItem x) -> resultItemToDoubleValue x) . flattenResultSource  -- | Represent the result source as lists of double floating point numbers.-resultSourceToDoubleListValues :: MonadComp m => ResultSource m -> [ResultValue [Double] m]+resultSourceToDoubleListValues :: MonadDES m => ResultSource m -> [ResultValue [Double] m] resultSourceToDoubleListValues = map (\(ResultItem x) -> resultItemToDoubleListValue x) . flattenResultSource  -- | Represent the result source as statistics based on double floating point numbers.-resultSourceToDoubleStatsValues :: MonadComp m => ResultSource m -> [ResultValue (SamplingStats Double) m]+resultSourceToDoubleStatsValues :: MonadDES m => ResultSource m -> [ResultValue (SamplingStats Double) m] resultSourceToDoubleStatsValues = map (\(ResultItem x) -> resultItemToDoubleStatsValue x) . flattenResultSource  -- | Represent the result source as statistics based on double floating point numbers and optimised for fast aggregation.-resultSourceToDoubleStatsEitherValues :: MonadComp m => ResultSource m -> [ResultValue (Either Double (SamplingStats Double)) m]+resultSourceToDoubleStatsEitherValues :: MonadDES m => ResultSource m -> [ResultValue (Either Double (SamplingStats Double)) m] resultSourceToDoubleStatsEitherValues = map (\(ResultItem x) -> resultItemToDoubleStatsEitherValue x) . flattenResultSource  -- | Represent the result source as timing statistics based on double floating point numbers.-resultSourceToDoubleTimingStatsValues :: MonadComp m => ResultSource m -> [ResultValue (TimingStats Double) m]+resultSourceToDoubleTimingStatsValues :: MonadDES m => ResultSource m -> [ResultValue (TimingStats Double) m] resultSourceToDoubleTimingStatsValues = map (\(ResultItem x) -> resultItemToDoubleTimingStatsValue x) . flattenResultSource  -- | Represent the result source as string values.-resultSourceToStringValues :: MonadComp m => ResultSource m -> [ResultValue String m]+resultSourceToStringValues :: MonadDES m => ResultSource m -> [ResultValue String m] resultSourceToStringValues = map (\(ResultItem x) -> resultItemToStringValue x) . flattenResultSource  -- | It contains the results of simulation.@@ -928,7 +1044,7 @@                           }  -- | Create the predefined signals provided by every simulation model.-newResultPredefinedSignals :: MonadComp m => Simulation m (ResultPredefinedSignals m)+newResultPredefinedSignals :: MonadDES m => Simulation m (ResultPredefinedSignals m) newResultPredefinedSignals = runDynamicsInStartTime $ runEventWith EarlierEvents d where   d = do signalInIntegTimes <- newSignalInIntegTimes          signalInStartTime  <- newSignalInStartTime@@ -949,62 +1065,62 @@             resultSourceList = ms }  -- | Represent the results as integer numbers.-resultsToIntValues :: MonadComp m => Results m -> [ResultValue Int m]+resultsToIntValues :: MonadDES m => Results m -> [ResultValue Int m] resultsToIntValues = concat . map resultSourceToIntValues . resultSourceList  -- | Represent the results as lists of integer numbers.-resultsToIntListValues :: MonadComp m => Results m -> [ResultValue [Int] m]+resultsToIntListValues :: MonadDES m => Results m -> [ResultValue [Int] m] resultsToIntListValues = concat . map resultSourceToIntListValues . resultSourceList  -- | Represent the results as statistics based on integer numbers.-resultsToIntStatsValues :: MonadComp m => Results m -> [ResultValue (SamplingStats Int) m]+resultsToIntStatsValues :: MonadDES m => Results m -> [ResultValue (SamplingStats Int) m] resultsToIntStatsValues = concat . map resultSourceToIntStatsValues . resultSourceList  -- | Represent the results as statistics based on integer numbers and optimised for fast aggregation.-resultsToIntStatsEitherValues :: MonadComp m => Results m -> [ResultValue (Either Int (SamplingStats Int)) m]+resultsToIntStatsEitherValues :: MonadDES m => Results m -> [ResultValue (Either Int (SamplingStats Int)) m] resultsToIntStatsEitherValues = concat . map resultSourceToIntStatsEitherValues . resultSourceList  -- | Represent the results as timing statistics based on integer numbers.-resultsToIntTimingStatsValues :: MonadComp m => Results m -> [ResultValue (TimingStats Int) m]+resultsToIntTimingStatsValues :: MonadDES m => Results m -> [ResultValue (TimingStats Int) m] resultsToIntTimingStatsValues = concat . map resultSourceToIntTimingStatsValues . resultSourceList  -- | Represent the results as double floating point numbers.-resultsToDoubleValues :: MonadComp m => Results m -> [ResultValue Double m]+resultsToDoubleValues :: MonadDES m => Results m -> [ResultValue Double m] resultsToDoubleValues = concat . map resultSourceToDoubleValues . resultSourceList  -- | Represent the results as lists of double floating point numbers.-resultsToDoubleListValues :: MonadComp m => Results m -> [ResultValue [Double] m]+resultsToDoubleListValues :: MonadDES m => Results m -> [ResultValue [Double] m] resultsToDoubleListValues = concat . map resultSourceToDoubleListValues . resultSourceList  -- | Represent the results as statistics based on double floating point numbers.-resultsToDoubleStatsValues :: MonadComp m => Results m -> [ResultValue (SamplingStats Double) m]+resultsToDoubleStatsValues :: MonadDES m => Results m -> [ResultValue (SamplingStats Double) m] resultsToDoubleStatsValues = concat . map resultSourceToDoubleStatsValues . resultSourceList  -- | Represent the results as statistics based on double floating point numbers and optimised for fast aggregation.-resultsToDoubleStatsEitherValues :: MonadComp m => Results m -> [ResultValue (Either Double (SamplingStats Double)) m]+resultsToDoubleStatsEitherValues :: MonadDES m => Results m -> [ResultValue (Either Double (SamplingStats Double)) m] resultsToDoubleStatsEitherValues = concat . map resultSourceToDoubleStatsEitherValues . resultSourceList  -- | Represent the results as timing statistics based on double floating point numbers.-resultsToDoubleTimingStatsValues :: MonadComp m => Results m -> [ResultValue (TimingStats Double) m]+resultsToDoubleTimingStatsValues :: MonadDES m => Results m -> [ResultValue (TimingStats Double) m] resultsToDoubleTimingStatsValues = concat . map resultSourceToDoubleTimingStatsValues . resultSourceList  -- | Represent the results as string values.-resultsToStringValues :: MonadComp m => Results m -> [ResultValue String m]+resultsToStringValues :: MonadDES m => Results m -> [ResultValue String m] resultsToStringValues = concat . map resultSourceToStringValues . resultSourceList  -- | Return a signal emitted by the specified results.-resultSignal :: MonadComp m => Results m -> ResultSignal m+resultSignal :: MonadDES m => Results m -> ResultSignal m resultSignal = mconcat . map resultSourceSignal . resultSourceList  -- | Return an expanded version of the simulation results expanding the properties as possible, which -- takes place for expanding statistics to show the count, average, deviation, minimum, maximum etc. -- as separate values.-expandResults :: MonadComp m => ResultTransform m+expandResults :: MonadDES m => ResultTransform m expandResults = results . map expandResultSource . resultSourceList  -- | Return a short version of the simulation results, i.e. their summary, expanding the main properties -- or excluding auxiliary properties if required.-resultSummary :: MonadComp m => ResultTransform m+resultSummary :: MonadDES m => ResultTransform m resultSummary = results . map resultSourceSummary . resultSourceList  -- | Take a result by its name.@@ -1146,7 +1262,7 @@ -- The signal returned is triggered when the source signal is triggered. -- The pure signal is also triggered in the integration time points -- if the source signal is unknown or it was combined with any unknown signal.-pureResultSignal :: MonadComp m => ResultPredefinedSignals m -> ResultSignal m -> Signal m ()+pureResultSignal :: MonadDES m => ResultPredefinedSignals m -> ResultSignal m -> Signal m () pureResultSignal rs EmptyResultSignal =   void (resultSignalInStartTime rs) pureResultSignal rs UnknownResultSignal =@@ -1156,192 +1272,8 @@ pureResultSignal rs (ResultSignalMix s) =   void (resultSignalInIntegTimes rs) <> s --- | Defines a final result extract: its name, values and other data.-data ResultExtract e m =-  ResultExtract { resultExtractName   :: ResultName,-                  -- ^ The result name.-                  resultExtractId     :: ResultId,-                  -- ^ The result identifier.-                  resultExtractData   :: Event m e,-                  -- ^ The result values.-                  resultExtractSignal :: ResultSignal m-                  -- ^ Whether the result emits a signal.-                }---- | Extract the results as integer values, or raise a conversion error.-extractIntResults :: MonadComp m => Results m -> [ResultExtract Int m]-extractIntResults rs = flip map (resultsToIntValues rs) $ \x ->-  let n = resultValueName x-      i = resultValueId x-      a = resultValueData x-      s = resultValueSignal x-  in case a of-    Nothing ->-      error $-      "Cannot represent variable " ++ n ++-      " as a source of integer values: extractIntResults"-    Just a ->-      ResultExtract n i a s---- | Extract the results as lists of integer values, or raise a conversion error.-extractIntListResults :: MonadComp m => Results m -> [ResultExtract [Int] m]-extractIntListResults rs = flip map (resultsToIntListValues rs) $ \x ->-  let n = resultValueName x-      i = resultValueId x-      a = resultValueData x-      s = resultValueSignal x-  in case a of-    Nothing ->-      error $-      "Cannot represent variable " ++ n ++-      " as a source of lists of integer values: extractIntListResults"-    Just a ->-      ResultExtract n i a s---- | Extract the results as statistics based on integer values,--- or raise a conversion error.-extractIntStatsResults :: MonadComp m => Results m -> [ResultExtract (SamplingStats Int) m]-extractIntStatsResults rs = flip map (resultsToIntStatsValues rs) $ \x ->-  let n = resultValueName x-      i = resultValueId x-      a = resultValueData x-      s = resultValueSignal x-  in case a of-    Nothing ->-      error $-      "Cannot represent variable " ++ n ++-      " as a source of statistics based on integer values: extractIntStatsResults"-    Just a ->-      ResultExtract n i a s---- | Extract the results as statistics based on integer values and optimised--- for fast aggregation, or raise a conversion error.-extractIntStatsEitherResults :: MonadComp m => Results m -> [ResultExtract (Either Int (SamplingStats Int)) m]-extractIntStatsEitherResults rs = flip map (resultsToIntStatsEitherValues rs) $ \x ->-  let n = resultValueName x-      i = resultValueId x-      a = resultValueData x-      s = resultValueSignal x-  in case a of-    Nothing ->-      error $-      "Cannot represent variable " ++ n ++-      " as a source of statistics based on integer values: extractIntStatsEitherResults"-    Just a ->-      ResultExtract n i a s---- | Extract the results as timing statistics based on integer values,--- or raise a conversion error.-extractIntTimingStatsResults :: MonadComp m => Results m -> [ResultExtract (TimingStats Int) m]-extractIntTimingStatsResults rs = flip map (resultsToIntTimingStatsValues rs) $ \x ->-  let n = resultValueName x-      i = resultValueId x-      a = resultValueData x-      s = resultValueSignal x-  in case a of-    Nothing ->-      error $-      "Cannot represent variable " ++ n ++-      " as a source of timing statistics based on integer values: extractIntTimingStatsResults"-    Just a ->-      ResultExtract n i a s---- | Extract the results as double floating point values, or raise a conversion error.-extractDoubleResults :: MonadComp m => Results m -> [ResultExtract Double m]-extractDoubleResults rs = flip map (resultsToDoubleValues rs) $ \x ->-  let n = resultValueName x-      i = resultValueId x-      a = resultValueData x-      s = resultValueSignal x-  in case a of-    Nothing ->-      error $-      "Cannot represent variable " ++ n ++-      " as a source of double floating point values: extractDoubleResults"-    Just a ->-      ResultExtract n i a s---- | Extract the results as lists of double floating point values,--- or raise a conversion error.-extractDoubleListResults :: MonadComp m => Results m -> [ResultExtract [Double] m]-extractDoubleListResults rs = flip map (resultsToDoubleListValues rs) $ \x ->-  let n = resultValueName x-      i = resultValueId x-      a = resultValueData x-      s = resultValueSignal x-  in case a of-    Nothing ->-      error $-      "Cannot represent variable " ++ n ++-      " as a source of lists of double floating point values: extractDoubleListResults"-    Just a ->-      ResultExtract n i a s---- | Extract the results as statistics based on double floating point values,--- or raise a conversion error.-extractDoubleStatsResults :: MonadComp m => Results m -> [ResultExtract (SamplingStats Double) m]-extractDoubleStatsResults rs = flip map (resultsToDoubleStatsValues rs) $ \x ->-  let n = resultValueName x-      i = resultValueId x-      a = resultValueData x-      s = resultValueSignal x-  in case a of-    Nothing ->-      error $-      "Cannot represent variable " ++ n ++-      " as a source of statistics based on double floating point values: extractDoubleStatsResults"-    Just a ->-      ResultExtract n i a s---- | Extract the results as statistics based on double floating point values--- and optimised for fast aggregation, or raise a conversion error.-extractDoubleStatsEitherResults :: MonadComp m => Results m -> [ResultExtract (Either Double (SamplingStats Double)) m]-extractDoubleStatsEitherResults rs = flip map (resultsToDoubleStatsEitherValues rs) $ \x ->-  let n = resultValueName x-      i = resultValueId x-      a = resultValueData x-      s = resultValueSignal x-  in case a of-    Nothing ->-      error $-      "Cannot represent variable " ++ n ++-      " as a source of statistics based on double floating point values: extractDoubleStatsEitherResults"-    Just a ->-      ResultExtract n i a s---- | Extract the results as timing statistics based on double floating point values,--- or raise a conversion error.-extractDoubleTimingStatsResults :: MonadComp m => Results m -> [ResultExtract (TimingStats Double) m]-extractDoubleTimingStatsResults rs = flip map (resultsToDoubleTimingStatsValues rs) $ \x ->-  let n = resultValueName x-      i = resultValueId x-      a = resultValueData x-      s = resultValueSignal x-  in case a of-    Nothing ->-      error $-      "Cannot represent variable " ++ n ++-      " as a source of timing statistics based on double floating point values: extractDoubleTimingStatsResults"-    Just a ->-      ResultExtract n i a s---- | Extract the results as string values, or raise a conversion error.-extractStringResults :: MonadComp m => Results m -> [ResultExtract String m]-extractStringResults rs = flip map (resultsToStringValues rs) $ \x ->-  let n = resultValueName x-      i = resultValueId x-      a = resultValueData x-      s = resultValueSignal x-  in case a of-    Nothing ->-      error $-      "Cannot represent variable " ++ n ++-      " as a source of string values: extractStringResults"-    Just a ->-      ResultExtract n i a s- -- | Represents a computation that can return the simulation data.-class MonadComp m => ResultComputing t m where+class MonadDES m => ResultComputing t m where    -- | Compute data with the results of simulation.   computeResultData :: t m a -> ResultData a m@@ -1365,48 +1297,48 @@     resultValueData   = computeResultData m,     resultValueSignal = computeResultSignal m } -instance MonadComp m => ResultComputing Parameter m where+instance MonadDES m => ResultComputing Parameter m where -  computeResultData = Just . liftParameter+  computeResultData = liftParameter   computeResultSignal = const UnknownResultSignal -instance MonadComp m => ResultComputing Simulation m where+instance MonadDES m => ResultComputing Simulation m where -  computeResultData = Just . liftSimulation+  computeResultData = liftSimulation   computeResultSignal = const UnknownResultSignal -instance MonadComp m => ResultComputing Dynamics m where+instance MonadDES m => ResultComputing Dynamics m where -  computeResultData = Just . liftDynamics+  computeResultData = liftDynamics   computeResultSignal = const UnknownResultSignal -instance MonadComp m => ResultComputing Event m where+instance MonadDES m => ResultComputing Event m where -  computeResultData = Just . id+  computeResultData = id   computeResultSignal = const UnknownResultSignal -instance MonadComp m => ResultComputing Ref m where+instance MonadDES m => ResultComputing Ref m where -  computeResultData = Just . readRef+  computeResultData = readRef   computeResultSignal = ResultSignal . refChanged_ -instance MonadComp m => ResultComputing LR.Ref m where+instance MonadDES m => ResultComputing B.Ref m where -  computeResultData = Just . LR.readRef+  computeResultData = B.readRef   computeResultSignal = const UnknownResultSignal -instance MonadComp m => ResultComputing Var m where+instance MonadVar m => ResultComputing Var m where -  computeResultData = Just . readVar+  computeResultData = readVar   computeResultSignal = ResultSignal . varChanged_ -instance MonadComp m => ResultComputing Signalable m where+instance MonadDES m => ResultComputing Signalable m where -  computeResultData = Just . readSignalable+  computeResultData = readSignalable   computeResultSignal = ResultSignal . signalableChanged_        -- | Return a source by the specified statistics.-samplingStatsResultSource :: (MonadComp m,+samplingStatsResultSource :: (MonadDES m,                               ResultItemable (ResultValue a),                               ResultItemable (ResultValue (SamplingStats a)))                              => ResultValue (SamplingStats a) m@@ -1432,7 +1364,7 @@     c = resultValueToContainer x  -- | Return the summary by the specified statistics.-samplingStatsResultSummary :: (MonadComp m,+samplingStatsResultSummary :: (MonadDES m,                                ResultItemable (ResultValue (SamplingStats a)))                               => ResultValue (SamplingStats a) m                               -- ^ the statistics@@ -1440,7 +1372,7 @@ samplingStatsResultSummary = ResultItemSource . ResultItem . resultItemToStringValue     -- | Return a source by the specified timing statistics.-timingStatsResultSource :: (MonadComp m,+timingStatsResultSource :: (MonadDES m,                             TimingData a,                             ResultItemable (ResultValue a),                             ResultItemable (ResultValue (TimingStats a)))@@ -1472,7 +1404,7 @@     c = resultValueToContainer x  -- | Return the summary by the specified timing statistics.-timingStatsResultSummary :: (MonadComp m,+timingStatsResultSummary :: (MonadDES m,                              TimingData a,                              ResultItemable (ResultValue (TimingStats a)))                             => ResultValue (TimingStats a) m @@ -1481,7 +1413,7 @@ timingStatsResultSummary = ResultItemSource . ResultItem . resultItemToStringValue    -- | Return a source by the specified counter.-samplingCounterResultSource :: (MonadComp m,+samplingCounterResultSource :: (MonadDES m,                                 ResultItemable (ResultValue a),                                 ResultItemable (ResultValue (SamplingStats a)))                                => ResultValue (SamplingCounter a) m@@ -1502,7 +1434,7 @@     c = resultValueToContainer x        -- | Return a source by the specified counter.-samplingCounterResultSummary :: (MonadComp m,+samplingCounterResultSummary :: (MonadDES m,                                  ResultItemable (ResultValue a),                                  ResultItemable (ResultValue (SamplingStats a)))                                 => ResultValue (SamplingCounter a) m@@ -1523,7 +1455,7 @@     c = resultValueToContainer x        -- | Return a source by the specified counter.-timingCounterResultSource :: (MonadComp m,+timingCounterResultSource :: (MonadDES m,                               ResultItemable (ResultValue a),                               ResultItemable (ResultValue (TimingStats a)))                              => ResultValue (TimingCounter a) m@@ -1544,7 +1476,7 @@     c = resultValueToContainer x        -- | Return a source by the specified counter.-timingCounterResultSummary :: (MonadComp m,+timingCounterResultSummary :: (MonadDES m,                                ResultItemable (ResultValue a),                                ResultItemable (ResultValue (TimingStats a)))                               => ResultValue (TimingCounter a) m@@ -1565,7 +1497,7 @@     c = resultValueToContainer x    -- | Return a source by the specified finite queue.-queueResultSource :: (MonadComp m,+queueResultSource :: (MonadDES m,                       Show si, Show sm, Show so,                       ResultItemable (ResultValue si),                       ResultItemable (ResultValue sm),@@ -1607,7 +1539,7 @@       resultContainerProperty c "queueRate" QueueRateId Q.queueRate Q.queueRateChanged_ ] }  -- | Return the summary by the specified finite queue.-queueResultSummary :: (MonadComp m,+queueResultSummary :: (MonadDES m,                        Show si, Show sm, Show so)                       => ResultContainer (Q.Queue m si sm so a) m                       -- ^ the queue container@@ -1633,7 +1565,7 @@       resultContainerProperty c "queueRate" QueueRateId Q.queueRate Q.queueRateChanged_ ] }  -- | Return a source by the specified infinite queue.-infiniteQueueResultSource :: (MonadComp m,+infiniteQueueResultSource :: (MonadDES m,                               Show sm, Show so,                               ResultItemable (ResultValue sm),                               ResultItemable (ResultValue so))@@ -1665,7 +1597,7 @@       resultContainerProperty c "queueRate" QueueRateId IQ.queueRate IQ.queueRateChanged_ ] }  -- | Return the summary by the specified infinite queue.-infiniteQueueResultSummary :: (MonadComp m,+infiniteQueueResultSummary :: (MonadDES m,                                Show sm, Show so)                               => ResultContainer (IQ.Queue m sm so a) m                               -- ^ the queue container@@ -1687,7 +1619,7 @@       resultContainerProperty c "queueRate" QueueRateId IQ.queueRate IQ.queueRateChanged_ ] }    -- | Return a source by the specified arrival timer.-arrivalTimerResultSource :: MonadComp m+arrivalTimerResultSource :: MonadDES m                             => ResultContainer (ArrivalTimer m) m                             -- ^ the arrival timer container                             -> ResultSource m@@ -1703,7 +1635,7 @@       resultContainerProperty c "processingTime" ArrivalProcessingTimeId arrivalProcessingTime arrivalProcessingTimeChanged_ ] }  -- | Return the summary by the specified arrival timer.-arrivalTimerResultSummary :: MonadComp m+arrivalTimerResultSummary :: MonadDES m                              => ResultContainer (ArrivalTimer m) m                              -- ^ the arrival timer container                              -> ResultSource m@@ -1719,7 +1651,7 @@       resultContainerProperty c "processingTime" ArrivalProcessingTimeId arrivalProcessingTime arrivalProcessingTimeChanged_ ] }  -- | Return a source by the specified server.-serverResultSource :: (MonadComp m,+serverResultSource :: (MonadDES m,                        Show s, ResultItemable (ResultValue s))                       => ResultContainer (Server m s a b) m                       -- ^ the server container@@ -1746,7 +1678,7 @@       resultContainerProperty c "outputWaitFactor" ServerOutputWaitFactorId serverOutputWaitFactor serverOutputWaitFactorChanged_ ] }  -- | Return the summary by the specified server.-serverResultSummary :: MonadComp m+serverResultSummary :: MonadDES m                        => ResultContainer (Server m s a b) m                        -- ^ the server container                        -> ResultSource m@@ -1767,7 +1699,7 @@       resultContainerProperty c "outputWaitFactor" ServerOutputWaitFactorId serverOutputWaitFactor serverOutputWaitFactorChanged_ ] }  -- | Return a source by the specified activity.-activityResultSource :: (MonadComp m,+activityResultSource :: (MonadDES m,                          Show s, ResultItemable (ResultValue s))                         => ResultContainer (Activity m s a b) m                         -- ^ the activity container@@ -1791,7 +1723,7 @@       resultContainerProperty c "idleFactor" ActivityIdleFactorId activityIdleFactor activityIdleFactorChanged_ ] }  -- | Return a summary by the specified activity.-activityResultSummary :: MonadComp m+activityResultSummary :: MonadDES m                          => ResultContainer (Activity m s a b) m                          -- ^ the activity container                          -> ResultSource m@@ -1816,7 +1748,7 @@   ResultSeparator { resultSeparatorText = text }  -- | Return the source of the modeling time.-timeResultSource :: MonadComp m => ResultSource m+timeResultSource :: MonadDES m => ResultSource m timeResultSource = resultSource' "t" TimeId time                           -- | Make an integer subscript@@ -2008,7 +1940,7 @@  #endif -instance (MonadComp m,+instance (MonadDES m,           Show si, Show sm, Show so,           ResultItemable (ResultValue si),           ResultItemable (ResultValue sm),@@ -2018,7 +1950,7 @@   resultSource' name i m =     queueResultSource $ ResultContainer name i m (ResultSignal $ Q.queueChanged_ m) -instance (MonadComp m,+instance (MonadDES m,           Show sm, Show so,           ResultItemable (ResultValue sm),           ResultItemable (ResultValue so))@@ -2027,17 +1959,17 @@   resultSource' name i m =     infiniteQueueResultSource $ ResultContainer name i m (ResultSignal $ IQ.queueChanged_ m) -instance MonadComp m => ResultProvider (ArrivalTimer m) m where+instance MonadDES m => ResultProvider (ArrivalTimer m) m where    resultSource' name i m =     arrivalTimerResultSource $ ResultContainer name i m (ResultSignal $ arrivalProcessingTimeChanged_ m) -instance (MonadComp m, Show s, ResultItemable (ResultValue s)) => ResultProvider (Server m s a b) m where+instance (MonadDES m, Show s, ResultItemable (ResultValue s)) => ResultProvider (Server m s a b) m where    resultSource' name i m =     serverResultSource $ ResultContainer name i m (ResultSignal $ serverChanged_ m) -instance (MonadComp m, Show s, ResultItemable (ResultValue s)) => ResultProvider (Activity m s a b) m where+instance (MonadDES m, Show s, ResultItemable (ResultValue s)) => ResultProvider (Activity m s a b) m where    resultSource' name i m =     activityResultSource $ ResultContainer name i m (ResultSignal $ activityChanged_ m)
Simulation/Aivika/Trans/Results/IO.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Results.IO--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The module allows printing and converting the 'Simulation' 'Results' to a 'String'. --@@ -63,6 +63,7 @@ import System.IO  import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Specs import Simulation.Aivika.Trans.Simulation import Simulation.Aivika.Trans.Dynamics@@ -80,7 +81,7 @@  -- | Print a localised text representation of the results by the specified source -- and with the given indent.-hPrintResultSourceIndented :: (MonadComp m, MonadIO m)+hPrintResultSourceIndented :: (MonadDES m, MonadIO m)                               => Handle                               -- ^ a handle                               -> Int@@ -88,6 +89,7 @@                               -> ResultLocalisation                               -- ^ a localisation                               -> ResultSourcePrint m+{-# INLINABLE hPrintResultSourceIndented #-} hPrintResultSourceIndented h indent loc source@(ResultItemSource (ResultItem x)) =   hPrintResultSourceIndentedLabelled h indent (resultItemName x) loc source hPrintResultSourceIndented h indent loc source@(ResultVectorSource x) =@@ -99,7 +101,7 @@  -- | Print an indented and labelled text representation of the results by -- the specified source.-hPrintResultSourceIndentedLabelled :: (MonadComp m, MonadIO m)+hPrintResultSourceIndentedLabelled :: (MonadDES m, MonadIO m)                                       => Handle                                       -- ^ a handle                                       -> Int@@ -109,25 +111,20 @@                                       -> ResultLocalisation                                       -- ^ a localisation                                       -> ResultSourcePrint m+{-# INLINABLE hPrintResultSourceIndentedLabelled #-} hPrintResultSourceIndentedLabelled h indent label loc (ResultItemSource (ResultItem x)) =-  case resultValueData (resultItemToStringValue x) of-    Just m ->-      do a <- m-         let tab = replicate indent ' '-         liftIO $-           do hPutStr h tab-              hPutStr h "-- "-              hPutStr h (loc $ resultItemId x)-              hPutStrLn h ""-              hPutStr h tab-              hPutStr h label-              hPutStr h " = "-              hPutStrLn h a-              hPutStrLn h ""-    _ ->-      error $-      "Expected to see a string value for variable " ++-      (resultItemName x) ++ ": hPrintResultSourceIndentedLabelled"+  do a <- resultValueData $ resultItemToStringValue x+     let tab = replicate indent ' '+     liftIO $+       do hPutStr h tab+          hPutStr h "-- "+          hPutStr h (loc $ resultItemId x)+          hPutStrLn h ""+          hPutStr h tab+          hPutStr h label+          hPutStr h " = "+          hPutStrLn h a+          hPutStrLn h "" hPrintResultSourceIndentedLabelled h indent label loc (ResultVectorSource x) =   do let tab = replicate indent ' '      liftIO $@@ -170,54 +167,62 @@  -- | Print a localised text representation of the results by the specified source -- and with the given indent.-printResultSourceIndented :: (MonadComp m, MonadIO m)+printResultSourceIndented :: (MonadDES m, MonadIO m)                              => Int                              -- ^ an indent                              -> ResultLocalisation                              -- ^ a localisation                              -> ResultSourcePrint m+{-# INLINABLE printResultSourceIndented #-} printResultSourceIndented = hPrintResultSourceIndented stdout  -- | Print a localised text representation of the results by the specified source.-hPrintResultSource :: (MonadComp m, MonadIO m)+hPrintResultSource :: (MonadDES m, MonadIO m)                       => Handle                       -- ^ a handle                       -> ResultLocalisation                       -- ^ a localisation                       -> ResultSourcePrint m+{-# INLINABLE hPrintResultSource #-} hPrintResultSource h = hPrintResultSourceIndented h 0  -- | Print a localised text representation of the results by the specified source.-printResultSource :: (MonadComp m, MonadIO m)+printResultSource :: (MonadDES m, MonadIO m)                      => ResultLocalisation                      -- ^ a localisation                      -> ResultSourcePrint m+{-# INLINABLE printResultSource #-} printResultSource = hPrintResultSource stdout  -- | Print in Russian a text representation of the results by the specified source.-hPrintResultSourceInRussian :: (MonadComp m, MonadIO m) => Handle -> ResultSourcePrint m+hPrintResultSourceInRussian :: (MonadDES m, MonadIO m) => Handle -> ResultSourcePrint m+{-# INLINABLE hPrintResultSourceInRussian #-} hPrintResultSourceInRussian h = hPrintResultSource h russianResultLocalisation  -- | Print in English a text representation of the results by the specified source.-hPrintResultSourceInEnglish :: (MonadComp m, MonadIO m) => Handle -> ResultSourcePrint m+hPrintResultSourceInEnglish :: (MonadDES m, MonadIO m) => Handle -> ResultSourcePrint m+{-# INLINABLE hPrintResultSourceInEnglish #-} hPrintResultSourceInEnglish h = hPrintResultSource h englishResultLocalisation  -- | Print in Russian a text representation of the results by the specified source.-printResultSourceInRussian :: (MonadComp m, MonadIO m) => ResultSourcePrint m+printResultSourceInRussian :: (MonadDES m, MonadIO m) => ResultSourcePrint m+{-# INLINABLE printResultSourceInRussian #-} printResultSourceInRussian = hPrintResultSourceInRussian stdout  -- | Print in English a text representation of the results by the specified source.-printResultSourceInEnglish :: (MonadComp m, MonadIO m) => ResultSourcePrint m+printResultSourceInEnglish :: (MonadDES m, MonadIO m) => ResultSourcePrint m+{-# INLINABLE printResultSourceInEnglish #-} printResultSourceInEnglish = hPrintResultSourceInEnglish stdout  -- | Show a localised text representation of the results by the specified source -- and with the given indent.-showResultSourceIndented :: MonadComp m+showResultSourceIndented :: MonadDES m                             => Int                             -- ^ an indent                             -> ResultLocalisation                             -- ^ a localisation                             -> ResultSourceShowS m+{-# INLINABLE showResultSourceIndented #-} showResultSourceIndented indent loc source@(ResultItemSource (ResultItem x)) =   showResultSourceIndentedLabelled indent (resultItemName x) loc source showResultSourceIndented indent loc source@(ResultVectorSource x) =@@ -228,7 +233,7 @@   showResultSourceIndentedLabelled indent (resultSeparatorText x) loc source  -- | Show an indented and labelled text representation of the results by the specified source.-showResultSourceIndentedLabelled :: MonadComp m+showResultSourceIndentedLabelled :: MonadDES m                                     => Int                                     -- ^ an indent                                     -> String@@ -236,25 +241,20 @@                                     -> ResultLocalisation                                     -- ^ a localisation                                     -> ResultSourceShowS m+{-# INLINABLE showResultSourceIndentedLabelled #-} showResultSourceIndentedLabelled indent label loc (ResultItemSource (ResultItem x)) =-  case resultValueData (resultItemToStringValue x) of-    Just m ->-      do a <- m-         let tab = replicate indent ' '-         return $-           showString tab .-           showString "-- " .-           showString (loc $ resultItemId x) .-           showString "\n" .-           showString tab .-           showString label .-           showString " = " .-           showString a .-           showString "\n\n"-    _ ->-      error $-      "Expected to see a string value for variable " ++-      (resultItemName x) ++ ": showResultSourceIndentedLabelled"+  do a <- resultValueData $ resultItemToStringValue x+     let tab = replicate indent ' '+     return $+       showString tab .+       showString "-- " .+       showString (loc $ resultItemId x) .+       showString "\n" .+       showString tab .+       showString label .+       showString " = " .+       showString a .+       showString "\n\n" showResultSourceIndentedLabelled indent label loc (ResultVectorSource x) =   do let tab = replicate indent ' '          items = A.elems (resultVectorItems x)@@ -299,22 +299,26 @@        showString "\n\n"  -- | Show a localised text representation of the results by the specified source.-showResultSource :: MonadComp m+showResultSource :: MonadDES m                     => ResultLocalisation                     -- ^ a localisation                     -> ResultSourceShowS m+{-# INLINABLE showResultSource #-} showResultSource = showResultSourceIndented 0  -- | Show in Russian a text representation of the results by the specified source.-showResultSourceInRussian :: MonadComp m => ResultSourceShowS m+showResultSourceInRussian :: MonadDES m => ResultSourceShowS m+{-# INLINABLE showResultSourceInRussian #-} showResultSourceInRussian = showResultSource russianResultLocalisation  -- | Show in English a text representation of the results by the specified source.-showResultSourceInEnglish :: MonadComp m => ResultSourceShowS m+showResultSourceInEnglish :: MonadDES m => ResultSourceShowS m+{-# INLINABLE showResultSourceInEnglish #-} showResultSourceInEnglish = showResultSource englishResultLocalisation  -- | Print the results with the information about the modeling time.-printResultsWithTime :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Results m -> Event m ()+printResultsWithTime :: (MonadDES m, MonadIO m) => ResultSourcePrint m -> Results m -> Event m ()+{-# INLINABLE printResultsWithTime #-} printResultsWithTime print results =   do let x1 = textResultSource "----------"          x2 = timeResultSource@@ -327,17 +331,20 @@      -- print x3  -- | Print the simulation results in start time.-printResultsInStartTime :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Results m -> Simulation m ()+printResultsInStartTime :: (MonadDES m, MonadIO m) => ResultSourcePrint m -> Results m -> Simulation m ()+{-# INLINABLE printResultsInStartTime #-} printResultsInStartTime print results =   runEventInStartTime $ printResultsWithTime print results  -- | Print the simulation results in stop time.-printResultsInStopTime :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Results m -> Simulation m ()+printResultsInStopTime :: (MonadDES m, MonadIO m) => ResultSourcePrint m -> Results m -> Simulation m ()+{-# INLINABLE printResultsInStopTime #-} printResultsInStopTime print results =   runEventInStopTime $ printResultsWithTime print results  -- | Print the simulation results in the integration time points.-printResultsInIntegTimes :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Results m -> Simulation m ()+printResultsInIntegTimes :: (MonadDES m, MonadIO m) => ResultSourcePrint m -> Results m -> Simulation m ()+{-# INLINABLE printResultsInIntegTimes #-} printResultsInIntegTimes print results =   do let loop (m : ms) = m >> loop ms          loop [] = return ()@@ -346,13 +353,15 @@      liftComp $ loop ms  -- | Print the simulation results in the specified time.-printResultsInTime :: (MonadComp m, MonadIO m) => Double -> ResultSourcePrint m -> Results m -> Simulation m ()+printResultsInTime :: (MonadDES m, MonadIO m) => Double -> ResultSourcePrint m -> Results m -> Simulation m ()+{-# INLINABLE printResultsInTime #-} printResultsInTime t print results =   runDynamicsInTime t $ runEvent $   printResultsWithTime print results  -- | Print the simulation results in the specified time points.-printResultsInTimes :: (MonadComp m, MonadIO m) => [Double] -> ResultSourcePrint m -> Results m -> Simulation m ()+printResultsInTimes :: (MonadDES m, MonadIO m) => [Double] -> ResultSourcePrint m -> Results m -> Simulation m ()+{-# INLINABLE printResultsInTimes #-} printResultsInTimes ts print results =   do let loop (m : ms) = m >> loop ms          loop [] = return ()@@ -361,7 +370,8 @@      liftComp $ loop ms  -- | Show the results with the information about the modeling time.-showResultsWithTime :: MonadComp m => ResultSourceShowS m -> Results m -> Event m ShowS+showResultsWithTime :: MonadDES m => ResultSourceShowS m -> Results m -> Event m ShowS+{-# INLINABLE showResultsWithTime #-} showResultsWithTime f results =   do let x1 = textResultSource "----------"          x2 = timeResultSource@@ -379,12 +389,14 @@        -- y3  -- | Show the simulation results in start time.-showResultsInStartTime :: MonadComp m => ResultSourceShowS m -> Results m -> Simulation m ShowS+showResultsInStartTime :: MonadDES m => ResultSourceShowS m -> Results m -> Simulation m ShowS+{-# INLINABLE showResultsInStartTime #-} showResultsInStartTime f results =   runEventInStartTime $ showResultsWithTime f results  -- | Show the simulation results in stop time.-showResultsInStopTime :: MonadComp m => ResultSourceShowS m -> Results m -> Simulation m ShowS+showResultsInStopTime :: MonadDES m => ResultSourceShowS m -> Results m -> Simulation m ShowS+{-# INLINABLE showResultsInStopTime #-} showResultsInStopTime f results =   runEventInStopTime $ showResultsWithTime f results @@ -392,7 +404,8 @@ -- -- It may consume much memory, for we have to traverse all the integration -- points to create the resulting function within the 'Simulation' computation.-showResultsInIntegTimes :: MonadComp m => ResultSourceShowS m -> Results m -> Simulation m ShowS+showResultsInIntegTimes :: MonadDES m => ResultSourceShowS m -> Results m -> Simulation m ShowS+{-# INLINABLE showResultsInIntegTimes #-} showResultsInIntegTimes f results =   do let loop (m : ms) = return (.) `ap` m `ap` loop ms          loop [] = return id@@ -401,7 +414,8 @@      liftComp $ loop ms  -- | Show the simulation results in the specified time point.-showResultsInTime :: MonadComp m => Double -> ResultSourceShowS m -> Results m -> Simulation m ShowS+showResultsInTime :: MonadDES m => Double -> ResultSourceShowS m -> Results m -> Simulation m ShowS+{-# INLINABLE showResultsInTime #-} showResultsInTime t f results =   runDynamicsInTime t $ runEvent $   showResultsWithTime f results@@ -410,7 +424,8 @@ -- -- It may consume much memory, for we have to traverse all the specified -- points to create the resulting function within the 'Simulation' computation.-showResultsInTimes :: MonadComp m => [Double] -> ResultSourceShowS m -> Results m -> Simulation m ShowS+showResultsInTimes :: MonadDES m => [Double] -> ResultSourceShowS m -> Results m -> Simulation m ShowS+{-# INLINABLE showResultsInTimes #-} showResultsInTimes ts f results =   do let loop (m : ms) = return (.) `ap` m `ap` loop ms          loop [] = return id@@ -419,43 +434,50 @@      liftComp $ loop ms  -- | Run the simulation and then print the results in the start time.-printSimulationResultsInStartTime :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m ()+printSimulationResultsInStartTime :: (MonadDES m, MonadIO m) => ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m ()+{-# INLINABLE printSimulationResultsInStartTime #-} printSimulationResultsInStartTime print model specs =   flip runSimulation specs $   model >>= printResultsInStartTime print  -- | Run the simulation and then print the results in the final time.-printSimulationResultsInStopTime :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m ()+printSimulationResultsInStopTime :: (MonadDES m, MonadIO m) => ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m ()+{-# INLINABLE printSimulationResultsInStopTime #-} printSimulationResultsInStopTime print model specs =   flip runSimulation specs $   model >>= printResultsInStopTime print  -- | Run the simulation and then print the results in the integration time points.-printSimulationResultsInIntegTimes :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m ()+printSimulationResultsInIntegTimes :: (MonadDES m, MonadIO m) => ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m ()+{-# INLINABLE printSimulationResultsInIntegTimes #-} printSimulationResultsInIntegTimes print model specs =   flip runSimulation specs $   model >>= printResultsInIntegTimes print  -- | Run the simulation and then print the results in the specified time point.-printSimulationResultsInTime :: (MonadComp m, MonadIO m) => Double -> ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m ()+printSimulationResultsInTime :: (MonadDES m, MonadIO m) => Double -> ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m ()+{-# INLINABLE printSimulationResultsInTime #-} printSimulationResultsInTime t print model specs =   flip runSimulation specs $   model >>= printResultsInTime t print  -- | Run the simulation and then print the results in the specified time points.-printSimulationResultsInTimes :: (MonadComp m, MonadIO m) => [Double] -> ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m ()+printSimulationResultsInTimes :: (MonadDES m, MonadIO m) => [Double] -> ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m ()+{-# INLINABLE printSimulationResultsInTimes #-} printSimulationResultsInTimes ts print model specs =   flip runSimulation specs $   model >>= printResultsInTimes ts print  -- | Run the simulation and then show the results in the start time.-showSimulationResultsInStartTime :: MonadComp m => ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS+showSimulationResultsInStartTime :: MonadDES m => ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS+{-# INLINABLE showSimulationResultsInStartTime #-} showSimulationResultsInStartTime f model specs =   flip runSimulation specs $   model >>= showResultsInStartTime f  -- | Run the simulation and then show the results in the final time.-showSimulationResultsInStopTime :: MonadComp m => ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS+showSimulationResultsInStopTime :: MonadDES m => ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS+{-# INLINABLE showSimulationResultsInStopTime #-} showSimulationResultsInStopTime f model specs =   flip runSimulation specs $   model >>= showResultsInStopTime f@@ -464,13 +486,15 @@ -- -- It may consume much memory, for we have to traverse all the integration -- points to create the resulting function within the 'IO' computation.-showSimulationResultsInIntegTimes :: MonadComp m => ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS+showSimulationResultsInIntegTimes :: MonadDES m => ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS+{-# INLINABLE showSimulationResultsInIntegTimes #-} showSimulationResultsInIntegTimes f model specs =   flip runSimulation specs $   model >>= showResultsInIntegTimes f  -- | Run the simulation and then show the results in the integration time point.-showSimulationResultsInTime :: MonadComp m => Double -> ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS+showSimulationResultsInTime :: MonadDES m => Double -> ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS+{-# INLINABLE showSimulationResultsInTime #-} showSimulationResultsInTime t f model specs =   flip runSimulation specs $   model >>= showResultsInTime t f@@ -479,7 +503,8 @@ -- -- It may consume much memory, for we have to traverse all the specified -- points to create the resulting function within the 'IO' computation.-showSimulationResultsInTimes :: MonadComp m => [Double] -> ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS+showSimulationResultsInTimes :: MonadDES m => [Double] -> ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS+{-# INLINABLE showSimulationResultsInTimes #-} showSimulationResultsInTimes ts f model specs =   flip runSimulation specs $   model >>= showResultsInTimes ts f
Simulation/Aivika/Trans/Results/Locale.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Results.Locale--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The module defines locales for outputting and printing the simulation results. --
+ Simulation/Aivika/Trans/SD.hs view
@@ -0,0 +1,25 @@++{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module     : Simulation.Aivika.Trans.SD+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- It defines a type class of monads for System Dynamics (SD).+--+module Simulation.Aivika.Trans.SD (MonadSD) where++import Simulation.Aivika.Trans.Comp+import qualified Simulation.Aivika.Trans.Dynamics.Memo as M+import qualified Simulation.Aivika.Trans.Dynamics.Memo.Unboxed as MU++-- | A type class of monads for SD. +class (MonadComp m,+       M.MonadMemo m,+       MU.MonadMemo m Double,+       MU.MonadMemo m Float,+       MU.MonadMemo m Int) => MonadSD m
Simulation/Aivika/Trans/Server.hs view
@@ -1,21 +1,20 @@  -- | -- Module     : Simulation.Aivika.Trans.Server--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- It models the server that prodives a service. module Simulation.Aivika.Trans.Server        (-- * Server         Server,-        ServerInterruption(..),         newServer,         newStateServer,-        newInterruptibleServer,-        newInterruptibleStateServer,+        newPreemptibleServer,+        newPreemptibleStateServer,         -- * Processing         serverProcessor,         -- * Server Properties and Activities@@ -24,12 +23,15 @@         serverTotalInputWaitTime,         serverTotalProcessingTime,         serverTotalOutputWaitTime,+        serverTotalPreemptionTime,         serverInputWaitTime,         serverProcessingTime,         serverOutputWaitTime,+        serverPreemptionTime,         serverInputWaitFactor,         serverProcessingFactor,         serverOutputWaitFactor,+        serverPreemptionFactor,         -- * Summary         serverSummary,         -- * Derived Signals for Properties@@ -41,21 +43,28 @@         serverTotalProcessingTimeChanged_,         serverTotalOutputWaitTimeChanged,         serverTotalOutputWaitTimeChanged_,+        serverTotalPreemptionTimeChanged,+        serverTotalPreemptionTimeChanged_,         serverInputWaitTimeChanged,         serverInputWaitTimeChanged_,         serverProcessingTimeChanged,         serverProcessingTimeChanged_,         serverOutputWaitTimeChanged,         serverOutputWaitTimeChanged_,+        serverPreemptionTimeChanged,+        serverPreemptionTimeChanged_,         serverInputWaitFactorChanged,         serverInputWaitFactorChanged_,         serverProcessingFactorChanged,         serverProcessingFactorChanged_,         serverOutputWaitFactorChanged,         serverOutputWaitFactorChanged_,+        serverPreemptionFactorChanged,+        serverPreemptionFactorChanged_,         -- * Basic Signals         serverInputReceived,-        serverTaskInterrupted,+        serverTaskPreemptionBeginning,+        serverTaskPreemptionEnding,         serverTaskProcessed,         serverOutputProvided,         -- * Overall Signal@@ -66,15 +75,14 @@ import Control.Monad import Control.Arrow -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Parameter import Simulation.Aivika.Trans.Simulation import Simulation.Aivika.Trans.Dynamics import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Event-import Simulation.Aivika.Trans.Internal.Signal+import Simulation.Aivika.Trans.Signal import Simulation.Aivika.Trans.Resource import Simulation.Aivika.Trans.Cont import Simulation.Aivika.Trans.Process@@ -82,34 +90,38 @@ import Simulation.Aivika.Trans.Stream import Simulation.Aivika.Trans.Statistics -import Simulation.Aivika.Server (ServerInterruption(..))- -- | It models a server that takes @a@ and provides @b@ having state @s@ within underlying computation @m@. data Server m s a b =   Server { serverInitState :: s,            -- ^ The initial state of the server.-           serverStateRef :: ProtoRef m s,+           serverStateRef :: Ref m s,            -- ^ The current state of the server.            serverProcess :: s -> a -> Process m (s, b),            -- ^ Provide @b@ by specified @a@.-           serverProcessInterruptible :: Bool,-           -- ^ Whether the process is interruptible.-           serverTotalInputWaitTimeRef :: ProtoRef m Double,+           serverProcessPreemptible :: Bool,+           -- ^ Whether the process can be preempted.+           serverTotalInputWaitTimeRef :: Ref m Double,            -- ^ The counted total time spent in awating the input.-           serverTotalProcessingTimeRef :: ProtoRef m Double,+           serverTotalProcessingTimeRef :: Ref m Double,            -- ^ The counted total time spent to process the input and prepare the output.-           serverTotalOutputWaitTimeRef :: ProtoRef m Double,+           serverTotalOutputWaitTimeRef :: Ref m Double,            -- ^ The counted total time spent for delivering the output.-           serverInputWaitTimeRef :: ProtoRef m (SamplingStats Double),+           serverTotalPreemptionTimeRef :: Ref m Double,+           -- ^ The counted total time spent being preempted and waiting for the proceeding. +           serverInputWaitTimeRef :: Ref m (SamplingStats Double),            -- ^ The statistics for the time spent in awaiting the input.-           serverProcessingTimeRef :: ProtoRef m (SamplingStats Double),+           serverProcessingTimeRef :: Ref m (SamplingStats Double),            -- ^ The statistics for the time spent to process the input and prepare the output.-           serverOutputWaitTimeRef :: ProtoRef m (SamplingStats Double),+           serverOutputWaitTimeRef :: Ref m (SamplingStats Double),            -- ^ The statistics for the time spent for delivering the output.+           serverPreemptionTimeRef :: Ref m (SamplingStats Double),+           -- ^ The statistics for the time spent being preempted.            serverInputReceivedSource :: SignalSource m a,            -- ^ A signal raised when the server recieves a new input to process.-           serverTaskInterruptedSource :: SignalSource m (ServerInterruption a),-           -- ^ A signal raised when the task was interrupted.+           serverTaskPreemptionBeginningSource :: SignalSource m a,+           -- ^ A signal raised when the task was preempted.+           serverTaskPreemptionEndingSource :: SignalSource m a,+           -- ^ A signal raised when the task was proceeded after it had been preempted earlier.            serverTaskProcessedSource :: SignalSource m (a, b),            -- ^ A signal raised when the input is processed and            -- the output is prepared for deliverying.@@ -119,80 +131,89 @@  -- | Create a new server that can provide output @b@ by input @a@. ----- By default, it is assumed that the server cannot be interrupted,--- because the handling of possible task interruption is rather costly+-- By default, it is assumed that the server process cannot be preempted,+-- because the handling of possible task preemption is rather costly -- operation.-newServer :: MonadComp m+newServer :: MonadDES m              => (a -> Process m b)              -- ^ provide an output by the specified input              -> Simulation m (Server m () a b)-newServer = newInterruptibleServer False+{-# INLINABLE newServer #-}+newServer = newPreemptibleServer False  -- | Create a new server that can provide output @b@ by input @a@ -- starting from state @s@. ----- By default, it is assumed that the server cannot be interrupted,--- because the handling of possible task interruption is rather costly+-- By default, it is assumed that the server process cannot be preempted,+-- because the handling of possible task preemption is rather costly -- operation.-newStateServer :: MonadComp m+newStateServer :: MonadDES m                   => (s -> a -> Process m (s, b))                   -- ^ provide a new state and output by the specified                    -- old state and input                   -> s                   -- ^ the initial state                   -> Simulation m (Server m s a b)-newStateServer = newInterruptibleStateServer False+{-# INLINABLE newStateServer #-}+newStateServer = newPreemptibleStateServer False --- | Create a new interruptible server that can provide output @b@ by input @a@.-newInterruptibleServer :: MonadComp m-                          => Bool-                          -- ^ whether the server can be interrupted-                          -> (a -> Process m b)-                          -- ^ provide an output by the specified input-                          -> Simulation m (Server m () a b)-newInterruptibleServer interruptible provide =-  flip (newInterruptibleStateServer interruptible) () $ \s a ->+-- | Create a new preemptible server that can provide output @b@ by input @a@.+newPreemptibleServer :: MonadDES m+                        => Bool+                        -- ^ whether the server process can be preempted+                        -> (a -> Process m b)+                        -- ^ provide an output by the specified input+                        -> Simulation m (Server m () a b)+{-# INLINABLE newPreemptibleServer #-}+newPreemptibleServer preemptible provide =+  flip (newPreemptibleStateServer preemptible) () $ \s a ->   do b <- provide a      return (s, b) --- | Create a new interruptible server that can provide output @b@ by input @a@+-- | Create a new preemptible server that can provide output @b@ by input @a@ -- starting from state @s@.-newInterruptibleStateServer :: MonadComp m-                               => Bool-                               -- ^ whether the server can be interrupted-                               -> (s -> a -> Process m (s, b))-                               -- ^ provide a new state and output by the specified -                               -- old state and input-                               -> s-                               -- ^ the initial state-                               -> Simulation m (Server m s a b)-newInterruptibleStateServer interruptible provide state =-  do sn <- liftParameter simulationSession-     r0 <- liftComp $ newProtoRef sn state-     r1 <- liftComp $ newProtoRef sn 0-     r2 <- liftComp $ newProtoRef sn 0-     r3 <- liftComp $ newProtoRef sn 0-     r4 <- liftComp $ newProtoRef sn emptySamplingStats-     r5 <- liftComp $ newProtoRef sn emptySamplingStats-     r6 <- liftComp $ newProtoRef sn emptySamplingStats+newPreemptibleStateServer :: MonadDES m+                             => Bool+                             -- ^ whether the server process can be preempted+                             -> (s -> a -> Process m (s, b))+                             -- ^ provide a new state and output by the specified +                             -- old state and input+                             -> s+                             -- ^ the initial state+                             -> Simulation m (Server m s a b)+{-# INLINABLE newPreemptibleStateServer #-}+newPreemptibleStateServer preemptible provide state =+  do r0 <- newRef state+     r1 <- newRef 0+     r2 <- newRef 0+     r3 <- newRef 0+     r4 <- newRef 0+     r5 <- newRef emptySamplingStats+     r6 <- newRef emptySamplingStats+     r7 <- newRef emptySamplingStats+     r8 <- newRef emptySamplingStats      s1 <- newSignalSource      s2 <- newSignalSource      s3 <- newSignalSource      s4 <- newSignalSource+     s5 <- newSignalSource      let server = Server { serverInitState = state,                            serverStateRef = r0,                            serverProcess = provide,-                           serverProcessInterruptible = interruptible,+                           serverProcessPreemptible = preemptible,                            serverTotalInputWaitTimeRef = r1,                            serverTotalProcessingTimeRef = r2,                            serverTotalOutputWaitTimeRef = r3,-                           serverInputWaitTimeRef = r4,-                           serverProcessingTimeRef = r5,-                           serverOutputWaitTimeRef = r6,+                           serverTotalPreemptionTimeRef = r4,+                           serverInputWaitTimeRef = r5,+                           serverProcessingTimeRef = r6,+                           serverOutputWaitTimeRef = r7,+                           serverPreemptionTimeRef = r8,                            serverInputReceivedSource = s1,-                           serverTaskInterruptedSource = s2,-                           serverTaskProcessedSource = s3,-                           serverOutputProvidedSource = s4 }+                           serverTaskPreemptionBeginningSource = s2,+                           serverTaskPreemptionEndingSource = s3,+                           serverTaskProcessedSource = s4,+                           serverOutputProvidedSource = s5 }      return server  -- | Return a processor for the specified server.@@ -215,8 +236,9 @@ -- -- The queue processors usually have the prefetching capabilities per se, where -- the items are already stored in the queue. Therefore, the server processor--- should not be prefetched if it is connected directly with the queue processor.-serverProcessor :: MonadComp m => Server m s a b -> Processor m a b+-- should not be prefetched if it is connected directly to the queue processor.+serverProcessor :: MonadDES m => Server m s a b -> Processor m a b+{-# INLINABLE serverProcessor #-} serverProcessor server =   Processor $ \xs -> loop (serverInitState server) Nothing xs   where@@ -227,67 +249,83 @@            case r of              Nothing -> return ()              Just (t', a', b') ->-               do liftComp $-                    do modifyProtoRef' (serverTotalOutputWaitTimeRef server) (+ (t0 - t'))-                       modifyProtoRef' (serverOutputWaitTimeRef server) $-                         addSamplingStats (t0 - t')+               do modifyRef (serverTotalOutputWaitTimeRef server) (+ (t0 - t'))+                  modifyRef (serverOutputWaitTimeRef server) $+                    addSamplingStats (t0 - t')                   triggerSignal (serverOutputProvidedSource server) (a', b')          -- get input          (a, xs') <- runStream xs          t1 <- liftDynamics time          liftEvent $-           do liftComp $-                do modifyProtoRef' (serverTotalInputWaitTimeRef server) (+ (t1 - t0))-                   modifyProtoRef' (serverInputWaitTimeRef server) $-                     addSamplingStats (t1 - t0)+           do modifyRef (serverTotalInputWaitTimeRef server) (+ (t1 - t0))+              modifyRef (serverInputWaitTimeRef server) $+                addSamplingStats (t1 - t0)               triggerSignal (serverInputReceivedSource server) a          -- provide the service-         (s', b) <--           if serverProcessInterruptible server-           then serverProcessInterrupting server s a-           else serverProcess server s a+         (s', b, dt) <-+           if serverProcessPreemptible server+           then serverProcessPreempting server s a+           else do (s', b) <- serverProcess server s a+                   return (s', b, 0)          t2 <- liftDynamics time          liftEvent $-           do liftComp $-                do writeProtoRef (serverStateRef server) $! s'-                   modifyProtoRef' (serverTotalProcessingTimeRef server) (+ (t2 - t1))-                   modifyProtoRef' (serverProcessingTimeRef server) $-                     addSamplingStats (t2 - t1)+           do writeRef (serverStateRef server) $! s'+              modifyRef (serverTotalProcessingTimeRef server) (+ (t2 - t1 - dt))+              modifyRef (serverProcessingTimeRef server) $+                addSamplingStats (t2 - t1 - dt)               triggerSignal (serverTaskProcessedSource server) (a, b)          return (b, loop s' (Just (t2, a, b)) xs') --- | Process the input with ability to handle a possible interruption.-serverProcessInterrupting :: MonadComp m => Server m s a b -> s -> a -> Process m (s, b)-serverProcessInterrupting server s a =+-- | Process the input with ability to handle a possible preemption.+serverProcessPreempting :: MonadDES m => Server m s a b -> s -> a -> Process m (s, b, Double)+{-# INLINABLE serverProcessPreempting #-}+serverProcessPreempting server s a =   do pid <- processId      t1  <- liftDynamics time-     finallyProcess-       (serverProcess server s a)-       (liftEvent $-        do cancelled <- processCancelled pid-           when cancelled $-             do t2 <- liftDynamics time-                liftComp $-                  do modifyProtoRef' (serverTotalProcessingTimeRef server) (+ (t2 - t1))-                     modifyProtoRef' (serverProcessingTimeRef server) $-                       addSamplingStats (t2 - t1)-                let x = ServerInterruption a t1 t2-                triggerSignal (serverTaskInterruptedSource server) x)+     rs  <- liftSimulation $ newRef 0+     r1  <- liftSimulation $ newRef t1+     h1  <- liftEvent $+            handleSignal (processPreemptionBeginning pid) $ \() ->+            do t1 <- liftDynamics time+               writeRef r1 t1+               triggerSignal (serverTaskPreemptionBeginningSource server) a+     h2  <- liftEvent $+            handleSignal (processPreemptionEnding pid) $ \() ->+            do t1 <- readRef r1+               t2 <- liftDynamics time+               let dt = t2 - t1+               modifyRef rs (+ dt)+               modifyRef (serverTotalPreemptionTimeRef server) (+ dt)+               modifyRef (serverPreemptionTimeRef server) $+                 addSamplingStats dt+               triggerSignal (serverTaskPreemptionEndingSource server) a +     let m1 =+           do (s', b) <- serverProcess server s a+              dt <- liftEvent $ readRef rs+              return (s', b, dt)+         m2 =+           liftEvent $+           do disposeEvent h1+              disposeEvent h2+     finallyProcess m1 m2  -- | Return the current state of the server. -- -- See also 'serverStateChanged' and 'serverStateChanged_'.-serverState :: MonadComp m => Server m s a b -> Event m s+serverState :: MonadDES m => Server m s a b -> Event m s+{-# INLINABLE serverState #-} serverState server =-  Event $ \p -> readProtoRef (serverStateRef server)+  Event $ \p -> invokeEvent p $ readRef (serverStateRef server)    -- | Signal when the 'serverState' property value has changed.-serverStateChanged :: MonadComp m => Server m s a b -> Signal m s+serverStateChanged :: MonadDES m => Server m s a b -> Signal m s+{-# INLINABLE serverStateChanged #-} serverStateChanged server =   mapSignalM (const $ serverState server) (serverStateChanged_ server)    -- | Signal when the 'serverState' property value has changed.-serverStateChanged_ :: MonadComp m => Server m s a b -> Signal m ()+serverStateChanged_ :: MonadDES m => Server m s a b -> Signal m ()+{-# INLINABLE serverStateChanged_ #-} serverStateChanged_ server =   mapSignal (const ()) (serverTaskProcessed server) @@ -297,17 +335,20 @@ -- to the current simulation time. -- -- See also 'serverTotalInputWaitTimeChanged' and 'serverTotalInputWaitTimeChanged_'.-serverTotalInputWaitTime :: MonadComp m => Server m s a b -> Event m Double+serverTotalInputWaitTime :: MonadDES m => Server m s a b -> Event m Double+{-# INLINABLE serverTotalInputWaitTime #-} serverTotalInputWaitTime server =-  Event $ \p -> readProtoRef (serverTotalInputWaitTimeRef server)+  Event $ \p -> invokeEvent p $ readRef (serverTotalInputWaitTimeRef server)    -- | Signal when the 'serverTotalInputWaitTime' property value has changed.-serverTotalInputWaitTimeChanged :: MonadComp m => Server m s a b -> Signal m Double+serverTotalInputWaitTimeChanged :: MonadDES m => Server m s a b -> Signal m Double+{-# INLINABLE serverTotalInputWaitTimeChanged #-} serverTotalInputWaitTimeChanged server =   mapSignalM (const $ serverTotalInputWaitTime server) (serverTotalInputWaitTimeChanged_ server)    -- | Signal when the 'serverTotalInputWaitTime' property value has changed.-serverTotalInputWaitTimeChanged_ :: MonadComp m => Server m s a b -> Signal m ()+serverTotalInputWaitTimeChanged_ :: MonadDES m => Server m s a b -> Signal m ()+{-# INLINABLE serverTotalInputWaitTimeChanged_ #-} serverTotalInputWaitTimeChanged_ server =   mapSignal (const ()) (serverInputReceived server) @@ -317,17 +358,20 @@ -- to the current simulation time. -- -- See also 'serverTotalProcessingTimeChanged' and 'serverTotalProcessingTimeChanged_'.-serverTotalProcessingTime :: MonadComp m => Server m s a b -> Event m Double+serverTotalProcessingTime :: MonadDES m => Server m s a b -> Event m Double+{-# INLINABLE serverTotalProcessingTime #-} serverTotalProcessingTime server =-  Event $ \p -> readProtoRef (serverTotalProcessingTimeRef server)+  Event $ \p -> invokeEvent p $ readRef (serverTotalProcessingTimeRef server)    -- | Signal when the 'serverTotalProcessingTime' property value has changed.-serverTotalProcessingTimeChanged :: MonadComp m => Server m s a b -> Signal m Double+serverTotalProcessingTimeChanged :: MonadDES m => Server m s a b -> Signal m Double+{-# INLINABLE serverTotalProcessingTimeChanged #-} serverTotalProcessingTimeChanged server =   mapSignalM (const $ serverTotalProcessingTime server) (serverTotalProcessingTimeChanged_ server)    -- | Signal when the 'serverTotalProcessingTime' property value has changed.-serverTotalProcessingTimeChanged_ :: MonadComp m => Server m s a b -> Signal m ()+serverTotalProcessingTimeChanged_ :: MonadDES m => Server m s a b -> Signal m ()+{-# INLINABLE serverTotalProcessingTimeChanged_ #-} serverTotalProcessingTimeChanged_ server =   mapSignal (const ()) (serverTaskProcessed server) @@ -338,37 +382,67 @@ -- to the current simulation time. -- -- See also 'serverTotalOutputWaitTimeChanged' and 'serverTotalOutputWaitTimeChanged_'.-serverTotalOutputWaitTime :: MonadComp m => Server m s a b -> Event m Double+serverTotalOutputWaitTime :: MonadDES m => Server m s a b -> Event m Double+{-# INLINABLE serverTotalOutputWaitTime #-} serverTotalOutputWaitTime server =-  Event $ \p -> readProtoRef (serverTotalOutputWaitTimeRef server)+  Event $ \p -> invokeEvent p $ readRef (serverTotalOutputWaitTimeRef server)    -- | Signal when the 'serverTotalOutputWaitTime' property value has changed.-serverTotalOutputWaitTimeChanged :: MonadComp m => Server m s a b -> Signal m Double+serverTotalOutputWaitTimeChanged :: MonadDES m => Server m s a b -> Signal m Double+{-# INLINABLE serverTotalOutputWaitTimeChanged #-} serverTotalOutputWaitTimeChanged server =   mapSignalM (const $ serverTotalOutputWaitTime server) (serverTotalOutputWaitTimeChanged_ server)    -- | Signal when the 'serverTotalOutputWaitTime' property value has changed.-serverTotalOutputWaitTimeChanged_ :: MonadComp m => Server m s a b -> Signal m ()+serverTotalOutputWaitTimeChanged_ :: MonadDES m => Server m s a b -> Signal m ()+{-# INLINABLE serverTotalOutputWaitTimeChanged_ #-} serverTotalOutputWaitTimeChanged_ server =   mapSignal (const ()) (serverOutputProvided server) +-- | Return the counted total time spent by the server while it was preempted+-- waiting for the further proceeding.+--+-- The value returned changes discretely and it is usually delayed relative+-- to the current simulation time.+--+-- See also 'serverTotalPreemptionTimeChanged' and 'serverTotalPreemptionTimeChanged_'.+serverTotalPreemptionTime :: MonadDES m => Server m s a b -> Event m Double+{-# INLINABLE serverTotalPreemptionTime #-}+serverTotalPreemptionTime server =+  Event $ \p -> invokeEvent p $ readRef (serverTotalPreemptionTimeRef server)+  +-- | Signal when the 'serverTotalPreemptionTime' property value has changed.+serverTotalPreemptionTimeChanged :: MonadDES m => Server m s a b -> Signal m Double+{-# INLINABLE serverTotalPreemptionTimeChanged #-}+serverTotalPreemptionTimeChanged server =+  mapSignalM (const $ serverTotalPreemptionTime server) (serverTotalPreemptionTimeChanged_ server)+  +-- | Signal when the 'serverTotalPreemptionTime' property value has changed.+serverTotalPreemptionTimeChanged_ :: MonadDES m => Server m s a b -> Signal m ()+{-# INLINABLE serverTotalPreemptionTimeChanged_ #-}+serverTotalPreemptionTimeChanged_ server =+  mapSignal (const ()) (serverTaskPreemptionEnding server)+ -- | Return the statistics of the time when the server was locked while awaiting the input. -- -- The value returned changes discretely and it is usually delayed relative -- to the current simulation time. -- -- See also 'serverInputWaitTimeChanged' and 'serverInputWaitTimeChanged_'.-serverInputWaitTime :: MonadComp m => Server m s a b -> Event m (SamplingStats Double)+serverInputWaitTime :: MonadDES m => Server m s a b -> Event m (SamplingStats Double)+{-# INLINABLE serverInputWaitTime #-} serverInputWaitTime server =-  Event $ \p -> readProtoRef (serverInputWaitTimeRef server)+  Event $ \p -> invokeEvent p $ readRef (serverInputWaitTimeRef server)    -- | Signal when the 'serverInputWaitTime' property value has changed.-serverInputWaitTimeChanged :: MonadComp m => Server m s a b -> Signal m (SamplingStats Double)+serverInputWaitTimeChanged :: MonadDES m => Server m s a b -> Signal m (SamplingStats Double)+{-# INLINABLE serverInputWaitTimeChanged #-} serverInputWaitTimeChanged server =   mapSignalM (const $ serverInputWaitTime server) (serverInputWaitTimeChanged_ server)    -- | Signal when the 'serverInputWaitTime' property value has changed.-serverInputWaitTimeChanged_ :: MonadComp m => Server m s a b -> Signal m ()+serverInputWaitTimeChanged_ :: MonadDES m => Server m s a b -> Signal m ()+{-# INLINABLE serverInputWaitTimeChanged_ #-} serverInputWaitTimeChanged_ server =   mapSignal (const ()) (serverInputReceived server) @@ -378,17 +452,20 @@ -- to the current simulation time. -- -- See also 'serverProcessingTimeChanged' and 'serverProcessingTimeChanged_'.-serverProcessingTime :: MonadComp m => Server m s a b -> Event m (SamplingStats Double)+serverProcessingTime :: MonadDES m => Server m s a b -> Event m (SamplingStats Double)+{-# INLINABLE serverProcessingTime #-} serverProcessingTime server =-  Event $ \p -> readProtoRef (serverProcessingTimeRef server)+  Event $ \p -> invokeEvent p $ readRef (serverProcessingTimeRef server)    -- | Signal when the 'serverProcessingTime' property value has changed.-serverProcessingTimeChanged :: MonadComp m => Server m s a b -> Signal m (SamplingStats Double)+serverProcessingTimeChanged :: MonadDES m => Server m s a b -> Signal m (SamplingStats Double)+{-# INLINABLE serverProcessingTimeChanged #-} serverProcessingTimeChanged server =   mapSignalM (const $ serverProcessingTime server) (serverProcessingTimeChanged_ server)    -- | Signal when the 'serverProcessingTime' property value has changed.-serverProcessingTimeChanged_ :: MonadComp m => Server m s a b -> Signal m ()+serverProcessingTimeChanged_ :: MonadDES m => Server m s a b -> Signal m ()+{-# INLINABLE serverProcessingTimeChanged_ #-} serverProcessingTimeChanged_ server =   mapSignal (const ()) (serverTaskProcessed server) @@ -399,52 +476,84 @@ -- to the current simulation time. -- -- See also 'serverOutputWaitTimeChanged' and 'serverOutputWaitTimeChanged_'.-serverOutputWaitTime :: MonadComp m => Server m s a b -> Event m (SamplingStats Double)+serverOutputWaitTime :: MonadDES m => Server m s a b -> Event m (SamplingStats Double)+{-# INLINABLE serverOutputWaitTime #-} serverOutputWaitTime server =-  Event $ \p -> readProtoRef (serverOutputWaitTimeRef server)+  Event $ \p -> invokeEvent p $ readRef (serverOutputWaitTimeRef server)    -- | Signal when the 'serverOutputWaitTime' property value has changed.-serverOutputWaitTimeChanged :: MonadComp m => Server m s a b -> Signal m (SamplingStats Double)+serverOutputWaitTimeChanged :: MonadDES m => Server m s a b -> Signal m (SamplingStats Double)+{-# INLINABLE serverOutputWaitTimeChanged #-} serverOutputWaitTimeChanged server =   mapSignalM (const $ serverOutputWaitTime server) (serverOutputWaitTimeChanged_ server)    -- | Signal when the 'serverOutputWaitTime' property value has changed.-serverOutputWaitTimeChanged_ :: MonadComp m => Server m s a b -> Signal m ()+serverOutputWaitTimeChanged_ :: MonadDES m => Server m s a b -> Signal m ()+{-# INLINABLE serverOutputWaitTimeChanged_ #-} serverOutputWaitTimeChanged_ server =   mapSignal (const ()) (serverOutputProvided server) +-- | Return the statistics of the time spent by the server while it was preempted+-- waiting for the further proceeding.+--+-- The value returned changes discretely and it is usually delayed relative+-- to the current simulation time.+--+-- See also 'serverPreemptionTimeChanged' and 'serverPreemptionTimeChanged_'.+serverPreemptionTime :: MonadDES m => Server m s a b -> Event m (SamplingStats Double)+{-# INLINABLE serverPreemptionTime #-}+serverPreemptionTime server =+  Event $ \p -> invokeEvent p $ readRef (serverPreemptionTimeRef server)+  +-- | Signal when the 'serverPreemptionTime' property value has changed.+serverPreemptionTimeChanged :: MonadDES m => Server m s a b -> Signal m (SamplingStats Double)+{-# INLINABLE serverPreemptionTimeChanged #-}+serverPreemptionTimeChanged server =+  mapSignalM (const $ serverPreemptionTime server) (serverPreemptionTimeChanged_ server)+  +-- | Signal when the 'serverPreemptionTime' property value has changed.+serverPreemptionTimeChanged_ :: MonadDES m => Server m s a b -> Signal m ()+{-# INLINABLE serverPreemptionTimeChanged_ #-}+serverPreemptionTimeChanged_ server =+  mapSignal (const ()) (serverTaskPreemptionEnding server)+ -- | It returns the factor changing from 0 to 1, which estimates how often -- the server was awaiting for the next input task. -- -- This factor is calculated as -- -- @---   totalInputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime)+--   totalInputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime + totalPreemptionTime) -- @ -- -- As before in this module, the value returned changes discretely and -- it is usually delayed relative to the current simulation time. -- -- See also 'serverInputWaitFactorChanged' and 'serverInputWaitFactorChanged_'.-serverInputWaitFactor :: MonadComp m => Server m s a b -> Event m Double+serverInputWaitFactor :: MonadDES m => Server m s a b -> Event m Double+{-# INLINABLE serverInputWaitFactor #-} serverInputWaitFactor server =   Event $ \p ->-  do x1 <- readProtoRef (serverTotalInputWaitTimeRef server)-     x2 <- readProtoRef (serverTotalProcessingTimeRef server)-     x3 <- readProtoRef (serverTotalOutputWaitTimeRef server)-     return (x1 / (x1 + x2 + x3))+  do x1 <- invokeEvent p $ readRef (serverTotalInputWaitTimeRef server)+     x2 <- invokeEvent p $ readRef (serverTotalProcessingTimeRef server)+     x3 <- invokeEvent p $ readRef (serverTotalOutputWaitTimeRef server)+     x4 <- invokeEvent p $ readRef (serverTotalPreemptionTimeRef server)+     return (x1 / (x1 + x2 + x3 + x4))    -- | Signal when the 'serverInputWaitFactor' property value has changed.-serverInputWaitFactorChanged :: MonadComp m => Server m s a b -> Signal m Double+serverInputWaitFactorChanged :: MonadDES m => Server m s a b -> Signal m Double+{-# INLINABLE serverInputWaitFactorChanged #-} serverInputWaitFactorChanged server =   mapSignalM (const $ serverInputWaitFactor server) (serverInputWaitFactorChanged_ server)    -- | Signal when the 'serverInputWaitFactor' property value has changed.-serverInputWaitFactorChanged_ :: MonadComp m => Server m s a b -> Signal m ()+serverInputWaitFactorChanged_ :: MonadDES m => Server m s a b -> Signal m ()+{-# INLINABLE serverInputWaitFactorChanged_ #-} serverInputWaitFactorChanged_ server =   mapSignal (const ()) (serverInputReceived server) <>   mapSignal (const ()) (serverTaskProcessed server) <>-  mapSignal (const ()) (serverOutputProvided server)+  mapSignal (const ()) (serverOutputProvided server) <>+  mapSignal (const ()) (serverTaskPreemptionEnding server)  -- | It returns the factor changing from 0 to 1, which estimates how often -- the server was busy with direct processing its tasks.@@ -452,32 +561,37 @@ -- This factor is calculated as -- -- @---   totalProcessingTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime)+--   totalProcessingTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime + totalPreemptionTime) -- @ -- -- As before in this module, the value returned changes discretely and -- it is usually delayed relative to the current simulation time. -- -- See also 'serverProcessingFactorChanged' and 'serverProcessingFactorChanged_'.-serverProcessingFactor :: MonadComp m => Server m s a b -> Event m Double+serverProcessingFactor :: MonadDES m => Server m s a b -> Event m Double+{-# INLINABLE serverProcessingFactor #-} serverProcessingFactor server =   Event $ \p ->-  do x1 <- readProtoRef (serverTotalInputWaitTimeRef server)-     x2 <- readProtoRef (serverTotalProcessingTimeRef server)-     x3 <- readProtoRef (serverTotalOutputWaitTimeRef server)-     return (x2 / (x1 + x2 + x3))+  do x1 <- invokeEvent p $ readRef (serverTotalInputWaitTimeRef server)+     x2 <- invokeEvent p $ readRef (serverTotalProcessingTimeRef server)+     x3 <- invokeEvent p $ readRef (serverTotalOutputWaitTimeRef server)+     x4 <- invokeEvent p $ readRef (serverTotalPreemptionTimeRef server)+     return (x2 / (x1 + x2 + x3 + x4))    -- | Signal when the 'serverProcessingFactor' property value has changed.-serverProcessingFactorChanged :: MonadComp m => Server m s a b -> Signal m Double+serverProcessingFactorChanged :: MonadDES m => Server m s a b -> Signal m Double+{-# INLINABLE serverProcessingFactorChanged #-} serverProcessingFactorChanged server =   mapSignalM (const $ serverProcessingFactor server) (serverProcessingFactorChanged_ server)    -- | Signal when the 'serverProcessingFactor' property value has changed.-serverProcessingFactorChanged_ :: MonadComp m => Server m s a b -> Signal m ()+serverProcessingFactorChanged_ :: MonadDES m => Server m s a b -> Signal m ()+{-# INLINABLE serverProcessingFactorChanged_ #-} serverProcessingFactorChanged_ server =   mapSignal (const ()) (serverInputReceived server) <>   mapSignal (const ()) (serverTaskProcessed server) <>-  mapSignal (const ()) (serverOutputProvided server)+  mapSignal (const ()) (serverOutputProvided server) <>+  mapSignal (const ()) (serverTaskPreemptionEnding server)  -- | It returns the factor changing from 0 to 1, which estimates how often -- the server was locked trying to deliver the output after the task is finished.@@ -485,71 +599,128 @@ -- This factor is calculated as -- -- @---   totalOutputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime)+--   totalOutputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime + totalPreemptionTime) -- @ -- -- As before in this module, the value returned changes discretely and -- it is usually delayed relative to the current simulation time. -- -- See also 'serverOutputWaitFactorChanged' and 'serverOutputWaitFactorChanged_'.-serverOutputWaitFactor :: MonadComp m => Server m s a b -> Event m Double+serverOutputWaitFactor :: MonadDES m => Server m s a b -> Event m Double+{-# INLINABLE serverOutputWaitFactor #-} serverOutputWaitFactor server =   Event $ \p ->-  do x1 <- readProtoRef (serverTotalInputWaitTimeRef server)-     x2 <- readProtoRef (serverTotalProcessingTimeRef server)-     x3 <- readProtoRef (serverTotalOutputWaitTimeRef server)-     return (x3 / (x1 + x2 + x3))+  do x1 <- invokeEvent p $ readRef (serverTotalInputWaitTimeRef server)+     x2 <- invokeEvent p $ readRef (serverTotalProcessingTimeRef server)+     x3 <- invokeEvent p $ readRef (serverTotalOutputWaitTimeRef server)+     x4 <- invokeEvent p $ readRef (serverTotalPreemptionTimeRef server)+     return (x3 / (x1 + x2 + x3 + x4))    -- | Signal when the 'serverOutputWaitFactor' property value has changed.-serverOutputWaitFactorChanged :: MonadComp m => Server m s a b -> Signal m Double+serverOutputWaitFactorChanged :: MonadDES m => Server m s a b -> Signal m Double+{-# INLINABLE serverOutputWaitFactorChanged #-} serverOutputWaitFactorChanged server =   mapSignalM (const $ serverOutputWaitFactor server) (serverOutputWaitFactorChanged_ server)    -- | Signal when the 'serverOutputWaitFactor' property value has changed.-serverOutputWaitFactorChanged_ :: MonadComp m => Server m s a b -> Signal m ()+serverOutputWaitFactorChanged_ :: MonadDES m => Server m s a b -> Signal m ()+{-# INLINABLE serverOutputWaitFactorChanged_ #-} serverOutputWaitFactorChanged_ server =   mapSignal (const ()) (serverInputReceived server) <>   mapSignal (const ()) (serverTaskProcessed server) <>-  mapSignal (const ()) (serverOutputProvided server)+  mapSignal (const ()) (serverOutputProvided server) <>+  mapSignal (const ()) (serverTaskPreemptionEnding server)+  +-- | It returns the factor changing from 0 to 1, which estimates how often+-- the server was preempted waiting for the further proceeding.+--+-- This factor is calculated as+--+-- @+--   totalPreemptionTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime + totalPreemptionTime)+-- @+--+-- As before in this module, the value returned changes discretely and+-- it is usually delayed relative to the current simulation time.+--+-- See also 'serverPreemptionFactorChanged' and 'serverPreemptionFactorChanged_'.+serverPreemptionFactor :: MonadDES m => Server m s a b -> Event m Double+{-# INLINABLE serverPreemptionFactor #-}+serverPreemptionFactor server =+  Event $ \p ->+  do x1 <- invokeEvent p $ readRef (serverTotalInputWaitTimeRef server)+     x2 <- invokeEvent p $ readRef (serverTotalProcessingTimeRef server)+     x3 <- invokeEvent p $ readRef (serverTotalOutputWaitTimeRef server)+     x4 <- invokeEvent p $ readRef (serverTotalPreemptionTimeRef server)+     return (x4 / (x1 + x2 + x3 + x4))+  +-- | Signal when the 'serverPreemptionFactor' property value has changed.+serverPreemptionFactorChanged :: MonadDES m => Server m s a b -> Signal m Double+{-# INLINABLE serverPreemptionFactorChanged #-}+serverPreemptionFactorChanged server =+  mapSignalM (const $ serverPreemptionFactor server) (serverPreemptionFactorChanged_ server)+  +-- | Signal when the 'serverPreemptionFactor' property value has changed.+serverPreemptionFactorChanged_ :: MonadDES m => Server m s a b -> Signal m ()+{-# INLINABLE serverPreemptionFactorChanged_ #-}+serverPreemptionFactorChanged_ server =+  mapSignal (const ()) (serverInputReceived server) <>+  mapSignal (const ()) (serverTaskProcessed server) <>+  mapSignal (const ()) (serverOutputProvided server) <>+  mapSignal (const ()) (serverTaskPreemptionEnding server)  -- | Raised when the server receives a new input task.-serverInputReceived :: MonadComp m => Server m s a b -> Signal m a+serverInputReceived :: MonadDES m => Server m s a b -> Signal m a+{-# INLINABLE serverInputReceived #-} serverInputReceived = publishSignal . serverInputReceivedSource --- | Raised when the task processing by the server was interrupted.-serverTaskInterrupted :: MonadComp m => Server m s a b -> Signal m (ServerInterruption a)-serverTaskInterrupted = publishSignal . serverTaskInterruptedSource+-- | Raised when the task processing was preempted.+serverTaskPreemptionBeginning :: MonadDES m => Server m s a b -> Signal m a+{-# INLINABLE serverTaskPreemptionBeginning #-}+serverTaskPreemptionBeginning = publishSignal . serverTaskPreemptionBeginningSource +-- | Raised when the task processing was proceeded after it had been preempeted earlier.+serverTaskPreemptionEnding :: MonadDES m => Server m s a b -> Signal m a+{-# INLINABLE serverTaskPreemptionEnding #-}+serverTaskPreemptionEnding = publishSignal . serverTaskPreemptionEndingSource+ -- | Raised when the server has just processed the task.-serverTaskProcessed :: MonadComp m => Server m s a b -> Signal m (a, b)+serverTaskProcessed :: MonadDES m => Server m s a b -> Signal m (a, b)+{-# INLINABLE serverTaskProcessed #-} serverTaskProcessed = publishSignal . serverTaskProcessedSource  -- | Raised when the server has just delivered the output.-serverOutputProvided :: MonadComp m => Server m s a b -> Signal m (a, b)+serverOutputProvided :: MonadDES m => Server m s a b -> Signal m (a, b)+{-# INLINABLE serverOutputProvided #-} serverOutputProvided = publishSignal . serverOutputProvidedSource  -- | Signal whenever any property of the server changes.-serverChanged_ :: MonadComp m => Server m s a b -> Signal m ()+serverChanged_ :: MonadDES m => Server m s a b -> Signal m ()+{-# INLINABLE serverChanged_ #-} serverChanged_ server =   mapSignal (const ()) (serverInputReceived server) <>-  mapSignal (const ()) (serverTaskInterrupted server) <>   mapSignal (const ()) (serverTaskProcessed server) <>-  mapSignal (const ()) (serverOutputProvided server)+  mapSignal (const ()) (serverOutputProvided server) <>+  mapSignal (const ()) (serverTaskPreemptionEnding server)  -- | Return the summary for the server with desciption of its -- properties and activities using the specified indent.-serverSummary :: MonadComp m => Server m s a b -> Int -> Event m ShowS+serverSummary :: MonadDES m => Server m s a b -> Int -> Event m ShowS+{-# INLINABLE serverSummary #-} serverSummary server indent =   Event $ \p ->-  do tx1 <- readProtoRef (serverTotalInputWaitTimeRef server)-     tx2 <- readProtoRef (serverTotalProcessingTimeRef server)-     tx3 <- readProtoRef (serverTotalOutputWaitTimeRef server)-     let xf1 = tx1 / (tx1 + tx2 + tx3)-         xf2 = tx2 / (tx1 + tx2 + tx3)-         xf3 = tx3 / (tx1 + tx2 + tx3)-     xs1 <- readProtoRef (serverInputWaitTimeRef server)-     xs2 <- readProtoRef (serverProcessingTimeRef server)-     xs3 <- readProtoRef (serverOutputWaitTimeRef server)+  do tx1 <- invokeEvent p $ readRef (serverTotalInputWaitTimeRef server)+     tx2 <- invokeEvent p $ readRef (serverTotalProcessingTimeRef server)+     tx3 <- invokeEvent p $ readRef (serverTotalOutputWaitTimeRef server)+     tx4 <- invokeEvent p $ readRef (serverTotalPreemptionTimeRef server)+     let xf1 = tx1 / (tx1 + tx2 + tx3 + tx4)+         xf2 = tx2 / (tx1 + tx2 + tx3 + tx4)+         xf3 = tx3 / (tx1 + tx2 + tx3 + tx4)+         xf4 = tx4 / (tx1 + tx2 + tx3 + tx4)+     xs1 <- invokeEvent p $ readRef (serverInputWaitTimeRef server)+     xs2 <- invokeEvent p $ readRef (serverProcessingTimeRef server)+     xs3 <- invokeEvent p $ readRef (serverOutputWaitTimeRef server)+     xs4 <- invokeEvent p $ readRef (serverPreemptionTimeRef server)      let tab = replicate indent ' '      return $        showString tab .@@ -562,6 +733,9 @@        showString "total output wait time (locked while delivering the output) = " . shows tx3 .        showString "\n\n" .        showString tab .+       showString "total preemption time = " . shows tx4 .+       showString "\n" .+       showString tab .        showString "input wait factor (from 0 to 1) = " . shows xf1 .        showString "\n" .        showString tab .@@ -571,6 +745,9 @@        showString "output wait factor (from 0 to 1) = " . shows xf3 .        showString "\n\n" .        showString tab .+       showString "output preemption factor (from 0 to 1) = " . shows xf4 .+       showString "\n\n" .+       showString tab .        showString "input wait time (locked while awaiting the input):\n\n" .        samplingStatsSummary xs1 (2 + indent) .        showString "\n\n" .@@ -580,4 +757,8 @@        showString "\n\n" .        showString tab .        showString "output wait time (locked while delivering the output):\n\n" .-       samplingStatsSummary xs3 (2 + indent)+       samplingStatsSummary xs3 (2 + indent) .+       showString "\n\n" .+       showString tab .+       showString "preemption time (waiting for the proceeding after preemption):\n\n" .+       samplingStatsSummary xs4 (2 + indent)
+ Simulation/Aivika/Trans/Server/Random.hs view
@@ -0,0 +1,259 @@++-- |+-- Module     : Simulation.Aivika.Trans.Server.Random+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- This module defines some useful predefined servers that+-- hold the current process for the corresponding random time+-- interval, when processing every input element.+--++module Simulation.Aivika.Trans.Server.Random+       (newRandomUniformServer,+        newRandomUniformIntServer,+        newRandomNormalServer,+        newRandomExponentialServer,+        newRandomErlangServer,+        newRandomPoissonServer,+        newRandomBinomialServer,+        newPreemptibleRandomUniformServer,+        newPreemptibleRandomUniformIntServer,+        newPreemptibleRandomNormalServer,+        newPreemptibleRandomExponentialServer,+        newPreemptibleRandomErlangServer,+        newPreemptibleRandomPoissonServer,+        newPreemptibleRandomBinomialServer) where++import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Simulation+import Simulation.Aivika.Trans.Process+import Simulation.Aivika.Trans.Process.Random+import Simulation.Aivika.Trans.Server++-- | Create a new server that holds the process for a random time interval+-- distributed uniformly, when processing every input element.+--+-- By default, it is assumed that the server process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomUniformServer :: MonadDES m+                          => Double+                          -- ^ the minimum time interval+                          -> Double+                          -- ^ the maximum time interval+                          -> Simulation m (Server m () a a)+{-# INLINABLE newRandomUniformServer #-}+newRandomUniformServer =+  newPreemptibleRandomUniformServer False++-- | Create a new server that holds the process for a random time interval+-- distributed uniformly, when processing every input element.+--+-- By default, it is assumed that the server process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomUniformIntServer :: MonadDES m+                             => Int+                             -- ^ the minimum time interval+                             -> Int+                             -- ^ the maximum time interval+                             -> Simulation m (Server m () a a)+{-# INLINABLE newRandomUniformIntServer #-}+newRandomUniformIntServer =+  newPreemptibleRandomUniformIntServer False++-- | Create a new server that holds the process for a random time interval+-- distributed normally, when processing every input element.+--+-- By default, it is assumed that the server process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomNormalServer :: MonadDES m+                         => Double+                         -- ^ the mean time interval+                         -> Double+                         -- ^ the time interval deviation+                         -> Simulation m (Server m () a a)+{-# INLINABLE newRandomNormalServer #-}+newRandomNormalServer =+  newPreemptibleRandomNormalServer False+         +-- | Create a new server that holds the process for a random time interval+-- distributed exponentially with the specified mean (the reciprocal of the rate),+-- when processing every input element.+--+-- By default, it is assumed that the server process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomExponentialServer :: MonadDES m+                              => Double+                              -- ^ the mean time interval (the reciprocal of the rate)+                              -> Simulation m (Server m () a a)+{-# INLINABLE newRandomExponentialServer #-}+newRandomExponentialServer =+  newPreemptibleRandomExponentialServer False+         +-- | Create a new server that holds the process for a random time interval+-- having the Erlang distribution with the specified scale (the reciprocal of the rate)+-- and shape parameters, when processing every input element.+--+-- By default, it is assumed that the server process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomErlangServer :: MonadDES m+                         => Double+                         -- ^ the scale (the reciprocal of the rate)+                         -> Int+                         -- ^ the shape+                         -> Simulation m (Server m () a a)+{-# INLINABLE newRandomErlangServer #-}+newRandomErlangServer =+  newPreemptibleRandomErlangServer False++-- | Create a new server that holds the process for a random time interval+-- having the Poisson distribution with the specified mean, when processing+-- every input element.+--+-- By default, it is assumed that the server process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomPoissonServer :: MonadDES m+                          => Double+                          -- ^ the mean time interval+                          -> Simulation m (Server m () a a)+{-# INLINABLE newRandomPoissonServer #-}+newRandomPoissonServer =+  newPreemptibleRandomPoissonServer False++-- | Create a new server that holds the process for a random time interval+-- having the binomial distribution with the specified probability and trials,+-- when processing every input element.+--+-- By default, it is assumed that the server process cannot be preempted,+-- because the handling of possible task preemption is rather costly+-- operation.+newRandomBinomialServer :: MonadDES m+                           => Double+                           -- ^ the probability+                           -> Int+                           -- ^ the number of trials+                           -> Simulation m (Server m () a a)+{-# INLINABLE newRandomBinomialServer #-}+newRandomBinomialServer =+  newPreemptibleRandomBinomialServer False++-- | Create a new server that holds the process for a random time interval+-- distributed uniformly, when processing every input element.+newPreemptibleRandomUniformServer :: MonadDES m+                                     => Bool+                                     -- ^ whether the server process can be preempted+                                     -> Double+                                     -- ^ the minimum time interval+                                     -> Double+                                     -- ^ the maximum time interval+                                     -> Simulation m (Server m () a a)+{-# INLINABLE newPreemptibleRandomUniformServer #-}+newPreemptibleRandomUniformServer preemptible min max =+  newPreemptibleServer preemptible $ \a ->+  do randomUniformProcess_ min max+     return a++-- | Create a new server that holds the process for a random time interval+-- distributed uniformly, when processing every input element.+newPreemptibleRandomUniformIntServer :: MonadDES m+                                        => Bool+                                        -- ^ whether the server process can be preempted+                                        -> Int+                                        -- ^ the minimum time interval+                                        -> Int+                                        -- ^ the maximum time interval+                                        -> Simulation m (Server m () a a)+{-# INLINABLE newPreemptibleRandomUniformIntServer #-}+newPreemptibleRandomUniformIntServer preemptible min max =+  newPreemptibleServer preemptible $ \a ->+  do randomUniformIntProcess_ min max+     return a++-- | Create a new server that holds the process for a random time interval+-- distributed normally, when processing every input element.+newPreemptibleRandomNormalServer :: MonadDES m+                                    => Bool+                                    -- ^ whether the server process can be preempted+                                    -> Double+                                    -- ^ the mean time interval+                                    -> Double+                                    -- ^ the time interval deviation+                                    -> Simulation m (Server m () a a)+{-# INLINABLE newPreemptibleRandomNormalServer #-}+newPreemptibleRandomNormalServer preemptible mu nu =+  newPreemptibleServer preemptible $ \a ->+  do randomNormalProcess_ mu nu+     return a+         +-- | Create a new server that holds the process for a random time interval+-- distributed exponentially with the specified mean (the reciprocal of the rate),+-- when processing every input element.+newPreemptibleRandomExponentialServer :: MonadDES m+                                         => Bool+                                         -- ^ whether the server process can be preempted+                                         -> Double+                                         -- ^ the mean time interval (the reciprocal of the rate)+                                         -> Simulation m (Server m () a a)+{-# INLINABLE newPreemptibleRandomExponentialServer #-}+newPreemptibleRandomExponentialServer preemptible mu =+  newPreemptibleServer preemptible $ \a ->+  do randomExponentialProcess_ mu+     return a+         +-- | Create a new server that holds the process for a random time interval+-- having the Erlang distribution with the specified scale (the reciprocal of the rate)+-- and shape parameters, when processing every input element.+newPreemptibleRandomErlangServer :: MonadDES m+                                    => Bool+                                    -- ^ whether the server process can be preempted+                                    -> Double+                                    -- ^ the scale (the reciprocal of the rate)+                                    -> Int+                                    -- ^ the shape+                                    -> Simulation m (Server m () a a)+{-# INLINABLE newPreemptibleRandomErlangServer #-}+newPreemptibleRandomErlangServer preemptible beta m =+  newPreemptibleServer preemptible $ \a ->+  do randomErlangProcess_ beta m+     return a++-- | Create a new server that holds the process for a random time interval+-- having the Poisson distribution with the specified mean, when processing+-- every input element.+newPreemptibleRandomPoissonServer :: MonadDES m+                                     => Bool+                                     -- ^ whether the server process can be preempted+                                     -> Double+                                     -- ^ the mean time interval+                                     -> Simulation m (Server m () a a)+{-# INLINABLE newPreemptibleRandomPoissonServer #-}+newPreemptibleRandomPoissonServer preemptible mu =+  newPreemptibleServer preemptible $ \a ->+  do randomPoissonProcess_ mu+     return a++-- | Create a new server that holds the process for a random time interval+-- having the binomial distribution with the specified probability and trials,+-- when processing every input element.+newPreemptibleRandomBinomialServer :: MonadDES m+                                      => Bool+                                      -- ^ whether the server process can be preempted+                                      -> Double+                                      -- ^ the probability+                                      -> Int+                                      -- ^ the number of trials+                                      -> Simulation m (Server m () a a)+{-# INLINABLE newPreemptibleRandomBinomialServer #-}+newPreemptibleRandomBinomialServer preemptible prob trials =+  newPreemptibleServer preemptible $ \a ->+  do randomBinomialProcess_ prob trials+     return a
− Simulation/Aivika/Trans/Session.hs 
@@ -1,56 +0,0 @@--{-# LANGUAGE TypeFamilies #-}---- |--- Module     : Simulation.Aivika.Trans.Session--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.8.3------ It identifies a current simulation session usually associated with the current simulation run.----module Simulation.Aivika.Trans.Session-       (SessionMonad(..),-        Session(..)) where--import Data.IORef---- | A monad within which computation we can create and work with a simulation session.-class (Functor m, Monad m) => SessionMonad m where-  -  -- | A simulation session.-  data Session m :: *--  -- | A marker that exists with the session and which can be compared for equality.-  data SessionMarker m :: *--  -- | Create a new session.-  newSession :: m (Session m)--  -- | Create a new marker within the current session.-  newSessionMarker :: Session m -> m (SessionMarker m)--  -- | Compare two markers for equality.-  equalSessionMarker :: SessionMarker m -> SessionMarker m -> Bool--instance SessionMonad IO where--  data Session IO = Session--  newtype SessionMarker IO = SessionMarker (IORef ())--  {-# SPECIALISE INLINE newSession :: IO (Session IO) #-}-  newSession = return Session--  {-# SPECIALISE INLINE newSessionMarker :: Session IO -> IO (SessionMarker IO) #-}-  newSessionMarker session = fmap SessionMarker $ newIORef ()--  {-# SPECIALISE INLINE equalSessionMarker :: SessionMarker IO -> SessionMarker IO -> Bool #-}-  equalSessionMarker (SessionMarker x) (SessionMarker y) = x == y--instance SessionMonad m => Eq (SessionMarker m) where--  {-# INLINE (==) #-}-  (==) = equalSessionMarker
Simulation/Aivika/Trans/Signal.hs view
@@ -1,23 +1,25 @@  -- | -- Module     : Simulation.Aivika.Trans.Signal--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines the signal which we can subscribe handlers to.  -- These handlers can be disposed. The signal is triggered in the  -- current time point actuating the corresponded computations from  -- the handlers.  --+ module Simulation.Aivika.Trans.Signal        (-- * Handling and Triggering Signal         Signal(..),         handleSignal_,         SignalSource,         newSignalSource,+        newSignalSource0,         publishSignal,         triggerSignal,         -- * Useful Combinators@@ -25,7 +27,9 @@         mapSignalM,         apSignal,         filterSignal,+        filterSignal_,         filterSignalM,+        filterSignalM_,         emptySignal,         merge2Signals,         merge3Signals,@@ -33,17 +37,14 @@         merge5Signals,         -- * Signal Arriving         arrivalSignal,+        -- * Delaying Signal+        delaySignal,+        delaySignalM,         -- * Creating Signal in Time Points         newSignalInTimes,         newSignalInIntegTimes,         newSignalInStartTime,         newSignalInStopTime,-        -- * Signal History-        SignalHistory,-        signalHistorySignal,-        newSignalHistory,-        newSignalHistoryStartingWith,-        readSignalHistory,         -- * Signalable Computations         Signalable(..),         signalableChanged,@@ -52,4 +53,402 @@         -- * Debugging         traceSignal) where -import Simulation.Aivika.Trans.Internal.Signal+import Data.Monoid+import Data.List+import Data.Array+import Data.Array.MArray.Safe++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.DES+import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Internal.Parameter+import Simulation.Aivika.Trans.Internal.Simulation+import Simulation.Aivika.Trans.Internal.Event+import Simulation.Aivika.Arrival (Arrival(..))++-- | The signal source that can publish its signal.+data SignalSource m a =+  SignalSource { publishSignal :: Signal m a,+                                  -- ^ Publish the signal.+                 triggerSignal :: a -> Event m ()+                                  -- ^ Trigger the signal actuating +                                  -- all its handlers at the current +                                  -- simulation time point.+               }+  +-- | The signal that can have disposable handlers.  +data Signal m a =+  Signal { handleSignal :: (a -> Event m ()) -> Event m (DisposableEvent m)+           -- ^ Subscribe the handler to the specified +           -- signal and return a nested computation+           -- within a disposable object that, being applied,+           -- unsubscribes the handler from this signal.+         }++-- | The queue of signal handlers.+data SignalHandlerQueue m a =+  SignalHandlerQueue { queueList :: Ref m [SignalHandler m a] }+  +-- | It contains the information about the disposable queue handler.+data SignalHandler m a =+  SignalHandler { handlerComp :: a -> Event m (),+                  handlerRef  :: Ref m () }++instance MonadDES m => Eq (SignalHandler m a) where++  {-# INLINE (==) #-}+  x == y = (handlerRef x) == (handlerRef y)++-- | Subscribe the handler to the specified signal forever.+-- To subscribe the disposable handlers, use function 'handleSignal'.+handleSignal_ :: MonadDES m => Signal m a -> (a -> Event m ()) -> Event m ()+{-# INLINE handleSignal_ #-}+handleSignal_ signal h = +  do x <- handleSignal signal h+     return ()+     +-- | Create a new signal source.+newSignalSource :: MonadDES m => Simulation m (SignalSource m a)+{-# INLINABLE newSignalSource #-}+newSignalSource =+  do list <- newRef []+     let queue  = SignalHandlerQueue { queueList = list }+         signal = Signal { handleSignal = handle }+         source = SignalSource { publishSignal = signal, +                                 triggerSignal = trigger }+         handle h =+           Event $ \p ->+           do x <- invokeEvent p $ enqueueSignalHandler queue h+              return $+                DisposableEvent $+                dequeueSignalHandler queue x+         trigger a =+           triggerSignalHandlers queue a+     return source+     +-- | Create a new signal source within more low level computation than 'Simulation'.+newSignalSource0 :: (MonadDES m, MonadRef0 m) => m (SignalSource m a)+{-# INLINABLE newSignalSource0 #-}+newSignalSource0 =+  do list <- newRef0 []+     let queue  = SignalHandlerQueue { queueList = list }+         signal = Signal { handleSignal = handle }+         source = SignalSource { publishSignal = signal, +                                 triggerSignal = trigger }+         handle h =+           Event $ \p ->+           do x <- invokeEvent p $ enqueueSignalHandler queue h+              return $+                DisposableEvent $+                dequeueSignalHandler queue x+         trigger a =+           triggerSignalHandlers queue a+     return source++-- | Trigger all next signal handlers.+triggerSignalHandlers :: MonadDES m => SignalHandlerQueue m a -> a -> Event m ()+{-# INLINABLE triggerSignalHandlers #-}+triggerSignalHandlers q a =+  Event $ \p ->+  do hs <- invokeEvent p $ readRef (queueList q)+     forM_ hs $ \h ->+       invokeEvent p $ handlerComp h a+            +-- | Enqueue the handler and return its representative in the queue.            +enqueueSignalHandler :: MonadDES m => SignalHandlerQueue m a -> (a -> Event m ()) -> Event m (SignalHandler m a)+{-# INLINABLE enqueueSignalHandler #-}+enqueueSignalHandler q h =+  Event $ \p ->+  do r <- invokeSimulation (pointRun p) $ newRef ()+     let handler = SignalHandler { handlerComp = h,+                                   handlerRef  = r }+     invokeEvent p $ modifyRef (queueList q) (handler :)+     return handler++-- | Dequeue the handler representative.+dequeueSignalHandler :: MonadDES m => SignalHandlerQueue m a -> SignalHandler m a -> Event m ()+{-# INLINABLE dequeueSignalHandler #-}+dequeueSignalHandler q h = +  modifyRef (queueList q) (delete h)++instance MonadDES m => Functor (Signal m) where++  {-# INLINE fmap #-}+  fmap = mapSignal+  +instance MonadDES m => Monoid (Signal m a) where ++  {-# INLINE mempty #-}+  mempty = emptySignal++  {-# INLINE mappend #-}+  mappend = merge2Signals++  {-# INLINABLE mconcat #-}+  mconcat [] = emptySignal+  mconcat [x1] = x1+  mconcat [x1, x2] = merge2Signals x1 x2+  mconcat [x1, x2, x3] = merge3Signals x1 x2 x3+  mconcat [x1, x2, x3, x4] = merge4Signals x1 x2 x3 x4+  mconcat [x1, x2, x3, x4, x5] = merge5Signals x1 x2 x3 x4 x5+  mconcat (x1 : x2 : x3 : x4 : x5 : xs) = +    mconcat $ merge5Signals x1 x2 x3 x4 x5 : xs+  +-- | Map the signal according the specified function.+mapSignal :: MonadDES m => (a -> b) -> Signal m a -> Signal m b+{-# INLINABLE mapSignal #-}+mapSignal f m =+  Signal { handleSignal = \h -> +            handleSignal m $ h . f }++-- | Filter only those signal values that satisfy +-- the specified predicate.+filterSignal :: MonadDES m => (a -> Bool) -> Signal m a -> Signal m a+{-# INLINABLE filterSignal #-}+filterSignal p m =+  Signal { handleSignal = \h ->+            handleSignal m $ \a ->+            when (p a) $ h a }++-- | Filter only those signal values that satisfy +-- the specified predicate, but then ignoring the values.+filterSignal_ :: MonadDES m => (a -> Bool) -> Signal m a -> Signal m ()+{-# INLINABLE filterSignal_ #-}+filterSignal_ p m =+  Signal { handleSignal = \h ->+            handleSignal m $ \a ->+            when (p a) $ h () }+  +-- | Filter only those signal values that satisfy +-- the specified predicate.+filterSignalM :: MonadDES m => (a -> Event m Bool) -> Signal m a -> Signal m a+{-# INLINABLE filterSignalM #-}+filterSignalM p m =+  Signal { handleSignal = \h ->+            handleSignal m $ \a ->+            do x <- p a+               when x $ h a }+  +-- | Filter only those signal values that satisfy +-- the specified predicate, but then ignoring the values.+filterSignalM_ :: MonadDES m => (a -> Event m Bool) -> Signal m a -> Signal m ()+{-# INLINABLE filterSignalM_ #-}+filterSignalM_ p m =+  Signal { handleSignal = \h ->+            handleSignal m $ \a ->+            do x <- p a+               when x $ h () }+  +-- | Merge two signals.+merge2Signals :: MonadDES m => Signal m a -> Signal m a -> Signal m a+{-# INLINABLE merge2Signals #-}+merge2Signals m1 m2 =+  Signal { handleSignal = \h ->+            do x1 <- handleSignal m1 h+               x2 <- handleSignal m2 h+               return $ x1 <> x2 }++-- | Merge three signals.+merge3Signals :: MonadDES m => Signal m a -> Signal m a -> Signal m a -> Signal m a+{-# INLINABLE merge3Signals #-}+merge3Signals m1 m2 m3 =+  Signal { handleSignal = \h ->+            do x1 <- handleSignal m1 h+               x2 <- handleSignal m2 h+               x3 <- handleSignal m3 h+               return $ x1 <> x2 <> x3 }++-- | Merge four signals.+merge4Signals :: MonadDES m+                 => Signal m a -> Signal m a -> Signal m a+                 -> Signal m a -> Signal m a+{-# INLINABLE merge4Signals #-}+merge4Signals m1 m2 m3 m4 =+  Signal { handleSignal = \h ->+            do x1 <- handleSignal m1 h+               x2 <- handleSignal m2 h+               x3 <- handleSignal m3 h+               x4 <- handleSignal m4 h+               return $ x1 <> x2 <> x3 <> x4 }+           +-- | Merge five signals.+merge5Signals :: MonadDES m+                 => Signal m a -> Signal m a -> Signal m a+                 -> Signal m a -> Signal m a -> Signal m a+{-# INLINABLE merge5Signals #-}+merge5Signals m1 m2 m3 m4 m5 =+  Signal { handleSignal = \h ->+            do x1 <- handleSignal m1 h+               x2 <- handleSignal m2 h+               x3 <- handleSignal m3 h+               x4 <- handleSignal m4 h+               x5 <- handleSignal m5 h+               return $ x1 <> x2 <> x3 <> x4 <> x5 }++-- | Compose the signal.+mapSignalM :: MonadDES m => (a -> Event m b) -> Signal m a -> Signal m b+{-# INLINABLE mapSignalM #-}+mapSignalM f m =+  Signal { handleSignal = \h ->+            handleSignal m (f >=> h) }+  +-- | Transform the signal.+apSignal :: MonadDES m => Event m (a -> b) -> Signal m a -> Signal m b+{-# INLINABLE apSignal #-}+apSignal f m =+  Signal { handleSignal = \h ->+            handleSignal m $ \a -> do { x <- f; h (x a) } }++-- | An empty signal which is never triggered.+emptySignal :: MonadDES m => Signal m a+{-# INLINABLE emptySignal #-}+emptySignal =+  Signal { handleSignal = \h -> return mempty }+     +-- | Trigger the signal with the current time.+triggerSignalWithCurrentTime :: MonadDES m => SignalSource m Double -> Event m ()+{-# INLINABLE triggerSignalWithCurrentTime #-}+triggerSignalWithCurrentTime s =+  Event $ \p -> invokeEvent p $ triggerSignal s (pointTime p)++-- | Return a signal that is triggered in the specified time points.+newSignalInTimes :: MonadDES m => [Double] -> Event m (Signal m Double)+{-# INLINABLE newSignalInTimes #-}+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 :: MonadDES m => Event m (Signal m Double)+{-# INLINABLE newSignalInIntegTimes #-}+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 :: MonadDES m => Event m (Signal m Double)+{-# INLINABLE newSignalInStartTime #-}+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 :: MonadDES m => Event m (Signal m Double)+{-# INLINABLE newSignalInStopTime #-}+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 m a =+  Signalable { readSignalable :: Event m a,+               -- ^ Return a computation of the value.+               signalableChanged_ :: Signal m ()+               -- ^ 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 :: MonadDES m => Signalable m a -> Signal m a+{-# INLINABLE signalableChanged #-}+signalableChanged x = mapSignalM (const $ readSignalable x) $ signalableChanged_ x++instance Functor m => Functor (Signalable m) where++  {-# INLINE fmap #-}+  fmap f x = x { readSignalable = fmap f (readSignalable x) }++instance (MonadDES m, Monoid a) => Monoid (Signalable m a) where++  {-# INLINE mempty #-}+  mempty = emptySignalable++  {-# INLINE mappend #-}+  mappend = appendSignalable++-- | Return an identity.+emptySignalable :: (MonadDES m, Monoid a) => Signalable m a+{-# INLINABLE emptySignalable #-}+emptySignalable =+  Signalable { readSignalable = return mempty,+               signalableChanged_ = mempty }++-- | An associative operation.+appendSignalable :: (MonadDES m, Monoid a) => Signalable m a -> Signalable m a -> Signalable m a+{-# INLINABLE appendSignalable #-}+appendSignalable m1 m2 =+  Signalable { readSignalable = liftM2 (<>) (readSignalable m1) (readSignalable m2),+               signalableChanged_ = (signalableChanged_ m1) <> (signalableChanged_ m2) }++-- | Transform a signal so that the resulting signal returns a sequence of arrivals+-- saving the information about the time points at which the original signal was received.+arrivalSignal :: MonadDES m => Signal m a -> Signal m (Arrival a)+{-# INLINABLE arrivalSignal #-}+arrivalSignal m = +  Signal { handleSignal = \h ->+             do r <- liftSimulation $ newRef Nothing+                handleSignal m $ \a ->+                  Event $ \p ->+                  do t0 <- invokeEvent p $ readRef r+                     let t = pointTime p+                     invokeEvent p $ writeRef r (Just t)+                     invokeEvent p $+                       h Arrival { arrivalValue = a,+                                   arrivalTime  = t,+                                   arrivalDelay =+                                     case t0 of+                                       Nothing -> Nothing+                                       Just t0 -> Just (t - t0) } }++-- | Delay the signal values for the specified time interval.+delaySignal :: MonadDES m => Double -> Signal m a -> Signal m a+{-# INLINABLE delaySignal #-}+delaySignal delta m =+  Signal { handleSignal = \h ->+            do r <- liftSimulation $ newRef False+               h <- handleSignal m $ \a ->+                 Event $ \p ->+                 invokeEvent p $+                 enqueueEvent (pointTime p + delta) $ +                 do x <- readRef r+                    unless x $ h a+               return $ DisposableEvent $+                 disposeEvent h >>+                 writeRef r True+         }++-- | Delay the signal values for time intervals recalculated for each value.+delaySignalM :: MonadDES m => Event m Double -> Signal m a -> Signal m a+{-# INLINABLE delaySignalM #-}+delaySignalM delta m =+  Signal { handleSignal = \h ->+            do r <- liftSimulation $ newRef False+               h <- handleSignal m $ \a ->+                 Event $ \p ->+                 do delta' <- invokeEvent p delta+                    invokeEvent p $+                      enqueueEvent (pointTime p + delta') $ +                      do x <- readRef r+                         unless x $ h a+               return $ DisposableEvent $+                 disposeEvent h >>+                 writeRef r True+         }++-- | Show the debug message with the current simulation time.+traceSignal :: MonadDES m => String -> Signal m a -> Signal m a +{-# INLINABLE traceSignal #-}+traceSignal message m =+  Signal { handleSignal = \h ->+            handleSignal m $ traceEvent message . h }
Simulation/Aivika/Trans/Simulation.hs view
@@ -1,13 +1,13 @@  -- | -- Module     : Simulation.Aivika.Trans.Simulation--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 ----- The module defines the 'SimulationT' monad transformer that represents a simulation run.+-- The module defines the 'Simulation' monad transformer that represents a simulation run. --  module Simulation.Aivika.Trans.Simulation        (-- * Simulation@@ -15,15 +15,13 @@         SimulationLift(..),         runSimulation,         runSimulations,+        runSimulationByIndex,         -- * Error Handling         catchSimulation,         finallySimulation,         throwSimulation,-        -- * Memoization-        memoSimulation,         -- * Exceptions         SimulationException(..),         SimulationAbort(..)) where -import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Simulation
Simulation/Aivika/Trans/Specs.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Specs--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- It defines the simulation specs and functions for this data type. module Simulation.Aivika.Trans.Specs
Simulation/Aivika/Trans/Statistics.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Statistics--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- Represents statistics. --@@ -28,19 +28,20 @@         timingStatsSummary,         returnTimingStats,         fromIntTimingStats,+        normTimingStats,         -- * Simple Counter         SamplingCounter(..),         emptySamplingCounter,         incSamplingCounter,         decSamplingCounter,-        resetSamplingCounter,+        setSamplingCounter,         returnSamplingCounter,         -- * Timing Counter         TimingCounter(..),         emptyTimingCounter,         incTimingCounter,         decTimingCounter,-        resetTimingCounter,+        setTimingCounter,         returnTimingCounter) where  import Simulation.Aivika.Statistics
Simulation/Aivika/Trans/Statistics/Accumulator.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Statistics.Accumulator--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This small utility module allows accumulating the timing statistics based on 'Signalable' data -- such as the queue size or the number of lost items in the queue.@@ -24,17 +24,20 @@ import Simulation.Aivika.Trans.Ref import Simulation.Aivika.Trans.Statistics import Simulation.Aivika.Trans.Signal+import Simulation.Aivika.Trans.DES  -- | Represents an accumulator for the timing statistics. newtype TimingStatsAccumulator m a =   TimingStatsAccumulator { timingStatsAccumulatedRef :: Ref m (TimingStats a) }  -- | Return the accumulated statistics.-timingStatsAccumulated :: MonadComp m => TimingStatsAccumulator m a -> Event m (TimingStats a)+timingStatsAccumulated :: MonadDES m => TimingStatsAccumulator m a -> Event m (TimingStats a)+{-# INLINABLE timingStatsAccumulated #-} timingStatsAccumulated = readRef . timingStatsAccumulatedRef  -- | Start gathering the timing statistics from the current simulation time. -newTimingStatsAccumulator :: (MonadComp m, TimingData a) => Signalable m a -> Event m (TimingStatsAccumulator m a)+newTimingStatsAccumulator :: (MonadDES m, TimingData a) => Signalable m a -> Event m (TimingStatsAccumulator m a)+{-# INLINABLE newTimingStatsAccumulator #-} newTimingStatsAccumulator x =   do t0 <- liftDynamics time      a0 <- readSignalable x
Simulation/Aivika/Trans/Stream.hs view
@@ -3,11 +3,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Stream--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The infinite stream of data in time. --@@ -25,6 +25,8 @@         splitStream,         splitStreamQueueing,         splitStreamPrioritising,+        splitStreamFiltering,+        splitStreamFilteringQueueing,         -- * Specifying Identifier         streamUsingId,         -- * Prefetching and Delaying Stream@@ -52,6 +54,16 @@         apStreamM,         filterStream,         filterStreamM,+        takeStream,+        takeStreamWhile,+        takeStreamWhileM,+        dropStream,+        dropStreamWhile,+        dropStreamWhileM,+        singletonStream,+        joinStream,+        -- * Failover+        failoverStream,         -- * Integrating with Signals         signalStream,         streamSignal,@@ -71,9 +83,8 @@ import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Parameter import Simulation.Aivika.Trans.Simulation import Simulation.Aivika.Trans.Dynamics@@ -92,12 +103,12 @@                             -- ^ Run the stream.                           } -instance MonadComp m => Functor (Stream m) where+instance MonadDES m => Functor (Stream m) where    {-# INLINE fmap #-}   fmap = mapStream -instance MonadComp m => Applicative (Stream m) where+instance MonadDES m => Applicative (Stream m) where    {-# INLINE pure #-}   pure a = let y = Cons (return (a, y)) in y@@ -105,8 +116,16 @@   {-# INLINE (<*>) #-}   (<*>) = apStream -instance MonadComp m => Monoid (Stream m a) where+instance MonadDES m => Alternative (Stream m) where +  {-# INLINE empty #-}+  empty = emptyStream++  {-# INLINE (<|>) #-}+  (<|>) = mergeStreams++instance MonadDES m => Monoid (Stream m a) where+   {-# INLINE mempty #-}   mempty  = emptyStream @@ -120,13 +139,15 @@ -- 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 :: MonadComp m => ProcessId m -> Stream m a -> Stream m a+streamUsingId :: MonadDES m => ProcessId m -> Stream m a -> Stream m a+{-# INLINABLE streamUsingId #-} 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 :: MonadComp m => Stream m a -> Simulation m (Stream m a)+memoStream :: MonadDES m => Stream m a -> Simulation m (Stream m a)+{-# INLINABLE memoStream #-} memoStream (Cons s) =   do p <- memoProcess $           do ~(x, xs) <- s@@ -135,7 +156,8 @@      return (Cons p)  -- | Zip two streams trying to get data sequentially.-zipStreamSeq :: MonadComp m => Stream m a -> Stream m b -> Stream m (a, b)+zipStreamSeq :: MonadDES m => Stream m a -> Stream m b -> Stream m (a, b)+{-# INLINABLE zipStreamSeq #-} zipStreamSeq (Cons sa) (Cons sb) = Cons y where   y = do ~(x, xs) <- sa          ~(y, ys) <- sb@@ -143,13 +165,15 @@  -- | Zip two streams trying to get data as soon as possible, -- launching the sub-processes in parallel.-zipStreamParallel :: MonadComp m => Stream m a -> Stream m b -> Stream m (a, b)+zipStreamParallel :: MonadDES m => Stream m a -> Stream m b -> Stream m (a, b)+{-# INLINABLE zipStreamParallel #-} 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 :: MonadComp m => Stream m a -> Stream m b -> Stream m c -> Stream m (a, b, c)+zip3StreamSeq :: MonadDES m => Stream m a -> Stream m b -> Stream m c -> Stream m (a, b, c)+{-# INLINABLE zip3StreamSeq #-} zip3StreamSeq (Cons sa) (Cons sb) (Cons sc) = Cons y where   y = do ~(x, xs) <- sa          ~(y, ys) <- sb@@ -158,13 +182,15 @@  -- | Zip three streams trying to get data as soon as possible, -- launching the sub-processes in parallel.-zip3StreamParallel :: MonadComp m => Stream m a -> Stream m b -> Stream m c -> Stream m (a, b, c)+zip3StreamParallel :: MonadDES m => Stream m a -> Stream m b -> Stream m c -> Stream m (a, b, c)+{-# INLINABLE zip3StreamParallel #-} 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 :: MonadComp m => Stream m (a, b) -> Simulation m (Stream m a, Stream m b)+unzipStream :: MonadDES m => Stream m (a, b) -> Simulation m (Stream m a, Stream m b)+{-# INLINABLE unzipStream #-} unzipStream s =   do s' <- memoStream s      let sa = mapStream fst s'@@ -175,7 +201,8 @@ -- read data sequentially from the input streams. -- -- This is a generalization of 'zipStreamSeq'.-streamSeq :: MonadComp m => [Stream m a] -> Stream m [a]+streamSeq :: MonadDES m => [Stream m a] -> Stream m [a]+{-# INLINABLE streamSeq #-} streamSeq xs = Cons y where   y = do ps <- forM xs runStream          return (map fst ps, streamSeq $ map snd ps)@@ -184,39 +211,45 @@ -- read data from the input streams in parallel. -- -- This is a generalization of 'zipStreamParallel'.-streamParallel :: MonadComp m => [Stream m a] -> Stream m [a]+streamParallel :: MonadDES m => [Stream m a] -> Stream m [a]+{-# INLINABLE streamParallel #-} 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 :: MonadComp m => Process m a -> Stream m a+repeatProcess :: MonadDES m => Process m a -> Stream m a+{-# INLINABLE repeatProcess #-} repeatProcess p = Cons y where   y = do a <- p          return (a, repeatProcess p)  -- | Map the stream according the specified function.-mapStream :: MonadComp m => (a -> b) -> Stream m a -> Stream m b+mapStream :: MonadDES m => (a -> b) -> Stream m a -> Stream m b+{-# INLINABLE mapStream #-} mapStream f (Cons s) = Cons y where   y = do (a, xs) <- s          return (f a, mapStream f xs)  -- | Compose the stream.-mapStreamM :: MonadComp m => (a -> Process m b) -> Stream m a -> Stream m b+mapStreamM :: MonadDES m => (a -> Process m b) -> Stream m a -> Stream m b+{-# INLINABLE mapStreamM #-} mapStreamM f (Cons s) = Cons y where   y = do (a, xs) <- s          b <- f a          return (b, mapStreamM f xs)  -- | Sequential application.-apStream :: MonadComp m => Stream m (a -> b) -> Stream m a -> Stream m b+apStream :: MonadDES m => Stream m (a -> b) -> Stream m a -> Stream m b+{-# INLINABLE apStream #-} apStream (Cons sf) (Cons sa) = Cons y where   y = do (f, sf') <- sf          (a, sa') <- sa          return (f a, apStream sf' sa')  -- | Sequential application.-apStreamM :: MonadComp m => Stream m (a -> Process m b) -> Stream m a -> Stream m b+apStreamM :: MonadDES m => Stream m (a -> Process m b) -> Stream m a -> Stream m b+{-# INLINABLE apStreamM #-} apStreamM (Cons sf) (Cons sa) = Cons y where   y = do (f, sf') <- sf          (a, sa') <- sa@@ -224,7 +257,8 @@          return (x, apStreamM sf' sa')  -- | Filter only those data values that satisfy to the specified predicate.-filterStream :: MonadComp m => (a -> Bool) -> Stream m a -> Stream m a+filterStream :: MonadDES m => (a -> Bool) -> Stream m a -> Stream m a+{-# INLINABLE filterStream #-} filterStream p (Cons s) = Cons y where   y = do (a, xs) <- s          if p a@@ -232,7 +266,8 @@            else let Cons z = filterStream p xs in z  -- | Filter only those data values that satisfy to the specified predicate.-filterStreamM :: MonadComp m => (a -> Process m Bool) -> Stream m a -> Stream m a+filterStreamM :: MonadDES m => (a -> Process m Bool) -> Stream m a -> Stream m a+{-# INLINABLE filterStreamM #-} filterStreamM p (Cons s) = Cons y where   y = do (a, xs) <- s          b <- p a@@ -241,7 +276,8 @@            else let Cons z = filterStreamM p xs in z  -- | The stream of 'Left' values.-leftStream :: MonadComp m => Stream m (Either a b) -> Stream m a+leftStream :: MonadDES m => Stream m (Either a b) -> Stream m a+{-# INLINABLE leftStream #-} leftStream (Cons s) = Cons y where   y = do (a, xs) <- s          case a of@@ -249,7 +285,8 @@            Right _ -> let Cons z = leftStream xs in z  -- | The stream of 'Right' values.-rightStream :: MonadComp m => Stream m (Either a b) -> Stream m b+rightStream :: MonadDES m => Stream m (Either a b) -> Stream m b+{-# INLINABLE rightStream #-} rightStream (Cons s) = Cons y where   y = do (a, xs) <- s          case a of@@ -257,7 +294,8 @@            Right a -> return (a, rightStream xs)  -- | Replace the 'Left' values.-replaceLeftStream :: MonadComp m => Stream m (Either a b) -> Stream m c -> Stream m (Either c b)+replaceLeftStream :: MonadDES m => Stream m (Either a b) -> Stream m c -> Stream m (Either c b)+{-# INLINABLE replaceLeftStream #-} replaceLeftStream (Cons sab) (ys0 @ ~(Cons sc)) = Cons z where   z = do (a, xs) <- sab          case a of@@ -268,7 +306,8 @@              return (Right a, replaceLeftStream xs ys0)  -- | Replace the 'Right' values.-replaceRightStream :: MonadComp m => Stream m (Either a b) -> Stream m c -> Stream m (Either a c)+replaceRightStream :: MonadDES m => Stream m (Either a b) -> Stream m c -> Stream m (Either a c)+{-# INLINABLE replaceRightStream #-} replaceRightStream (Cons sab) (ys0 @ ~(Cons sc)) = Cons z where   z = do (a, xs) <- sab          case a of@@ -279,14 +318,16 @@              return (Left a, replaceRightStream xs ys0)  -- | Partition the stream of 'Either' values into two streams.-partitionEitherStream :: MonadComp m => Stream m (Either a b) -> Simulation m (Stream m a, Stream m b)+partitionEitherStream :: MonadDES m => Stream m (Either a b) -> Simulation m (Stream m a, Stream m b)+{-# INLINABLE partitionEitherStream #-} 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 :: MonadComp m => Int -> Stream m a -> Simulation m [Stream m a]+splitStream :: MonadDES m => Int -> Stream m a -> Simulation m [Stream m a]+{-# INLINABLE splitStream #-} splitStream = splitStreamQueueing FCFS  -- | Split the input stream into the specified number of output streams.@@ -294,7 +335,7 @@ -- If you don't know what the strategy to apply, then you probably -- need the 'FCFS' strategy, or function 'splitStream' that -- does namely this.-splitStreamQueueing :: (MonadComp m, EnqueueStrategy m s)+splitStreamQueueing :: (MonadDES m, EnqueueStrategy m s)                        => s                        -- ^ the strategy applied for enqueuing the output requests                        -> Int@@ -303,21 +344,21 @@                        -- ^ the input stream                        -> Simulation m [Stream m a]                        -- ^ the splitted output streams+{-# INLINABLE splitStreamQueueing #-} splitStreamQueueing s n x =-  do session <- liftParameter simulationSession-     ref <- liftComp $ newProtoRef session x+  do ref <- newRef x      res <- newResource s 1      let reader =            usingResource res $-           do p <- liftComp $ readProtoRef ref+           do p <- liftEvent $ readRef ref               (a, xs) <- runStream p-              liftComp $ writeProtoRef ref xs+              liftEvent $ writeRef 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 :: (MonadComp m, PriorityQueueStrategy m s p)+splitStreamPrioritising :: (MonadDES m, PriorityQueueStrategy m s p)                            => s                            -- ^ the strategy applied for enqueuing the output requests                            -> [Stream m p]@@ -326,23 +367,65 @@                            -- ^ the input stream                            -> Simulation m [Stream m a]                            -- ^ the splitted output streams+{-# INLINABLE splitStreamPrioritising #-} splitStreamPrioritising s ps x =-  do session <- liftParameter simulationSession-     ref <- liftComp $ newProtoRef session x+  do ref <- newRef x      res <- newResource s 1      let stream (Cons p) = Cons z where            z = do (p', ps) <- p                   a <- usingResourceWithPriority res p' $-                       do p <- liftComp $ readProtoRef ref+                       do p <- liftEvent $ readRef ref                           (a, xs) <- runStream p-                          liftComp $ writeProtoRef ref xs+                          liftEvent $ writeRef ref xs                           return a                   return (a, stream ps)      return $ map stream ps +-- | Split the input stream into the specified number of output streams+-- after filtering and applying the 'FCFS' strategy for enqueuing the output requests.+splitStreamFiltering :: MonadDES m => [a -> Event m Bool] -> Stream m a -> Simulation m [Stream m a]+{-# INLINABLE splitStreamFiltering #-}+splitStreamFiltering = splitStreamFilteringQueueing FCFS++-- | Split the input stream into the specified number of output streams after filtering.+--+-- If you don't know what the strategy to apply, then you probably+-- need the 'FCFS' strategy, or function 'splitStreamFiltering' that+-- does namely this.+splitStreamFilteringQueueing :: (MonadDES m, EnqueueStrategy m s)+                                => s+                                -- ^ the strategy applied for enqueuing the output requests+                                -> [a -> Event m Bool]+                                -- ^ the filters for output streams+                                -> Stream m a+                                -- ^ the input stream+                                -> Simulation m [Stream m a]+                                -- ^ the splitted output streams+{-# INLINABLE splitStreamFilteringQueueing #-}+splitStreamFilteringQueueing s preds x =+  do ref <- liftSimulation $ newRef x+     res <- newResource s 1+     let reader pred =+           do a <-+                usingResource res $+                do p <- liftEvent $ readRef ref+                   (a, xs) <- runStream p+                   liftEvent $+                     do f <- pred a+                        if f+                          then do writeRef ref xs+                                  return $ Just a+                          else do writeRef ref $ Cons (return (a, xs))+                                  return Nothing+              case a of+                Just a  -> return a+                Nothing -> reader pred+     return $ map (repeatProcess . reader) preds+ -- | Concatenate the input streams applying the 'FCFS' strategy and -- producing one output stream.-concatStreams :: MonadComp m => [Stream m a] -> Stream m a+concatStreams :: MonadDES m => [Stream m a] -> Stream m a+{-# INLINABLE concatStreams #-} concatStreams = concatQueuedStreams FCFS  -- | Concatenate the input streams producing one output stream.@@ -350,30 +433,30 @@ -- 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 :: (MonadComp m, EnqueueStrategy m s)+concatQueuedStreams :: (MonadDES m, EnqueueStrategy m s)                        => s                        -- ^ the strategy applied for enqueuing the input data                        -> [Stream m a]                        -- ^ the input stream                        -> Stream m a                        -- ^ the combined output stream+{-# INLINABLE concatQueuedStreams #-} concatQueuedStreams s streams = Cons z where   z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1)          writing <- liftSimulation $ newResourceWithMaxCount s 1 (Just 1)          conting <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1)-         session <- liftParameter simulationSession-         ref <- liftComp $ newProtoRef session Nothing+         ref <- liftSimulation $ newRef Nothing          let writer p =                do (a, xs) <- runStream p                   requestResource writing-                  liftComp $ writeProtoRef ref (Just a)+                  liftEvent $ writeRef ref (Just a)                   releaseResource reading                   requestResource conting                   writer xs              reader =                do requestResource reading-                  Just a <- liftComp $ readProtoRef ref-                  liftComp $ writeProtoRef ref Nothing+                  Just a <- liftEvent $ readRef ref+                  liftEvent $ writeRef ref Nothing                   releaseResource writing                   return a          forM_ streams $ spawnProcess . writer@@ -382,30 +465,30 @@          return (a, xs)  -- | Concatenate the input priority streams producing one output stream.-concatPriorityStreams :: (MonadComp m, PriorityQueueStrategy m s p)+concatPriorityStreams :: (MonadDES m, PriorityQueueStrategy m s p)                          => s                          -- ^ the strategy applied for enqueuing the input data                          -> [Stream m (p, a)]                          -- ^ the input stream                          -> Stream m a                          -- ^ the combined output stream+{-# INLINABLE concatPriorityStreams #-} concatPriorityStreams s streams = Cons z where   z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1)          writing <- liftSimulation $ newResourceWithMaxCount s 1 (Just 1)          conting <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1)-         session <- liftParameter simulationSession-         ref <- liftComp $ newProtoRef session Nothing+         ref <- liftSimulation $ newRef Nothing          let writer p =                do ((priority, a), xs) <- runStream p                   requestResourceWithPriority writing priority-                  liftComp $ writeProtoRef ref (Just a)+                  liftEvent $ writeRef ref (Just a)                   releaseResource reading                   requestResource conting                   writer xs              reader =                do requestResource reading-                  Just a <- liftComp $ readProtoRef ref-                  liftComp $ writeProtoRef ref Nothing+                  Just a <- liftEvent $ readRef ref+                  liftEvent $ writeRef ref Nothing                   releaseResource writing                   return a          forM_ streams $ spawnProcess . writer@@ -414,7 +497,8 @@          return (a, xs)  -- | Merge two streams applying the 'FCFS' strategy for enqueuing the input data.-mergeStreams :: MonadComp m => Stream m a -> Stream m a -> Stream m a+mergeStreams :: MonadDES m => Stream m a -> Stream m a -> Stream m a+{-# INLINABLE mergeStreams #-} mergeStreams = mergeQueuedStreams FCFS  -- | Merge two streams.@@ -422,7 +506,7 @@ -- 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 :: (MonadComp m, EnqueueStrategy m s)+mergeQueuedStreams :: (MonadDES m, EnqueueStrategy m s)                       => s                       -- ^ the strategy applied for enqueuing the input data                       -> Stream m a@@ -431,10 +515,11 @@                       -- ^ the second input stream                       -> Stream m a                       -- ^ the output combined stream+{-# INLINABLE mergeQueuedStreams #-} mergeQueuedStreams s x y = concatQueuedStreams s [x, y]  -- | Merge two priority streams.-mergePriorityStreams :: (MonadComp m, PriorityQueueStrategy m s p)+mergePriorityStreams :: (MonadDES m, PriorityQueueStrategy m s p)                         => s                         -- ^ the strategy applied for enqueuing the input data                         -> Stream m (p, a)@@ -443,30 +528,34 @@                         -- ^ the second input stream                         -> Stream m a                         -- ^ the output combined stream+{-# INLINABLE mergePriorityStreams #-} mergePriorityStreams s x y = concatPriorityStreams s [x, y]  -- | An empty stream that never returns data.-emptyStream :: MonadComp m => Stream m a+emptyStream :: MonadDES m => Stream m a+{-# INLINABLE emptyStream #-} emptyStream = Cons neverProcess  -- | 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 enqueueing data in the queue -- from the input stream.-consumeStream :: MonadComp m => (a -> Process m ()) -> Stream m a -> Process m ()-consumeStream f = p where-  p (Cons s) = do (a, xs) <- s-                  f a-                  p xs+consumeStream :: MonadDES m => (a -> Process m ()) -> Stream m a -> Process m ()+{-# INLINABLE consumeStream #-}+consumeStream f (Cons s) =+  do (a, xs) <- s+     f a+     consumeStream f 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 :: MonadComp m => Stream m a -> Process m ()-sinkStream = p where-  p (Cons s) = do (a, xs) <- s-                  p xs+sinkStream :: MonadDES m => Stream m a -> Process m ()+{-# INLINABLE sinkStream #-}+sinkStream (Cons s) =+  do (a, xs) <- s+     sinkStream xs    -- | Prefetch the input stream requesting for one more data item in advance  -- while the last received item is not yet fully processed in the chain of @@ -475,22 +564,22 @@ -- You can think of this as the prefetched stream could place its latest  -- data item in some temporary space for later use, which is very useful  -- for modeling a sequence of separate and independent work places.-prefetchStream :: MonadComp m => Stream m a -> Stream m a+prefetchStream :: MonadDES m => Stream m a -> Stream m a+{-# INLINABLE prefetchStream #-} prefetchStream s = Cons z where   z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1)          writing <- liftSimulation $ newResourceWithMaxCount FCFS 1 (Just 1)-         session <- liftParameter simulationSession-         ref <- liftComp $ newProtoRef session Nothing+         ref <- liftSimulation $ newRef Nothing          let writer p =                do (a, xs) <- runStream p                   requestResource writing-                  liftComp $ writeProtoRef ref (Just a)+                  liftEvent $ writeRef ref (Just a)                   releaseResource reading                   writer xs              reader =                do requestResource reading-                  Just a <- liftComp $ readProtoRef ref-                  liftComp $ writeProtoRef ref Nothing+                  Just a <- liftEvent $ readRef ref+                  liftEvent $ writeRef ref Nothing                   releaseResource writing                   return a          spawnProcess $ writer s@@ -511,7 +600,8 @@ -- the stream and it is returned within the computation. -- -- Cancel the stream's process to unsubscribe from the specified signal.-signalStream :: MonadComp m => Signal m a -> Process m (Stream m a)+signalStream :: MonadDES m => Signal m a -> Process m (Stream m a)+{-# INLINABLE signalStream #-} signalStream s =   do q <- liftEvent newFCFSQueue      h <- liftEvent $@@ -525,7 +615,8 @@ -- computation. -- -- Cancel the returned process to stop reading from the specified stream. -streamSignal :: MonadComp m => Stream m a -> Process m (Signal m a)+streamSignal :: MonadDES m => Stream m a -> Process m (Signal m a)+{-# INLINABLE streamSignal #-} streamSignal z =   do s <- liftSimulation newSignalSource      spawnProcess $@@ -535,7 +626,8 @@ -- | Transform a stream so that the resulting stream returns a sequence of arrivals -- saving the information about the time points at which the original stream items  -- were received by demand.-arrivalStream :: MonadComp m => Stream m a -> Stream m (Arrival a)+arrivalStream :: MonadDES m => Stream m a -> Stream m (Arrival a)+{-# INLINABLE arrivalStream #-} arrivalStream s = Cons $ loop s Nothing where   loop s t0 = do (a, xs) <- runStream s                  t <- liftDynamics time@@ -548,11 +640,128 @@                  return (b, Cons $ loop xs (Just t))  -- | Delay the stream by one step using the specified initial value.-delayStream :: MonadComp m => a -> Stream m a -> Stream m a+delayStream :: MonadDES m => a -> Stream m a -> Stream m a+{-# INLINABLE delayStream #-} delayStream a0 s = Cons $ return (a0, s) +-- | Return a stream consisting of exactly one element and inifinite tail.+singletonStream :: MonadDES m => a -> Stream m a+{-# INLINABLE singletonStream #-}+singletonStream a = Cons $ return (a, emptyStream)++-- | Removes one level of the computation, projecting its bound stream into the outer level.+joinStream :: MonadDES m => Process m (Stream m a) -> Stream m a+{-# INLINABLE joinStream #-}+joinStream m = Cons $ m >>= runStream++-- | Takes the next stream from the list after the current stream fails because of cancelling the underlying process.+failoverStream :: MonadDES m => [Stream m a] -> Stream m a+{-# INLINABLE failoverStream #-}+failoverStream ps = Cons z where+  z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1)+         writing <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1)+         ref <- liftSimulation $ newRef Nothing+         pid <- processId+         let writer p =+               do requestResource writing+                  pid' <- processId+                  (a, xs) <-+                    finallyProcess (runStream p) $+                    liftEvent $+                    do cancelled' <- processCancelled pid'+                       when cancelled' $+                         releaseResourceWithinEvent writing+                  liftEvent $ writeRef ref (Just a)+                  releaseResource reading+                  writer xs+             reader =+               do releaseResource writing+                  requestResource reading+                  Just a <- liftEvent $ readRef ref+                  liftEvent $ writeRef ref Nothing+                  return a+             loop [] = return ()+             loop (p: ps) =+               do pid' <- processId+                  h' <- liftEvent $+                        handleSignal (processCancelling pid) $ \() ->+                        cancelProcessWithId pid'+                  finallyProcess (writer p) $+                    liftEvent $+                    do disposeEvent h'+                       cancelled <- processCancelled pid+                       unless cancelled $+                         do cancelled' <- processCancelled pid'+                            unless cancelled' $+                              error "Expected the sub-process to be cancelled: failoverStream"+                            runProcess $ loop ps+         liftEvent $ runProcess $ loop ps+         runStream $ repeatProcess reader++-- | Return the prefix of the stream of the specified length.+takeStream :: MonadDES m => Int -> Stream m a -> Stream m a+{-# INLINABLE takeStream #-}+takeStream n s+  | n <= 0    = emptyStream+  | otherwise =+    Cons $+    do (a, xs) <- runStream s+       return (a, takeStream (n - 1) xs)++-- | Return the longest prefix of the stream of elements that satisfy the predicate.+takeStreamWhile :: MonadDES m => (a -> Bool) -> Stream m a -> Stream m a+{-# INLINABLE takeStreamWhile #-}+takeStreamWhile p s =+  Cons $+  do (a, xs) <- runStream s+     if p a+       then return (a, takeStreamWhile p xs)+       else neverProcess++-- | Return the longest prefix of the stream of elements that satisfy the computation.+takeStreamWhileM :: MonadDES m => (a -> Process m Bool) -> Stream m a -> Stream m a+{-# INLINABLE takeStreamWhileM #-}+takeStreamWhileM p s =+  Cons $+  do (a, xs) <- runStream s+     f <- p a+     if f+       then return (a, takeStreamWhileM p xs)+       else neverProcess++-- | Return the suffix of the stream after the specified first elements.+dropStream :: MonadDES m => Int -> Stream m a -> Stream m a+{-# INLINABLE dropStream #-}+dropStream n s+  | n <= 0    = s+  | otherwise =+    Cons $+    do (a, xs) <- runStream s+       runStream $ dropStream (n - 1) xs++-- | Return the suffix of the stream of elements remaining after 'takeStreamWhile'.+dropStreamWhile :: MonadDES m => (a -> Bool) -> Stream m a -> Stream m a+{-# INLINABLE dropStreamWhile #-}+dropStreamWhile p s =+  Cons $+  do (a, xs) <- runStream s+     if p a+       then runStream $ dropStreamWhile p xs+       else return (a, xs)++-- | Return the suffix of the stream of elements remaining after 'takeStreamWhileM'.+dropStreamWhileM :: MonadDES m => (a -> Process m Bool) -> Stream m a -> Stream m a+{-# INLINABLE dropStreamWhileM #-}+dropStreamWhileM p s =+  Cons $+  do (a, xs) <- runStream s+     f <- p a+     if f+       then runStream $ dropStreamWhileM p xs+       else return (a, xs)+ -- | Show the debug messages with the current simulation time.-traceStream :: MonadComp m+traceStream :: MonadDES m                => Maybe String                -- ^ the request message                -> Maybe String@@ -560,6 +769,7 @@                -> Stream m a                -- ^ a stream                -> Stream m a+{-# INLINABLE traceStream #-} traceStream request response s = Cons $ loop s where   loop s = do (a, xs) <-                 case request of
Simulation/Aivika/Trans/Stream/Random.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Stream.Random--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines random streams of events, which are useful -- for describing the input of the model.@@ -27,7 +27,7 @@ import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Parameter import Simulation.Aivika.Trans.Parameter.Random import Simulation.Aivika.Trans.Simulation@@ -41,11 +41,12 @@ import Simulation.Aivika.Trans.Arrival  -- | Return a sream of random events that arrive with the specified delay.-randomStream :: MonadComp m+randomStream :: MonadDES m                 => Parameter m (Double, a)                 -- ^ compute a pair of the delay and event of type @a@                 -> Stream m (Arrival a)                 -- ^ a stream of delayed events+{-# INLINE randomStream #-} randomStream delay = Cons $ loop Nothing where   loop t0 =     do t1 <- liftDynamics time@@ -71,39 +72,42 @@        return (arrival, Cons $ loop (Just t2))  -- | Create a new stream with delays distributed uniformly.-randomUniformStream :: MonadComp m+randomUniformStream :: MonadDES m                        => Double                        -- ^ the minimum delay                        -> Double                        -- ^ the maximum delay                        -> Stream m (Arrival Double)                        -- ^ the stream of random events with the delays generated+{-# INLINABLE randomUniformStream #-} randomUniformStream min max =   randomStream $   randomUniform min max >>= \x ->   return (x, x)  -- | Create a new stream with integer delays distributed uniformly.-randomUniformIntStream :: MonadComp m+randomUniformIntStream :: MonadDES m                           => Int                           -- ^ the minimum delay                           -> Int                           -- ^ the maximum delay                           -> Stream m (Arrival Int)                           -- ^ the stream of random events with the delays generated+{-# INLINABLE randomUniformIntStream #-} randomUniformIntStream min max =   randomStream $   randomUniformInt min max >>= \x ->   return (fromIntegral x, x)  -- | Create a new stream with delays distributed normally.-randomNormalStream :: MonadComp m+randomNormalStream :: MonadDES m                       => Double                       -- ^ the mean delay                       -> Double                       -- ^ the delay deviation                       -> Stream m (Arrival Double)                       -- ^ the stream of random events with the delays generated+{-# INLINABLE randomNormalStream #-} randomNormalStream mu nu =   randomStream $   randomNormal mu nu >>= \x ->@@ -111,11 +115,12 @@           -- | Return a new stream with delays distibuted exponentially with the specified mean -- (the reciprocal of the rate).-randomExponentialStream :: MonadComp m+randomExponentialStream :: MonadDES m                            => Double                            -- ^ the mean delay (the reciprocal of the rate)                            -> Stream m (Arrival Double)                            -- ^ the stream of random events with the delays generated+{-# INLINABLE randomExponentialStream #-} randomExponentialStream mu =   randomStream $   randomExponential mu >>= \x ->@@ -123,13 +128,14 @@           -- | Return a new stream with delays having the Erlang distribution with the specified -- scale (the reciprocal of the rate) and shape parameters.-randomErlangStream :: MonadComp m+randomErlangStream :: MonadDES m                       => Double                       -- ^ the scale (the reciprocal of the rate)                       -> Int                       -- ^ the shape                       -> Stream m (Arrival Double)                       -- ^ the stream of random events with the delays generated+{-# INLINABLE randomErlangStream #-} randomErlangStream beta m =   randomStream $   randomErlang beta m >>= \x ->@@ -137,11 +143,12 @@  -- | Return a new stream with delays having the Poisson distribution with -- the specified mean.-randomPoissonStream :: MonadComp m+randomPoissonStream :: MonadDES m                        => Double                        -- ^ the mean delay                        -> Stream m (Arrival Int)                        -- ^ the stream of random events with the delays generated+{-# INLINABLE randomPoissonStream #-} randomPoissonStream mu =   randomStream $   randomPoisson mu >>= \x ->@@ -149,13 +156,14 @@  -- | Return a new stream with delays having the binomial distribution with the specified -- probability and trials.-randomBinomialStream :: MonadComp m+randomBinomialStream :: MonadDES m                         => Double                         -- ^ the probability                         -> Int                         -- ^ the number of trials                         -> Stream m (Arrival Int)                         -- ^ the stream of random events with the delays generated+{-# INLINABLE randomBinomialStream #-} randomBinomialStream prob trials =   randomStream $   randomBinomial prob trials >>= \x ->
Simulation/Aivika/Trans/SystemDynamics.hs view
@@ -3,11 +3,11 @@  -- | -- Module     : Simulation.Aivika.Trans.SystemDynamics--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines integrals and other functions of System Dynamics. --@@ -68,10 +68,8 @@ import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Dynamics import Simulation.Aivika.Trans.Dynamics.Extra-import Simulation.Aivika.Trans.Comp-import Simulation.Aivika.Trans.Comp.IO-import Simulation.Aivika.Trans.Unboxed import Simulation.Aivika.Trans.Table+import Simulation.Aivika.Trans.SD  import qualified Simulation.Aivika.Trans.Dynamics.Memo as M import qualified Simulation.Aivika.Trans.Dynamics.Memo.Unboxed as MU@@ -81,47 +79,47 @@ --  -- | Compare for equality.-(.==.) :: (MonadComp m, Eq a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool+(.==.) :: (Monad m, Eq a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool {-# INLINE (.==.) #-} (.==.) = liftM2 (==)  -- | Compare for inequality.-(./=.) :: (MonadComp m, Eq a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool+(./=.) :: (Monad m, Eq a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool {-# INLINE (./=.) #-} (./=.) = liftM2 (/=)  -- | Compare for ordering.-(.<.) :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool+(.<.) :: (Monad m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool {-# INLINE (.<.) #-} (.<.) = liftM2 (<)  -- | Compare for ordering.-(.>=.) :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool+(.>=.) :: (Monad m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool {-# INLINE (.>=.) #-} (.>=.) = liftM2 (>=)  -- | Compare for ordering.-(.>.) :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool+(.>.) :: (Monad m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool {-# INLINE (.>.) #-} (.>.) = liftM2 (>)  -- | Compare for ordering.-(.<=.) :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool+(.<=.) :: (Monad m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool {-# INLINE (.<=.) #-} (.<=.) = liftM2 (<=)  -- | Return the maximum.-maxDynamics :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m a+maxDynamics :: (Monad m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m a {-# INLINE maxDynamics #-} maxDynamics = liftM2 max  -- | Return the minimum.-minDynamics :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m a+minDynamics :: (Monad m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m a {-# INLINE minDynamics #-} minDynamics = liftM2 min  -- | Implement the if-then-else operator.-ifDynamics :: MonadComp m => Dynamics m Bool -> Dynamics m a -> Dynamics m a -> Dynamics m a+ifDynamics :: Monad m => Dynamics m Bool -> Dynamics m a -> Dynamics m a -> Dynamics m a {-# INLINE ifDynamics #-} ifDynamics cond x y =   do a <- cond@@ -131,12 +129,13 @@ -- Ordinary Differential Equations -- -integEuler :: MonadComp m+integEuler :: Monad m               => Dynamics m Double               -> Dynamics m Double                -> Dynamics m Double                -> Point m               -> m Double+{-# INLINABLE integEuler #-} integEuler (Dynamics f) (Dynamics i) (Dynamics y) p =    case pointIteration p of     0 -> @@ -150,12 +149,13 @@       let !v = a + spcDT (pointSpecs p) * b       return v -integRK2 :: MonadComp m+integRK2 :: Monad m             => Dynamics m Double             -> Dynamics m Double             -> Dynamics m Double             -> Point m             -> m Double+{-# INLINABLE integRK2 #-} integRK2 (Dynamics f) (Dynamics i) (Dynamics y) p =   case pointPhase p of     0 -> case pointIteration p of@@ -188,12 +188,13 @@     _ ->        error "Incorrect phase: integRK2" -integRK4 :: MonadComp m+integRK4 :: Monad m             => Dynamics m Double             -> Dynamics m Double             -> Dynamics m Double             -> Point m             -> m Double+{-# INLINABLE integRK4 #-} integRK4 (Dynamics f) (Dynamics i) (Dynamics y) p =   case pointPhase p of     0 -> case pointIteration p of@@ -269,10 +270,11 @@ --           kb = 1 --       runDynamicsInStopTime $ sequence [a, b, c] -- @-integ :: (MonadComp m, MonadFix m)+integ :: (MonadSD m, MonadFix m)          => Dynamics m Double                  -- ^ the derivative          -> Dynamics m Double                  -- ^ the initial value          -> Simulation m (Dynamics m Double)   -- ^ the integral+{-# INLINABLE integ #-} integ diff i =   mdo y <- MU.memoDynamics z       z <- Simulation $ \r ->@@ -282,12 +284,13 @@           RungeKutta4 -> return $ Dynamics $ integRK4 diff i y       return y -integEulerEither :: MonadComp m+integEulerEither :: Monad m                     => Dynamics m (Either Double Double)                     -> Dynamics m Double                      -> Dynamics m Double                      -> Point m                     -> m Double+{-# INLINABLE integEulerEither #-} integEulerEither (Dynamics f) (Dynamics i) (Dynamics y) p =    case pointIteration p of     0 -> @@ -309,12 +312,13 @@ -- or integrating using the 'Right' derivative directly within computation. -- -- This function always uses Euler's method.-integEither :: (MonadComp m, MonadFix m)+integEither :: (MonadSD m, MonadFix m)                => Dynamics m (Either Double Double)                -- ^ either set a new 'Left' integral value, or use a 'Right' derivative                -> Dynamics m Double                -- ^ the initial value                -> Simulation m (Dynamics m Double)+{-# INLINABLE integEither #-} integEither diff i =   mdo y <- MU.memoDynamics z       z <- Simulation $ \r ->@@ -331,11 +335,12 @@ --   mdo y <- integ ((x - y) \/ t) i --       return y -- @     -smoothI :: (MonadComp m, MonadFix m)+smoothI :: (MonadSD m, MonadFix m)            => Dynamics m Double                  -- ^ the value to smooth over time            -> Dynamics m Double                  -- ^ time            -> Dynamics m Double                  -- ^ the initial value            -> Simulation m (Dynamics m Double)   -- ^ the first order exponential smooth+{-# INLINABLE smoothI #-} smoothI x t i =   mdo y <- integ ((x - y) / t) i       return y@@ -344,10 +349,11 @@ -- -- This is a simplified version of the 'smoothI' function -- without specifing the initial value.-smooth :: (MonadComp m, MonadFix m)+smooth :: (MonadSD m, MonadFix m)           => Dynamics m Double                  -- ^ the value to smooth over time           -> Dynamics m Double                  -- ^ time           -> Simulation m (Dynamics m Double)   -- ^ the first order exponential smooth+{-# INLINABLE smooth #-} smooth x t = smoothI x t x  -- | Return the third order exponential smooth.@@ -363,11 +369,12 @@ --       let t' = t \/ 3.0 --       return y -- @     -smooth3I :: (MonadComp m, MonadFix m)+smooth3I :: (MonadSD m, MonadFix m)             => Dynamics m Double                  -- ^ the value to smooth over time             -> Dynamics m Double                  -- ^ time             -> Dynamics m Double                  -- ^ the initial value             -> Simulation m (Dynamics m Double)   -- ^ the third order exponential smooth+{-# INLINABLE smooth3I #-} smooth3I x t i =   mdo y  <- integ ((s2 - y) / t') i       s2 <- integ ((s1 - s2) / t') i@@ -379,10 +386,11 @@ --  -- This is a simplified version of the 'smooth3I' function -- without specifying the initial value.-smooth3 :: (MonadComp m, MonadFix m)+smooth3 :: (MonadSD m, MonadFix m)            => Dynamics m Double                  -- ^ the value to smooth over time            -> Dynamics m Double                  -- ^ time            -> Simulation m (Dynamics m Double)   -- ^ the third order exponential smooth+{-# INLINABLE smooth3 #-} smooth3 x t = smooth3I x t x  -- | Return the n'th order exponential smooth.@@ -391,12 +399,13 @@ -- interval depending on the integration method used. Probably, you should apply -- the 'discreteDynamics' function to the result if you want to achieve an effect when -- the value is not changed within the time interval, which is used sometimes.-smoothNI :: (MonadComp m, MonadFix m)+smoothNI :: (MonadSD m, MonadFix m)             => Dynamics m Double                  -- ^ the value to smooth over time             -> Dynamics m Double                  -- ^ time             -> Int                                -- ^ the order             -> Dynamics m Double                  -- ^ the initial value             -> Simulation m (Dynamics m Double)   -- ^ the n'th order exponential smooth+{-# INLINABLE smoothNI #-} smoothNI x t n i =   mdo s <- forM [1 .. n] $ \k ->         if k == 1@@ -410,11 +419,12 @@ -- -- This is a simplified version of the 'smoothNI' function -- without specifying the initial value.-smoothN :: (MonadComp m, MonadFix m)+smoothN :: (MonadSD m, MonadFix m)            => Dynamics m Double                  -- ^ the value to smooth over time            -> Dynamics m Double                  -- ^ time            -> Int                                -- ^ the order            -> Simulation m (Dynamics m Double)   -- ^ the n'th order exponential smooth+{-# INLINABLE smoothN #-} smoothN x t n = smoothNI x t n x  -- | Return the first order exponential delay.@@ -427,11 +437,12 @@ --   mdo y <- integ (x - y \/ t) (i * t) --       return $ y \/ t -- @     -delay1I :: (MonadComp m, MonadFix m)+delay1I :: (MonadSD m, MonadFix m)            => Dynamics m Double                  -- ^ the value to conserve            -> Dynamics m Double                  -- ^ time            -> Dynamics m Double                  -- ^ the initial value            -> Simulation m (Dynamics m Double)   -- ^ the first order exponential delay+{-# INLINABLE delay1I #-} delay1I x t i =   mdo y <- integ (x - y / t) (i * t)       return $ y / t@@ -440,18 +451,20 @@ -- -- This is a simplified version of the 'delay1I' function -- without specifying the initial value.-delay1 :: (MonadComp m, MonadFix m)+delay1 :: (MonadSD m, MonadFix m)           => Dynamics m Double                  -- ^ the value to conserve           -> Dynamics m Double                  -- ^ time           -> Simulation m (Dynamics m Double)   -- ^ the first order exponential delay+{-# INLINABLE delay1 #-} delay1 x t = delay1I x t x  -- | Return the third order exponential delay.-delay3I :: (MonadComp m, MonadFix m)+delay3I :: (MonadSD m, MonadFix m)            => Dynamics m Double                  -- ^ the value to conserve            -> Dynamics m Double                  -- ^ time            -> Dynamics m Double                  -- ^ the initial value            -> Simulation m (Dynamics m Double)   -- ^ the third order exponential delay+{-# INLINABLE delay3I #-} delay3I x t i =   mdo y  <- integ (s2 / t' - y / t') (i * t')       s2 <- integ (s1 / t' - s2 / t') (i * t')@@ -463,19 +476,21 @@ -- -- This is a simplified version of the 'delay3I' function -- without specifying the initial value.-delay3 :: (MonadComp m, MonadFix m)+delay3 :: (MonadSD m, MonadFix m)           => Dynamics m Double                  -- ^ the value to conserve           -> Dynamics m Double                  -- ^ time           -> Simulation m (Dynamics m Double)   -- ^ the third order exponential delay+{-# INLINABLE delay3 #-} delay3 x t = delay3I x t x  -- | Return the n'th order exponential delay.-delayNI :: (MonadComp m, MonadFix m)+delayNI :: (MonadSD m, MonadFix m)            => Dynamics m Double                  -- ^ the value to conserve            -> Dynamics m Double                  -- ^ time            -> Int                                -- ^ the order            -> Dynamics m Double                  -- ^ the initial value            -> Simulation m (Dynamics m Double)   -- ^ the n'th order exponential delay+{-# INLINABLE delayNI #-} delayNI x t n i =   mdo s <- forM [1 .. n] $ \k ->         if k == 1@@ -489,11 +504,12 @@ -- -- This is a simplified version of the 'delayNI' function -- without specifying the initial value.-delayN :: (MonadComp m, MonadFix m)+delayN :: (MonadSD m, MonadFix m)           => Dynamics m Double                  -- ^ the value to conserve           -> Dynamics m Double                  -- ^ time           -> Int                                -- ^ the order           -> Simulation m (Dynamics m Double)   -- ^ the n'th order exponential delay+{-# INLINABLE delayN #-} delayN x t n = delayNI x t n x  -- | Return the forecast.@@ -505,11 +521,12 @@ --   do y <- smooth x at --      return $ x * (1.0 + (x \/ y - 1.0) \/ at * hz) -- @-forecast :: (MonadComp m, MonadFix m)+forecast :: (MonadSD m, MonadFix m)             => Dynamics m Double                  -- ^ the value to forecast             -> Dynamics m Double                  -- ^ the average time             -> Dynamics m Double                  -- ^ the time horizon             -> Simulation m (Dynamics m Double)   -- ^ the forecast+{-# INLINABLE forecast #-} forecast x at hz =   do y <- smooth x at      return $ x * (1.0 + (x / y - 1.0) / at * hz)@@ -523,11 +540,12 @@ --   do y <- smoothI x at (x \/ (1.0 + i * at)) --      return $ (x \/ y - 1.0) \/ at -- @-trend :: (MonadComp m, MonadFix m)+trend :: (MonadSD m, MonadFix m)          => Dynamics m Double                  -- ^ the value for which the trend is calculated          -> Dynamics m Double                  -- ^ the average time          -> Dynamics m Double                  -- ^ the initial value          -> Simulation m (Dynamics m Double)   -- ^ the fractional change rate+{-# INLINABLE trend #-} trend x at i =   do y <- smoothI x at (x / (1.0 + i * at))      return $ (x / y - 1.0) / at@@ -541,11 +559,12 @@ -- the difference is used instead of derivative. -- -- As usual, to create a loopback, you should use the recursive do-notation.-diffsum :: (MonadComp m, MonadFix m,-            Unboxed m a, Num a)+diffsum :: (MonadSD m, MonadFix m,+            MU.MonadMemo m a, Num a)            => Dynamics m a                  -- ^ the difference            -> Dynamics m a                  -- ^ the initial value            -> Simulation m (Dynamics m a)   -- ^ the sum+{-# INLINABLE diffsum #-} diffsum (Dynamics diff) (Dynamics i) =   mdo y <-         MU.memo0Dynamics $@@ -566,14 +585,15 @@       return y  -- | Like 'diffsum' but allows either setting a new 'Left' sum value, or adding the 'Right' difference.-diffsumEither :: (MonadComp m, MonadFix m,-                  Unboxed m a, Num a)+diffsumEither :: (MonadSD m, MonadFix m,+                  MU.MonadMemo m a, Num a)                  => Dynamics m (Either a a)                  -- ^ either set the 'Left' value for the sum, or add the 'Right' difference to the sum                  -> Dynamics m a                  -- ^ the initial value                  -> Simulation m (Dynamics m a)                  -- ^ the sum+{-# INLINABLE diffsumEither #-} diffsumEither (Dynamics diff) (Dynamics i) =   mdo y <-         MU.memo0Dynamics $@@ -602,14 +622,16 @@ --  -- | Lookup @x@ in a table of pairs @(x, y)@ using linear interpolation.-lookupDynamics :: MonadComp m => Dynamics m Double -> Array Int (Double, Double) -> Dynamics m Double+lookupDynamics :: Monad m => Dynamics m Double -> Array Int (Double, Double) -> Dynamics m Double+{-# INLINABLE lookupDynamics #-} lookupDynamics (Dynamics m) tbl =   Dynamics $ \p ->   do a <- m p      return $ tableLookup a tbl  -- | Lookup @x@ in a table of pairs @(x, y)@ using stepwise function.-lookupStepwiseDynamics :: MonadComp m => Dynamics m Double -> Array Int (Double, Double) -> Dynamics m Double+lookupStepwiseDynamics :: Monad m => Dynamics m Double -> Array Int (Double, Double) -> Dynamics m Double+{-# INLINABLE lookupStepwiseDynamics #-} lookupStepwiseDynamics (Dynamics m) tbl =   Dynamics $ \p ->   do a <- m p@@ -620,10 +642,11 @@ --  -- | Return the delayed value using the specified lag time.-delay :: MonadComp m+delay :: Monad m          => Dynamics m a          -- ^ the value to delay          -> Dynamics m Double     -- ^ the lag time          -> Dynamics m a          -- ^ the delayed value+{-# INLINABLE delay #-} delay (Dynamics x) (Dynamics d) = discreteDynamics $ Dynamics r    where     r p = do @@ -649,11 +672,12 @@  -- | Return the delayed value using the specified lag time and initial value. -- Because of the latter, it allows creating a loop back.-delayI :: MonadComp m+delayI :: MonadSD m           => Dynamics m a                    -- ^ the value to delay           -> Dynamics m Double               -- ^ the lag time           -> Dynamics m a                    -- ^ the initial value           -> Simulation m (Dynamics m a)     -- ^ the delayed value+{-# INLINABLE delayI #-} delayI (Dynamics x) (Dynamics d) (Dynamics i) = M.memo0Dynamics $ Dynamics r    where     r p = do @@ -693,12 +717,13 @@ --       accum <- integ (stream * df) init --       return $ (accum + dt' * stream * df) * factor -- @-npv :: (MonadComp m, MonadFix m)+npv :: (MonadSD m, MonadFix m)        => Dynamics m Double                  -- ^ the stream        -> Dynamics m Double                  -- ^ the discount rate        -> Dynamics m Double                  -- ^ the initial value        -> Dynamics m Double                  -- ^ factor        -> Simulation m (Dynamics m Double)   -- ^ the Net Present Value (NPV)+{-# INLINABLE npv #-} npv stream rate init factor =   mdo let dt' = liftParameter dt       df <- integ (- df * rate) 1@@ -717,12 +742,13 @@ --       accum <- integ (stream * df) init --       return $ (accum + dt' * stream * df) * factor -- @-npve :: (MonadComp m, MonadFix m)+npve :: (MonadSD m, MonadFix m)         => Dynamics m Double                  -- ^ the stream         -> Dynamics m Double                  -- ^ the discount rate         -> Dynamics m Double                  -- ^ the initial value         -> Dynamics m Double                  -- ^ factor         -> Simulation m (Dynamics m Double)   -- ^ the Net Present Value End (NPVE)+{-# INLINABLE npve #-} npve stream rate init factor =   mdo let dt' = liftParameter dt       df <- integ (- df * rate / (1 + rate * dt')) (1 / (1 + rate * dt'))@@ -730,12 +756,13 @@       return $ (accum + dt' * stream * df) * factor  -- | Computation that returns 0 until the step time and then returns the specified height.-step :: MonadComp m+step :: Monad m         => Dynamics m Double         -- ^ the height         -> Dynamics m Double         -- ^ the step time         -> Dynamics m Double+{-# INLINABLE step #-} step h st =   discreteDynamics $   Dynamics $ \p ->@@ -749,12 +776,13 @@  -- | Computation that returns 1, starting at the time start, and lasting for the interval -- width; 0 is returned at all other times.-pulse :: MonadComp m+pulse :: Monad m          => Dynamics m Double          -- ^ the time start          -> Dynamics m Double          -- ^ the interval width          -> Dynamics m Double+{-# INLINABLE pulse #-} pulse st w =   discreteDynamics $   Dynamics $ \p ->@@ -770,7 +798,7 @@ -- | 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 :: MonadComp m+pulseP :: Monad m           => Dynamics m Double           -- ^ the time start           -> Dynamics m Double@@ -778,6 +806,7 @@           -> Dynamics m Double           -- ^ the time period           -> Dynamics m Double+{-# INLINABLE pulseP #-} pulseP st w period =   discreteDynamics $   Dynamics $ \p ->@@ -797,7 +826,7 @@  -- | Computation that returns 0 until the specified time start and then -- slopes upward until the end time and then holds constant.-ramp :: MonadComp m+ramp :: Monad m         => Dynamics m Double         -- ^ the slope parameter         -> Dynamics m Double@@ -805,6 +834,7 @@         -> Dynamics m Double         -- ^ the end time         -> Dynamics m Double+{-# INLINABLE ramp #-} ramp slope st e =   discreteDynamics $   Dynamics $ \p ->
Simulation/Aivika/Trans/Table.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Table--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- It defines the table functions. --
Simulation/Aivika/Trans/Task.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Task--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The 'Task' value represents a process that was already started in background. -- We can check the completion of the task, receive notifications about changing@@ -34,7 +34,10 @@         spawnTaskUsingIdWith,         -- * Enqueueing Task         enqueueTask,-        enqueueTaskUsingId) where+        enqueueTaskUsingId,+        -- * Parallel Tasks+        taskParallelResult,+        taskParallelProcess) where  import Data.Monoid @@ -42,9 +45,8 @@ import Control.Monad.Trans import Control.Exception -import Simulation.Aivika.Trans.Specs-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Ref.Base+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Parameter import Simulation.Aivika.Trans.Internal.Simulation@@ -52,14 +54,14 @@ import Simulation.Aivika.Trans.Internal.Event import Simulation.Aivika.Trans.Internal.Cont import Simulation.Aivika.Trans.Internal.Process-import Simulation.Aivika.Trans.Internal.Signal+import Simulation.Aivika.Trans.Signal  -- | The task represents a process that was already started in background. data Task m a =   Task { taskId :: ProcessId m,          -- ^ Return an identifier for the process that was launched          -- in background for this task.-         taskResultRef :: ProtoRef m (Maybe (TaskResult a)),+         taskResultRef :: Ref m (Maybe (TaskResult a)),          -- ^ It contains the result of the computation.          taskResultReceived :: Signal m (TaskResult a)          -- ^ Return a signal that notifies about receiving@@ -76,109 +78,169 @@                     -- ^ the task was cancelled  -- | Try to get the task result immediately without suspension.-tryGetTaskResult :: MonadComp m => Task m a -> Event m (Maybe (TaskResult a))-tryGetTaskResult t =-  Event $ \p -> readProtoRef (taskResultRef t)+tryGetTaskResult :: MonadDES m => Task m a -> Event m (Maybe (TaskResult a))+{-# INLINABLE tryGetTaskResult #-}+tryGetTaskResult t = readRef (taskResultRef t)  -- | Return the task result suspending the outer process if required.-taskResult :: MonadComp m => Task m a -> Process m (TaskResult a)+taskResult :: MonadDES m => Task m a -> Process m (TaskResult a)+{-# INLINABLE taskResult #-} taskResult t =-  do x <- liftComp $ readProtoRef (taskResultRef t)+  do x <- liftEvent $ readRef (taskResultRef t)      case x of        Just x -> return x        Nothing -> processAwait (taskResultReceived t)  -- | Cancel the task.-cancelTask :: MonadComp m => Task m a -> Event m ()+cancelTask :: MonadDES m => Task m a -> Event m ()+{-# INLINABLE cancelTask #-} cancelTask t =   cancelProcessWithId (taskId t)  -- | Test whether the task was cancelled.-taskCancelled :: MonadComp m => Task m a -> Event m Bool+taskCancelled :: MonadDES m => Task m a -> Event m Bool+{-# INLINABLE taskCancelled #-} taskCancelled t =   processCancelled (taskId t)  -- | Create a task by the specified process and its identifier.-newTaskUsingId :: MonadComp m => ProcessId m -> Process m a -> Event m (Task m a, Process m ())+newTaskUsingId :: MonadDES m => ProcessId m -> Process m a -> Event m (Task m a, Process m ())+{-# INLINABLE newTaskUsingId #-} newTaskUsingId pid p =-  do sn <- liftParameter simulationSession-     r <- liftComp $ newProtoRef sn Nothing+  do r <- liftSimulation $ newRef Nothing      s <- liftSimulation newSignalSource      let t = Task { taskId = pid,                     taskResultRef = r,                     taskResultReceived = publishSignal s }      let m =-           do v <- liftComp $ newProtoRef sn TaskCancelled+           do v <- liftSimulation $ newRef TaskCancelled               finallyProcess                 (catchProcess                  (do a <- p-                     liftComp $ writeProtoRef v (TaskCompleted a))+                     liftEvent $ writeRef v (TaskCompleted a))                  (\e ->-                   liftComp $ writeProtoRef v (TaskError e)))+                   liftEvent $ writeRef v (TaskError e)))                 (liftEvent $-                 do x <- liftComp $ readProtoRef v-                    liftComp $ writeProtoRef r (Just x)+                 do x <- readRef v+                    writeRef 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 :: MonadComp m => ProcessId m -> Process m a -> Event m (Task m a)+-- return the corresponding task immediately.+runTaskUsingId :: MonadDES m => ProcessId m -> Process m a -> Event m (Task m a)+{-# INLINABLE runTaskUsingId #-} 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 :: MonadComp m => Process m a -> Event m (Task m a)+-- | Run the process in background and return the corresponding task immediately.+runTask :: MonadDES m => Process m a -> Event m (Task m a)+{-# INLINABLE runTask #-} 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 :: MonadComp m => Double -> ProcessId m -> Process m a -> Event m (Task m a)+-- identifier from the event queue. It returns the corresponding task immediately.+enqueueTaskUsingId :: MonadDES m => Double -> ProcessId m -> Process m a -> Event m (Task m a)+{-# INLINABLE enqueueTaskUsingId #-} 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 :: MonadComp m => Double -> Process m a -> Event m (Task m a)+-- It returns the corresponding task immediately.+enqueueTask :: MonadDES m => Double -> Process m a -> Event m (Task m a)+{-# INLINABLE enqueueTask #-} 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 :: MonadComp m => ProcessId m -> Process m a -> Process m (Task m a)+-- immediately the corresponding task.+spawnTaskUsingId :: MonadDES m => ProcessId m -> Process m a -> Process m (Task m a)+{-# INLINABLE spawnTaskUsingId #-} spawnTaskUsingId = spawnTaskUsingIdWith CancelTogether --- | Run a child process in background and return immediately the corresponded task.-spawnTask :: MonadComp m => Process m a -> Process m (Task m a)+-- | Run a child process in background and return immediately the corresponding task.+spawnTask :: MonadDES m => Process m a -> Process m (Task m a)+{-# INLINABLE spawnTask #-} spawnTask = spawnTaskWith CancelTogether  -- | Run using the specified identifier a child process in background and return--- immediately the corresponded task.-spawnTaskUsingIdWith :: MonadComp m => ContCancellation -> ProcessId m -> Process m a -> Process m (Task m a)+-- immediately the corresponding task.+spawnTaskUsingIdWith :: MonadDES m => ContCancellation -> ProcessId m -> Process m a -> Process m (Task m a)+{-# INLINABLE spawnTaskUsingIdWith #-} spawnTaskUsingIdWith cancellation pid p =   do (t, m) <- liftEvent $ newTaskUsingId pid p      spawnProcessUsingIdWith cancellation pid m      return t --- | Run a child process in background and return immediately the corresponded task.-spawnTaskWith :: MonadComp m => ContCancellation -> Process m a -> Process m (Task m a)+-- | Run a child process in background and return immediately the corresponding task.+spawnTaskWith :: MonadDES m => ContCancellation -> Process m a -> Process m (Task m a)+{-# INLINABLE spawnTaskWith #-} spawnTaskWith cancellation p =   do pid <- liftSimulation newProcessId      spawnTaskUsingIdWith 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 :: MonadComp m => Task m a -> Process m a+-- | Return an outer process that behaves like the task itself, for example,+-- when the task is cancelled if the outer process is cancelled. +taskProcess :: MonadDES m => Task m a -> Process m a+{-# INLINABLE taskProcess #-} taskProcess t =-  do x <- taskResult t+  do x <- finallyProcess+          (taskResult t)+          (do pid <- processId+              liftEvent $+                do cancelled <- processCancelled pid+                   when cancelled $+                     cancelTask t)      case x of        TaskCompleted a -> return a        TaskError e -> throwProcess e        TaskCancelled -> cancelProcess++-- | Return the result of two parallel tasks.+taskParallelResult :: MonadDES m => Task m a -> Task m a -> Process m (TaskResult a, Task m a)+{-# INLINABLE taskParallelResult #-}+taskParallelResult t1 t2 =+  do x1 <- liftEvent $ readRef (taskResultRef t1)+     case x1 of+       Just x1 -> return (x1, t2)+       Nothing ->+         do x2 <- liftEvent $ readRef (taskResultRef t2)+            case x2 of+              Just x2 -> return (x2, t1)+              Nothing ->+                do let s1 = fmap Left $ taskResultReceived t1+                       s2 = fmap Right $ taskResultReceived t2+                   x <- processAwait $ s1 <> s2+                   case x of+                     Left x1  -> return (x1, t2)+                     Right x2 -> return (x2, t1) ++-- | Return an outer process for two parallel tasks returning the result of+-- the first finished task and the rest task in pair. +taskParallelProcess :: MonadDES m => Task m a -> Task m a -> Process m (a, Task m a)+{-# INLINABLE taskParallelProcess #-}+taskParallelProcess t1 t2 =+  do (x, t) <-+       finallyProcess+       (taskParallelResult t1 t2)+       (do pid <- processId+           liftEvent $+             do cancelled <- processCancelled pid+                when cancelled $+                  do cancelTask t1+                     cancelTask t2)+     case x of+       TaskCompleted a -> return (a, t)+       TaskError e ->+         do liftEvent $ cancelTask t+            throwProcess e+       TaskCancelled ->+         do liftEvent $ cancelTask t+            cancelProcess
+ Simulation/Aivika/Trans/Template.hs view
@@ -0,0 +1,21 @@++-- |+-- Module     : Simulation.Aivika.Trans.Template+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.10.1+--+-- It defines an explicit type sub-class of 'IO'-based monads on top of which+-- the simulation monads can be automatically generated.+--+module Simulation.Aivika.Trans.Template (MonadTemplate) where++import Control.Monad.Trans++-- | It defines a type class based on which the simulation computations can be automatically generated.+class Monad m => MonadTemplate m++-- | An instance of the type class.+instance MonadTemplate IO
Simulation/Aivika/Trans/Transform.hs view
@@ -3,11 +3,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Transform--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- The module defines something which is most close to the notion of -- analogous circuit as an opposite to the digital one.@@ -30,12 +30,12 @@ import Control.Monad import Control.Monad.Fix -import Simulation.Aivika.Trans.Comp import Simulation.Aivika.Trans.Simulation import Simulation.Aivika.Trans.Dynamics-import Simulation.Aivika.Trans.Dynamics.Memo-import Simulation.Aivika.Trans.Unboxed+import qualified Simulation.Aivika.Trans.Dynamics.Memo as M+import qualified Simulation.Aivika.Trans.Dynamics.Memo.Unboxed as MU import Simulation.Aivika.Trans.SystemDynamics+import Simulation.Aivika.Trans.SD  -- | It allows representing an analogous circuit as an opposite to -- the digital one.@@ -50,62 +50,72 @@               -- ^ Run the transform.             } -instance MonadComp m => C.Category (Transform m) where+instance Monad m => C.Category (Transform m) where +  {-# INLINE id #-}   id = Transform return   +  {-# INLINE (.) #-}   (Transform g) . (Transform f) =     Transform $ \a -> f a >>= g -instance MonadComp m => Arrow (Transform m) where+instance MonadSD m => Arrow (Transform m) where +  {-# INLINE arr #-}   arr f = Transform $ return . fmap f +  {-# INLINABLE first #-}   first (Transform f) =     Transform $ \bd ->-    do (b, d) <- unzip0Dynamics bd+    do (b, d) <- M.unzip0Dynamics bd        c <- f b        return $ liftM2 (,) c d  +  {-# INLINABLE second #-}   second (Transform f) =     Transform $ \db ->-    do (d, b) <- unzip0Dynamics db+    do (d, b) <- M.unzip0Dynamics db        c <- f b        return $ liftM2 (,) d c +  {-# INLINABLE (***) #-}   (Transform f) *** (Transform g) =     Transform $ \bb' ->-    do (b, b') <- unzip0Dynamics bb'+    do (b, b') <- M.unzip0Dynamics bb'        c  <- f b        c' <- g b'        return $ liftM2 (,) c c' +  {-# INLINABLE (&&&) #-}   (Transform f) &&& (Transform g) =     Transform $ \b ->     do c  <- f b        c' <- g b        return $ liftM2 (,) c c' -instance (MonadComp m, MonadFix m) => ArrowLoop (Transform m) where+instance (MonadSD m, MonadFix m) => ArrowLoop (Transform m) where +  {-# INLINABLE loop #-}   loop (Transform f) =     Transform $ \b ->     mdo let bd = liftM2 (,) b d         cd <- f bd-        (c, d) <- unzip0Dynamics cd+        (c, d) <- M.unzip0Dynamics cd         return c  -- | A transform that returns the current modeling time.-timeTransform :: MonadComp m => Transform m a Double+timeTransform :: Monad m => Transform m a Double+{-# INLINE timeTransform #-} timeTransform = Transform $ const $ return time  -- | Return a delayed transform by the specified lag time and initial value. -- -- This is actually the 'delayI' function wrapped in the 'Transform' type. -delayTransform :: MonadComp m+delayTransform :: MonadSD m                   => Dynamics m Double     -- ^ the lag time                   -> Dynamics m a       -- ^ the initial value                   -> Transform m a a    -- ^ the delayed transform+{-# INLINE delayTransform #-} delayTransform lagTime init =   Transform $ \a -> delayI a lagTime init   @@ -113,38 +123,42 @@ -- by the specified initial value. -- -- This is actually the 'integ' function wrapped in the 'Transform' type. -integTransform :: (MonadComp m, MonadFix m)+integTransform :: (MonadSD m, MonadFix m)                   => Dynamics m Double                   -- ^ the initial value                   -> Transform m Double Double                   -- ^ map the derivative to an integral+{-# INLINE integTransform #-} integTransform init = Transform $ \diff -> integ diff init    -- | Like 'integTransform' but allows either setting a new 'Left' value of the integral, -- or updating it by the specified 'Right' derivative.-integTransformEither :: (MonadComp m, MonadFix m)+integTransformEither :: (MonadSD m, MonadFix m)                         => Dynamics m Double                         -- ^ the initial value                         -> Transform m (Either Double Double) Double                         -- ^ map either a new 'Left' value or the 'Right' derivative to an integral+{-# INLINE integTransformEither #-} integTransformEither init = Transform $ \diff -> integEither diff init  -- | Return a transform that maps the difference to a sum -- by the specified initial value. -- -- This is actually the 'diffsum' function wrapped in the 'Transform' type. -sumTransform :: (MonadComp m, MonadFix m, Num a, Unboxed m a)+sumTransform :: (MonadSD m, MonadFix m, Num a, MU.MonadMemo m a)                 => Dynamics m a                 -- ^ the initial value                 -> Transform m a a                 -- ^ map the difference to a sum+{-# INLINE sumTransform #-} sumTransform init = Transform $ \diff -> diffsum diff init  -- | Like 'sumTransform' but allows either setting a new 'Left' value of the sum, -- or updating it by the specified 'Right' difference.-sumTransformEither :: (MonadComp m, MonadFix m, Num a, Unboxed m a)+sumTransformEither :: (MonadSD m, MonadFix m, Num a, MU.MonadMemo m a)                       => Dynamics m a                       -- ^ the initial value                       -> Transform m (Either a a) a                       -- ^ map either a new 'Left' value or the 'Right' difference to a sum+{-# INLINE sumTransformEither #-} sumTransformEither init = Transform $ \diff -> diffsumEither diff init
Simulation/Aivika/Trans/Transform/Extra.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Transform.Extra--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines auxiliary computations such as interpolation ones -- that complement the memoization, for example. There are scan computations too.@@ -23,7 +23,6 @@ import Control.Monad import Control.Monad.Fix -import Simulation.Aivika.Trans.Comp import Simulation.Aivika.Trans.Dynamics import Simulation.Aivika.Trans.Dynamics.Extra import Simulation.Aivika.Trans.Transform@@ -31,28 +30,33 @@  -- | A transform that returns the initial value. initTransform :: Monad m => Transform m a a+{-# INLINE initTransform #-} initTransform = Transform $ return . initDynamics  -- | A transform that discretizes the computation in the integration time points. discreteTransform :: Monad m => Transform m a a+{-# INLINE discreteTransform #-} discreteTransform = Transform $ return . discreteDynamics  -- | A tranform that interpolates the computation based on the integration time points only. -- Unlike the 'discreteTransform' computation it knows about the intermediate  -- time points that are used in the Runge-Kutta method. interpolatingTransform :: Monad m => Transform m a a+{-# INLINE interpolatingTransform #-} interpolatingTransform = Transform $ return . interpolateDynamics   -- | Like the standard 'scanl1' function but applied to values in  -- the integration time points. The accumulator values are transformed -- according to the second argument, which should be either   -- 'memo0Transform' or its unboxed version.-scan1Transform :: (MonadComp m, MonadFix m) => (a -> a -> a) -> Transform m a a -> Transform m a a+scan1Transform :: MonadFix m => (a -> a -> a) -> Transform m a a -> Transform m a a+{-# INLINE scan1Transform #-} scan1Transform f (Transform tr) = Transform $ scan1Dynamics f tr  -- | Like the standard 'scanl' function but applied to values in  -- the integration time points. The accumulator values are transformed -- according to the third argument, which should be either -- 'memo0Transform' or its unboxed version.-scanTransform :: (MonadComp m, MonadFix m) => (a -> b -> a) -> a -> Transform m a a -> Transform m b a+scanTransform :: MonadFix m => (a -> b -> a) -> a -> Transform m a a -> Transform m b a+{-# INLINE scanTransform #-} scanTransform f acc (Transform tr) = Transform $ scanDynamics f acc tr
Simulation/Aivika/Trans/Transform/Memo.hs view
@@ -1,11 +1,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Transform.Memo--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines memoization transforms. The memoization creates such 'Dynamics' -- computations, which values are cached in the integration time points. Then@@ -17,17 +17,16 @@         memo0Transform,         iteratingTransform) where -import Simulation.Aivika.Trans.Comp-import Simulation.Aivika.Trans.Parameter import Simulation.Aivika.Trans.Dynamics-import Simulation.Aivika.Trans.Dynamics.Extra import Simulation.Aivika.Trans.Dynamics.Memo import Simulation.Aivika.Trans.Transform+import Simulation.Aivika.Trans.SD  -- | A transform that memoizes and order the computation in the integration time points -- using the interpolation that knows of the Runge-Kutta method. The values are -- calculated sequentially starting from 'starttime'.-memoTransform :: MonadComp m => Transform m e e+memoTransform :: MonadSD m => Transform m e e+{-# INLINE memoTransform #-} memoTransform = Transform memoDynamics   -- | A transform that memoizes and order the computation in the integration time points using @@ -36,11 +35,13 @@ -- difference when we request for values in the intermediate time points -- that are used by this method to integrate. In general case you should  -- prefer the 'memo0Transform' computation above 'memoTransform'.-memo0Transform :: MonadComp m => Transform m e e+memo0Transform :: MonadSD m => Transform m e e+{-# INLINE memo0Transform #-} memo0Transform =  Transform memo0Dynamics  -- | A transform that iterates sequentially the dynamic process with side effects in  -- the integration time points. It is equivalent to the 'memo0Transform' computation -- but significantly more efficient, for the internal array is not created.-iteratingTransform :: MonadComp m => Transform m () ()+iteratingTransform :: MonadSD m => Transform m () ()+{-# INLINE iteratingTransform #-} iteratingTransform = Transform iterateDynamics
Simulation/Aivika/Trans/Transform/Memo/Unboxed.hs view
@@ -3,11 +3,11 @@  -- | -- Module     : Simulation.Aivika.Trans.Transform.Memo.Unboxed--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines the unboxed memoization transforms. The memoization creates such 'Dynamics' -- computations, which values are cached in the integration time points. Then@@ -18,18 +18,16 @@        (memoTransform,         memo0Transform) where -import Simulation.Aivika.Trans.Comp-import Simulation.Aivika.Trans.Parameter import Simulation.Aivika.Trans.Dynamics-import Simulation.Aivika.Trans.Dynamics.Extra import Simulation.Aivika.Trans.Dynamics.Memo.Unboxed import Simulation.Aivika.Trans.Transform-import Simulation.Aivika.Trans.Unboxed+import Simulation.Aivika.Trans.SD  -- | A transform that memoizes and order the computation in the integration time points -- using the interpolation that knows of the Runge-Kutta method. The values are -- calculated sequentially starting from 'starttime'.-memoTransform :: (MonadComp m, Unboxed m e) => Transform m e e+memoTransform :: (MonadSD m, MonadMemo m e) => Transform m e e+{-# INLINE memoTransform #-} memoTransform = Transform memoDynamics   -- | A transform that memoizes and order the computation in the integration time points using @@ -38,5 +36,6 @@ -- difference when we request for values in the intermediate time points -- that are used by this method to integrate. In general case you should  -- prefer the 'memo0Transform' computation above 'memoTransform'.-memo0Transform :: (MonadComp m, Unboxed m e) => Transform m e e+memo0Transform :: (MonadSD m, MonadMemo m e) => Transform m e e+{-# INLINE memo0Transform #-} memo0Transform =  Transform memo0Dynamics
− Simulation/Aivika/Trans/Unboxed.hs 
@@ -1,45 +0,0 @@--{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses #-}---- |--- Module     : Simulation.Aivika.Trans.Unboxed--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.8.3------ The 'Unboxed' class allows creating unboxed arrays in monad 'IO'.-----module Simulation.Aivika.Trans.Unboxed-       (Unboxed(..)) where--import Simulation.Aivika.Trans.ProtoArray.Unboxed--import Data.Array-import Data.Int-import Data.Word---- | The type which values can be contained in an unboxed array.-class ProtoArrayMonad m e => Unboxed m e--instance Unboxed IO Bool-instance Unboxed IO Char-instance Unboxed IO Double-instance Unboxed IO Float-instance Unboxed IO Int-instance Unboxed IO Int8-instance Unboxed IO Int16-instance Unboxed IO Int32-instance Unboxed IO Word-instance Unboxed IO Word8-instance Unboxed IO Word16-instance Unboxed IO Word32--#ifndef __HASTE__--instance Unboxed IO Int64-instance Unboxed IO Word64--#endif
Simulation/Aivika/Trans/Var.hs view
@@ -1,190 +1,77 @@ +{-# LANGUAGE TypeFamilies #-}+ -- | -- Module     : Simulation.Aivika.Trans.Var--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines a variable that is bound up with the event queue and  -- that keeps the history of changes storing the values in arrays, which -- allows using the variable in differential and difference equations of -- System Dynamics within hybrid discrete-continuous simulation. ---module Simulation.Aivika.Trans.Var-       (Var,-        varChanged,-        varChanged_,-        newVar,-        readVar,-        varMemo,-        writeVar,-        modifyVar,-        freezeVar) where+module Simulation.Aivika.Trans.Var (MonadVar(..)) where  import Data.Array -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.Comp-import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Ref+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Dynamics import Simulation.Aivika.Trans.Internal.Event-import Simulation.Aivika.Trans.Internal.Signal-import Simulation.Aivika.Trans.Ref import Simulation.Aivika.Trans.Signal -import qualified Simulation.Aivika.Trans.Vector as V-import qualified Simulation.Aivika.Trans.Vector.Unboxed as UV+-- | A type class of monads within which we can create mutable variables.+class MonadDES m => MonadVar m where --- | Like the 'Ref' reference but keeps the history of changes in --- different time points. The 'Var' variable is safe to be used in--- the hybrid discrete-continuous simulation.------ For example, the memoised values of a variable can be used in--- the differential or difference equations of System Dynamics, while--- the variable iself can be updated wihin the discrete event simulation.------ Only this variable is much slower than the reference.-data Var m a = -  Var { varXS    :: UV.Vector m Double,-        varMS    :: V.Vector m a,-        varYS    :: V.Vector m a,-        varChangedSource :: SignalSource m a }+  -- | Like the 'Ref' reference but keeps the history of changes in +  -- different time points. The 'Var' variable is safe to be used in+  -- the hybrid discrete-continuous simulation.+  --+  -- For example, the memoised values of a variable can be used in+  -- the differential or difference equations of System Dynamics, while+  -- the variable iself can be updated wihin the discrete event simulation.+  --+  -- Only this variable is much slower than the reference.+  data Var m a      --- | Create a new variable.-newVar :: MonadComp m => a -> Simulation m (Var m a)-newVar a =-  Simulation $ \r ->-  do let sn = runSession r-     xs <- UV.newVector sn-     ms <- V.newVector sn-     ys <- V.newVector sn-     UV.appendVector xs $ spcStartTime $ runSpecs r-     V.appendVector ms a-     V.appendVector ys a-     s  <- invokeSimulation r newSignalSource-     return Var { varXS = xs,-                  varMS = ms,-                  varYS = ms,-                  varChangedSource = s }---- | Read the first actual, i.e. memoised, value of a variable for the requested time--- actuating the current events from the queue if needed.------ This computation can be used in the ordinary differential and--- difference equations of System Dynamics.-varMemo :: MonadComp m => Var m a -> Dynamics m a-varMemo v =-  runEventWith CurrentEventsOrFromPast $-  Event $ \p ->-  do let xs = varXS v-         ms = varMS v-         ys = varYS v-         t  = pointTime p-     count <- UV.vectorCount xs-     let i = count - 1-     x <- UV.readVector xs i-     if x < t-       then do a <- V.readVector ys i-               UV.appendVector xs t-               V.appendVector ms a-               V.appendVector ys a-               return a-       else if x == t-            then V.readVector ms i-            else do i <- UV.vectorBinarySearch xs t-                    if i >= 0-                      then V.readVector ms i-                      else V.readVector ms $ - (i + 1) - 1---- | Read the recent actual value of a variable for the requested time.------ This computation is destined for using within discrete event simulation.-readVar :: MonadComp m => Var m a -> Event m a-readVar v = -  Event $ \p ->-  do let xs = varXS v-         ys = varYS v-         t  = pointTime p-     count <- UV.vectorCount xs-     let i = count - 1-     x <- UV.readVector xs i-     if x <= t -       then V.readVector ys i-       else do i <- UV.vectorBinarySearch xs t-               if i >= 0-                 then V.readVector ys i-                 else V.readVector ys $ - (i + 1) - 1+  -- | Create a new variable.+  newVar :: a -> Simulation m (Var m a) --- | Write a new value into the variable.-writeVar :: MonadComp m => Var m a -> a -> Event m ()-writeVar v a =-  Event $ \p ->-  do let xs = varXS v-         ms = varMS v-         ys = varYS v-         t  = pointTime p-         s  = varChangedSource v-     count <- UV.vectorCount xs-     let i = count - 1-     x <- UV.readVector xs i-     if t < x -       then error "Cannot update the past data: writeVar."-       else if t == x-            then V.writeVector ys i $! a-            else do UV.appendVector xs t-                    V.appendVector ms $! a-                    V.appendVector ys $! a-     invokeEvent p $ triggerSignal s a+  -- | Read the first actual, i.e. memoised, value of a variable for the requested time+  -- actuating the current events from the queue if needed.+  --+  -- This computation can be used in the ordinary differential and+  -- difference equations of System Dynamics.+  varMemo :: Var m a -> Dynamics m a+  +  -- | Read the recent actual value of a variable for the requested time.+  --+  -- This computation is destined for using within discrete event simulation.+  readVar :: Var m a -> Event m a+  +  -- | Write a new value into the variable.+  writeVar :: Var m a -> a -> Event m () --- | Mutate the contents of the variable.-modifyVar :: MonadComp m => Var m a -> (a -> a) -> Event m ()-modifyVar v f =-  Event $ \p ->-  do let xs = varXS v-         ms = varMS v-         ys = varYS v-         t  = pointTime p-         s  = varChangedSource v-     count <- UV.vectorCount xs-     let i = count - 1-     x <- UV.readVector xs i-     if t < x-       then error "Cannot update the past data: modifyVar."-       else if t == x-            then do a <- V.readVector ys i-                    let b = f a-                    V.writeVector ys i $! b-                    invokeEvent p $ triggerSignal s b-            else do a <- V.readVector ys i-                    let b = f a-                    UV.appendVector xs t-                    V.appendVector ms $! b-                    V.appendVector ys $! b-                    invokeEvent p $ triggerSignal s b+  -- | Mutate the contents of the variable.+  modifyVar :: Var m a -> (a -> a) -> Event m () --- | Freeze the variable and return in arrays the time points and corresponded --- first and last values when the variable had changed or had been memoised in--- different time points: (1) the time points are sorted in ascending order;--- (2) the first and last actual values per each time point are provided.------ If you need to get all changes including those ones that correspond to the same--- simulation time points then you can use the 'newSignalHistory' function passing--- in the 'varChanged' signal to it and then call function 'readSignalHistory'.-freezeVar :: MonadComp m => Var m a -> Event m (Array Int Double, Array Int a, Array Int a)-freezeVar v =-  Event $ \p ->-  do xs <- UV.freezeVector (varXS v)-     ms <- V.freezeVector (varMS v)-     ys <- V.freezeVector (varYS v)-     return (xs, ms, ys)+  -- | Freeze the variable and return in arrays the time points and corresponded +  -- first and last values when the variable had changed or had been memoised in+  -- different time points: (1) the time points are sorted in ascending order;+  -- (2) the first and last actual values per each time point are provided.+  --+  -- If you need to get all changes including those ones that correspond to the same+  -- simulation time points then you can use the 'newSignalHistory' function passing+  -- in the 'varChanged' signal to it and then call function 'readSignalHistory'.+  freezeVar :: Var m a -> Event m (Array Int Double, Array Int a, Array Int a)      --- | Return a signal that notifies about every change of the variable state.-varChanged :: Var m a -> Signal m a-varChanged v = publishSignal (varChangedSource v)+  -- | Return a signal that notifies about every change of the variable state.+  varChanged :: Var m a -> Signal m a --- | Return a signal that notifies about every change of the variable state.-varChanged_ :: MonadComp m => Var m a -> Signal m ()-varChanged_ v = mapSignal (const ()) $ varChanged v     +  -- | Return a signal that notifies about every change of the variable state.+  varChanged_ :: MonadDES m => Var m a -> Signal m ()
Simulation/Aivika/Trans/Var/Unboxed.hs view
@@ -1,190 +1,77 @@ +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}+ -- | -- Module     : Simulation.Aivika.Trans.Var.Unboxed--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- Copyright  : Copyright (c) 2009-2015, David Sorokin <david.sorokin@gmail.com> -- License    : BSD3 -- Maintainer : David Sorokin <david.sorokin@gmail.com> -- Stability  : experimental--- Tested with: GHC 7.8.3+-- Tested with: GHC 7.10.1 -- -- This module defines an unboxed variable that is bound up with the event queue and  -- that keeps the history of changes storing the values in unboxed arrays, which -- allows using the variable in differential and difference equations of -- System Dynamics within hybrid discrete-continuous simulation. ---module Simulation.Aivika.Trans.Var.Unboxed-       (Var,-        varChanged,-        varChanged_,-        newVar,-        readVar,-        varMemo,-        writeVar,-        modifyVar,-        freezeVar) where+module Simulation.Aivika.Trans.Var.Unboxed (MonadVar(..)) where  import Data.Array -import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.Comp-import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Ref+import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Dynamics import Simulation.Aivika.Trans.Internal.Event-import Simulation.Aivika.Trans.Internal.Signal-import Simulation.Aivika.Trans.Ref import Simulation.Aivika.Trans.Signal-import Simulation.Aivika.Trans.Unboxed -import qualified Simulation.Aivika.Trans.Vector.Unboxed as UV---- | Like the 'Ref' reference but keeps the history of changes in --- different time points. The 'Var' variable is safe to be used in--- the hybrid discrete-continuous simulation.------ For example, the memoised values of a variable can be used in--- the differential or difference equations of System Dynamics, while--- the variable iself can be updated wihin the discrete event simulation.------ Only this variable is much slower than the reference.-data Var m a = -  Var { varXS    :: UV.Vector m Double,-        varMS    :: UV.Vector m a,-        varYS    :: UV.Vector m a,-        varChangedSource :: SignalSource m a }---- | Create a new variable.-newVar :: (MonadComp m, Unboxed m a) => a -> Simulation m (Var m a)-newVar a =-  Simulation $ \r ->-  do let sn = runSession r-     xs <- UV.newVector sn-     ms <- UV.newVector sn-     ys <- UV.newVector sn-     UV.appendVector xs $ spcStartTime $ runSpecs r-     UV.appendVector ms a-     UV.appendVector ys a-     s  <- invokeSimulation r newSignalSource-     return Var { varXS = xs,-                  varMS = ms,-                  varYS = ms,-                  varChangedSource = s }---- | Read the first actual, i.e. memoised, value of a variable for the requested time--- actuating the current events from the queue if needed.------ This computation can be used in the ordinary differential and--- difference equations of System Dynamics.-varMemo :: (MonadComp m, Unboxed m a) => Var m a -> Dynamics m a-varMemo v =-  runEventWith CurrentEventsOrFromPast $-  Event $ \p ->-  do let xs = varXS v-         ms = varMS v-         ys = varYS v-         t  = pointTime p-     count <- UV.vectorCount xs-     let i = count - 1-     x <- UV.readVector xs i-     if x < t-       then do a <- UV.readVector ys i-               UV.appendVector xs t-               UV.appendVector ms a-               UV.appendVector ys a-               return a-       else if x == t-            then UV.readVector ms i-            else do i <- UV.vectorBinarySearch xs t-                    if i >= 0-                      then UV.readVector ms i-                      else UV.readVector ms $ - (i + 1) - 1+-- | A type class of monads within which we can create mutable unboxed variables.+class MonadDES m => MonadVar m a where --- | Read the recent actual value of a variable for the requested time.------ This computation is destined for using within discrete event simulation.-readVar :: (MonadComp m, Unboxed m a) => Var m a -> Event m a-readVar v = -  Event $ \p ->-  do let xs = varXS v-         ys = varYS v-         t  = pointTime p-     count <- UV.vectorCount xs-     let i = count - 1-     x <- UV.readVector xs i-     if x <= t -       then UV.readVector ys i-       else do i <- UV.vectorBinarySearch xs t-               if i >= 0-                 then UV.readVector ys i-                 else UV.readVector ys $ - (i + 1) - 1+  -- | Like the 'Ref' reference but keeps the history of changes in +  -- different time points. The 'Var' variable is safe to be used in+  -- the hybrid discrete-continuous simulation.+  --+  -- For example, the memoised values of a variable can be used in+  -- the differential or difference equations of System Dynamics, while+  -- the variable iself can be updated wihin the discrete event simulation.+  --+  -- Only this variable is much slower than the reference.+  data Var m a+     +  -- | Create a new variable.+  newVar :: a -> Simulation m (Var m a) --- | Write a new value into the variable.-writeVar :: (MonadComp m, Unboxed m a) => Var m a -> a -> Event m ()-writeVar v a =-  Event $ \p ->-  do let xs = varXS v-         ms = varMS v-         ys = varYS v-         t  = pointTime p-         s  = varChangedSource v-     count <- UV.vectorCount xs-     let i = count - 1-     x <- UV.readVector xs i-     if t < x -       then error "Cannot update the past data: writeVar."-       else if t == x-            then UV.writeVector ys i $! a-            else do UV.appendVector xs t-                    UV.appendVector ms $! a-                    UV.appendVector ys $! a-     invokeEvent p $ triggerSignal s a+  -- | Read the first actual, i.e. memoised, value of a variable for the requested time+  -- actuating the current events from the queue if needed.+  --+  -- This computation can be used in the ordinary differential and+  -- difference equations of System Dynamics.+  varMemo :: Var m a -> Dynamics m a+  +  -- | Read the recent actual value of a variable for the requested time.+  --+  -- This computation is destined for using within discrete event simulation.+  readVar :: Var m a -> Event m a+  +  -- | Write a new value into the variable.+  writeVar :: Var m a -> a -> Event m () --- | Mutate the contents of the variable.-modifyVar :: (MonadComp m, Unboxed m a) => Var m a -> (a -> a) -> Event m ()-modifyVar v f =-  Event $ \p ->-  do let xs = varXS v-         ms = varMS v-         ys = varYS v-         t  = pointTime p-         s  = varChangedSource v-     count <- UV.vectorCount xs-     let i = count - 1-     x <- UV.readVector xs i-     if t < x-       then error "Cannot update the past data: modifyVar."-       else if t == x-            then do a <- UV.readVector ys i-                    let b = f a-                    UV.writeVector ys i $! b-                    invokeEvent p $ triggerSignal s b-            else do a <- UV.readVector ys i-                    let b = f a-                    UV.appendVector xs t-                    UV.appendVector ms $! b-                    UV.appendVector ys $! b-                    invokeEvent p $ triggerSignal s b+  -- | Mutate the contents of the variable.+  modifyVar :: Var m a -> (a -> a) -> Event m () --- | Freeze the variable and return in arrays the time points and corresponded --- first and last values when the variable had changed or had been memoised in--- different time points: (1) the time points are sorted in ascending order;--- (2) the first and last actual values per each time point are provided.------ If you need to get all changes including those ones that correspond to the same--- simulation time points then you can use the 'newSignalHistory' function passing--- in the 'varChanged' signal to it and then call function 'readSignalHistory'.-freezeVar :: (MonadComp m, Unboxed m a) => Var m a -> Event m (Array Int Double, Array Int a, Array Int a)-freezeVar v =-  Event $ \p ->-  do xs <- UV.freezeVector (varXS v)-     ms <- UV.freezeVector (varMS v)-     ys <- UV.freezeVector (varYS v)-     return (xs, ms, ys)+  -- | Freeze the variable and return in arrays the time points and corresponded +  -- first and last values when the variable had changed or had been memoised in+  -- different time points: (1) the time points are sorted in ascending order;+  -- (2) the first and last actual values per each time point are provided.+  --+  -- If you need to get all changes including those ones that correspond to the same+  -- simulation time points then you can use the 'newSignalHistory' function passing+  -- in the 'varChanged' signal to it and then call function 'readSignalHistory'.+  freezeVar :: Var m a -> Event m (Array Int Double, Array Int a, Array Int a)      --- | Return a signal that notifies about every change of the variable state.-varChanged :: Var m a -> Signal m a-varChanged v = publishSignal (varChangedSource v)+  -- | Return a signal that notifies about every change of the variable state.+  varChanged :: Var m a -> Signal m a --- | Return a signal that notifies about every change of the variable state.-varChanged_ :: MonadComp m => Var m a -> Signal m ()-varChanged_ v = mapSignal (const ()) $ varChanged v     +  -- | Return a signal that notifies about every change of the variable state.+  varChanged_ :: MonadDES m => Var m a -> Signal m ()
− Simulation/Aivika/Trans/Vector.hs 
@@ -1,199 +0,0 @@--{-# LANGUAGE TypeFamilies #-}---- |--- Module     : Simulation.Aivika.Trans.Vector--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.8.3------ It defines a prototype of mutable vectors.----module Simulation.Aivika.Trans.Vector-       (Vector,-        newVector, -        copyVector,-        vectorCount, -        appendVector, -        readVector, -        writeVector,-        vectorBinarySearch,-        vectorInsert,-        vectorDeleteAt,-        vectorIndex,-        freezeVector) where --import Data.Array--import Control.Monad--import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.ProtoArray---- | A prototype of mutable vector.-data Vector m a =-    Vector { vectorSession  :: Session m,-             vectorArrayRef :: ProtoRef m (ProtoArray m a),-             vectorCountRef :: ProtoRef m Int, -             vectorCapacityRef :: ProtoRef m Int }---- | Create a new vector within the specified simulation session.-newVector :: ProtoArrayMonad m => Session m -> m (Vector m a)-newVector session = -  do array <- newProtoArray_ session 4-     arrayRef <- newProtoRef session array-     countRef <- newProtoRef session 0-     capacityRef <- newProtoRef session 4-     return Vector { vectorSession  = session,-                     vectorArrayRef = arrayRef,-                     vectorCountRef = countRef,-                     vectorCapacityRef = capacityRef }---- | Copy the vector.-copyVector :: ProtoArrayMonad m => Vector m a -> m (Vector m a)-copyVector vector =-  do let session = vectorSession vector-     array <- readProtoRef (vectorArrayRef vector)-     count <- readProtoRef (vectorCountRef vector)-     array' <- newProtoArray_ session count-     arrayRef' <- newProtoRef session array'-     countRef' <- newProtoRef session count-     capacityRef' <- newProtoRef session count-     forM_ [0 .. count - 1] $ \i ->-       do x <- readProtoArray array i-          writeProtoArray array' i x-     return Vector { vectorSession  = session,-                     vectorArrayRef = arrayRef',-                     vectorCountRef = countRef',-                     vectorCapacityRef = capacityRef' }-       --- | Ensure that the vector has the specified capacity.-vectorEnsureCapacity :: ProtoArrayMonad m => Vector m a -> Int -> m ()-vectorEnsureCapacity vector capacity =-  do capacity' <- readProtoRef (vectorCapacityRef vector)-     when (capacity' < capacity) $-       do array' <- readProtoRef (vectorArrayRef vector)-          count' <- readProtoRef (vectorCountRef vector)-          let capacity'' = max (2 * capacity') capacity-              session    = vectorSession vector-          array'' <- newProtoArray_ session capacity''-          forM_ [0 .. count' - 1] $ \i ->-            do x <- readProtoArray array' i-               writeProtoArray array'' i x-          writeProtoRef (vectorArrayRef vector) array''-          writeProtoRef (vectorCapacityRef vector) capacity''---- | Return the element count.-vectorCount :: ProtoArrayMonad m => Vector m a -> m Int-vectorCount vector = readProtoRef (vectorCountRef vector)---- | Add the specified element to the end of the vector.-appendVector :: ProtoArrayMonad m => Vector m a -> a -> m ()          -appendVector vector item =-  do count <- readProtoRef (vectorCountRef vector)-     vectorEnsureCapacity vector (count + 1)-     array <- readProtoRef (vectorArrayRef vector)-     writeProtoArray array count item-     writeProtoRef (vectorCountRef vector) (count + 1)---- | Read a value from the vector, where indices are started from 0.-readVector :: ProtoArrayMonad m => Vector m a -> Int -> m a-readVector vector index =-  do array <- readProtoRef (vectorArrayRef vector)-     readProtoArray array index---- | Set an array item at the specified index which is started from 0.-writeVector :: ProtoArrayMonad m => Vector m a -> Int -> a -> m ()-writeVector vector index item =-  do array <- readProtoRef (vectorArrayRef vector)-     writeProtoArray array index item---- | Return the index of the specified element using binary search; otherwise, --- a negated insertion index minus one: 0 -> -0 - 1, ..., i -> -i - 1, ....-vectorBinarySearch :: (ProtoArrayMonad m, Ord a) => Vector m a -> a -> m Int-vectorBinarySearch vector item =-  do array <- readProtoRef (vectorArrayRef vector)-     count <- readProtoRef (vectorCountRef vector)-     vectorBinarySearch' array item 0 (count - 1)---- | Return the index of the specified element using binary search--- within the specified range; otherwise, a negated insertion index minus one.-vectorBinarySearchWithin :: (ProtoArrayMonad m, Ord a) => Vector m a -> a -> Int -> Int -> m Int-vectorBinarySearchWithin vector item left right =-  do array <- readProtoRef (vectorArrayRef vector)-     vectorBinarySearch' array item left right---- | Return the elements of the vector in an immutable array.-freezeVector :: ProtoArrayMonad m => Vector m a -> m (Array Int a)-freezeVector vector =-  do array <- readProtoRef (vectorArrayRef vector)-     freezeProtoArray array---- | Insert the element in the vector at the specified index.-vectorInsert :: ProtoArrayMonad m => Vector m a -> Int -> a -> m ()-vectorInsert vector index item =-  do count <- readProtoRef (vectorCountRef vector)-     when (index < 0) $-       error $-       "Index cannot be " ++-       "negative: vectorInsert."-     when (index > count) $-       error $-       "Index cannot be greater " ++-       "than the count: vectorInsert."-     vectorEnsureCapacity vector (count + 1)-     array <- readProtoRef (vectorArrayRef vector)-     forM_ [count, count - 1 .. index + 1] $ \i ->-       do x <- readProtoArray array (i - 1)-          writeProtoArray array i x-     writeProtoArray array index item-     writeProtoRef (vectorCountRef vector) (count + 1)---- | Delete the element at the specified index.-vectorDeleteAt :: ProtoArrayMonad m => Vector m a -> Int -> m ()-vectorDeleteAt vector index =-  do count <- readProtoRef (vectorCountRef vector)-     when (index < 0) $-       error $-       "Index cannot be " ++-       "negative: vectorDeleteAt."-     when (index >= count) $-       error $-       "Index must be less " ++-       "than the count: vectorDeleteAt."-     array <- readProtoRef (vectorArrayRef vector)-     forM_ [index, index + 1 .. count - 2] $ \i ->-       do x <- readProtoArray array (i + 1)-          writeProtoArray array i x-     writeProtoArray array (count - 1) undefined-     writeProtoRef (vectorCountRef vector) (count - 1)---- | Return the index of the item or -1.-vectorIndex :: (ProtoArrayMonad m, Eq a) => Vector m a -> a -> m Int-vectorIndex vector item =-  do count <- readProtoRef (vectorCountRef vector)-     array <- readProtoRef (vectorArrayRef vector)-     let loop index =-           if index >= count-           then return $ -1-           else do x <- readProtoArray array index-                   if item == x-                     then return index-                     else loop $ index + 1-     loop 0--vectorBinarySearch' :: (ProtoArrayMonad m, Ord a) => ProtoArray m a -> a -> Int -> Int -> m Int-vectorBinarySearch' array item left right =-  if left > right -  then return $ - (right + 1) - 1-  else-    do let index = (left + right) `div` 2-       curr <- readProtoArray array index-       if item < curr -         then vectorBinarySearch' array item left (index - 1)-         else if item == curr-              then return index-              else vectorBinarySearch' array item (index + 1) right
− Simulation/Aivika/Trans/Vector/Unboxed.hs 
@@ -1,199 +0,0 @@--{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}---- |--- Module     : Simulation.Aivika.Trans.Vector.Unboxed--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.8.3------ It defines a prototype of mutable unboxed vectors.----module Simulation.Aivika.Trans.Vector.Unboxed-       (Vector,-        newVector, -        copyVector,-        vectorCount, -        appendVector, -        readVector, -        writeVector,-        vectorBinarySearch,-        vectorInsert,-        vectorDeleteAt,-        vectorIndex,-        freezeVector) where --import Data.Array--import Control.Monad--import Simulation.Aivika.Trans.Session-import Simulation.Aivika.Trans.ProtoRef-import Simulation.Aivika.Trans.ProtoArray.Unboxed---- | A prototype of mutable unboxed vector.-data Vector m a =-    Vector { vectorSession  :: Session m,-             vectorArrayRef :: ProtoRef m (ProtoArray m a),-             vectorCountRef :: ProtoRef m Int, -             vectorCapacityRef :: ProtoRef m Int }---- | Create a new vector within the specified simulation session.-newVector :: ProtoArrayMonad m a => Session m -> m (Vector m a)-newVector session = -  do array <- newProtoArray_ session 4-     arrayRef <- newProtoRef session array-     countRef <- newProtoRef session 0-     capacityRef <- newProtoRef session 4-     return Vector { vectorSession  = session,-                     vectorArrayRef = arrayRef,-                     vectorCountRef = countRef,-                     vectorCapacityRef = capacityRef }---- | Copy the vector.-copyVector :: ProtoArrayMonad m a => Vector m a -> m (Vector m a)-copyVector vector =-  do let session = vectorSession vector-     array <- readProtoRef (vectorArrayRef vector)-     count <- readProtoRef (vectorCountRef vector)-     array' <- newProtoArray_ session count-     arrayRef' <- newProtoRef session array'-     countRef' <- newProtoRef session count-     capacityRef' <- newProtoRef session count-     forM_ [0 .. count - 1] $ \i ->-       do x <- readProtoArray array i-          writeProtoArray array' i x-     return Vector { vectorSession  = session,-                     vectorArrayRef = arrayRef',-                     vectorCountRef = countRef',-                     vectorCapacityRef = capacityRef' }-       --- | Ensure that the vector has the specified capacity.-vectorEnsureCapacity :: ProtoArrayMonad m a => Vector m a -> Int -> m ()-vectorEnsureCapacity vector capacity =-  do capacity' <- readProtoRef (vectorCapacityRef vector)-     when (capacity' < capacity) $-       do array' <- readProtoRef (vectorArrayRef vector)-          count' <- readProtoRef (vectorCountRef vector)-          let capacity'' = max (2 * capacity') capacity-              session    = vectorSession vector-          array'' <- newProtoArray_ session capacity''-          forM_ [0 .. count' - 1] $ \i ->-            do x <- readProtoArray array' i-               writeProtoArray array'' i x-          writeProtoRef (vectorArrayRef vector) array''-          writeProtoRef (vectorCapacityRef vector) capacity''---- | Return the element count.-vectorCount :: ProtoArrayMonad m a => Vector m a -> m Int-vectorCount vector = readProtoRef (vectorCountRef vector)---- | Add the specified element to the end of the vector.-appendVector :: ProtoArrayMonad m a => Vector m a -> a -> m ()          -appendVector vector item =-  do count <- readProtoRef (vectorCountRef vector)-     vectorEnsureCapacity vector (count + 1)-     array <- readProtoRef (vectorArrayRef vector)-     writeProtoArray array count item-     writeProtoRef (vectorCountRef vector) (count + 1)---- | Read a value from the vector, where indices are started from 0.-readVector :: ProtoArrayMonad m a => Vector m a -> Int -> m a-readVector vector index =-  do array <- readProtoRef (vectorArrayRef vector)-     readProtoArray array index---- | Set an array item at the specified index which is started from 0.-writeVector :: ProtoArrayMonad m a => Vector m a -> Int -> a -> m ()-writeVector vector index item =-  do array <- readProtoRef (vectorArrayRef vector)-     writeProtoArray array index item---- | Return the index of the specified element using binary search; otherwise, --- a negated insertion index minus one: 0 -> -0 - 1, ..., i -> -i - 1, ....-vectorBinarySearch :: (ProtoArrayMonad m a, Ord a) => Vector m a -> a -> m Int-vectorBinarySearch vector item =-  do array <- readProtoRef (vectorArrayRef vector)-     count <- readProtoRef (vectorCountRef vector)-     vectorBinarySearch' array item 0 (count - 1)---- | Return the index of the specified element using binary search--- within the specified range; otherwise, a negated insertion index minus one.-vectorBinarySearchWithin :: (ProtoArrayMonad m a, Ord a) => Vector m a -> a -> Int -> Int -> m Int-vectorBinarySearchWithin vector item left right =-  do array <- readProtoRef (vectorArrayRef vector)-     vectorBinarySearch' array item left right---- | Return the elements of the vector in an immutable array.-freezeVector :: ProtoArrayMonad m a => Vector m a -> m (Array Int a)-freezeVector vector =-  do array <- readProtoRef (vectorArrayRef vector)-     freezeProtoArray array---- | Insert the element in the vector at the specified index.-vectorInsert :: ProtoArrayMonad m a => Vector m a -> Int -> a -> m ()-vectorInsert vector index item =-  do count <- readProtoRef (vectorCountRef vector)-     when (index < 0) $-       error $-       "Index cannot be " ++-       "negative: vectorInsert."-     when (index > count) $-       error $-       "Index cannot be greater " ++-       "than the count: vectorInsert."-     vectorEnsureCapacity vector (count + 1)-     array <- readProtoRef (vectorArrayRef vector)-     forM_ [count, count - 1 .. index + 1] $ \i ->-       do x <- readProtoArray array (i - 1)-          writeProtoArray array i x-     writeProtoArray array index item-     writeProtoRef (vectorCountRef vector) (count + 1)---- | Delete the element at the specified index.-vectorDeleteAt :: ProtoArrayMonad m a => Vector m a -> Int -> m ()-vectorDeleteAt vector index =-  do count <- readProtoRef (vectorCountRef vector)-     when (index < 0) $-       error $-       "Index cannot be " ++-       "negative: vectorDeleteAt."-     when (index >= count) $-       error $-       "Index must be less " ++-       "than the count: vectorDeleteAt."-     array <- readProtoRef (vectorArrayRef vector)-     forM_ [index, index + 1 .. count - 2] $ \i ->-       do x <- readProtoArray array (i + 1)-          writeProtoArray array i x-     writeProtoArray array (count - 1) undefined-     writeProtoRef (vectorCountRef vector) (count - 1)---- | Return the index of the item or -1.-vectorIndex :: (ProtoArrayMonad m a, Eq a) => Vector m a -> a -> m Int-vectorIndex vector item =-  do count <- readProtoRef (vectorCountRef vector)-     array <- readProtoRef (vectorArrayRef vector)-     let loop index =-           if index >= count-           then return $ -1-           else do x <- readProtoArray array index-                   if item == x-                     then return index-                     else loop $ index + 1-     loop 0--vectorBinarySearch' :: (ProtoArrayMonad m a, Ord a) => ProtoArray m a -> a -> Int -> Int -> m Int-vectorBinarySearch' array item left right =-  if left > right -  then return $ - (right + 1) - 1-  else-    do let index = (left + right) `div` 2-       curr <- readProtoArray array index-       if item < curr -         then vectorBinarySearch' array item left (index - 1)-         else if item == curr-              then return index-              else vectorBinarySearch' array item (index + 1) right
aivika-transformers.cabal view
@@ -1,22 +1,22 @@ name:            aivika-transformers-version:         3.0+version:         4.3.1 synopsis:        Transformers for the Aivika simulation library description:-    The package adds the monad and other computation transformers to -    the Aivika [1] library. This is a generalization of the simulation library.+    This package is a generalization of the Aivika [1] simulation library+    with extensive use of monad transformers and type families.     .     \[1] <http://hackage.haskell.org/package/aivika>     . category:        Simulation license:         BSD3 license-file:    LICENSE-copyright:       (c) 2009-2014. David Sorokin <david.sorokin@gmail.com>+copyright:       (c) 2009-2015. David Sorokin <david.sorokin@gmail.com> author:          David Sorokin maintainer:      David Sorokin <david.sorokin@gmail.com>-homepage:        http://github.com/dsorokin/aivika-transformers+homepage:        http://www.aivikasoft.com/en/products/aivika.html cabal-version:   >= 1.10 build-type:      Simple-tested-with:     GHC == 7.8.3+tested-with:     GHC == 7.10.1  extra-source-files:  examples/BassDiffusion.hs                      examples/ChemicalReaction.hs@@ -34,23 +34,19 @@                      examples/TimeOutInt.hs                      examples/TimeOutWait.hs -flag haste-inst-    -    description: The package is built using haste-inst-    default:     False- library      exposed-modules: Simulation.Aivika.Trans                      Simulation.Aivika.Trans.Activity+                     Simulation.Aivika.Trans.Activity.Random                      Simulation.Aivika.Trans.Agent+                     Simulation.Aivika.Trans.Array                      Simulation.Aivika.Trans.Arrival                      Simulation.Aivika.Trans.Circuit                      Simulation.Aivika.Trans.Comp-                     Simulation.Aivika.Trans.Comp.IO-                     Simulation.Aivika.Trans.Comp.Template                      Simulation.Aivika.Trans.Cont                      Simulation.Aivika.Trans.DoubleLinkedList+                     Simulation.Aivika.Trans.DES                      Simulation.Aivika.Trans.Dynamics                      Simulation.Aivika.Trans.Dynamics.Extra                      Simulation.Aivika.Trans.Dynamics.Memo@@ -58,28 +54,31 @@                      Simulation.Aivika.Trans.Dynamics.Random                      Simulation.Aivika.Trans.Event                      Simulation.Aivika.Trans.Exception+                     Simulation.Aivika.Trans.Gate                      Simulation.Aivika.Trans.Generator+                     Simulation.Aivika.Trans.Internal.Types                      Simulation.Aivika.Trans.Net+                     Simulation.Aivika.Trans.Net.Random                      Simulation.Aivika.Trans.Parameter                      Simulation.Aivika.Trans.Parameter.Random-                     Simulation.Aivika.Trans.PriorityQueue                      Simulation.Aivika.Trans.Process+                     Simulation.Aivika.Trans.Process.Random                      Simulation.Aivika.Trans.Processor+                     Simulation.Aivika.Trans.Processor.Random                      Simulation.Aivika.Trans.Processor.RoundRobbin-                     Simulation.Aivika.Trans.ProtoArray-                     Simulation.Aivika.Trans.ProtoArray.Unboxed-                     Simulation.Aivika.Trans.ProtoRef                      Simulation.Aivika.Trans.Queue                      Simulation.Aivika.Trans.Queue.Infinite                      Simulation.Aivika.Trans.QueueStrategy                      Simulation.Aivika.Trans.Ref-                     Simulation.Aivika.Trans.Ref.Plain+                     Simulation.Aivika.Trans.Ref.Base                      Simulation.Aivika.Trans.Resource+                     Simulation.Aivika.Trans.Resource.Preemption                      Simulation.Aivika.Trans.Results.Locale                      Simulation.Aivika.Trans.Results                      Simulation.Aivika.Trans.Results.IO-                     Simulation.Aivika.Trans.Session+                     Simulation.Aivika.Trans.SD                      Simulation.Aivika.Trans.Server+                     Simulation.Aivika.Trans.Server.Random                      Simulation.Aivika.Trans.Signal                      Simulation.Aivika.Trans.Simulation                      Simulation.Aivika.Trans.Specs@@ -90,22 +89,34 @@                      Simulation.Aivika.Trans.SystemDynamics                      Simulation.Aivika.Trans.Table                      Simulation.Aivika.Trans.Task+                     Simulation.Aivika.Trans.Template                      Simulation.Aivika.Trans.Transform                      Simulation.Aivika.Trans.Transform.Extra                      Simulation.Aivika.Trans.Transform.Memo                      Simulation.Aivika.Trans.Transform.Memo.Unboxed-                     Simulation.Aivika.Trans.Unboxed                      Simulation.Aivika.Trans.Var                      Simulation.Aivika.Trans.Var.Unboxed-                     Simulation.Aivika.Trans.Vector-                     Simulation.Aivika.Trans.Vector.Unboxed+                     Simulation.Aivika.IO+                     Simulation.Aivika.IO.Comp+                     Simulation.Aivika.IO.DES+                     Simulation.Aivika.IO.Dynamics.Memo+                     Simulation.Aivika.IO.Dynamics.Memo.Unboxed+                     Simulation.Aivika.IO.Event+                     Simulation.Aivika.IO.Exception+                     Simulation.Aivika.IO.Generator+                     Simulation.Aivika.IO.QueueStrategy+                     Simulation.Aivika.IO.SD+                     Simulation.Aivika.IO.Signal+                     Simulation.Aivika.IO.Ref.Base+                     Simulation.Aivika.IO.Resource.Preemption+                     Simulation.Aivika.IO.Var+                     Simulation.Aivika.IO.Var.Unboxed      other-modules:   Simulation.Aivika.Trans.Internal.Cont                      Simulation.Aivika.Trans.Internal.Dynamics                      Simulation.Aivika.Trans.Internal.Event                      Simulation.Aivika.Trans.Internal.Parameter                      Simulation.Aivika.Trans.Internal.Process-                     Simulation.Aivika.Trans.Internal.Signal                      Simulation.Aivika.Trans.Internal.Simulation                      Simulation.Aivika.Trans.Internal.Specs                      @@ -114,10 +125,8 @@                      array >= 0.3.0.0,                      containers >= 0.4.0.0,                      random >= 1.0.0.3,-                     aivika >= 3.0--    if !flag(haste-inst)-       build-depends:   vector >= 0.10.0.1+                     vector >= 0.10.0.1,+                     aivika >= 4.3.1      other-extensions:   FlexibleContexts,                         FlexibleInstances,
examples/BassDiffusion.hs view
@@ -9,6 +9,7 @@ import Control.Monad.Trans  import Simulation.Aivika.Trans+import Simulation.Aivika.IO  n = 500    -- the number of agents @@ -26,7 +27,7 @@                          personPotentialAdopter :: AgentState m,                          personAdopter :: AgentState m }               -createPerson :: MonadComp m => Simulation m (Person m) +createPerson :: Simulation IO (Person IO)  createPerson =       do agent <- newAgent      potentialAdopter <- newState agent@@ -35,14 +36,14 @@                      personPotentialAdopter = potentialAdopter,                      personAdopter = adopter }        -createPersons :: MonadComp m => Simulation m (Array Int (Person m))+createPersons :: Simulation IO (Array Int (Person IO)) createPersons =   do list <- forM [1 .. n] $ \i ->        do p <- createPerson           return (i, p)      return $ array (1, n) list      -definePerson :: MonadComp m => Person m -> Array Int (Person m) -> Ref m Int -> Ref m Int -> Simulation m ()+definePerson :: Person IO -> Array Int (Person IO) -> Ref IO Int -> Ref IO Int -> Event IO () definePerson p ps potentialAdopters adopters =   do setStateActivation (personPotentialAdopter p) $        do modifyRef potentialAdopters $ \a -> a + 1@@ -71,26 +72,26 @@      setStateDeactivation (personAdopter p) $        modifyRef adopters $ \a -> a - 1         -definePersons :: MonadComp m => Array Int (Person m) -> Ref m Int -> Ref m Int -> Simulation m ()+definePersons :: Array Int (Person IO) -> Ref IO Int -> Ref IO Int -> Event IO () definePersons ps potentialAdopters adopters =   forM_ (elems ps) $ \p ->    definePerson p ps potentialAdopters adopters                                -activatePerson :: MonadComp m => Person m -> Event m ()+activatePerson :: Person IO -> Event IO () activatePerson p = selectState (personPotentialAdopter p) -activatePersons :: MonadComp m => Array Int (Person m) -> Event m ()+activatePersons :: Array Int (Person IO) -> Event IO () activatePersons ps =   forM_ (elems ps) $ \p -> activatePerson p -model :: MonadComp m => Simulation m (Results m)+model :: Simulation IO (Results IO) model =   do potentialAdopters <- newRef 0      adopters <- newRef 0      ps <- createPersons-     definePersons ps potentialAdopters adopters      runEventInStartTime $-       activatePersons ps+       do definePersons ps potentialAdopters adopters+          activatePersons ps      return $         results        [resultSource
examples/ChemicalReaction.hs view
@@ -1,10 +1,9 @@  {-# LANGUAGE RecursiveDo #-} -import Control.Monad.Fix- import Simulation.Aivika.Trans import Simulation.Aivika.Trans.SystemDynamics+import Simulation.Aivika.IO  specs = Specs { spcStartTime = 0,                  spcStopTime = 13, @@ -12,7 +11,7 @@                 spcMethod = RungeKutta4,                 spcGeneratorType = SimpleGenerator } -model :: (MonadComp m, MonadFix m) => Simulation m (Results m)+model :: Simulation IO (Results IO) model =    mdo a <- integ (- ka * a) 100       b <- integ (ka * a - kb * b) 0@@ -27,4 +26,5 @@ main =   printSimulationResultsInStopTime   printResultSourceInEnglish+   model specs
examples/ChemicalReactionCircuit.hs view
@@ -11,9 +11,9 @@ {-# LANGUAGE Arrows #-}  import Control.Arrow-import Control.Monad.Fix  import Simulation.Aivika.Trans+import Simulation.Aivika.IO  specs = Specs { spcStartTime = 0,                  spcStopTime = 13, @@ -21,7 +21,7 @@                 spcMethod = RungeKutta4,                 spcGeneratorType = SimpleGenerator } -circuit :: (MonadComp m, MonadFix m) => Circuit m () [Double]+circuit :: Circuit IO () [Double] circuit =   let ka = 1       kb = 1@@ -34,7 +34,7 @@         c  <- integCircuit 0 -< dc     returnA -< [a, b, c] -model :: (MonadComp m, MonadFix m) => Simulation m [Double]+model :: Simulation IO [Double] model =   do results <-        runTransform (circuitTransform circuit) $
examples/FishBank.hs view
@@ -1,12 +1,11 @@  {-# LANGUAGE RecursiveDo #-} -import Control.Monad.Fix- import Data.Array  import Simulation.Aivika.Trans import Simulation.Aivika.Trans.SystemDynamics+import Simulation.Aivika.IO  specs = Specs { spcStartTime = 0,                  spcStopTime = 13, @@ -15,7 +14,7 @@                 spcMethod = RungeKutta4,                 spcGeneratorType = SimpleGenerator } -model :: (MonadComp m, MonadFix m) => Simulation m (Results m)+model :: Simulation IO (Results IO) model =   mdo let annualProfit = profit           area = 100
examples/Furnace.hs view
@@ -6,13 +6,15 @@ -- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006  import Data.Maybe-import System.Random import Control.Monad import Control.Monad.Trans  import Simulation.Aivika.Trans import Simulation.Aivika.Trans.Queue.Infinite+import Simulation.Aivika.IO +type DES = IO+ -- | The simulation specs. specs = Specs { spcStartTime = 0.0,                 -- spcStopTime = 1000.0,@@ -22,44 +24,44 @@                 spcGeneratorType = SimpleGenerator }          -- | Return a random initial temperature of the item.     -randomTemp :: MonadComp m => Parameter m Double+randomTemp :: Parameter IO Double randomTemp = randomUniform 400 600  -- | Represents the furnace.-data Furnace m = -  Furnace { furnacePits :: [Pit m],+data Furnace = +  Furnace { furnacePits :: [Pit],             -- ^ The pits for ingots.-            furnacePitCount :: Ref m Int,+            furnacePitCount :: Ref DES Int,             -- ^ The count of active pits with ingots.-            furnaceQueue :: FCFSQueue m (Ingot m),+            furnaceQueue :: FCFSQueue DES Ingot,             -- ^ The furnace queue.-            furnaceUnloadedSource :: SignalSource m (),+            furnaceUnloadedSource :: SignalSource DES (),             -- ^ Notifies when the ingots have been             -- unloaded from the furnace.-            furnaceHeatingTime :: Ref m (SamplingStats Double),+            furnaceHeatingTime :: Ref DES (SamplingStats Double),             -- ^ The heating time for the ready ingots.-            furnaceTemp :: Ref m Double,+            furnaceTemp :: Ref DES Double,             -- ^ The furnace temperature.-            furnaceReadyCount :: Ref m Int,+            furnaceReadyCount :: Ref DES Int,             -- ^ The count of ready ingots.-            furnaceReadyTemps :: Ref m [Double]+            furnaceReadyTemps :: Ref DES [Double]             -- ^ The temperatures of all ready ingots.             }  -- | Notifies when the ingots have been unloaded from the furnace.-furnaceUnloaded :: Furnace m -> Signal m ()+furnaceUnloaded :: Furnace -> Signal DES () furnaceUnloaded = publishSignal . furnaceUnloadedSource  -- | A pit in the furnace to place the ingots.-data Pit m = -  Pit { pitIngot :: Ref m (Maybe (Ingot m)),+data Pit = +  Pit { pitIngot :: Ref DES (Maybe Ingot),         -- ^ The ingot in the pit.-        pitTemp :: Ref m Double+        pitTemp :: Ref DES Double         -- ^ The ingot temperature in the pit.         } -data Ingot m = -  Ingot { ingotFurnace :: Furnace m,+data Ingot = +  Ingot { ingotFurnace :: Furnace,           -- ^ The furnace.           ingotReceiveTime :: Double,           -- ^ The time at which the ingot was received.@@ -74,7 +76,7 @@           }  -- | Create a furnace.-newFurnace :: MonadComp m => Simulation m (Furnace m)+newFurnace :: Simulation DES Furnace newFurnace =   do pits <- sequence [newPit | i <- [1..10]]      pitCount <- newRef 0@@ -94,7 +96,7 @@                       furnaceReadyTemps = readyTemps }  -- | Create a new pit.-newPit :: MonadComp m => Simulation m (Pit m)+newPit :: Simulation DES Pit newPit =   do ingot <- newRef Nothing      h' <- newRef 0.0@@ -102,7 +104,7 @@                   pitTemp  = h' }  -- | Create a new ingot.-newIngot :: MonadComp m => Furnace m -> Event m (Ingot m)+newIngot :: Furnace -> Event DES Ingot newIngot furnace =   do t  <- liftDynamics time      xi <- liftParameter $ randomNormal 0.05 0.01@@ -116,7 +118,7 @@                     ingotCoeff = c }  -- | Heat the ingot up in the pit if there is such an ingot.-heatPitUp :: MonadComp m => Pit m -> Event m ()+heatPitUp :: Pit -> Event DES () heatPitUp pit =   do ingot <- readRef (pitIngot pit)      case ingot of@@ -133,14 +135,14 @@            h' + dt' * (h - h') * ingotCoeff ingot  -- | Check whether there are ready ingots in the pits.-ingotsReady :: MonadComp m => Furnace m -> Event m Bool+ingotsReady :: Furnace -> Event DES Bool ingotsReady furnace =   fmap (not . null) $    filterM (fmap (>= 2200.0) . readRef . pitTemp) $    furnacePits furnace  -- | Try to unload the ready ingot from the specified pit.-tryUnloadPit :: MonadComp m => Furnace m -> Pit m -> Event m ()+tryUnloadPit :: Furnace -> Pit -> Event DES () tryUnloadPit furnace pit =   do h' <- readRef (pitTemp pit)      when (h' >= 2000.0) $@@ -148,7 +150,7 @@           unloadIngot furnace ingot pit  -- | Try to load an awaiting ingot in the specified empty pit.-tryLoadPit :: MonadComp m => Furnace m -> Pit m -> Event m ()       +tryLoadPit :: Furnace -> Pit -> Event DES ()        tryLoadPit furnace pit =   do ingot <- tryDequeue (furnaceQueue furnace)      case ingot of@@ -160,7 +162,7 @@                                        ingotLoadTemp = 400.0 }) pit                -- | Unload the ingot from the specified pit.       -unloadIngot :: MonadComp m => Furnace m -> Ingot m -> Pit m -> Event m ()+unloadIngot :: Furnace -> Ingot -> Pit -> Event DES () unloadIngot furnace ingot pit =    do h' <- readRef (pitTemp pit)      writeRef (pitIngot pit) Nothing@@ -181,7 +183,7 @@      modifyRef (furnaceReadyCount furnace) (+ 1)       -- | Load the ingot in the specified pit-loadIngot :: MonadComp m => Furnace m -> Ingot m -> Pit m -> Event m ()+loadIngot :: Furnace -> Ingot -> Pit -> Event DES () loadIngot furnace ingot pit =   do writeRef (pitIngot pit) $ Just ingot      writeRef (pitTemp pit) $ ingotLoadTemp ingot@@ -197,7 +199,7 @@      writeRef (furnaceTemp furnace) $ h + dh   -- | Start iterating the furnace processing through the event queue.-startIteratingFurnace :: MonadComp m => Furnace m -> Event m ()+startIteratingFurnace :: Furnace -> Event DES () startIteratingFurnace furnace =    let pits = furnacePits furnace   in enqueueEventWithIntegTimes $@@ -217,14 +219,14 @@           h + dt' * (2600.0 - h) * 0.2  -- | Return all empty pits.-emptyPits :: MonadComp m => Furnace m -> Event m [Pit m]+emptyPits :: Furnace -> Event DES [Pit] emptyPits furnace =   filterM (fmap isNothing . readRef . pitIngot) $   furnacePits furnace  -- | This process takes ingots from the queue and then -- loads them in the furnace.-loadingProcess :: MonadComp m => Furnace m -> Process m ()+loadingProcess :: Furnace -> Process DES () loadingProcess furnace =   do ingot <- dequeue (furnaceQueue furnace)      let wait =@@ -241,7 +243,7 @@      loadingProcess furnace                    -- | The input process that adds new ingots to the queue.-inputProcess :: MonadComp m => Furnace m -> Process m ()+inputProcess :: Furnace -> Process DES () inputProcess furnace =   do delay <- liftParameter $               randomExponential 2.5@@ -254,7 +256,7 @@      inputProcess furnace  -- | Initialize the furnace.-initializeFurnace :: MonadComp m => Furnace m -> Event m ()+initializeFurnace :: Furnace -> Event DES () initializeFurnace furnace =   do x1 <- newIngot furnace      x2 <- newIngot furnace@@ -273,7 +275,7 @@      writeRef (furnaceTemp furnace) 1650.0       -- | The simulation model.-model :: MonadComp m => Simulation m (Results m)+model :: Simulation DES (Results DES) model =   do furnace <- newFurnace
examples/InspectionAdjustmentStations.hs view
@@ -21,7 +21,10 @@  import Simulation.Aivika.Trans import Simulation.Aivika.Trans.Queue.Infinite+import Simulation.Aivika.IO +type DES = IO+ -- | The simulation specs. specs = Specs { spcStartTime = 0.0,                 spcStopTime = 480.0,@@ -57,7 +60,7 @@ adjustmentStationCount = 1  -- create an inspection station (server)-newInspectionStation :: MonadComp m => Simulation m (Server m () a (Either a a))+newInspectionStation :: Simulation DES (Server DES () a (Either a a)) newInspectionStation =   newServer $ \a ->   do holdProcess =<<@@ -71,7 +74,7 @@        else return $ Left a   -- create an adjustment station (server)-newAdjustmentStation :: MonadComp m => Simulation m (Server m () a a)+newAdjustmentStation :: Simulation DES (Server DES () a a) newAdjustmentStation =   newServer $ \a ->   do holdProcess =<<@@ -79,7 +82,7 @@         randomUniform minAdjustmentTime maxAdjustmentTime)      return a   -model :: (MonadComp m, MonadFix m) => Simulation m (Results m)+model :: Simulation DES (Results DES) model = mdo   -- to count the arrived TV sets for inspecting and adjusting   inputArrivalTimer <- newArrivalTimer@@ -155,7 +158,7 @@      "adjustmentStations" "the adjustment stations"      adjustmentStations] -modelSummary :: (MonadComp m, MonadFix m) => Simulation m (Results m)+modelSummary :: Simulation DES (Results DES) modelSummary = fmap resultSummary model  main =
examples/MachRep1.hs view
@@ -18,6 +18,7 @@ import Control.Monad.Trans  import Simulation.Aivika.Trans+import Simulation.Aivika.IO  meanUpTime = 1.0 meanRepairTime = 0.5@@ -28,7 +29,7 @@                 spcMethod = RungeKutta4,                 spcGeneratorType = SimpleGenerator }         -model :: MonadComp m => Simulation m (Results m)+model :: Simulation IO (Results IO) model =   do totalUpTime <- newRef 0.0
examples/MachRep1EventDriven.hs view
@@ -18,6 +18,7 @@ import Control.Monad.Trans  import Simulation.Aivika.Trans+import Simulation.Aivika.IO  meanUpTime = 1.0 meanRepairTime = 0.5@@ -28,7 +29,7 @@                 spcMethod = RungeKutta4,                 spcGeneratorType = SimpleGenerator }         -model :: MonadComp m => Simulation m (Results m)+model :: Simulation IO (Results IO) model =   do totalUpTime <- newRef 0.0
examples/MachRep1TimeDriven.hs view
@@ -18,6 +18,7 @@ import Control.Monad.Trans  import Simulation.Aivika.Trans+import Simulation.Aivika.IO  meanUpTime = 1.0 meanRepairTime = 0.5@@ -28,7 +29,7 @@                 spcMethod = RungeKutta4,                 spcGeneratorType = SimpleGenerator }         -model :: MonadComp m => Simulation m (Results m)+model :: Simulation IO (Results IO) model =   do totalUpTime <- newRef 0.0
examples/MachRep2.hs view
@@ -21,6 +21,7 @@ import Control.Monad.Trans  import Simulation.Aivika.Trans+import Simulation.Aivika.IO  meanUpTime = 1.0 meanRepairTime = 0.5@@ -31,7 +32,7 @@                 spcMethod = RungeKutta4,                 spcGeneratorType = SimpleGenerator }      -model :: MonadComp m => Simulation m (Results m)+model :: Simulation IO (Results IO) model =   do -- number of times the machines have broken down      nRep <- newRef 0
examples/MachRep3.hs view
@@ -17,6 +17,7 @@ import Control.Monad.Trans  import Simulation.Aivika.Trans+import Simulation.Aivika.IO  meanUpTime = 1.0 meanRepairTime = 0.5@@ -27,7 +28,7 @@                 spcMethod = RungeKutta4,                 spcGeneratorType = SimpleGenerator }      -model :: MonadComp m => Simulation m (Results m)+model :: Simulation IO (Results IO) model =   do -- number of machines currently up      nUp <- newRef 2
examples/TimeOut.hs view
@@ -22,6 +22,7 @@ import Control.Monad.Trans  import Simulation.Aivika.Trans+import Simulation.Aivika.IO  ackRate = 1.0 / 1.0  -- reciprocal of the acknowledge mean time toPeriod = 0.5       -- timeout period@@ -32,7 +33,7 @@                 spcMethod = RungeKutta4,                 spcGeneratorType = SimpleGenerator }      -model :: MonadComp m => Simulation m Double+model :: Simulation IO Double model =   do -- number of messages sent      nMsgs <- newRef 0
examples/TimeOutInt.hs view
@@ -20,6 +20,7 @@ import Control.Monad.Trans  import Simulation.Aivika.Trans+import Simulation.Aivika.IO  ackRate = 1.0 / 1.0  -- reciprocal of the acknowledge mean time toPeriod = 0.5       -- timeout period@@ -30,7 +31,7 @@                 spcMethod = RungeKutta4,                 spcGeneratorType = SimpleGenerator }      -model :: MonadComp m => Simulation m Double+model :: Simulation IO Double model =   do -- number of messages sent      nMsgs <- newRef 0
examples/TimeOutWait.hs view
@@ -26,6 +26,7 @@ import Data.Maybe  import Simulation.Aivika.Trans+import Simulation.Aivika.IO  ackRate = 1.0 / 1.0  -- reciprocal of the acknowledge mean time toPeriod = 0.5       -- timeout period@@ -36,7 +37,7 @@                 spcMethod = RungeKutta4,                 spcGeneratorType = SimpleGenerator }         -model :: MonadComp m => Simulation m Double+model :: Simulation IO Double model =   do -- number of messages sent      nMsgs <- newRef 0
examples/WorkStationsInSeries.hs view
@@ -19,6 +19,8 @@ import Simulation.Aivika.Trans import Simulation.Aivika.Trans.Queue +import Simulation.Aivika.IO+ -- | The simulation specs. specs = Specs { spcStartTime = 0.0,                 spcStopTime = 300.0,@@ -52,7 +54,7 @@ workStationCount2 = 1  -- create a work station (server) with the exponential processing time-newWorkStationExponential :: MonadComp m => Double -> Simulation m (Server m () a a)+newWorkStationExponential :: Double -> Simulation IO (Server IO () a a) newWorkStationExponential meanTime =   newServer $ \a ->   do holdProcess =<<@@ -60,7 +62,7 @@         randomExponential meanTime)      return a -model :: MonadComp m => Simulation m (Results m)+model :: Simulation IO (Results IO) model = do   -- it will gather the statistics of the processing time   arrivalTimer <- newArrivalTimer@@ -125,7 +127,7 @@      "arrivalTimer" "The arrival timer"      arrivalTimer] -modelSummary :: MonadComp m => Simulation m (Results m)+modelSummary :: Simulation IO (Results IO) modelSummary =   fmap resultSummary model