diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009, 2010, 2011, 2012, 2013, 2014 David Sorokin +Copyright (c) 2009-2015 David Sorokin All rights reserved. diff --git a/Simulation/Aivika/IO.hs b/Simulation/Aivika/IO.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO.hs @@ -0,0 +1,37 @@ + +-- | +-- Module : Simulation.Aivika.IO +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/IO/Comp.hs b/Simulation/Aivika/IO/Comp.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/Comp.hs @@ -0,0 +1,30 @@ + +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.IO.Comp +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 #-} diff --git a/Simulation/Aivika/IO/DES.hs b/Simulation/Aivika/IO/DES.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/DES.hs @@ -0,0 +1,32 @@ + +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.IO.DES +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 #-} diff --git a/Simulation/Aivika/IO/Dynamics/Memo.hs b/Simulation/Aivika/IO/Dynamics/Memo.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/Dynamics/Memo.hs @@ -0,0 +1,112 @@ + +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.IO.Dynamics.Memo +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/IO/Dynamics/Memo/Unboxed.hs b/Simulation/Aivika/IO/Dynamics/Memo/Unboxed.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/Dynamics/Memo/Unboxed.hs @@ -0,0 +1,95 @@ + +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.IO.Dynamics.Memo.Unboxed +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/IO/Event.hs b/Simulation/Aivika/IO/Event.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/Event.hs @@ -0,0 +1,147 @@ + +{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.IO.Event +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/IO/Exception.hs b/Simulation/Aivika/IO/Exception.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/Exception.hs @@ -0,0 +1,29 @@ + +-- | +-- Module : Simulation.Aivika.IO.Exception +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/IO/Generator.hs b/Simulation/Aivika/IO/Generator.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/Generator.hs @@ -0,0 +1,238 @@ + +{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.IO.Generator +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/IO/QueueStrategy.hs b/Simulation/Aivika/IO/QueueStrategy.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/QueueStrategy.hs @@ -0,0 +1,198 @@ + +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, FunctionalDependencies, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.IO.QueueStrategy +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/IO/Ref/Base.hs b/Simulation/Aivika/IO/Ref/Base.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/Ref/Base.hs @@ -0,0 +1,65 @@ + +{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.IO.Ref.Base +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } + diff --git a/Simulation/Aivika/IO/Resource/Preemption.hs b/Simulation/Aivika/IO/Resource/Preemption.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/Resource/Preemption.hs @@ -0,0 +1,250 @@ + +{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.IO.Resource.Preemption +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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' diff --git a/Simulation/Aivika/IO/SD.hs b/Simulation/Aivika/IO/SD.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/SD.hs @@ -0,0 +1,30 @@ + +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.IO.SD +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 #-} diff --git a/Simulation/Aivika/IO/Signal.hs b/Simulation/Aivika/IO/Signal.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/Signal.hs @@ -0,0 +1,88 @@ + +-- | +-- Module : Simulation.Aivika.IO.Signal +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) diff --git a/Simulation/Aivika/IO/Var.hs b/Simulation/Aivika/IO/Var.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/Var.hs @@ -0,0 +1,163 @@ + +{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.IO.Var +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/IO/Var/Unboxed.hs b/Simulation/Aivika/IO/Var/Unboxed.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/Var/Unboxed.hs @@ -0,0 +1,165 @@ + +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.IO.Var.Unboxed +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans.hs b/Simulation/Aivika/Trans.hs --- a/Simulation/Aivika/Trans.hs +++ b/Simulation/Aivika/Trans.hs @@ -1,35 +1,38 @@ -- | -- Module : Simulation.Aivika.Trans --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Activity.hs b/Simulation/Aivika/Trans/Activity.hs --- a/Simulation/Aivika/Trans/Activity.hs +++ b/Simulation/Aivika/Trans/Activity.hs @@ -1,22 +1,21 @@ -- | -- Module : Simulation.Aivika.Trans.Activity --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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) diff --git a/Simulation/Aivika/Trans/Activity/Random.hs b/Simulation/Aivika/Trans/Activity/Random.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Activity/Random.hs @@ -0,0 +1,259 @@ + +-- | +-- Module : Simulation.Aivika.Trans.Activity.Random +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans/Agent.hs b/Simulation/Aivika/Trans/Agent.hs --- a/Simulation/Aivika/Trans/Agent.hs +++ b/Simulation/Aivika/Trans/Agent.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Agent --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Array.hs b/Simulation/Aivika/Trans/Array.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Array.hs @@ -0,0 +1,27 @@ + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.Array +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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_ diff --git a/Simulation/Aivika/Trans/Arrival.hs b/Simulation/Aivika/Trans/Arrival.hs --- a/Simulation/Aivika/Trans/Arrival.hs +++ b/Simulation/Aivika/Trans/Arrival.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Arrival --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 = diff --git a/Simulation/Aivika/Trans/Circuit.hs b/Simulation/Aivika/Trans/Circuit.hs --- a/Simulation/Aivika/Trans/Circuit.hs +++ b/Simulation/Aivika/Trans/Circuit.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Trans.Circuit --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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. -( 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 (?>) -- | 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') <- diff --git a/Simulation/Aivika/Trans/Comp.hs b/Simulation/Aivika/Trans/Comp.hs --- a/Simulation/Aivika/Trans/Comp.hs +++ b/Simulation/Aivika/Trans/Comp.hs @@ -1,52 +1,34 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Simulation.Aivika.Trans.Comp --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Comp/IO.hs b/Simulation/Aivika/Trans/Comp/IO.hs deleted file mode 100644 --- a/Simulation/Aivika/Trans/Comp/IO.hs +++ /dev/null @@ -1,128 +0,0 @@ - -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Simulation.Aivika.Trans.Comp.IO --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 diff --git a/Simulation/Aivika/Trans/Comp/Template.hs b/Simulation/Aivika/Trans/Comp/Template.hs deleted file mode 100644 --- a/Simulation/Aivika/Trans/Comp/Template.hs +++ /dev/null @@ -1,130 +0,0 @@ - -{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} - --- | --- Module : Simulation.Aivika.Trans.Comp.Template --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 diff --git a/Simulation/Aivika/Trans/Cont.hs b/Simulation/Aivika/Trans/Cont.hs --- a/Simulation/Aivika/Trans/Cont.hs +++ b/Simulation/Aivika/Trans/Cont.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Cont --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/DES.hs b/Simulation/Aivika/Trans/DES.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/DES.hs @@ -0,0 +1,26 @@ + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.DES +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans/DoubleLinkedList.hs b/Simulation/Aivika/Trans/DoubleLinkedList.hs --- a/Simulation/Aivika/Trans/DoubleLinkedList.hs +++ b/Simulation/Aivika/Trans/DoubleLinkedList.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.DoubleLinkedList --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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" diff --git a/Simulation/Aivika/Trans/Dynamics.hs b/Simulation/Aivika/Trans/Dynamics.hs --- a/Simulation/Aivika/Trans/Dynamics.hs +++ b/Simulation/Aivika/Trans/Dynamics.hs @@ -1,13 +1,13 @@ -- | -- Module : Simulation.Aivika.Trans.Dynamics --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Dynamics/Extra.hs b/Simulation/Aivika/Trans/Dynamics/Extra.hs --- a/Simulation/Aivika/Trans/Dynamics/Extra.hs +++ b/Simulation/Aivika/Trans/Dynamics/Extra.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Trans.Dynamics.Extra --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Dynamics/Memo.hs b/Simulation/Aivika/Trans/Dynamics/Memo.hs --- a/Simulation/Aivika/Trans/Dynamics/Memo.hs +++ b/Simulation/Aivika/Trans/Dynamics/Memo.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Dynamics.Memo --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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) diff --git a/Simulation/Aivika/Trans/Dynamics/Memo/Unboxed.hs b/Simulation/Aivika/Trans/Dynamics/Memo/Unboxed.hs --- a/Simulation/Aivika/Trans/Dynamics/Memo/Unboxed.hs +++ b/Simulation/Aivika/Trans/Dynamics/Memo/Unboxed.hs @@ -1,105 +1,40 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Simulation.Aivika.Trans.Dynamics.Memo.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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) diff --git a/Simulation/Aivika/Trans/Dynamics/Random.hs b/Simulation/Aivika/Trans/Dynamics/Random.hs --- a/Simulation/Aivika/Trans/Dynamics/Random.hs +++ b/Simulation/Aivika/Trans/Dynamics/Random.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Dynamics.Random --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 -> diff --git a/Simulation/Aivika/Trans/Event.hs b/Simulation/Aivika/Trans/Event.hs --- a/Simulation/Aivika/Trans/Event.hs +++ b/Simulation/Aivika/Trans/Event.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Event --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 + diff --git a/Simulation/Aivika/Trans/Exception.hs b/Simulation/Aivika/Trans/Exception.hs --- a/Simulation/Aivika/Trans/Exception.hs +++ b/Simulation/Aivika/Trans/Exception.hs @@ -1,46 +1,27 @@ -- | -- Module : Simulation.Aivika.Trans.Exception --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Gate.hs b/Simulation/Aivika/Trans/Gate.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Gate.hs @@ -0,0 +1,102 @@ + +-- | +-- Module : Simulation.Aivika.Trans.Gate +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) diff --git a/Simulation/Aivika/Trans/Generator.hs b/Simulation/Aivika/Trans/Generator.hs --- a/Simulation/Aivika/Trans/Generator.hs +++ b/Simulation/Aivika/Trans/Generator.hs @@ -3,26 +3,22 @@ -- | -- Module : Simulation.Aivika.Trans.Generator --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Internal/Cont.hs b/Simulation/Aivika/Trans/Internal/Cont.hs --- a/Simulation/Aivika/Trans/Internal/Cont.hs +++ b/Simulation/Aivika/Trans/Internal/Cont.hs @@ -1,27 +1,38 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + -- | -- Module : Simulation.Aivika.Trans.Internal.Cont --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Internal/Dynamics.hs b/Simulation/Aivika/Trans/Internal/Dynamics.hs --- a/Simulation/Aivika/Trans/Internal/Dynamics.hs +++ b/Simulation/Aivika/Trans/Internal/Dynamics.hs @@ -1,19 +1,21 @@ -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE RecursiveDo, MultiParamTypeClasses, FlexibleInstances #-} -- | -- Module : Simulation.Aivika.Trans.Internal.Dynamics --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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) $ diff --git a/Simulation/Aivika/Trans/Internal/Event.hs b/Simulation/Aivika/Trans/Internal/Event.hs --- a/Simulation/Aivika/Trans/Internal/Event.hs +++ b/Simulation/Aivika/Trans/Internal/Event.hs @@ -1,23 +1,27 @@ -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE RecursiveDo, MultiParamTypeClasses, FlexibleInstances #-} -- | -- Module : Simulation.Aivika.Trans.Internal.Event --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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) $ diff --git a/Simulation/Aivika/Trans/Internal/Parameter.hs b/Simulation/Aivika/Trans/Internal/Parameter.hs --- a/Simulation/Aivika/Trans/Internal/Parameter.hs +++ b/Simulation/Aivika/Trans/Internal/Parameter.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Trans.Internal.Parameter --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Internal/Process.hs b/Simulation/Aivika/Trans/Internal/Process.hs --- a/Simulation/Aivika/Trans/Internal/Process.hs +++ b/Simulation/Aivika/Trans/Internal/Process.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + -- | -- Module : Simulation.Aivika.Trans.Internal.Process --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 $ diff --git a/Simulation/Aivika/Trans/Internal/Signal.hs b/Simulation/Aivika/Trans/Internal/Signal.hs deleted file mode 100644 --- a/Simulation/Aivika/Trans/Internal/Signal.hs +++ /dev/null @@ -1,404 +0,0 @@ - --- | --- Module : Simulation.Aivika.Trans.Internal.Signal --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 } diff --git a/Simulation/Aivika/Trans/Internal/Simulation.hs b/Simulation/Aivika/Trans/Internal/Simulation.hs --- a/Simulation/Aivika/Trans/Internal/Simulation.hs +++ b/Simulation/Aivika/Trans/Internal/Simulation.hs @@ -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 +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Internal/Specs.hs b/Simulation/Aivika/Trans/Internal/Specs.hs --- a/Simulation/Aivika/Trans/Internal/Specs.hs +++ b/Simulation/Aivika/Trans/Internal/Specs.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Trans.Internal.Specs --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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] diff --git a/Simulation/Aivika/Trans/Internal/Types.hs b/Simulation/Aivika/Trans/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Internal/Types.hs @@ -0,0 +1,155 @@ + +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Simulation.Aivika.Trans.Internal.Types +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans/Net.hs b/Simulation/Aivika/Trans/Net.hs --- a/Simulation/Aivika/Trans/Net.hs +++ b/Simulation/Aivika/Trans/Net.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Net --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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') <- diff --git a/Simulation/Aivika/Trans/Net/Random.hs b/Simulation/Aivika/Trans/Net/Random.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Net/Random.hs @@ -0,0 +1,118 @@ + +-- | +-- Module : Simulation.Aivika.Trans.Net.Random +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans/Parameter.hs b/Simulation/Aivika/Trans/Parameter.hs --- a/Simulation/Aivika/Trans/Parameter.hs +++ b/Simulation/Aivika/Trans/Parameter.hs @@ -1,12 +1,12 @@ -- | -- Module : Simulation.Aivika.Trans.Parameter --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Parameter/Random.hs b/Simulation/Aivika/Trans/Parameter/Random.hs --- a/Simulation/Aivika/Trans/Parameter/Random.hs +++ b/Simulation/Aivika/Trans/Parameter/Random.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Parameter.Random --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.8.3 +-- Tested with: GHC 7.10.1 -- -- This module defines the random parameters of simulation experiments. -- diff --git a/Simulation/Aivika/Trans/PriorityQueue.hs b/Simulation/Aivika/Trans/PriorityQueue.hs deleted file mode 100644 --- a/Simulation/Aivika/Trans/PriorityQueue.hs +++ /dev/null @@ -1,186 +0,0 @@ - --- | --- Module : Simulation.Aivika.Trans.PriorityQueue --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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) diff --git a/Simulation/Aivika/Trans/Process.hs b/Simulation/Aivika/Trans/Process.hs --- a/Simulation/Aivika/Trans/Process.hs +++ b/Simulation/Aivika/Trans/Process.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Process --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Process/Random.hs b/Simulation/Aivika/Trans/Process/Random.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Process/Random.hs @@ -0,0 +1,228 @@ + +-- | +-- Module : Simulation.Aivika.Trans.Process.Random +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans/Processor.hs b/Simulation/Aivika/Trans/Processor.hs --- a/Simulation/Aivika/Trans/Processor.hs +++ b/Simulation/Aivika/Trans/Processor.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Trans.Processor --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Processor/Random.hs b/Simulation/Aivika/Trans/Processor/Random.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Processor/Random.hs @@ -0,0 +1,118 @@ + +-- | +-- Module : Simulation.Aivika.Trans.Processor.Random +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans/Processor/RoundRobbin.hs b/Simulation/Aivika/Trans/Processor/RoundRobbin.hs --- a/Simulation/Aivika/Trans/Processor/RoundRobbin.hs +++ b/Simulation/Aivika/Trans/Processor/RoundRobbin.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Processor.RoundRobbin --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 $ diff --git a/Simulation/Aivika/Trans/ProtoArray.hs b/Simulation/Aivika/Trans/ProtoArray.hs deleted file mode 100644 --- a/Simulation/Aivika/Trans/ProtoArray.hs +++ /dev/null @@ -1,82 +0,0 @@ - -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Simulation.Aivika.Trans.ProtoArray --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 diff --git a/Simulation/Aivika/Trans/ProtoArray/Unboxed.hs b/Simulation/Aivika/Trans/ProtoArray/Unboxed.hs deleted file mode 100644 --- a/Simulation/Aivika/Trans/ProtoArray/Unboxed.hs +++ /dev/null @@ -1,98 +0,0 @@ - -{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} - --- | --- Module : Simulation.Aivika.Trans.ProtoArray.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 diff --git a/Simulation/Aivika/Trans/ProtoRef.hs b/Simulation/Aivika/Trans/ProtoRef.hs deleted file mode 100644 --- a/Simulation/Aivika/Trans/ProtoRef.hs +++ /dev/null @@ -1,61 +0,0 @@ - -{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleInstances #-} - --- | --- Module : Simulation.Aivika.Trans.ProtoRef --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 diff --git a/Simulation/Aivika/Trans/Queue.hs b/Simulation/Aivika/Trans/Queue.hs --- a/Simulation/Aivika/Trans/Queue.hs +++ b/Simulation/Aivika/Trans/Queue.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Trans.Queue --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Queue/Infinite.hs b/Simulation/Aivika/Trans/Queue/Infinite.hs --- a/Simulation/Aivika/Trans/Queue/Infinite.hs +++ b/Simulation/Aivika/Trans/Queue/Infinite.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Trans.Queue.Infinite --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/QueueStrategy.hs b/Simulation/Aivika/Trans/QueueStrategy.hs --- a/Simulation/Aivika/Trans/QueueStrategy.hs +++ b/Simulation/Aivika/Trans/QueueStrategy.hs @@ -3,31 +3,22 @@ -- | -- Module : Simulation.Aivika.Trans.QueueStrategy --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Ref.hs b/Simulation/Aivika/Trans/Ref.hs --- a/Simulation/Aivika/Trans/Ref.hs +++ b/Simulation/Aivika/Trans/Ref.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Ref --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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) diff --git a/Simulation/Aivika/Trans/Ref/Base.hs b/Simulation/Aivika/Trans/Ref/Base.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Ref/Base.hs @@ -0,0 +1,58 @@ + +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Simulation.Aivika.Trans.Ref.Base +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) diff --git a/Simulation/Aivika/Trans/Ref/Plain.hs b/Simulation/Aivika/Trans/Ref/Plain.hs deleted file mode 100644 --- a/Simulation/Aivika/Trans/Ref/Plain.hs +++ /dev/null @@ -1,60 +0,0 @@ - --- | --- Module : Simulation.Aivika.Trans.Ref.Plain --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 diff --git a/Simulation/Aivika/Trans/Resource.hs b/Simulation/Aivika/Trans/Resource.hs --- a/Simulation/Aivika/Trans/Resource.hs +++ b/Simulation/Aivika/Trans/Resource.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Trans.Resource --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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) diff --git a/Simulation/Aivika/Trans/Resource/Preemption.hs b/Simulation/Aivika/Trans/Resource/Preemption.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Resource/Preemption.hs @@ -0,0 +1,105 @@ + +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Simulation.Aivika.Trans.Resource.Preemption +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 () diff --git a/Simulation/Aivika/Trans/Results.hs b/Simulation/Aivika/Trans/Results.hs --- a/Simulation/Aivika/Trans/Results.hs +++ b/Simulation/Aivika/Trans/Results.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Trans.Results --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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) diff --git a/Simulation/Aivika/Trans/Results/IO.hs b/Simulation/Aivika/Trans/Results/IO.hs --- a/Simulation/Aivika/Trans/Results/IO.hs +++ b/Simulation/Aivika/Trans/Results/IO.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Results.IO --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Results/Locale.hs b/Simulation/Aivika/Trans/Results/Locale.hs --- a/Simulation/Aivika/Trans/Results/Locale.hs +++ b/Simulation/Aivika/Trans/Results/Locale.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Results.Locale --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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. -- diff --git a/Simulation/Aivika/Trans/SD.hs b/Simulation/Aivika/Trans/SD.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/SD.hs @@ -0,0 +1,25 @@ + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.SD +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans/Server.hs b/Simulation/Aivika/Trans/Server.hs --- a/Simulation/Aivika/Trans/Server.hs +++ b/Simulation/Aivika/Trans/Server.hs @@ -1,21 +1,20 @@ -- | -- Module : Simulation.Aivika.Trans.Server --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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) diff --git a/Simulation/Aivika/Trans/Server/Random.hs b/Simulation/Aivika/Trans/Server/Random.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Server/Random.hs @@ -0,0 +1,259 @@ + +-- | +-- Module : Simulation.Aivika.Trans.Server.Random +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans/Session.hs b/Simulation/Aivika/Trans/Session.hs deleted file mode 100644 --- a/Simulation/Aivika/Trans/Session.hs +++ /dev/null @@ -1,56 +0,0 @@ - -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Simulation.Aivika.Trans.Session --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 diff --git a/Simulation/Aivika/Trans/Signal.hs b/Simulation/Aivika/Trans/Signal.hs --- a/Simulation/Aivika/Trans/Signal.hs +++ b/Simulation/Aivika/Trans/Signal.hs @@ -1,23 +1,25 @@ -- | -- Module : Simulation.Aivika.Trans.Signal --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 } diff --git a/Simulation/Aivika/Trans/Simulation.hs b/Simulation/Aivika/Trans/Simulation.hs --- a/Simulation/Aivika/Trans/Simulation.hs +++ b/Simulation/Aivika/Trans/Simulation.hs @@ -1,13 +1,13 @@ -- | -- Module : Simulation.Aivika.Trans.Simulation --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Specs.hs b/Simulation/Aivika/Trans/Specs.hs --- a/Simulation/Aivika/Trans/Specs.hs +++ b/Simulation/Aivika/Trans/Specs.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Specs --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Statistics.hs b/Simulation/Aivika/Trans/Statistics.hs --- a/Simulation/Aivika/Trans/Statistics.hs +++ b/Simulation/Aivika/Trans/Statistics.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Statistics --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Statistics/Accumulator.hs b/Simulation/Aivika/Trans/Statistics/Accumulator.hs --- a/Simulation/Aivika/Trans/Statistics/Accumulator.hs +++ b/Simulation/Aivika/Trans/Statistics/Accumulator.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Statistics.Accumulator --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Stream.hs b/Simulation/Aivika/Trans/Stream.hs --- a/Simulation/Aivika/Trans/Stream.hs +++ b/Simulation/Aivika/Trans/Stream.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Trans.Stream --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Stream/Random.hs b/Simulation/Aivika/Trans/Stream/Random.hs --- a/Simulation/Aivika/Trans/Stream/Random.hs +++ b/Simulation/Aivika/Trans/Stream/Random.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Stream.Random --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 -> diff --git a/Simulation/Aivika/Trans/SystemDynamics.hs b/Simulation/Aivika/Trans/SystemDynamics.hs --- a/Simulation/Aivika/Trans/SystemDynamics.hs +++ b/Simulation/Aivika/Trans/SystemDynamics.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Trans.SystemDynamics --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 -> diff --git a/Simulation/Aivika/Trans/Table.hs b/Simulation/Aivika/Trans/Table.hs --- a/Simulation/Aivika/Trans/Table.hs +++ b/Simulation/Aivika/Trans/Table.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Table --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.8.3 +-- Tested with: GHC 7.10.1 -- -- It defines the table functions. -- diff --git a/Simulation/Aivika/Trans/Task.hs b/Simulation/Aivika/Trans/Task.hs --- a/Simulation/Aivika/Trans/Task.hs +++ b/Simulation/Aivika/Trans/Task.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Task --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Template.hs b/Simulation/Aivika/Trans/Template.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Template.hs @@ -0,0 +1,21 @@ + +-- | +-- Module : Simulation.Aivika.Trans.Template +-- Copyright : Copyright (c) 2009-2015, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans/Transform.hs b/Simulation/Aivika/Trans/Transform.hs --- a/Simulation/Aivika/Trans/Transform.hs +++ b/Simulation/Aivika/Trans/Transform.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Trans.Transform --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Transform/Extra.hs b/Simulation/Aivika/Trans/Transform/Extra.hs --- a/Simulation/Aivika/Trans/Transform/Extra.hs +++ b/Simulation/Aivika/Trans/Transform/Extra.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Transform.Extra --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Transform/Memo.hs b/Simulation/Aivika/Trans/Transform/Memo.hs --- a/Simulation/Aivika/Trans/Transform/Memo.hs +++ b/Simulation/Aivika/Trans/Transform/Memo.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Trans.Transform.Memo --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Transform/Memo/Unboxed.hs b/Simulation/Aivika/Trans/Transform/Memo/Unboxed.hs --- a/Simulation/Aivika/Trans/Transform/Memo/Unboxed.hs +++ b/Simulation/Aivika/Trans/Transform/Memo/Unboxed.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Trans.Transform.Memo.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 diff --git a/Simulation/Aivika/Trans/Unboxed.hs b/Simulation/Aivika/Trans/Unboxed.hs deleted file mode 100644 --- a/Simulation/Aivika/Trans/Unboxed.hs +++ /dev/null @@ -1,45 +0,0 @@ - -{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses #-} - --- | --- Module : Simulation.Aivika.Trans.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 diff --git a/Simulation/Aivika/Trans/Var.hs b/Simulation/Aivika/Trans/Var.hs --- a/Simulation/Aivika/Trans/Var.hs +++ b/Simulation/Aivika/Trans/Var.hs @@ -1,190 +1,77 @@ +{-# LANGUAGE TypeFamilies #-} + -- | -- Module : Simulation.Aivika.Trans.Var --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 () diff --git a/Simulation/Aivika/Trans/Var/Unboxed.hs b/Simulation/Aivika/Trans/Var/Unboxed.hs --- a/Simulation/Aivika/Trans/Var/Unboxed.hs +++ b/Simulation/Aivika/Trans/Var/Unboxed.hs @@ -1,190 +1,77 @@ +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} + -- | -- Module : Simulation.Aivika.Trans.Var.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- 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 () diff --git a/Simulation/Aivika/Trans/Vector.hs b/Simulation/Aivika/Trans/Vector.hs deleted file mode 100644 --- a/Simulation/Aivika/Trans/Vector.hs +++ /dev/null @@ -1,199 +0,0 @@ - -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Simulation.Aivika.Trans.Vector --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 diff --git a/Simulation/Aivika/Trans/Vector/Unboxed.hs b/Simulation/Aivika/Trans/Vector/Unboxed.hs deleted file mode 100644 --- a/Simulation/Aivika/Trans/Vector/Unboxed.hs +++ /dev/null @@ -1,199 +0,0 @@ - -{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} - --- | --- Module : Simulation.Aivika.Trans.Vector.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 diff --git a/aivika-transformers.cabal b/aivika-transformers.cabal --- a/aivika-transformers.cabal +++ b/aivika-transformers.cabal @@ -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] . category: Simulation license: BSD3 license-file: LICENSE -copyright: (c) 2009-2014. David Sorokin +copyright: (c) 2009-2015. David Sorokin author: David Sorokin maintainer: David Sorokin -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, diff --git a/examples/BassDiffusion.hs b/examples/BassDiffusion.hs --- a/examples/BassDiffusion.hs +++ b/examples/BassDiffusion.hs @@ -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 diff --git a/examples/ChemicalReaction.hs b/examples/ChemicalReaction.hs --- a/examples/ChemicalReaction.hs +++ b/examples/ChemicalReaction.hs @@ -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 diff --git a/examples/ChemicalReactionCircuit.hs b/examples/ChemicalReactionCircuit.hs --- a/examples/ChemicalReactionCircuit.hs +++ b/examples/ChemicalReactionCircuit.hs @@ -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) $ diff --git a/examples/FishBank.hs b/examples/FishBank.hs --- a/examples/FishBank.hs +++ b/examples/FishBank.hs @@ -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 diff --git a/examples/Furnace.hs b/examples/Furnace.hs --- a/examples/Furnace.hs +++ b/examples/Furnace.hs @@ -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 diff --git a/examples/InspectionAdjustmentStations.hs b/examples/InspectionAdjustmentStations.hs --- a/examples/InspectionAdjustmentStations.hs +++ b/examples/InspectionAdjustmentStations.hs @@ -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 = diff --git a/examples/MachRep1.hs b/examples/MachRep1.hs --- a/examples/MachRep1.hs +++ b/examples/MachRep1.hs @@ -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 diff --git a/examples/MachRep1EventDriven.hs b/examples/MachRep1EventDriven.hs --- a/examples/MachRep1EventDriven.hs +++ b/examples/MachRep1EventDriven.hs @@ -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 diff --git a/examples/MachRep1TimeDriven.hs b/examples/MachRep1TimeDriven.hs --- a/examples/MachRep1TimeDriven.hs +++ b/examples/MachRep1TimeDriven.hs @@ -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 diff --git a/examples/MachRep2.hs b/examples/MachRep2.hs --- a/examples/MachRep2.hs +++ b/examples/MachRep2.hs @@ -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 diff --git a/examples/MachRep3.hs b/examples/MachRep3.hs --- a/examples/MachRep3.hs +++ b/examples/MachRep3.hs @@ -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 diff --git a/examples/TimeOut.hs b/examples/TimeOut.hs --- a/examples/TimeOut.hs +++ b/examples/TimeOut.hs @@ -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 diff --git a/examples/TimeOutInt.hs b/examples/TimeOutInt.hs --- a/examples/TimeOutInt.hs +++ b/examples/TimeOutInt.hs @@ -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 diff --git a/examples/TimeOutWait.hs b/examples/TimeOutWait.hs --- a/examples/TimeOutWait.hs +++ b/examples/TimeOutWait.hs @@ -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 diff --git a/examples/WorkStationsInSeries.hs b/examples/WorkStationsInSeries.hs --- a/examples/WorkStationsInSeries.hs +++ b/examples/WorkStationsInSeries.hs @@ -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