diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,13 @@ +Version 5.1 +----- + +* Includes changes destined for Aivika Exension Pack. + +* Minor changes in the resource preemption statistics. + +* Added the statistics reset. + Version 5.0 ----- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009-2016 David Sorokin +Copyright (c) 2009-2017 David Sorokin All rights reserved. diff --git a/Simulation/Aivika/IO.hs b/Simulation/Aivika/IO.hs --- a/Simulation/Aivika/IO.hs +++ b/Simulation/Aivika/IO.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.IO --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -19,9 +19,7 @@ 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 @@ -31,7 +29,5 @@ 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 --- a/Simulation/Aivika/IO/Comp.hs +++ b/Simulation/Aivika/IO/Comp.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.IO.Comp --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/IO/DES.hs b/Simulation/Aivika/IO/DES.hs --- a/Simulation/Aivika/IO/DES.hs +++ b/Simulation/Aivika/IO/DES.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.IO.DES --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -15,7 +15,8 @@ import Control.Monad.Trans import Simulation.Aivika.IO.Comp -import Simulation.Aivika.IO.Ref.Base +import qualified Simulation.Aivika.IO.Ref.Base.Strict as StrictRef +import qualified Simulation.Aivika.IO.Ref.Base.Lazy as LazyRef import Simulation.Aivika.IO.Event import Simulation.Aivika.Trans.Comp diff --git a/Simulation/Aivika/IO/Dynamics/Memo.hs b/Simulation/Aivika/IO/Dynamics/Memo.hs --- a/Simulation/Aivika/IO/Dynamics/Memo.hs +++ b/Simulation/Aivika/IO/Dynamics/Memo.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.IO.Dynamics.Memo --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/IO/Dynamics/Memo/Unboxed.hs b/Simulation/Aivika/IO/Dynamics/Memo/Unboxed.hs --- a/Simulation/Aivika/IO/Dynamics/Memo/Unboxed.hs +++ b/Simulation/Aivika/IO/Dynamics/Memo/Unboxed.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.IO.Dynamics.Memo.Unboxed --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/IO/Event.hs b/Simulation/Aivika/IO/Event.hs --- a/Simulation/Aivika/IO/Event.hs +++ b/Simulation/Aivika/IO/Event.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.IO.Event --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/IO/Exception.hs b/Simulation/Aivika/IO/Exception.hs --- a/Simulation/Aivika/IO/Exception.hs +++ b/Simulation/Aivika/IO/Exception.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.IO.Exception --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/IO/Generator.hs b/Simulation/Aivika/IO/Generator.hs --- a/Simulation/Aivika/IO/Generator.hs +++ b/Simulation/Aivika/IO/Generator.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.IO.Generator --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -32,8 +32,10 @@ data Generator IO = Generator { generator01 :: IO Double, -- ^ the generator of uniform numbers from 0 to 1 - generatorNormal01 :: IO Double + generatorNormal01 :: IO Double, -- ^ the generator of normal numbers with mean 0 and variance 1 + generatorSequenceNo :: IO Int + -- ^ the generator of sequence numbers } {-# INLINE generateUniform #-} @@ -75,6 +77,9 @@ {-# INLINE generateDiscrete #-} generateDiscrete = generateDiscrete01 . generator01 + {-# INLINE generateSequenceNo #-} + generateSequenceNo = generatorSequenceNo + {-# INLINABLE newGenerator #-} newGenerator tp = case tp of @@ -99,8 +104,11 @@ {-# INLINABLE newRandomGenerator01 #-} newRandomGenerator01 g01 = do gNormal01 <- newNormalGenerator01 g01 + gSeqNoRef <- newIORef 0 + let gSeqNo = do { x <- readIORef gSeqNoRef; modifyIORef' gSeqNoRef (+1); return x } return Generator { generator01 = g01, - generatorNormal01 = gNormal01 } + generatorNormal01 = gNormal01, + generatorSequenceNo = gSeqNo } -- | Create a normal random number generator with mean 0 and variance 1 -- by the specified generator of uniform random numbers from 0 to 1. diff --git a/Simulation/Aivika/IO/QueueStrategy.hs b/Simulation/Aivika/IO/QueueStrategy.hs --- a/Simulation/Aivika/IO/QueueStrategy.hs +++ b/Simulation/Aivika/IO/QueueStrategy.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.IO.QueueStrategy --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/IO/Ref/Base.hs b/Simulation/Aivika/IO/Ref/Base.hs --- a/Simulation/Aivika/IO/Ref/Base.hs +++ b/Simulation/Aivika/IO/Ref/Base.hs @@ -1,66 +1,17 @@ -{-# LANGUAGE TypeFamilies #-} - -- | -- Module : Simulation.Aivika.IO.Ref.Base --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental -- Tested with: GHC 8.0.1 -- --- The 'IO' monad in an instance of 'MonadRef'. +-- The 'IO' monad in an instance of strict 'MonadRef', but it can also be +-- an instance of similar lazy reference. -- -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 - --- | 'IO' is an instance of 'MonadRef'. -instance MonadRef IO where --- instance (Monad m, MonadIO m, MonadTemplate m) => MonadRef m where - - {-# SPECIALISE instance MonadRef IO #-} - - -- | A type safe wrapper for the 'IORef' reference. - newtype Ref IO 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) - --- | 'IO' is an instance of 'MonadRef0'. -instance MonadRef0 IO where --- instance (MonadIO m, MonadTemplate m) => MonadRef0 m where +module Simulation.Aivika.IO.Ref.Base + (module Simulation.Aivika.IO.Ref.Base.Strict) where - {-# SPECIALISE instance MonadRef0 IO #-} - - {-# INLINE newRef0 #-} - newRef0 a = - do x <- liftIO $ newIORef a - return Ref { refValue = x } - +import Simulation.Aivika.Trans.Ref.Base.Strict +import Simulation.Aivika.IO.Ref.Base.Strict diff --git a/Simulation/Aivika/IO/Ref/Base/Lazy.hs b/Simulation/Aivika/IO/Ref/Base/Lazy.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/Ref/Base/Lazy.hs @@ -0,0 +1,66 @@ + +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Simulation.Aivika.IO.Ref.Base.Lazy +-- Copyright : Copyright (c) 2009-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The 'IO' monad in an instance of lazy 'MonadRef'. +-- +module Simulation.Aivika.IO.Ref.Base.Lazy () where + +import Data.IORef + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Internal.Types +import Simulation.Aivika.Trans.Ref.Base.Lazy + +-- | 'IO' is an instance of 'MonadRef'. +instance MonadRef IO where +-- instance (Monad m, MonadIO m, MonadTemplate m) => MonadRef m where + + {-# SPECIALISE instance MonadRef IO #-} + + -- | A type safe wrapper for the 'IORef' reference. + newtype Ref IO 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 -> + liftIO $ writeIORef (refValue r) a + + {-# INLINE modifyRef #-} + modifyRef r f = Event $ \p -> + do a <- liftIO $ readIORef (refValue r) + let b = f a + liftIO $ writeIORef (refValue r) b + + {-# INLINE equalRef #-} + equalRef (Ref r1) (Ref r2) = (r1 == r2) + +-- | 'IO' is an instance of 'MonadRef0'. +instance MonadRef0 IO where +-- 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/Ref/Base/Strict.hs b/Simulation/Aivika/IO/Ref/Base/Strict.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/IO/Ref/Base/Strict.hs @@ -0,0 +1,66 @@ + +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Simulation.Aivika.IO.Ref.Base.Strict +-- Copyright : Copyright (c) 2009-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The 'IO' monad in an instance of strict 'MonadRef'. +-- +module Simulation.Aivika.IO.Ref.Base.Strict () where + +import Data.IORef + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Internal.Types +import Simulation.Aivika.Trans.Ref.Base.Strict + +-- | 'IO' is an instance of 'MonadRef'. +instance MonadRef IO where +-- instance (Monad m, MonadIO m, MonadTemplate m) => MonadRef m where + + {-# SPECIALISE instance MonadRef IO #-} + + -- | A type safe wrapper for the 'IORef' reference. + newtype Ref IO 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) + +-- | 'IO' is an instance of 'MonadRef0'. +instance MonadRef0 IO where +-- 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 --- a/Simulation/Aivika/IO/Resource/Preemption.hs +++ b/Simulation/Aivika/IO/Resource/Preemption.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.IO.Resource.Preemption --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -212,6 +212,7 @@ 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 t pid0) + invokeEvent p $ updateResourceWaitTime r 0 invokeEvent p $ updateResourceQueueCount r 1 invokeEvent p $ processPreemptionBegin pid0 invokeEvent p $ resumeCont c () @@ -268,6 +269,24 @@ | n < 0 = decResourceCount r (- n) | n > 0 = incResourceCount r n | n == 0 = return () + + {-# INLINABLE resetResource #-} + resetResource r = + Event $ \p -> + do let t = pointTime p + count <- readIORef (resourceCountRef r) + writeIORef (resourceCountStatsRef r) $ + returnTimingStats t count + utilCount <- readIORef (resourceUtilisationCountRef r) + writeIORef (resourceUtilisationCountStatsRef r) $ + returnTimingStats t utilCount + queueCount <- readIORef (resourceQueueCountRef r) + writeIORef (resourceQueueCountStatsRef r) $ + returnTimingStats t queueCount + writeIORef (resourceTotalWaitTimeRef r) 0 + writeIORef (resourceWaitTimeRef r) emptySamplingStats + invokeEvent p $ + triggerSignal (resourceWaitTimeSource r) () -- | Identifies an acting item that acquired the resource. data ResourceActingItem m = diff --git a/Simulation/Aivika/IO/Resource/Preemption/Base.hs b/Simulation/Aivika/IO/Resource/Preemption/Base.hs --- a/Simulation/Aivika/IO/Resource/Preemption/Base.hs +++ b/Simulation/Aivika/IO/Resource/Preemption/Base.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.IO.Resource.Preemption.Base --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/IO/SD.hs b/Simulation/Aivika/IO/SD.hs --- a/Simulation/Aivika/IO/SD.hs +++ b/Simulation/Aivika/IO/SD.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.IO.SD --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/IO/Signal.hs b/Simulation/Aivika/IO/Signal.hs --- a/Simulation/Aivika/IO/Signal.hs +++ b/Simulation/Aivika/IO/Signal.hs @@ -1,13 +1,14 @@ -- | -- Module : Simulation.Aivika.IO.Signal --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental -- Tested with: GHC 8.0.1 -- --- This module allows collecting the signal history. +-- This module allows collecting the signal history in a more +-- optimal way than it suggests the general implementation. -- module Simulation.Aivika.IO.Signal @@ -28,8 +29,14 @@ import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Dynamics import Simulation.Aivika.Trans.Internal.Event -import Simulation.Aivika.Trans.Signal +import Simulation.Aivika.Trans.Composite +import Simulation.Aivika.Trans.Signal hiding (SignalHistory, + signalHistorySignal, + newSignalHistory, + newSignalHistoryStartingWith, + readSignalHistory) import Simulation.Aivika.IO.DES @@ -44,31 +51,26 @@ signalHistoryValues :: V.Vector a } -- | Create a history of the signal values. -newSignalHistory :: Signal IO a -> Event IO (SignalHistory IO a) --- newSignalHistory :: (MonadDES m, MonadIO m, MonadTemplate m) --- => Signal m a -> Event m (SignalHistory m a) +newSignalHistory :: Signal IO a -> Composite IO (SignalHistory IO a) {-# INLINABLE newSignalHistory #-} newSignalHistory = newSignalHistoryStartingWith Nothing -- | Create a history of the signal values starting with -- the optional initial value. -newSignalHistoryStartingWith :: Maybe a -> Signal IO a -> Event IO (SignalHistory IO a) --- newSignalHistoryStartingWith :: (MonadDES m, MonadIO m, MonadTemplate m) --- => Maybe a -> Signal m a -> Event m (SignalHistory m a) +newSignalHistoryStartingWith :: Maybe a -> Signal IO a -> Composite IO (SignalHistory IO 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 -> + do t <- liftDynamics time + liftIO $ + do UV.appendVector ts t + V.appendVector xs a + handleSignalComposite signal $ \a -> Event $ \p -> liftIO $ do UV.appendVector ts (pointTime p) diff --git a/Simulation/Aivika/IO/Var.hs b/Simulation/Aivika/IO/Var.hs --- a/Simulation/Aivika/IO/Var.hs +++ b/Simulation/Aivika/IO/Var.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.IO.Var --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/IO/Var/Unboxed.hs b/Simulation/Aivika/IO/Var/Unboxed.hs --- a/Simulation/Aivika/IO/Var/Unboxed.hs +++ b/Simulation/Aivika/IO/Var/Unboxed.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.IO.Var.Unboxed --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Trans.hs b/Simulation/Aivika/Trans.hs --- a/Simulation/Aivika/Trans.hs +++ b/Simulation/Aivika/Trans.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Activity --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -30,6 +30,8 @@ activityUtilisationFactor, activityIdleFactor, activityPreemptionFactor, + -- * Statistics Reset + resetActivity, -- * Summary activitySummary, -- * Derived Signals for Properties @@ -609,3 +611,15 @@ showString tab . showString "preemption time:\n\n" . samplingStatsSummary xs3 (2 + indent) + +-- | Reset the statistics. +resetActivity :: MonadDES m => Activity m s a b -> Event m () +{-# INLINABLE resetActivity #-} +resetActivity act = + do writeRef (activityTotalUtilisationTimeRef act) 0 + writeRef (activityTotalIdleTimeRef act) 0 + writeRef (activityTotalPreemptionTimeRef act) 0 + writeRef (activityUtilisationTimeRef act) mempty + writeRef (activityIdleTimeRef act) mempty + writeRef (activityPreemptionTimeRef act) mempty + diff --git a/Simulation/Aivika/Trans/Activity/Random.hs b/Simulation/Aivika/Trans/Activity/Random.hs --- a/Simulation/Aivika/Trans/Activity/Random.hs +++ b/Simulation/Aivika/Trans/Activity/Random.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Activity.Random --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Agent --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Trans/Array.hs b/Simulation/Aivika/Trans/Array.hs --- a/Simulation/Aivika/Trans/Array.hs +++ b/Simulation/Aivika/Trans/Array.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Array --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Arrival --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -22,7 +22,8 @@ arrivalTimerChannel, arrivalProcessingTime, arrivalProcessingTimeChanged, - arrivalProcessingTimeChanged_) where + arrivalProcessingTimeChanged_, + resetArrivalTimer) where import Control.Monad import Control.Monad.Trans @@ -111,3 +112,10 @@ arrivalTimerChannel timer = Channel $ \sa -> return $ arrivalTimerSignal timer sa + +-- | Reset the statistics. +resetArrivalTimer :: MonadDES m => ArrivalTimer m -> Event m () +{-# INLINABLE resetArrivalTimer #-} +resetArrivalTimer timer = + do writeRef (arrivalProcessingTimeRef timer) emptySamplingStats + triggerSignal (arrivalProcessingTimeChangedSource timer) () diff --git a/Simulation/Aivika/Trans/Channel.hs b/Simulation/Aivika/Trans/Channel.hs --- a/Simulation/Aivika/Trans/Channel.hs +++ b/Simulation/Aivika/Trans/Channel.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Channel --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Circuit --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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 @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Comp --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Trans/Composite.hs b/Simulation/Aivika/Trans/Composite.hs --- a/Simulation/Aivika/Trans/Composite.hs +++ b/Simulation/Aivika/Trans/Composite.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Composite --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -15,6 +15,7 @@ module Simulation.Aivika.Trans.Composite (-- * Composite Monad Composite, + CompositeLift(..), runComposite, runComposite_, runCompositeInStartTime_, @@ -159,3 +160,14 @@ Composite $ \h0 -> do a <- liftEvent m return (a, h0) + +-- | A type class to lift the 'Composite' computation to other computations. +class CompositeLift t m where + + -- | Lift the specified 'Composite' computation to another computation. + liftComposite :: Composite m a -> t m a + +instance Monad m => CompositeLift Composite m where + + {-# INLINE liftComposite #-} + liftComposite = id diff --git a/Simulation/Aivika/Trans/Concurrent/MVar.hs b/Simulation/Aivika/Trans/Concurrent/MVar.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Concurrent/MVar.hs @@ -0,0 +1,79 @@ + +-- | +-- Module : Simulation.Aivika.Trans.Concurrent.MVar +-- Copyright : Copyright (c) 2009-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines helper functions for working with 'MVar'. +-- +module Simulation.Aivika.Trans.Concurrent.MVar + (withMVarComp, + withMVarParameter, + withMVarSimulation, + withMVarDynamics, + withMVarEvent, + withMVarProcess) where + +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Exception +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.DES +import Simulation.Aivika.Trans.Parameter +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Event +import Simulation.Aivika.Trans.Process + +-- | Like 'withMVar' but operates within the specified computation. +withMVarComp :: (MonadComp m, MonadIO m) => MVar a -> (a -> m b) -> m b +withMVarComp v f = + do a <- liftIO $ takeMVar v + finallyComp + (f a) + (liftIO $ putMVar v a) + +-- | Like 'withMVar' but operates within the 'Parameter' computation. +withMVarParameter :: (MonadComp m, MonadIO m) => MVar a -> (a -> Parameter m b) -> Parameter m b +withMVarParameter v f = + do a <- liftIO $ takeMVar v + finallyParameter + (f a) + (liftIO $ putMVar v a) + +-- | Like 'withMVar' but operates within the 'Simulation' computation. +withMVarSimulation :: (MonadComp m, MonadIO m) => MVar a -> (a -> Simulation m b) -> Simulation m b +withMVarSimulation v f = + do a <- liftIO $ takeMVar v + finallySimulation + (f a) + (liftIO $ putMVar v a) + +-- | Like 'withMVar' but operates within the 'Dynamics' computation. +withMVarDynamics :: (MonadComp m, MonadIO m) => MVar a -> (a -> Dynamics m b) -> Dynamics m b +withMVarDynamics v f = + do a <- liftIO $ takeMVar v + finallyDynamics + (f a) + (liftIO $ putMVar v a) + +-- | Like 'withMVar' but operates within the 'Event' computation. +withMVarEvent :: (MonadComp m, MonadIO m) => MVar a -> (a -> Event m b) -> Event m b +withMVarEvent v f = + do a <- liftIO $ takeMVar v + finallyEvent + (f a) + (liftIO $ putMVar v a) + +-- | Like 'withMVar' but operates within the 'Process' computation. +withMVarProcess :: (MonadDES m, MonadIO m) => MVar a -> (a -> Process m b) -> Process m b +withMVarProcess v f = + do a <- liftIO $ takeMVar v + finallyProcess + (f a) + (liftIO $ putMVar v a) diff --git a/Simulation/Aivika/Trans/Concurrent/MVar.hs-boot b/Simulation/Aivika/Trans/Concurrent/MVar.hs-boot new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Concurrent/MVar.hs-boot @@ -0,0 +1,21 @@ + +-- | +-- Module : Simulation.Aivika.Trans.Concurrent.MVar +-- Copyright : Copyright (c) 2009-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines helper functions for working with 'MVar'. +-- +module Simulation.Aivika.Trans.Concurrent.MVar + (withMVarComp) where + +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Comp + +withMVarComp :: (MonadComp m, MonadIO m) => MVar a -> (a -> m b) -> m b 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Cont --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Trans/DES.hs b/Simulation/Aivika/Trans/DES.hs --- a/Simulation/Aivika/Trans/DES.hs +++ b/Simulation/Aivika/Trans/DES.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.DES --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -14,13 +14,15 @@ module Simulation.Aivika.Trans.DES (MonadDES) where import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Ref.Base +import qualified Simulation.Aivika.Trans.Ref.Base.Strict as StrictRef +import qualified Simulation.Aivika.Trans.Ref.Base.Lazy as LazyRef 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, + StrictRef.MonadRef m, + LazyRef.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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.DoubleLinkedList --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Dynamics --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Dynamics.Extra --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Dynamics.Memo --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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 @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Dynamics.Memo.Unboxed --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Dynamics.Random --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Event --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Exception --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Trans/Gate.hs b/Simulation/Aivika/Trans/Gate.hs --- a/Simulation/Aivika/Trans/Gate.hs +++ b/Simulation/Aivika/Trans/Gate.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Gate --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -16,6 +16,7 @@ newGateClosed, openGate, closeGate, + invertGate, gateOpened, gateClosed, awaitGateOpened, @@ -62,6 +63,12 @@ {-# INLINE closeGate #-} closeGate gate = writeRef (gateRef gate) False + +-- | Invert the gate. +invertGate :: MonadDES m => Gate m -> Event m () +{-# INLINABLE invertGate #-} +invertGate gate = + modifyRef (gateRef gate) not -- | Test whether the gate is open. gateOpened :: MonadDES m => Gate m -> Event m Bool 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,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Generator --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -85,6 +85,9 @@ -- | Generate a random value from the specified discrete distribution. generateDiscrete :: forall a. Generator m -> DiscretePDF a -> m a + -- | Generate a sequence number which can be considered quite unique. + generateSequenceNo :: Generator m -> m Int + -- | Create a new random number generator. newGenerator :: GeneratorType m -> m (Generator m) diff --git a/Simulation/Aivika/Trans/Generator/Primitive.hs b/Simulation/Aivika/Trans/Generator/Primitive.hs --- a/Simulation/Aivika/Trans/Generator/Primitive.hs +++ b/Simulation/Aivika/Trans/Generator/Primitive.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Generator.Primitive --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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 @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Internal.Cont --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -51,6 +51,7 @@ substituteCont, contCanceled, contAwait, + transferCont, traceCont) where import Data.Array @@ -903,6 +904,27 @@ Just c -> invokeEvent p $ reenterCont c a invokeEvent p $ writeRef rh $ Just h + +-- | Like the GoTo statement it transfers the direction of computation, +-- but raises an exception when used within 'catchCont' or 'finallyCont'. +transferCont :: MonadDES m => Cont m () -> Cont m a +{-# INLINABLE transferCont #-} +transferCont x = + Cont $ \c -> + Event $ \p -> + do let worker = + do let cid = contId $ contAux c + cont = return + econt = throwEvent + ccont = return + when (contCatchFlag $ contAux c) $ + error "Cannot be combined with the exception handling: unsafeTransferCont" + invokeEvent p $ + runCont x cont econt ccont cid False + z <- invokeEvent p $ contCanceled c + if z + then invokeEvent p $ cancelCont c + else worker -- | Show the debug message with the current simulation time. traceCont :: MonadDES m => String -> Cont m a -> Cont m a 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 @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Internal.Dynamics --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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 @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Internal.Event --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Internal.Parameter --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -57,6 +57,7 @@ import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Internal.Types import Simulation.Aivika.Trans.Internal.Specs +import {-# SOURCE #-} Simulation.Aivika.Trans.Concurrent.MVar instance Monad m => Monad (Parameter m) where @@ -284,23 +285,23 @@ -- within a simulation run. However, the value will be recalculated for other -- simulation runs. Also it is thread-safe when different simulation runs -- are executed in parallel on physically different operating system threads. -memoParameter :: Parameter IO a -> IO (Parameter IO a) +memoParameter :: (MonadComp m, MonadIO m) => Parameter m a -> m (Parameter m a) memoParameter x = - do lock <- newMVar () - dict <- newIORef M.empty + do lock <- liftIO $ newMVar () + dict <- liftIO $ newIORef M.empty return $ Parameter $ \r -> do let i = runIndex r - m <- readIORef dict + m <- liftIO $ readIORef dict if M.member i m then do let Just v = M.lookup i m return v - else withMVar lock $ - \() -> do { m <- readIORef dict; + else withMVarComp lock $ + \() -> do { m <- liftIO $ readIORef dict; if M.member i m then do let Just v = M.lookup i m return v else do v <- invokeParameter r x - writeIORef dict $ M.insert i v m + liftIO $ writeIORef dict $ M.insert i v m return v } -- | Return a parameter which value is taken consequently from the specified table 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 @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Internal.Process --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -48,9 +48,12 @@ holdProcess, interruptProcess, processInterrupted, + processInterruptionTime, passivateProcess, + passivateProcessBefore, processPassive, reactivateProcess, + reactivateProcessImmediately, cancelProcessWithId, cancelProcess, processCancelled, @@ -87,6 +90,8 @@ neverProcess, -- * Retrying Computation retryProcess, + -- * GoTo Statement + transferProcess, -- * Debugging traceProcess) where @@ -179,6 +184,21 @@ Event $ \p -> invokeEvent p $ readRef (processInterruptRef pid) +-- | Return the expected interruption time after finishing the 'holdProcess' computation, +-- which value may change if the corresponding process is preempted. +processInterruptionTime :: MonadDES m => ProcessId m -> Event m (Maybe Double) +{-# INLINABLE processInterruptionTime #-} +processInterruptionTime pid = + Event $ \p -> + do let x = processInterruptCont pid + a <- invokeEvent p $ readRef x + case a of + Just c -> + do t <- invokeEvent p $ readRef (processInterruptTime pid) + return (Just t) + Nothing -> + return Nothing + -- | Define a reaction when the process with the specified identifier is preempted. processPreempted :: MonadDES m => ProcessId m -> Event m () {-# INLINABLE processPreempted #-} @@ -224,6 +244,21 @@ Nothing -> invokeEvent p $ writeRef x $ Just c Just _ -> error "Cannot passivate the process twice: passivateProcess" +-- | Passivate the process before performing some action. +passivateProcessBefore :: MonadDES m => Event m () -> Process m () +{-# INLINABLE passivateProcessBefore #-} +passivateProcessBefore m = + Process $ \pid -> + Cont $ \c -> + Event $ \p -> + do let x = processReactCont pid + a <- invokeEvent p $ readRef x + case a of + Nothing -> + do invokeEvent p $ writeRef x $ Just c + invokeEvent p m + Just _ -> error "Cannot passivate the process twice: passivateProcessBefore" + -- | Test whether the process with the specified identifier is passivated. processPassive :: MonadDES m => ProcessId m -> Event m Bool {-# INLINABLE processPassive #-} @@ -247,6 +282,20 @@ do invokeEvent p $ writeRef x Nothing invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c () +-- | Reactivate a process with the specified identifier immediately. +reactivateProcessImmediately :: MonadDES m => ProcessId m -> Event m () +{-# INLINABLE reactivateProcessImmediately #-} +reactivateProcessImmediately pid = + Event $ \p -> + do let x = processReactCont pid + a <- invokeEvent p $ readRef x + case a of + Nothing -> + return () + Just c -> + do invokeEvent p $ writeRef x Nothing + invokeEvent p $ resumeCont c () + -- | Prepare the processes identifier for running. processIdPrepare :: MonadDES m => ProcessId m -> Event m () {-# INLINABLE processIdPrepare #-} @@ -768,7 +817,15 @@ -- | Retry the current computation as possible, using the specified argument -- as a 'SimulationRetry' exception message in case of failure. retryProcess :: MonadDES m => String -> Process m a +{-# INLINABLE retryProcess #-} retryProcess = liftEvent . retryEvent + +-- | Like the GoTo statement it transfers the direction of computation, +-- but raises an exception when used within 'catchProcess' or 'finallyProcess'. +transferProcess :: MonadDES m => Process m () -> Process m a +{-# INLINABLE transferProcess #-} +transferProcess (Process m) = + Process $ \pid -> transferCont (m pid) -- | Show the debug message with the current simulation time. traceProcess :: MonadDES m => String -> Process m a -> Process m a 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 @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Internal.Simulation --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Internal.Specs --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Trans/Internal/Types.hs b/Simulation/Aivika/Trans/Internal/Types.hs --- a/Simulation/Aivika/Trans/Internal/Types.hs +++ b/Simulation/Aivika/Trans/Internal/Types.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Internal.Types --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Net --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Trans/Net/Random.hs b/Simulation/Aivika/Trans/Net/Random.hs --- a/Simulation/Aivika/Trans/Net/Random.hs +++ b/Simulation/Aivika/Trans/Net/Random.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Net.Random --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Trans/Observable.hs b/Simulation/Aivika/Trans/Observable.hs --- a/Simulation/Aivika/Trans/Observable.hs +++ b/Simulation/Aivika/Trans/Observable.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Observable --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Trans/Operation.hs b/Simulation/Aivika/Trans/Operation.hs --- a/Simulation/Aivika/Trans/Operation.hs +++ b/Simulation/Aivika/Trans/Operation.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Operation --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -22,6 +22,8 @@ operationPreemptionTime, operationUtilisationFactor, operationPreemptionFactor, + -- * Statistics Reset + resetOperation, -- * Summary operationSummary, -- * Derived Signals for Properties @@ -72,7 +74,7 @@ -- ^ Provide @b@ by specified @a@. operationProcessPreemptible :: Bool, -- ^ Whether the process is preemptible. - operationStartTime :: Double, + operationStartTimeRef :: Ref m Double, -- ^ The start time of creating the operation. operationLastTimeRef :: Ref m Double, -- ^ The last time of utilising the operation activity. @@ -116,6 +118,7 @@ {-# INLINABLE newPreemptibleOperation #-} newPreemptibleOperation preemptible provide = do t0 <- liftDynamics time + r' <- liftSimulation $ newRef t0 r0 <- liftSimulation $ newRef t0 r1 <- liftSimulation $ newRef 0 r2 <- liftSimulation $ newRef 0 @@ -127,7 +130,7 @@ s4 <- liftSimulation newSignalSource return Operation { operationInitProcess = provide, operationProcessPreemptible = preemptible, - operationStartTime = t0, + operationStartTimeRef = r', operationLastTimeRef = r0, operationTotalUtilisationTimeRef = r1, operationTotalPreemptionTimeRef = r2, @@ -300,7 +303,7 @@ {-# INLINABLE operationUtilisationFactor #-} operationUtilisationFactor op = Event $ \p -> - do let t0 = operationStartTime op + do t0 <- invokeEvent p $ readRef (operationStartTimeRef op) t1 <- invokeEvent p $ readRef (operationLastTimeRef op) x <- invokeEvent p $ readRef (operationTotalUtilisationTimeRef op) return (x / (t1 - t0)) @@ -330,7 +333,7 @@ {-# INLINABLE operationPreemptionFactor #-} operationPreemptionFactor op = Event $ \p -> - do let t0 = operationStartTime op + do t0 <- invokeEvent p $ readRef (operationStartTimeRef op) t1 <- invokeEvent p $ readRef (operationLastTimeRef op) x <- invokeEvent p $ readRef (operationTotalPreemptionTimeRef op) return (x / (t1 - t0)) @@ -382,7 +385,7 @@ {-# INLINABLE operationSummary #-} operationSummary op indent = Event $ \p -> - do let t0 = operationStartTime op + do t0 <- invokeEvent p $ readRef (operationStartTimeRef op) t1 <- invokeEvent p $ readRef (operationLastTimeRef op) tx1 <- invokeEvent p $ readRef (operationTotalUtilisationTimeRef op) tx2 <- invokeEvent p $ readRef (operationTotalPreemptionTimeRef op) @@ -411,3 +414,15 @@ showString tab . showString "preemption time:\n\n" . samplingStatsSummary xs2 (2 + indent) + +-- | Reset the statistics. +resetOperation :: MonadDES m => Operation m a b -> Event m () +{-# INLINABLE resetOperation #-} +resetOperation op = + do t0 <- liftDynamics time + writeRef (operationStartTimeRef op) t0 + writeRef (operationLastTimeRef op) t0 + writeRef (operationTotalUtilisationTimeRef op) 0 + writeRef (operationTotalPreemptionTimeRef op) 0 + writeRef (operationUtilisationTimeRef op) emptySamplingStats + writeRef (operationPreemptionTimeRef op) emptySamplingStats diff --git a/Simulation/Aivika/Trans/Operation/Random.hs b/Simulation/Aivika/Trans/Operation/Random.hs --- a/Simulation/Aivika/Trans/Operation/Random.hs +++ b/Simulation/Aivika/Trans/Operation/Random.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Operation.Random --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,6 +1,6 @@ -- | -- Module : Simulation.Aivika.Trans.Parameter --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Parameter.Random --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Process --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -48,9 +48,12 @@ holdProcess, interruptProcess, processInterrupted, + processInterruptionTime, passivateProcess, + passivateProcessBefore, processPassive, reactivateProcess, + reactivateProcessImmediately, cancelProcessWithId, cancelProcess, processCancelled, @@ -85,6 +88,8 @@ neverProcess, -- * Retrying Computation retryProcess, + -- * GoTo Statement + transferProcess, -- * Debugging traceProcess) where diff --git a/Simulation/Aivika/Trans/Process/Random.hs b/Simulation/Aivika/Trans/Process/Random.hs --- a/Simulation/Aivika/Trans/Process/Random.hs +++ b/Simulation/Aivika/Trans/Process/Random.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Process.Random --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Processor --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Trans/Processor/Random.hs b/Simulation/Aivika/Trans/Processor/Random.hs --- a/Simulation/Aivika/Trans/Processor/Random.hs +++ b/Simulation/Aivika/Trans/Processor/Random.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Processor.Random --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Processor.RoundRobbin --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Queue --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -72,6 +72,8 @@ queueContains, queueContainsBy, clearQueue, + -- * Statistics Reset + resetQueue, -- * Awaiting waitWhileFullQueue, -- * Summary @@ -1353,3 +1355,22 @@ showString tab . showString "the dequeue wait time (when was requested for dequeueing -> when was dequeued) = \n\n" . samplingStatsSummary dequeueWaitTime (2 + indent) + +-- | Reset the statistics. +resetQueue :: MonadDES m => Queue m si sm so a -> Event m () +{-# INLINABLE resetQueue #-} +resetQueue q = + Event $ \p -> + do let t = pointTime p + queueCount <- invokeEvent p $ readRef (queueCountRef q) + invokeEvent p $ writeRef (queueCountStatsRef q) $ + returnTimingStats t queueCount + invokeEvent p $ writeRef (enqueueCountRef q) 0 + invokeEvent p $ writeRef (enqueueLostCountRef q) 0 + invokeEvent p $ writeRef (enqueueStoreCountRef q) 0 + invokeEvent p $ writeRef (dequeueCountRef q) 0 + invokeEvent p $ writeRef (dequeueExtractCountRef q) 0 + invokeEvent p $ writeRef (queueWaitTimeRef q) mempty + invokeEvent p $ writeRef (queueTotalWaitTimeRef q) mempty + invokeEvent p $ writeRef (enqueueWaitTimeRef q) mempty + invokeEvent p $ writeRef (dequeueWaitTimeRef q) mempty diff --git a/Simulation/Aivika/Trans/Queue/Base.hs b/Simulation/Aivika/Trans/Queue/Base.hs --- a/Simulation/Aivika/Trans/Queue/Base.hs +++ b/Simulation/Aivika/Trans/Queue/Base.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Queue.Base --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Queue.Infinite --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -52,6 +52,8 @@ queueContains, queueContainsBy, clearQueue, + -- * Statistics Reset + resetQueue, -- * Summary queueSummary, -- * Derived Signals for Properties @@ -838,3 +840,18 @@ showString tab . showString "the dequeue wait time (when was requested for dequeueing -> when was dequeued) = \n\n" . samplingStatsSummary dequeueWaitTime (2 + indent) + +-- | Reset the statistics. +resetQueue :: MonadDES m => Queue m sm so a -> Event m () +{-# INLINABLE resetQueue #-} +resetQueue q = + Event $ \p -> + do let t = pointTime p + queueCount <- invokeEvent p $ readRef (queueCountRef q) + invokeEvent p $ writeRef (queueCountStatsRef q) $ + returnTimingStats t queueCount + invokeEvent p $ writeRef (enqueueStoreCountRef q) 0 + invokeEvent p $ writeRef (dequeueCountRef q) 0 + invokeEvent p $ writeRef (dequeueExtractCountRef q) 0 + invokeEvent p $ writeRef (queueWaitTimeRef q) mempty + invokeEvent p $ writeRef (dequeueWaitTimeRef q) mempty diff --git a/Simulation/Aivika/Trans/Queue/Infinite/Base.hs b/Simulation/Aivika/Trans/Queue/Infinite/Base.hs --- a/Simulation/Aivika/Trans/Queue/Infinite/Base.hs +++ b/Simulation/Aivika/Trans/Queue/Infinite/Base.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Queue.Infinite.Base --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.QueueStrategy --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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 @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Ref --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Trans/Ref/Base.hs b/Simulation/Aivika/Trans/Ref/Base.hs --- a/Simulation/Aivika/Trans/Ref/Base.hs +++ b/Simulation/Aivika/Trans/Ref/Base.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} - -- | -- Module : Simulation.Aivika.Trans.Ref.Base --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -12,53 +10,11 @@ -- 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. -- +-- By default, the module uses a strict version defined in "Simulation.Aivika.Trans.Ref.Base.Strict". +-- There is also another lazy version defined in "Simulation.Aivika.Trans.Ref.Base.Lazy". +-- 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 -import Simulation.Aivika.Trans.Observable - --- | A monad within which we can create mutable references. -class Monad m => MonadRef m where - - -- | 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 - - -- | 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) - -instance (Monad m, MonadRef m) => Observable (Ref m) (Event m) where + (module Simulation.Aivika.Trans.Ref.Base.Strict) where - {-# INLINE readObservable #-} - readObservable = readRef +import Simulation.Aivika.Trans.Ref.Base.Strict +import Simulation.Aivika.Trans.Ref.Base.Lazy diff --git a/Simulation/Aivika/Trans/Ref/Base/Lazy.hs b/Simulation/Aivika/Trans/Ref/Base/Lazy.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Ref/Base/Lazy.hs @@ -0,0 +1,64 @@ + +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} + +-- | +-- Module : Simulation.Aivika.Trans.Ref.Base.Lazy +-- Copyright : Copyright (c) 2009-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- This module defines a plain and more fast version of an updatable and lazy reference +-- that depends on the event queue but that doesn't supply with the signal notification. +-- +module Simulation.Aivika.Trans.Ref.Base.Lazy + (MonadRef(..), + MonadRef0(..)) where + +import Data.IORef + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Internal.Types +import Simulation.Aivika.Trans.Observable + +-- | A monad within which we can create mutable references. +class Monad m => MonadRef m where + + -- | 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 + + -- | 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) + +instance (Monad m, MonadRef m) => Observable (Ref m) (Event m) where + + {-# INLINE readObservable #-} + readObservable = readRef diff --git a/Simulation/Aivika/Trans/Ref/Base/Strict.hs b/Simulation/Aivika/Trans/Ref/Base/Strict.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Ref/Base/Strict.hs @@ -0,0 +1,64 @@ + +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} + +-- | +-- Module : Simulation.Aivika.Trans.Ref.Base.Strict +-- Copyright : Copyright (c) 2009-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- This module defines a plain and more fast version of an updatable and strict reference +-- that depends on the event queue but that doesn't supply with the signal notification. +-- +module Simulation.Aivika.Trans.Ref.Base.Strict + (MonadRef(..), + MonadRef0(..)) where + +import Data.IORef + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Internal.Types +import Simulation.Aivika.Trans.Observable + +-- | A monad within which we can create mutable references. +class Monad m => MonadRef m where + + -- | 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 + + -- | 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) + +instance (Monad m, MonadRef m) => Observable (Ref m) (Event m) where + + {-# INLINE readObservable #-} + readObservable = readRef 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,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Resource --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -55,6 +55,8 @@ -- * Altering Resource incResourceCount, decResourceCount, + -- * Statistics Reset + resetResource, -- * Signals resourceCountChanged, resourceCountChanged_, @@ -637,5 +639,25 @@ invokeEvent p $ modifyRef (resourceWaitTimeRef r) $ addSamplingStats delta + invokeEvent p $ + triggerSignal (resourceWaitTimeSource r) () + +-- | Reset the statistics. +resetResource :: MonadDES m => Resource m s -> Event m () +{-# INLINABLE resetResource #-} +resetResource r = + Event $ \p -> + do let t = pointTime p + count <- invokeEvent p $ readRef (resourceCountRef r) + invokeEvent p $ writeRef (resourceCountStatsRef r) $ + returnTimingStats t count + utilCount <- invokeEvent p $ readRef (resourceUtilisationCountRef r) + invokeEvent p $ writeRef (resourceUtilisationCountStatsRef r) $ + returnTimingStats t utilCount + queueCount <- invokeEvent p $ readRef (resourceQueueCountRef r) + invokeEvent p $ writeRef (resourceQueueCountStatsRef r) $ + returnTimingStats t queueCount + invokeEvent p $ writeRef (resourceTotalWaitTimeRef r) 0 + invokeEvent p $ writeRef (resourceWaitTimeRef r) emptySamplingStats invokeEvent p $ triggerSignal (resourceWaitTimeSource r) () diff --git a/Simulation/Aivika/Trans/Resource/Base.hs b/Simulation/Aivika/Trans/Resource/Base.hs --- a/Simulation/Aivika/Trans/Resource/Base.hs +++ b/Simulation/Aivika/Trans/Resource/Base.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Resource.Base --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Trans/Resource/Preemption.hs b/Simulation/Aivika/Trans/Resource/Preemption.hs --- a/Simulation/Aivika/Trans/Resource/Preemption.hs +++ b/Simulation/Aivika/Trans/Resource/Preemption.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Resource.Preemption --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -153,3 +153,6 @@ -> Int -- ^ a change of the resource count -> Event m () + + -- | Reset the statistics. + resetResource :: Resource m -> Event m () diff --git a/Simulation/Aivika/Trans/Resource/Preemption/Base.hs b/Simulation/Aivika/Trans/Resource/Preemption/Base.hs --- a/Simulation/Aivika/Trans/Resource/Preemption/Base.hs +++ b/Simulation/Aivika/Trans/Resource/Preemption/Base.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Resource.Preemption.Base --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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 @@ -1,9 +1,9 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances, ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances, ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies, OverlappingInstances #-} -- | -- Module : Simulation.Aivika.Trans.Results --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -1888,71 +1888,176 @@ intSubscript :: Int -> ResultName intSubscript i = "[" ++ show i ++ "]" -instance ResultComputing t m => ResultProvider (t m Double) m where +instance {-# OVERLAPPABLE #-} (MonadDES m, ResultItemable (ResultValue a)) => ResultProvider (Parameter m a) m where resultSource' name i m = ResultItemSource $ ResultItem $ computeResultValue name i m -instance ResultComputing t m => ResultProvider (t m [Double]) m where +instance {-# OVERLAPPABLE #-} (MonadDES m, ResultItemable (ResultValue a)) => ResultProvider (Simulation m a) m where resultSource' name i m = ResultItemSource $ ResultItem $ computeResultValue name i m -instance ResultComputing t m => ResultProvider (t m (SamplingStats Double)) m where +instance {-# OVERLAPPABLE #-} (MonadDES m, ResultItemable (ResultValue a)) => ResultProvider (Dynamics m a) m where resultSource' name i m = ResultItemSource $ ResultItem $ computeResultValue name i m -instance ResultComputing t m => ResultProvider (t m (TimingStats Double)) m where +instance {-# OVERLAPPABLE #-} (MonadDES m, ResultItemable (ResultValue a)) => ResultProvider (Event m a) m where resultSource' name i m = ResultItemSource $ ResultItem $ computeResultValue name i m -instance ResultComputing t m => ResultProvider (t m (SamplingCounter Double)) m where +instance {-# OVERLAPPABLE #-} (MonadDES m, ResultItemable (ResultValue a)) => ResultProvider (Ref m a) m where resultSource' name i m = - samplingCounterResultSource $ computeResultValue name i m + ResultItemSource $ ResultItem $ computeResultValue name i m -instance ResultComputing t m => ResultProvider (t m (TimingCounter Double)) m where +instance {-# OVERLAPPABLE #-} (MonadDES m, ResultItemable (ResultValue a)) => ResultProvider (B.Ref m a) m where resultSource' name i m = - timingCounterResultSource $ computeResultValue name i m + ResultItemSource $ ResultItem $ computeResultValue name i m -instance ResultComputing t m => ResultProvider (t m Int) m where +instance {-# OVERLAPPABLE #-} (MonadDES m, MonadVar m, ResultItemable (ResultValue a)) => ResultProvider (Var m a) m where resultSource' name i m = ResultItemSource $ ResultItem $ computeResultValue name i m -instance ResultComputing t m => ResultProvider (t m [Int]) m where +instance {-# OVERLAPPABLE #-} (MonadDES m, ResultItemable (ResultValue a)) => ResultProvider (Signalable m a) m where resultSource' name i m = ResultItemSource $ ResultItem $ computeResultValue name i m -instance ResultComputing t m => ResultProvider (t m (SamplingStats Int)) m where +instance {-# OVERLAPPING #-} (MonadDES m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (SamplingStats a))) + => ResultProvider (Parameter m (SamplingCounter a)) m where resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m + samplingCounterResultSource $ computeResultValue name i m -instance ResultComputing t m => ResultProvider (t m (TimingStats Int)) m where +instance {-# OVERLAPPING #-} (MonadDES m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (SamplingStats a))) + => ResultProvider (Simulation m (SamplingCounter a)) m where resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m + samplingCounterResultSource $ computeResultValue name i m -instance ResultComputing t m => ResultProvider (t m (SamplingCounter Int)) m where +instance {-# OVERLAPPING #-} (MonadDES m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (SamplingStats a))) + => ResultProvider (Dynamics m (SamplingCounter a)) m where resultSource' name i m = samplingCounterResultSource $ computeResultValue name i m -instance ResultComputing t m => ResultProvider (t m (TimingCounter Int)) m where +instance {-# OVERLAPPING #-} (MonadDES m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (SamplingStats a))) + => ResultProvider (Event m (SamplingCounter a)) m where resultSource' name i m = + samplingCounterResultSource $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (SamplingStats a))) + => ResultProvider (Ref m (SamplingCounter a)) m where + + resultSource' name i m = + samplingCounterResultSource $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (SamplingStats a))) + => ResultProvider (B.Ref m (SamplingCounter a)) m where + + resultSource' name i m = + samplingCounterResultSource $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, + MonadVar m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (SamplingStats a))) + => ResultProvider (Var m (SamplingCounter a)) m where + + resultSource' name i m = + samplingCounterResultSource $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (SamplingStats a))) + => ResultProvider (Signalable m (SamplingCounter a)) m where + + resultSource' name i m = + samplingCounterResultSource $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (TimingStats a))) + => ResultProvider (Parameter m (TimingCounter a)) m where + + resultSource' name i m = timingCounterResultSource $ computeResultValue name i m -instance ResultComputing t m => ResultProvider (t m String) m where +instance {-# OVERLAPPING #-} (MonadDES m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (TimingStats a))) + => ResultProvider (Simulation m (TimingCounter a)) m where resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m + timingCounterResultSource $ computeResultValue name i m +instance {-# OVERLAPPING #-} (MonadDES m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (TimingStats a))) + => ResultProvider (Dynamics m (TimingCounter a)) m where + + resultSource' name i m = + timingCounterResultSource $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (TimingStats a))) + => ResultProvider (Event m (TimingCounter a)) m where + + resultSource' name i m = + timingCounterResultSource $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (TimingStats a))) + => ResultProvider (Ref m (TimingCounter a)) m where + + resultSource' name i m = + timingCounterResultSource $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (TimingStats a))) + => ResultProvider (B.Ref m (TimingCounter a)) m where + + resultSource' name i m = + timingCounterResultSource $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, + MonadVar m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (TimingStats a))) + => ResultProvider (Var m (TimingCounter a)) m where + + resultSource' name i m = + timingCounterResultSource $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (TimingStats a))) + => ResultProvider (Signalable m (TimingCounter a)) m where + + resultSource' name i m = + timingCounterResultSource $ computeResultValue name i m + instance ResultProvider p m => ResultProvider [p] m where resultSource' name i m = @@ -2037,22 +2142,82 @@ in resultSource' name' (VectorItemId y) x items' = V.map resultSourceSummary items -instance (Ix i, Show i, ResultComputing t m) => ResultProvider (t m (A.Array i Double)) m where +instance {-# OVERLAPPING #-} (Ix i, Show i, MonadDES m, ResultItemable (ResultValue [e])) => ResultProvider (Parameter m (A.Array i e)) m where resultSource' name i m = ResultItemSource $ ResultItem $ mapResultValue A.elems $ computeResultValue name i m -instance (Ix i, Show i, ResultComputing t m) => ResultProvider (t m (A.Array i Int)) m where +instance {-# OVERLAPPING #-} (Ix i, Show i, MonadDES m, ResultItemable (ResultValue [e])) => ResultProvider (Simulation m (A.Array i e)) m where resultSource' name i m = ResultItemSource $ ResultItem $ mapResultValue A.elems $ computeResultValue name i m -instance ResultComputing t m => ResultProvider (t m (V.Vector Double)) m where +instance {-# OVERLAPPING #-} (Ix i, Show i, MonadDES m, ResultItemable (ResultValue [e])) => ResultProvider (Dynamics m (A.Array i e)) m where resultSource' name i m = + ResultItemSource $ ResultItem $ mapResultValue A.elems $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (Ix i, Show i, MonadDES m, ResultItemable (ResultValue [e])) => ResultProvider (Event m (A.Array i e)) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ mapResultValue A.elems $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (Ix i, Show i, MonadDES m, ResultItemable (ResultValue [e])) => ResultProvider (Ref m (A.Array i e)) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ mapResultValue A.elems $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (Ix i, Show i, MonadDES m, ResultItemable (ResultValue [e])) => ResultProvider (B.Ref m (A.Array i e)) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ mapResultValue A.elems $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (Ix i, Show i, MonadDES m, MonadVar m, ResultItemable (ResultValue [e])) => ResultProvider (Var m (A.Array i e)) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ mapResultValue A.elems $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (Ix i, Show i, MonadDES m, ResultItemable (ResultValue [e])) => ResultProvider (Signalable m (A.Array i e)) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ mapResultValue A.elems $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, ResultItemable (ResultValue [e])) => ResultProvider (Parameter m (V.Vector e)) m where + + resultSource' name i m = ResultItemSource $ ResultItem $ mapResultValue V.toList $ computeResultValue name i m -instance ResultComputing t m => ResultProvider (t m (V.Vector Int)) m where +instance {-# OVERLAPPING #-} (MonadDES m, ResultItemable (ResultValue [e])) => ResultProvider (Simulation m (V.Vector e)) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ mapResultValue V.toList $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, ResultItemable (ResultValue [e])) => ResultProvider (Dynamics m (V.Vector e)) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ mapResultValue V.toList $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, ResultItemable (ResultValue [e])) => ResultProvider (Event m (V.Vector e)) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ mapResultValue V.toList $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, ResultItemable (ResultValue [e])) => ResultProvider (Ref m (V.Vector e)) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ mapResultValue V.toList $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, ResultItemable (ResultValue [e])) => ResultProvider (B.Ref m (V.Vector e)) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ mapResultValue V.toList $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, MonadVar m, ResultItemable (ResultValue [e])) => ResultProvider (Var m (V.Vector e)) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ mapResultValue V.toList $ computeResultValue name i m + +instance {-# OVERLAPPING #-} (MonadDES m, ResultItemable (ResultValue [e])) => ResultProvider (Signalable m (V.Vector e)) m where resultSource' name i m = ResultItemSource $ ResultItem $ mapResultValue V.toList $ computeResultValue name i 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 @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Results.IO --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Results.Locale --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Trans/Results/Transform.hs b/Simulation/Aivika/Trans/Results/Transform.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Results/Transform.hs @@ -0,0 +1,656 @@ + +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +-- | +-- Module : Simulation.Aivika.Trans.Results.Transform +-- Copyright : Copyright (c) 2009-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines useful result transformations that can +-- be used in simulation experiments. +-- +module Simulation.Aivika.Trans.Results.Transform + (-- * Basic Class Type + ResultTransformer(..), + -- * Sampling Statistics + SamplingStats(..), + samplingStatsCount, + samplingStatsMin, + samplingStatsMax, + samplingStatsMean, + samplingStatsMean2, + samplingStatsVariance, + samplingStatsDeviation, + -- * Time-dependent Statistics + TimingStats(..), + timingStatsCount, + timingStatsMin, + timingStatsMax, + timingStatsMean, + timingStatsVariance, + timingStatsDeviation, + timingStatsMinTime, + timingStatsMaxTime, + timingStatsStartTime, + timingStatsLastTime, + timingStatsSum, + timingStatsSum2, + -- * Sampling-based Counter + SamplingCounter(..), + samplingCounterValue, + samplingCounterStats, + -- * Time-dependent Counter + TimingCounter(..), + timingCounterValue, + timingCounterStats, + -- * Queue + Queue(..), + enqueueStrategy, + enqueueStoringStrategy, + dequeueStrategy, + queueNull, + queueFull, + queueMaxCount, + queueCount, + queueCountStats, + enqueueCount, + enqueueLostCount, + enqueueStoreCount, + dequeueCount, + dequeueExtractCount, + queueLoadFactor, + enqueueRate, + enqueueStoreRate, + dequeueRate, + dequeueExtractRate, + queueWaitTime, + queueTotalWaitTime, + enqueueWaitTime, + dequeueWaitTime, + queueRate, + -- * Arrival Timer + ArrivalTimer(..), + arrivalProcessingTime, + -- * Server + Server(..), + serverInitState, + serverState, + serverTotalInputWaitTime, + serverTotalProcessingTime, + serverTotalOutputWaitTime, + serverTotalPreemptionTime, + serverInputWaitTime, + serverProcessingTime, + serverOutputWaitTime, + serverPreemptionTime, + serverInputWaitFactor, + serverProcessingFactor, + serverOutputWaitFactor, + serverPreemptionFactor, + -- * Activity + Activity(..), + activityInitState, + activityState, + activityTotalUtilisationTime, + activityTotalIdleTime, + activityTotalPreemptionTime, + activityUtilisationTime, + activityIdleTime, + activityPreemptionTime, + activityUtilisationFactor, + activityIdleFactor, + activityPreemptionFactor, + -- * Resource + Resource(..), + resourceCount, + resourceCountStats, + resourceUtilisationCount, + resourceUtilisationCountStats, + resourceQueueCount, + resourceQueueCountStats, + resourceTotalWaitTime, + resourceWaitTime, + -- * Operation + Operation(..), + operationTotalUtilisationTime, + operationTotalPreemptionTime, + operationUtilisationTime, + operationPreemptionTime, + operationUtilisationFactor, + operationPreemptionFactor) where + +import Control.Arrow + +import Simulation.Aivika.Trans.DES +import Simulation.Aivika.Trans.Results +import Simulation.Aivika.Trans.Results.Locale + +-- | Something that can transform the results. +class ResultTransformer t m where + + -- | Return the result transform. + tr :: t m -> ResultTransform m + +-- | Represents a statistics based upon observations. +newtype SamplingStats m = SamplingStats (ResultTransform m) + +instance ResultTransformer SamplingStats m where + tr (SamplingStats a) = a + +-- | The total number of samples. +samplingStatsCount :: MonadDES m => SamplingStats m -> ResultTransform m +samplingStatsCount (SamplingStats a) = + a >>> expandResults >>> resultById SamplingStatsCountId + +-- | The minimum value among the samples. +samplingStatsMin :: MonadDES m => SamplingStats m -> ResultTransform m +samplingStatsMin (SamplingStats a) = + a >>> expandResults >>> resultById SamplingStatsMinId + +-- | The maximum value among the samples. +samplingStatsMax :: MonadDES m => SamplingStats m -> ResultTransform m +samplingStatsMax (SamplingStats a) = + a >>> expandResults >>> resultById SamplingStatsMaxId + +-- | The average value. +samplingStatsMean :: MonadDES m => SamplingStats m -> ResultTransform m +samplingStatsMean (SamplingStats a) = + a >>> expandResults >>> resultById SamplingStatsMeanId + +-- | The average square value. +samplingStatsMean2 :: MonadDES m => SamplingStats m -> ResultTransform m +samplingStatsMean2 (SamplingStats a) = + a >>> expandResults >>> resultById SamplingStatsMean2Id + +-- | Return tha variance. +samplingStatsVariance :: MonadDES m => SamplingStats m -> ResultTransform m +samplingStatsVariance (SamplingStats a) = + a >>> expandResults >>> resultById SamplingStatsVarianceId + +-- | Return the deviation. +samplingStatsDeviation :: MonadDES m => SamplingStats m -> ResultTransform m +samplingStatsDeviation (SamplingStats a) = + a >>> expandResults >>> resultById SamplingStatsDeviationId + +-- | A counter for which the statistics is collected too. +newtype SamplingCounter m = SamplingCounter (ResultTransform m) + +instance ResultTransformer SamplingCounter m where + tr (SamplingCounter a) = a + +-- | The counter value. +samplingCounterValue :: SamplingCounter m -> ResultTransform m +samplingCounterValue (SamplingCounter a) = + a >>> resultById SamplingCounterValueId + +-- | The counter statistics. +samplingCounterStats :: SamplingCounter m -> SamplingStats m +samplingCounterStats (SamplingCounter a) = + SamplingStats (a >>> resultById SamplingCounterStatsId) + +-- | The time-dependent statistics. +newtype TimingStats m = TimingStats (ResultTransform m) + +instance ResultTransformer TimingStats m where + tr (TimingStats a) = a + +-- | Return the number of samples. +timingStatsCount :: MonadDES m => TimingStats m -> ResultTransform m +timingStatsCount (TimingStats a) = + a >>> expandResults >>> resultById TimingStatsCountId + +-- | Return the minimum value. +timingStatsMin :: MonadDES m => TimingStats m -> ResultTransform m +timingStatsMin (TimingStats a) = + a >>> expandResults >>> resultById TimingStatsMinId + +-- | Return the maximum value. +timingStatsMax :: MonadDES m => TimingStats m -> ResultTransform m +timingStatsMax (TimingStats a) = + a >>> expandResults >>> resultById TimingStatsMaxId + +-- | Return the average value. +timingStatsMean :: MonadDES m => TimingStats m -> ResultTransform m +timingStatsMean (TimingStats a) = + a >>> expandResults >>> resultById TimingStatsMeanId + +-- | Return the variance. +timingStatsVariance :: MonadDES m => TimingStats m -> ResultTransform m +timingStatsVariance (TimingStats a) = + a >>> expandResults >>> resultById TimingStatsVarianceId + +-- | Return the deviation. +timingStatsDeviation :: MonadDES m => TimingStats m -> ResultTransform m +timingStatsDeviation (TimingStats a) = + a >>> expandResults >>> resultById TimingStatsDeviationId + +-- | Return the time at which the minimum is attained. +timingStatsMinTime :: MonadDES m => TimingStats m -> ResultTransform m +timingStatsMinTime (TimingStats a) = + a >>> expandResults >>> resultById TimingStatsMinTimeId + +-- | Return the time at which the maximum is attained. +timingStatsMaxTime :: MonadDES m => TimingStats m -> ResultTransform m +timingStatsMaxTime (TimingStats a) = + a >>> expandResults >>> resultById TimingStatsMaxTimeId + +-- | Return the start time of sampling. +timingStatsStartTime :: MonadDES m => TimingStats m -> ResultTransform m +timingStatsStartTime (TimingStats a) = + a >>> expandResults >>> resultById TimingStatsStartTimeId + +-- | Return the last time of sampling. +timingStatsLastTime :: MonadDES m => TimingStats m -> ResultTransform m +timingStatsLastTime (TimingStats a) = + a >>> expandResults >>> resultById TimingStatsLastTimeId + +-- | Return the sum of values. +timingStatsSum :: MonadDES m => TimingStats m -> ResultTransform m +timingStatsSum (TimingStats a) = + a >>> expandResults >>> resultById TimingStatsSumId + +-- | Return the sum of square values. +timingStatsSum2 :: MonadDES m => TimingStats m -> ResultTransform m +timingStatsSum2 (TimingStats a) = + a >>> expandResults >>> resultById TimingStatsSum2Id + +-- | A time-dependent counter that collects the statistics too. +newtype TimingCounter m = TimingCounter (ResultTransform m) + +instance ResultTransformer TimingCounter m where + tr (TimingCounter a) = a + +-- | The counter value. +timingCounterValue :: TimingCounter m -> ResultTransform m +timingCounterValue (TimingCounter a) = + a >>> resultById TimingCounterValueId + +-- | The counter statistics. +timingCounterStats :: TimingCounter m -> TimingStats m +timingCounterStats (TimingCounter a) = + TimingStats (a >>> resultById TimingCounterStatsId) + +-- | Represents either finite or infinite queue. +newtype Queue m = Queue (ResultTransform m) + +instance ResultTransformer Queue m where + tr (Queue a) = a + +-- | The strategy applied to the enqueueing (input) processes when the finite queue is full. +enqueueStrategy :: Queue m -> ResultTransform m +enqueueStrategy (Queue a) = + a >>> resultById EnqueueStrategyId + +-- | The strategy applied when storing (in memory) items in the queue. +enqueueStoringStrategy :: Queue m -> ResultTransform m +enqueueStoringStrategy (Queue a) = + a >>> resultById EnqueueStoringStrategyId + +-- | The strategy applied to the dequeueing (output) processes when the queue is empty. +dequeueStrategy :: Queue m -> ResultTransform m +dequeueStrategy (Queue a) = + a >>> resultById DequeueStrategyId + +-- | Test whether the queue is empty. +queueNull :: Queue m -> ResultTransform m +queueNull (Queue a) = + a >>> resultById QueueNullId + +-- | Test whether the finite queue is full. +queueFull :: Queue m -> ResultTransform m +queueFull (Queue a) = + a >>> resultById QueueFullId + +-- | The finite queue capacity. +queueMaxCount :: Queue m -> ResultTransform m +queueMaxCount (Queue a) = + a >>> resultById QueueMaxCountId + +-- | Return the current queue size. +queueCount :: Queue m -> ResultTransform m +queueCount (Queue a) = + a >>> resultById QueueCountId + +-- | Return the queue size statistics. +queueCountStats :: Queue m -> TimingStats m +queueCountStats (Queue a) = + TimingStats (a >>> resultById QueueCountStatsId) + +-- | Return the total number of input items that were enqueued in the finite queue. +enqueueCount :: Queue m -> ResultTransform m +enqueueCount (Queue a) = + a >>> resultById EnqueueCountId + +-- | Return the number of lost items for the finite queue. +enqueueLostCount :: Queue m -> ResultTransform m +enqueueLostCount (Queue a) = + a >>> resultById EnqueueLostCountId + +-- | Return the total number of input items that were stored. +enqueueStoreCount :: Queue m -> ResultTransform m +enqueueStoreCount (Queue a) = + a >>> resultById EnqueueStoreCountId + +-- | Return the total number of requests for dequeueing the items, not taking +-- into account the failed attempts to dequeue immediately without suspension. +dequeueCount :: Queue m -> ResultTransform m +dequeueCount (Queue a) = + a >>> resultById DequeueCountId + +-- | Return the total number of output items that were actually dequeued. +dequeueExtractCount :: Queue m -> ResultTransform m +dequeueExtractCount (Queue a) = + a >>> resultById DequeueExtractCountId + +-- | Return the load factor: the finite queue size divided by its capacity. +queueLoadFactor :: Queue m -> ResultTransform m +queueLoadFactor (Queue a) = + a >>> resultById QueueLoadFactorId + +-- | Return the rate of the input items that were enqueued in the finite queue: +-- how many items per time. +enqueueRate :: Queue m -> ResultTransform m +enqueueRate (Queue a) = + a >>> resultById EnqueueRateId + +-- | Return the rate of the items that were stored: how many items per time. +enqueueStoreRate :: Queue m -> ResultTransform m +enqueueStoreRate (Queue a) = + a >>> resultById EnqueueStoreRateId + +-- | 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 :: Queue m -> ResultTransform m +dequeueRate (Queue a) = + a >>> resultById DequeueRateId + +-- | Return the rate of the output items that were dequeued: how many items per time. +dequeueExtractRate :: Queue m -> ResultTransform m +dequeueExtractRate (Queue a) = + a >>> resultById DequeueExtractRateId + +-- | Return the wait time from the time at which the item was stored in +-- the queue to the time at which it was dequeued. +queueWaitTime :: Queue m -> SamplingStats m +queueWaitTime (Queue a) = + SamplingStats (a >>> resultById QueueWaitTimeId) + +-- | Return the total wait time for the finite queue from the time at which +-- the enqueueing operation was initiated to the time at which the item was dequeued. +queueTotalWaitTime :: Queue m -> SamplingStats m +queueTotalWaitTime (Queue a) = + SamplingStats (a >>> resultById QueueTotalWaitTimeId) + +-- | Return the wait time from the time at which the item was stored in +-- the queue to the time at which it was dequeued. +enqueueWaitTime :: Queue m -> SamplingStats m +enqueueWaitTime (Queue a) = + SamplingStats (a >>> resultById EnqueueWaitTimeId) + +-- | Return the dequeue wait time from the time at which the item was requested +-- for dequeueing to the time at which it was actually dequeued. +dequeueWaitTime :: Queue m -> SamplingStats m +dequeueWaitTime (Queue a) = + SamplingStats (a >>> resultById DequeueWaitTimeId) + +-- | Return a long-term average queue rate calculated as the average queue size +-- divided by the average wait time. +queueRate :: Queue m -> ResultTransform m +queueRate (Queue a) = + a >>> resultById QueueRateId + +-- | Accumulates the statistics about that how long the arrived events are processed. +newtype ArrivalTimer m = ArrivalTimer (ResultTransform m) + +instance ResultTransformer ArrivalTimer m where + tr (ArrivalTimer a) = a + +-- | Return the statistics about that how long the arrived events were processed. +arrivalProcessingTime :: ArrivalTimer m -> SamplingStats m +arrivalProcessingTime (ArrivalTimer a) = + SamplingStats (a >>> resultById ArrivalProcessingTimeId) + +-- | It models the server that prodives a service. +newtype Server m = Server (ResultTransform m) + +instance ResultTransformer Server m where + tr (Server a) = a + +-- | The initial state of the server. +serverInitState :: Server m -> ResultTransform m +serverInitState (Server a) = + a >>> resultById ServerInitStateId + +-- | Return the current state of the server. +serverState :: Server m -> ResultTransform m +serverState (Server a) = + a >>> resultById ServerStateId + +-- | Return the counted total time when the server was locked while +-- awaiting the input. +serverTotalInputWaitTime :: Server m -> ResultTransform m +serverTotalInputWaitTime (Server a) = + a >>> resultById ServerTotalInputWaitTimeId + +-- | Return the counted total time spent by the server while +-- processing the tasks. +serverTotalProcessingTime :: Server m -> ResultTransform m +serverTotalProcessingTime (Server a) = + a >>> resultById ServerTotalProcessingTimeId + +-- | Return the counted total time when the server was locked while +-- trying to deliver the output. +serverTotalOutputWaitTime :: Server m -> ResultTransform m +serverTotalOutputWaitTime (Server a) = + a >>> resultById ServerTotalOutputWaitTimeId + +-- | Return the counted total time spent by the server while it was +-- preempted waiting for the further proceeding. +serverTotalPreemptionTime :: Server m -> ResultTransform m +serverTotalPreemptionTime (Server a) = + a >>> resultById ServerTotalPreemptionTimeId + +-- | Return the statistics of the time when the server was locked +-- while awaiting the input. +serverInputWaitTime :: Server m -> SamplingStats m +serverInputWaitTime (Server a) = + SamplingStats (a >>> resultById ServerInputWaitTimeId) + +-- | Return the statistics of the time spent by the server while +-- processing the tasks. +serverProcessingTime :: Server m -> SamplingStats m +serverProcessingTime (Server a) = + SamplingStats (a >>> resultById ServerProcessingTimeId) + +-- | Return the statistics of the time when the server was locked +-- while trying to deliver the output. +serverOutputWaitTime :: Server m -> SamplingStats m +serverOutputWaitTime (Server a) = + SamplingStats (a >>> resultById ServerOutputWaitTimeId) + +-- | Return the statistics of the time spent by the server while +-- it was preempted waiting for the further proceeding. +serverPreemptionTime :: Server m -> SamplingStats m +serverPreemptionTime (Server a) = + SamplingStats (a >>> resultById ServerPreemptionTimeId) + +-- | It returns the factor changing from 0 to 1, which estimates +-- how often the server was awaiting for the next input task. +serverInputWaitFactor :: Server m -> ResultTransform m +serverInputWaitFactor (Server a) = + a >>> resultById ServerInputWaitFactorId + +-- | It returns the factor changing from 0 to 1, which estimates +-- how often the server was busy with direct processing its tasks. +serverProcessingFactor :: Server m -> ResultTransform m +serverProcessingFactor (Server a) = + a >>> resultById ServerProcessingFactorId + +-- | 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. +serverOutputWaitFactor :: Server m -> ResultTransform m +serverOutputWaitFactor (Server a) = + a >>> resultById ServerOutputWaitFactorId + +-- | It returns the factor changing from 0 to 1, which estimates +-- how often the server was preempted waiting for the further proceeding. +serverPreemptionFactor :: Server m -> ResultTransform m +serverPreemptionFactor (Server a) = + a >>> resultById ServerPreemptionFactorId + +-- | It models an activity that can be utilised. +newtype Activity m = Activity (ResultTransform m) + +instance ResultTransformer Activity m where + tr (Activity a) = a + +-- | The initial state of the activity. +activityInitState :: Activity m -> ResultTransform m +activityInitState (Activity a) = + a >>> resultById ActivityInitStateId + +-- | Return the current state of the activity. +activityState :: Activity m -> ResultTransform m +activityState (Activity a) = + a >>> resultById ActivityStateId + +-- | Return the counted total time when the activity was utilised. +activityTotalUtilisationTime :: Activity m -> ResultTransform m +activityTotalUtilisationTime (Activity a) = + a >>> resultById ActivityTotalUtilisationTimeId + +-- | Return the counted total time when the activity was idle. +activityTotalIdleTime :: Activity m -> ResultTransform m +activityTotalIdleTime (Activity a) = + a >>> resultById ActivityTotalIdleTimeId + +-- | Return the counted total time when the activity was preemted +-- waiting for the further proceeding. +activityTotalPreemptionTime :: Activity m -> ResultTransform m +activityTotalPreemptionTime (Activity a) = + a >>> resultById ActivityTotalPreemptionTimeId + +-- | Return the statistics for the time when the activity was utilised. +activityUtilisationTime :: Activity m -> SamplingStats m +activityUtilisationTime (Activity a) = + SamplingStats (a >>> resultById ActivityUtilisationTimeId) + +-- | Return the statistics for the time when the activity was idle. +activityIdleTime :: Activity m -> SamplingStats m +activityIdleTime (Activity a) = + SamplingStats (a >>> resultById ActivityIdleTimeId) + +-- | Return the statistics for the time when the activity was preempted +-- waiting for the further proceeding. +activityPreemptionTime :: Activity m -> SamplingStats m +activityPreemptionTime (Activity a) = + SamplingStats (a >>> resultById ActivityPreemptionTimeId) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the activity was utilised. +activityUtilisationFactor :: Activity m -> ResultTransform m +activityUtilisationFactor (Activity a) = + a >>> resultById ActivityUtilisationFactorId + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the activity was idle. +activityIdleFactor :: Activity m -> ResultTransform m +activityIdleFactor (Activity a) = + a >>> resultById ActivityIdleFactorId + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the activity was preempted waiting for the further proceeding. +activityPreemptionFactor :: Activity m -> ResultTransform m +activityPreemptionFactor (Activity a) = + a >>> resultById ActivityPreemptionFactorId + +-- | The resource which can be acquired and then released. +newtype Resource m = Resource (ResultTransform m) + +instance ResultTransformer Resource m where + tr (Resource a) = a + +-- | Return the current available count of the resource. +resourceCount :: Resource m -> ResultTransform m +resourceCount (Resource a) = + a >>> resultById ResourceCountId + +-- | Return the statistics for the available count of the resource. +resourceCountStats :: Resource m -> TimingStats m +resourceCountStats (Resource a) = + TimingStats (a >>> resultById ResourceCountStatsId) + +-- | Return the current utilisation count of the resource. +resourceUtilisationCount :: Resource m -> ResultTransform m +resourceUtilisationCount (Resource a) = + a >>> resultById ResourceUtilisationCountId + +-- | Return the statistics for the utilisation count of the resource. +resourceUtilisationCountStats :: Resource m -> TimingStats m +resourceUtilisationCountStats (Resource a) = + TimingStats (a >>> resultById ResourceUtilisationCountStatsId) + +-- | Return the current queue length of the resource. +resourceQueueCount :: Resource m -> ResultTransform m +resourceQueueCount (Resource a) = + a >>> resultById ResourceQueueCountId + +-- | Return the statistics for the queue length of the resource. +resourceQueueCountStats :: Resource m -> TimingStats m +resourceQueueCountStats (Resource a) = + TimingStats (a >>> resultById ResourceQueueCountStatsId) + +-- | Return the total wait time of the resource. +resourceTotalWaitTime :: Resource m -> ResultTransform m +resourceTotalWaitTime (Resource a) = + a >>> resultById ResourceTotalWaitTimeId + +-- | Return the statistics for the wait time of the resource. +resourceWaitTime :: Resource m -> SamplingStats m +resourceWaitTime (Resource a) = + SamplingStats (a >>> resultById ResourceWaitTimeId) + +-- | It models an opreation which actvity can be utilised. +newtype Operation m = Operation (ResultTransform m) + +instance ResultTransformer Operation m where + tr (Operation a) = a + +-- | Return the counted total time when the operation activity was utilised. +operationTotalUtilisationTime :: Operation m -> ResultTransform m +operationTotalUtilisationTime (Operation a) = + a >>> resultById OperationTotalUtilisationTimeId + +-- | Return the counted total time when the operation activity was preemted +-- waiting for the further proceeding. +operationTotalPreemptionTime :: Operation m -> ResultTransform m +operationTotalPreemptionTime (Operation a) = + a >>> resultById OperationTotalPreemptionTimeId + +-- | Return the statistics for the time when the operation activity was utilised. +operationUtilisationTime :: Operation m -> SamplingStats m +operationUtilisationTime (Operation a) = + SamplingStats (a >>> resultById OperationUtilisationTimeId) + +-- | Return the statistics for the time when the operation activity was preempted +-- waiting for the further proceeding. +operationPreemptionTime :: Operation m -> SamplingStats m +operationPreemptionTime (Operation a) = + SamplingStats (a >>> resultById OperationPreemptionTimeId) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the operation activity was utilised. +operationUtilisationFactor :: Operation m -> ResultTransform m +operationUtilisationFactor (Operation a) = + a >>> resultById OperationUtilisationFactorId + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the operation activity was preempted waiting for the further proceeding. +operationPreemptionFactor :: Operation m -> ResultTransform m +operationPreemptionFactor (Operation a) = + a >>> resultById OperationPreemptionFactorId diff --git a/Simulation/Aivika/Trans/SD.hs b/Simulation/Aivika/Trans/SD.hs --- a/Simulation/Aivika/Trans/SD.hs +++ b/Simulation/Aivika/Trans/SD.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.SD --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Server --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -32,6 +32,8 @@ serverProcessingFactor, serverOutputWaitFactor, serverPreemptionFactor, + -- * Statistics Reset + resetServer, -- * Summary serverSummary, -- * Derived Signals for Properties @@ -761,3 +763,16 @@ showString tab . showString "preemption time (waiting for the proceeding after preemption):\n\n" . samplingStatsSummary xs4 (2 + indent) + +-- | Reset the statistics. +resetServer :: MonadDES m => Server m s a b -> Event m () +{-# INLINABLE resetServer #-} +resetServer server = + do writeRef (serverTotalInputWaitTimeRef server) 0 + writeRef (serverTotalProcessingTimeRef server) 0 + writeRef (serverTotalOutputWaitTimeRef server) 0 + writeRef (serverTotalPreemptionTimeRef server) 0 + writeRef (serverInputWaitTimeRef server) mempty + writeRef (serverProcessingTimeRef server) mempty + writeRef (serverOutputWaitTimeRef server) mempty + writeRef (serverPreemptionTimeRef server) mempty diff --git a/Simulation/Aivika/Trans/Server/Random.hs b/Simulation/Aivika/Trans/Server/Random.hs --- a/Simulation/Aivika/Trans/Server/Random.hs +++ b/Simulation/Aivika/Trans/Server/Random.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Server.Random --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Signal --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -17,6 +17,7 @@ (-- * Handling and Triggering Signal Signal(..), handleSignal_, + handleSignalComposite, SignalSource, newSignalSource, newSignalSource0, @@ -40,6 +41,12 @@ -- * Delaying Signal delaySignal, delaySignalM, + -- * Signal History + SignalHistory, + signalHistorySignal, + newSignalHistory, + newSignalHistoryStartingWith, + readSignalHistory, -- * Creating Signal in Time Points newSignalInTimes, newSignalInIntegTimes, @@ -56,7 +63,6 @@ import Data.Monoid import Data.List import Data.Array -import Data.Array.MArray.Safe import Control.Monad import Control.Monad.Trans @@ -66,7 +72,9 @@ 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.Composite import Simulation.Aivika.Arrival (Arrival(..)) -- | The signal source that can publish its signal. @@ -109,6 +117,13 @@ handleSignal_ signal h = do x <- handleSignal signal h return () + +-- | Like 'handleSignal' but within the 'Composite' computation. +handleSignalComposite :: MonadDES m => Signal m a -> (a -> Event m ()) -> Composite m () +{-# INLINABLE handleSignalComposite #-} +handleSignalComposite signal h = + do x <- liftEvent $ handleSignal signal h + disposableComposite x -- | Create a new signal source. newSignalSource :: MonadDES m => Simulation m (SignalSource m a) @@ -307,7 +322,53 @@ {-# INLINABLE emptySignal #-} 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 :: Ref m [Double], + signalHistoryValues :: Ref m [a] } + +-- | Create a history of the signal values. +newSignalHistory :: MonadDES m => Signal m a -> Composite 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 => Maybe a -> Signal m a -> Composite m (SignalHistory m a) +{-# INLINABLE newSignalHistoryStartingWith #-} +newSignalHistoryStartingWith init signal = + do ts <- liftSimulation $ newRef [] + xs <- liftSimulation $ newRef [] + case init of + Nothing -> return () + Just a -> + liftEvent $ + do t <- liftDynamics time + modifyRef ts (t :) + modifyRef xs (a :) + handleSignalComposite signal $ \a -> + do t <- liftDynamics time + modifyRef ts (t :) + modifyRef xs (a :) + return SignalHistory { signalHistorySignal = signal, + signalHistoryTimes = ts, + signalHistoryValues = xs } + +-- | Read the history of signal values. +readSignalHistory :: MonadDES m => SignalHistory m a -> Event m (Array Int Double, Array Int a) +{-# INLINABLE readSignalHistory #-} +readSignalHistory history = + do xs0 <- readRef (signalHistoryTimes history) + ys0 <- readRef (signalHistoryValues history) + let n = length xs0 + xs = listArray (0, n - 1) (reverse xs0) + ys = listArray (0, n - 1) (reverse ys0) + return (xs, ys) + -- | Trigger the signal with the current time. triggerSignalWithCurrentTime :: MonadDES m => SignalSource m Double -> Event m () {-# INLINABLE triggerSignalWithCurrentTime #-} diff --git a/Simulation/Aivika/Trans/Signal/Random.hs b/Simulation/Aivika/Trans/Signal/Random.hs --- a/Simulation/Aivika/Trans/Signal/Random.hs +++ b/Simulation/Aivika/Trans/Signal/Random.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Signal.Random --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Simulation --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Specs --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Statistics --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Statistics.Accumulator --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Stream --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Stream.Random --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.SystemDynamics --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Table --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Task --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Transform --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Transform.Extra --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Trans.Transform.Memo --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Transform.Memo.Unboxed --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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 @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Var --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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 @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Trans.Var.Unboxed --- Copyright : Copyright (c) 2009-2016, David Sorokin +-- Copyright : Copyright (c) 2009-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Trans/Vector.hs b/Simulation/Aivika/Trans/Vector.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Vector.hs @@ -0,0 +1,299 @@ + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.Vector +-- Copyright : Copyright (c) 2009-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- An imperative vector. +-- +module Simulation.Aivika.Trans.Vector + (Vector, + newVector, + copyVector, + vectorCount, + appendVector, + readVector, + writeVector, + vectorBinarySearch, + vectorInsert, + vectorDeleteAt, + vectorDeleteRange, + vectorDelete, + vectorDeleteBy, + vectorIndex, + vectorIndexBy, + vectorContains, + vectorContainsBy, + freezeVector) where + +import Data.Array + +import Control.Monad + +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Event +import Simulation.Aivika.Trans.Ref.Base.Lazy + +-- | Represents a resizable vector. +data Vector m a = Vector { vectorArrayRef :: Ref m (Array Int (Ref m a)), + vectorCountRef :: Ref m Int, + vectorCapacityRef :: Ref m Int } + +-- | Create a new vector. +newVector :: MonadRef m => Simulation m (Vector m a) +{-# INLINABLE newVector #-} +newVector = + do xs <- forM [0 .. 4 - 1] $ \i -> newRef undefined + let arr = array (0, 4 - 1) $ zip [0..] xs + arrRef <- newRef $! arr + countRef <- newRef $! 0 + capacityRef <- newRef $! 4 + return Vector { vectorArrayRef = arrRef, + vectorCountRef = countRef, + vectorCapacityRef = capacityRef } + +-- | Copy the vector. +copyVector :: MonadRef m => Vector m a -> Event m (Vector m a) +{-# INLINABLE copyVector #-} +copyVector vector = + do arr <- readRef (vectorArrayRef vector) + count <- readRef (vectorCountRef vector) + xs' <- + forM [0 .. count - 1] $ \i -> + do x <- readRef (arr ! i) + liftSimulation $ newRef x + let arr' = array (0, count - 1) $ zip [0..] xs' + arrRef' <- liftSimulation $ newRef $! arr' + countRef' <- liftSimulation $ newRef $! count + capacityRef' <- liftSimulation $ newRef $! count + return Vector { vectorArrayRef = arrRef', + vectorCountRef = countRef', + vectorCapacityRef = capacityRef' } + +-- | Ensure that the vector has the specified capacity. +vectorEnsureCapacity :: MonadRef m => Vector m a -> Int -> Event m () +{-# INLINABLE vectorEnsureCapacity #-} +vectorEnsureCapacity vector capacity = + do capacity' <- readRef (vectorCapacityRef vector) + when (capacity' < capacity) $ + do arr' <- readRef (vectorArrayRef vector) + count' <- readRef (vectorCountRef vector) + let capacity'' = max (2 * capacity') capacity + xs'' <- + forM [0 .. capacity'' - 1] $ \i -> + liftSimulation $ newRef undefined + let arr'' = array (0, capacity'' - 1) $ zip [0..] xs'' + forM_ [0 .. count' - 1] $ \i -> + do x <- readRef (arr' ! i) + writeRef (arr'' ! i) x + writeRef (vectorArrayRef vector) $! arr'' + writeRef (vectorCapacityRef vector) $! capacity'' + +-- | Return the element count. +vectorCount :: MonadRef m => Vector m a -> Event m Int +{-# INLINABLE vectorCount #-} +vectorCount vector = readRef (vectorCountRef vector) + +-- | Add the specified element to the end of the vector. +appendVector :: MonadRef m => Vector m a -> a -> Event m () +{-# INLINABLE appendVector #-} +appendVector vector item = + do count <- readRef (vectorCountRef vector) + vectorEnsureCapacity vector (count + 1) + arr <- readRef (vectorArrayRef vector) + writeRef (arr ! count) $! item + writeRef (vectorCountRef vector) $! (count + 1) + +-- | Read a value from the vector, where indices are started from 0. +readVector :: MonadRef m => Vector m a -> Int -> Event m a +{-# INLINABLE readVector #-} +readVector vector index = + do arr <- readRef (vectorArrayRef vector) + readRef (arr ! index) + +-- | Set an array item at the specified index which is started from 0. +writeVector :: MonadRef m => Vector m a -> Int -> a -> Event m () +{-# INLINABLE writeVector #-} +writeVector vector index item = + do arr <- readRef (vectorArrayRef vector) + writeRef (arr ! index) $! item + +vectorBinarySearch' :: (MonadRef m, Ord a) => Array Int (Ref m a) -> a -> Int -> Int -> Event m Int +{-# INLINABLE vectorBinarySearch' #-} +vectorBinarySearch' arr item left right = + if left > right + then return $ - (right + 1) - 1 + else + do let index = (left + right) `div` 2 + curr <- readRef (arr ! index) + if item < curr + then vectorBinarySearch' arr item left (index - 1) + else if item == curr + then return index + else vectorBinarySearch' arr item (index + 1) right + +-- | Return the index of the specified element using binary search; otherwise, +-- a negated insertion index minus one: 0 -> -0 - 1, ..., i -> -i - 1, .... +vectorBinarySearch :: (MonadRef m, Ord a) => Vector m a -> a -> Event m Int +{-# INLINABLE vectorBinarySearch #-} +vectorBinarySearch vector item = + do arr <- readRef (vectorArrayRef vector) + count <- readRef (vectorCountRef vector) + vectorBinarySearch' arr item 0 (count - 1) + +-- | Return the elements of the vector in an immutable array. +freezeVector :: MonadRef m => Vector m a -> Event m (Array Int a) +{-# INLINABLE freezeVector #-} +freezeVector vector = + do arr <- readRef (vectorArrayRef vector) + count <- readRef (vectorCountRef vector) + xs' <- + forM [0 .. count - 1] $ \i -> + readRef (arr ! i) + let arr' = array (0, count - 1) $ zip [0..] xs' + return arr' + +-- | Insert the element in the vector at the specified index. +vectorInsert :: MonadRef m => Vector m a -> Int -> a -> Event m () +{-# INLINABLE vectorInsert #-} +vectorInsert vector index item = + do count <- readRef (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) + arr <- readRef (vectorArrayRef vector) + forM_ [count, count - 1 .. index + 1] $ \i -> + do x <- readRef (arr ! (i - 1)) + writeRef (arr ! i) x + writeRef (arr ! index) $! item + writeRef (vectorCountRef vector) $! (count + 1) + +-- | Delete the element at the specified index. +vectorDeleteAt :: MonadRef m => Vector m a -> Int -> Event m () +{-# INLINABLE vectorDeleteAt #-} +vectorDeleteAt vector index = + do count <- readRef (vectorCountRef vector) + when (index < 0) $ + error $ + "Index cannot be " ++ + "negative: vectorDeleteAt." + when (index >= count) $ + error $ + "Index must be less " ++ + "than the count: vectorDeleteAt." + arr <- readRef (vectorArrayRef vector) + forM_ [index, index + 1 .. count - 2] $ \i -> + do x <- readRef (arr ! (i + 1)) + writeRef (arr ! i) x + writeRef (arr ! (count - 1)) undefined + writeRef (vectorCountRef vector) $! (count - 1) + +-- | Delete the specified range of elements. +vectorDeleteRange :: MonadRef m + => Vector m a + -- ^ the vector + -> Int + -- ^ the start index + -> Int + -- ^ the count of items to be removed + -> Event m () +{-# INLINABLE vectorDeleteRange #-} +vectorDeleteRange vector index len = + do count <- readRef (vectorCountRef vector) + when (index < 0) $ + error $ + "The first index cannot be " ++ + "negative: vectorDeleteRange." + when (index + len - 1 >= count) $ + error $ + "The last index must be less " ++ + "than the count: vectorDeleteRange." + when (len < 0) $ + error "Negative range length: vectorDeleteRange." + arr <- readRef (vectorArrayRef vector) + forM_ [index, index + 1 .. (count - len) - 1] $ \i -> + do x <- readRef (arr ! (i + len)) + writeRef (arr ! i) x + forM_ [(count - len) .. count - 1] $ \i -> + writeRef (arr ! i) undefined + writeRef (vectorCountRef vector) $! (count - len) + +-- | Return the index of the item or -1. +vectorIndex :: (MonadRef m, Eq a) => Vector m a -> a -> Event m Int +{-# INLINABLE vectorIndex #-} +vectorIndex vector item = + do count <- readRef (vectorCountRef vector) + arr <- readRef (vectorArrayRef vector) + let loop index = + if index >= count + then return $ -1 + else do x <- readRef (arr ! index) + if item == x + then return index + else loop $ index + 1 + loop 0 + +-- | Return an index of the item satisfying the predicate or -1. +vectorIndexBy :: MonadRef m => Vector m a -> (a -> Bool) -> Event m Int +{-# INLINABLE vectorIndexBy #-} +vectorIndexBy vector pred = + do count <- readRef (vectorCountRef vector) + arr <- readRef (vectorArrayRef vector) + let loop index = + if index >= count + then return $ -1 + else do x <- readRef (arr ! index) + if pred x + then return index + else loop $ index + 1 + loop 0 + +-- | Remove the specified element and return a flag indicating +-- whether the element was found and removed. +vectorDelete :: (MonadRef m, Eq a) => Vector m a -> a -> Event m Bool +{-# INLINABLE vectorDelete #-} +vectorDelete vector item = + do index <- vectorIndex vector item + if index >= 0 + then do vectorDeleteAt vector index + return True + else return False + +-- | Remove an element by the specified predicate and return the element if found. +vectorDeleteBy :: MonadRef m => Vector m a -> (a -> Bool) -> Event m (Maybe a) +{-# INLINABLE vectorDeleteBy #-} +vectorDeleteBy vector pred = + do index <- vectorIndexBy vector pred + if index >= 0 + then do a <- readVector vector index + vectorDeleteAt vector index + return (Just a) + else return Nothing + +-- | Detect whether the specified element is contained in the vector. +vectorContains :: (MonadRef m, Eq a) => Vector m a -> a -> Event m Bool +{-# INLINABLE vectorContains #-} +vectorContains vector item = + do index <- vectorIndex vector item + return (index >= 0) + +-- | Detect whether an element satisfying the specified predicate is contained in the vector. +vectorContainsBy :: MonadRef m => Vector m a -> (a -> Bool) -> Event m (Maybe a) +{-# INLINABLE vectorContainsBy #-} +vectorContainsBy vector pred = + do index <- vectorIndexBy vector pred + if index >= 0 + then do a <- readVector vector index + return (Just a) + else return Nothing diff --git a/aivika-transformers.cabal b/aivika-transformers.cabal --- a/aivika-transformers.cabal +++ b/aivika-transformers.cabal @@ -1,19 +1,36 @@ name: aivika-transformers -version: 5.0.1 +version: 5.1 synopsis: Transformers for the Aivika simulation library description: This package is a generalization of the aivika [1] simulation library with extensive use of monad transformers and type families. + It can be applied for nested simulation [2] and parallel distributed simulation [3]. . + Unlike sequential simulation, the distribution simulation is more difficult for implementing + the simulation experiments by the Monte-Carlo method. Therefore, there are additional packages + that allow saving the results of distribution simulation in SQL databases + and only then the simulation reports are generated. These reports are HTML pages + with charts, histograms, links to CSV tables, statistics summary and so on. + . + This method can be used not only for the parallel distribution simulation, but also for other + simulation models created with help of the generalized version of the Aivika simulation library. + Please consult the AivikaSoft [4] website for more details. + . \[1] . + \[2] + . + \[3] + . + \[4] + . category: Simulation license: BSD3 license-file: LICENSE -copyright: (c) 2009-2016. David Sorokin +copyright: (c) 2009-2017. David Sorokin author: David Sorokin maintainer: David Sorokin -homepage: http://www.aivikasoft.com/en/products/aivika.html +homepage: http://www.aivikasoft.com cabal-version: >= 1.10 build-type: Simple tested-with: GHC == 8.0.1 @@ -57,6 +74,7 @@ Simulation.Aivika.Trans.Circuit Simulation.Aivika.Trans.Comp Simulation.Aivika.Trans.Composite + Simulation.Aivika.Trans.Concurrent.MVar Simulation.Aivika.Trans.Cont Simulation.Aivika.Trans.DoubleLinkedList Simulation.Aivika.Trans.DES @@ -70,6 +88,13 @@ Simulation.Aivika.Trans.Gate Simulation.Aivika.Trans.Generator Simulation.Aivika.Trans.Generator.Primitive + 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.Simulation + Simulation.Aivika.Trans.Internal.Specs Simulation.Aivika.Trans.Internal.Types Simulation.Aivika.Trans.Net Simulation.Aivika.Trans.Net.Random @@ -90,6 +115,8 @@ Simulation.Aivika.Trans.QueueStrategy Simulation.Aivika.Trans.Ref Simulation.Aivika.Trans.Ref.Base + Simulation.Aivika.Trans.Ref.Base.Lazy + Simulation.Aivika.Trans.Ref.Base.Strict Simulation.Aivika.Trans.Resource Simulation.Aivika.Trans.Resource.Base Simulation.Aivika.Trans.Resource.Preemption @@ -97,6 +124,7 @@ Simulation.Aivika.Trans.Results.Locale Simulation.Aivika.Trans.Results Simulation.Aivika.Trans.Results.IO + Simulation.Aivika.Trans.Results.Transform Simulation.Aivika.Trans.SD Simulation.Aivika.Trans.Server Simulation.Aivika.Trans.Server.Random @@ -117,6 +145,7 @@ Simulation.Aivika.Trans.Transform.Memo.Unboxed Simulation.Aivika.Trans.Var Simulation.Aivika.Trans.Var.Unboxed + Simulation.Aivika.Trans.Vector Simulation.Aivika.IO Simulation.Aivika.IO.Comp Simulation.Aivika.IO.DES @@ -129,26 +158,20 @@ Simulation.Aivika.IO.SD Simulation.Aivika.IO.Signal Simulation.Aivika.IO.Ref.Base + Simulation.Aivika.IO.Ref.Base.Lazy + Simulation.Aivika.IO.Ref.Base.Strict Simulation.Aivika.IO.Resource.Preemption Simulation.Aivika.IO.Resource.Preemption.Base 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.Simulation - Simulation.Aivika.Trans.Internal.Specs - - build-depends: base >= 4.5.0.0 && < 6, + build-depends: base >= 4.6.0.0 && < 6, mtl >= 2.1.1, array >= 0.3.0.0, containers >= 0.4.0.0, random >= 1.0.0.3, vector >= 0.10.0.1, - aivika >= 5.0 + aivika >= 5.1 other-extensions: FlexibleContexts, FlexibleInstances, @@ -163,7 +186,8 @@ TypeSynonymInstances, DeriveDataTypeable, RankNTypes, - ConstrainedClassMethods + ConstrainedClassMethods, + OverlappingInstances ghc-options: -O2