diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (c) 2009, 2010, 2011, 2012, 2013, 2014 David Sorokin - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. +Copyright (c) 2009, 2010, 2011, 2012, 2013, 2014 David Sorokin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,3 +1,3 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/Simulation/Aivika/Trans.hs b/Simulation/Aivika/Trans.hs --- a/Simulation/Aivika/Trans.hs +++ b/Simulation/Aivika/Trans.hs @@ -1,91 +1,93 @@ - --- | --- Module : Simulation.Aivika.Trans --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module re-exports the most part of the library functionality. --- But there are modules that must be imported explicitly, though. --- -module Simulation.Aivika.Trans - (-- * Modules - module Simulation.Aivika.Trans.Agent, - module Simulation.Aivika.Trans.Arrival, - module Simulation.Aivika.Trans.Circuit, - module Simulation.Aivika.Trans.Comp, - module Simulation.Aivika.Trans.Comp.IO, - module Simulation.Aivika.Trans.Comp.Template, - module Simulation.Aivika.Trans.Cont, - module Simulation.Aivika.Trans.Dynamics, - module Simulation.Aivika.Trans.Dynamics.Extra, - module Simulation.Aivika.Trans.Dynamics.Memo.Unboxed, - module Simulation.Aivika.Trans.Dynamics.Random, - module Simulation.Aivika.Trans.Event, - module Simulation.Aivika.Trans.Generator, - module Simulation.Aivika.Trans.Net, - module Simulation.Aivika.Trans.Parameter, - module Simulation.Aivika.Trans.Parameter.Random, - module Simulation.Aivika.Trans.Process, - module Simulation.Aivika.Trans.Processor, - module Simulation.Aivika.Trans.Processor.RoundRobbin, - module Simulation.Aivika.Trans.QueueStrategy, - module Simulation.Aivika.Trans.Ref, - module Simulation.Aivika.Trans.Resource, - module Simulation.Aivika.Trans.Results, - module Simulation.Aivika.Trans.Results.Locale, - module Simulation.Aivika.Trans.Results.IO, - module Simulation.Aivika.Trans.Server, - module Simulation.Aivika.Trans.Signal, - module Simulation.Aivika.Trans.Simulation, - module Simulation.Aivika.Trans.Specs, - module Simulation.Aivika.Trans.Statistics, - module Simulation.Aivika.Trans.Statistics.Accumulator, - module Simulation.Aivika.Trans.Stream, - module Simulation.Aivika.Trans.Stream.Random, - module Simulation.Aivika.Trans.Task, - module Simulation.Aivika.Trans.Transform, - module Simulation.Aivika.Trans.Transform.Extra, - module Simulation.Aivika.Trans.Transform.Memo.Unboxed, - module Simulation.Aivika.Trans.Var.Unboxed) where - -import Simulation.Aivika.Trans.Agent -import Simulation.Aivika.Trans.Arrival -import Simulation.Aivika.Trans.Circuit -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Comp.IO -import Simulation.Aivika.Trans.Comp.Template -import Simulation.Aivika.Trans.Cont -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Dynamics.Extra -import Simulation.Aivika.Trans.Dynamics.Memo.Unboxed -import Simulation.Aivika.Trans.Dynamics.Random -import Simulation.Aivika.Trans.Event -import Simulation.Aivika.Trans.Generator -import Simulation.Aivika.Trans.Net -import Simulation.Aivika.Trans.Parameter -import Simulation.Aivika.Trans.Parameter.Random -import Simulation.Aivika.Trans.Process -import Simulation.Aivika.Trans.Processor -import Simulation.Aivika.Trans.Processor.RoundRobbin -import Simulation.Aivika.Trans.QueueStrategy -import Simulation.Aivika.Trans.Ref -import Simulation.Aivika.Trans.Resource -import Simulation.Aivika.Trans.Results -import Simulation.Aivika.Trans.Results.Locale -import Simulation.Aivika.Trans.Results.IO -import Simulation.Aivika.Trans.Server -import Simulation.Aivika.Trans.Signal -import Simulation.Aivika.Trans.Simulation -import Simulation.Aivika.Trans.Specs -import Simulation.Aivika.Trans.Statistics -import Simulation.Aivika.Trans.Statistics.Accumulator -import Simulation.Aivika.Trans.Stream -import Simulation.Aivika.Trans.Stream.Random -import Simulation.Aivika.Trans.Task -import Simulation.Aivika.Trans.Transform -import Simulation.Aivika.Trans.Transform.Extra -import Simulation.Aivika.Trans.Transform.Memo.Unboxed -import Simulation.Aivika.Trans.Var.Unboxed + +-- | +-- Module : Simulation.Aivika.Trans +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module re-exports the most part of the library functionality. +-- But there are modules that must be imported explicitly, though. +-- +module Simulation.Aivika.Trans + (-- * Modules + module Simulation.Aivika.Trans.Activity, + module Simulation.Aivika.Trans.Agent, + module Simulation.Aivika.Trans.Arrival, + module Simulation.Aivika.Trans.Circuit, + module Simulation.Aivika.Trans.Comp, + module Simulation.Aivika.Trans.Comp.IO, + module Simulation.Aivika.Trans.Comp.Template, + module Simulation.Aivika.Trans.Cont, + module Simulation.Aivika.Trans.Dynamics, + module Simulation.Aivika.Trans.Dynamics.Extra, + module Simulation.Aivika.Trans.Dynamics.Memo.Unboxed, + module Simulation.Aivika.Trans.Dynamics.Random, + module Simulation.Aivika.Trans.Event, + module Simulation.Aivika.Trans.Generator, + module Simulation.Aivika.Trans.Net, + module Simulation.Aivika.Trans.Parameter, + module Simulation.Aivika.Trans.Parameter.Random, + module Simulation.Aivika.Trans.Process, + module Simulation.Aivika.Trans.Processor, + module Simulation.Aivika.Trans.Processor.RoundRobbin, + module Simulation.Aivika.Trans.QueueStrategy, + module Simulation.Aivika.Trans.Ref, + module Simulation.Aivika.Trans.Resource, + module Simulation.Aivika.Trans.Results, + module Simulation.Aivika.Trans.Results.Locale, + module Simulation.Aivika.Trans.Results.IO, + module Simulation.Aivika.Trans.Server, + module Simulation.Aivika.Trans.Signal, + module Simulation.Aivika.Trans.Simulation, + module Simulation.Aivika.Trans.Specs, + module Simulation.Aivika.Trans.Statistics, + module Simulation.Aivika.Trans.Statistics.Accumulator, + module Simulation.Aivika.Trans.Stream, + module Simulation.Aivika.Trans.Stream.Random, + module Simulation.Aivika.Trans.Task, + module Simulation.Aivika.Trans.Transform, + module Simulation.Aivika.Trans.Transform.Extra, + module Simulation.Aivika.Trans.Transform.Memo.Unboxed, + module Simulation.Aivika.Trans.Var.Unboxed) where + +import Simulation.Aivika.Trans.Activity +import Simulation.Aivika.Trans.Agent +import Simulation.Aivika.Trans.Arrival +import Simulation.Aivika.Trans.Circuit +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Comp.IO +import Simulation.Aivika.Trans.Comp.Template +import Simulation.Aivika.Trans.Cont +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Dynamics.Extra +import Simulation.Aivika.Trans.Dynamics.Memo.Unboxed +import Simulation.Aivika.Trans.Dynamics.Random +import Simulation.Aivika.Trans.Event +import Simulation.Aivika.Trans.Generator +import Simulation.Aivika.Trans.Net +import Simulation.Aivika.Trans.Parameter +import Simulation.Aivika.Trans.Parameter.Random +import Simulation.Aivika.Trans.Process +import Simulation.Aivika.Trans.Processor +import Simulation.Aivika.Trans.Processor.RoundRobbin +import Simulation.Aivika.Trans.QueueStrategy +import Simulation.Aivika.Trans.Ref +import Simulation.Aivika.Trans.Resource +import Simulation.Aivika.Trans.Results +import Simulation.Aivika.Trans.Results.Locale +import Simulation.Aivika.Trans.Results.IO +import Simulation.Aivika.Trans.Server +import Simulation.Aivika.Trans.Signal +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Specs +import Simulation.Aivika.Trans.Statistics +import Simulation.Aivika.Trans.Statistics.Accumulator +import Simulation.Aivika.Trans.Stream +import Simulation.Aivika.Trans.Stream.Random +import Simulation.Aivika.Trans.Task +import Simulation.Aivika.Trans.Transform +import Simulation.Aivika.Trans.Transform.Extra +import Simulation.Aivika.Trans.Transform.Memo.Unboxed +import Simulation.Aivika.Trans.Var.Unboxed diff --git a/Simulation/Aivika/Trans/Activity.hs b/Simulation/Aivika/Trans/Activity.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Activity.hs @@ -0,0 +1,376 @@ + +-- | +-- Module : Simulation.Aivika.Trans.Activity +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It models an activity that can be utilised. The activity is similar to a 'Server' +-- but destined for simulation within 'Net' computation. +module Simulation.Aivika.Trans.Activity + (-- * Activity + Activity, + newActivity, + newStateActivity, + -- * Processing + activityNet, + -- * Activity Properties + activityInitState, + activityState, + activityTotalUtilisationTime, + activityTotalIdleTime, + activityUtilisationTime, + activityIdleTime, + activityUtilisationFactor, + activityIdleFactor, + -- * Summary + activitySummary, + -- * Derived Signals for Properties + activityStateChanged, + activityStateChanged_, + activityTotalUtilisationTimeChanged, + activityTotalUtilisationTimeChanged_, + activityTotalIdleTimeChanged, + activityTotalIdleTimeChanged_, + activityUtilisationTimeChanged, + activityUtilisationTimeChanged_, + activityIdleTimeChanged, + activityIdleTimeChanged_, + activityUtilisationFactorChanged, + activityUtilisationFactorChanged_, + activityIdleFactorChanged, + activityIdleFactorChanged_, + -- * Basic Signals + activityUtilising, + activityUtilised, + -- * Overall Signal + activityChanged_) where + +import Data.Monoid + +import Control.Monad.Trans +import Control.Arrow + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Parameter +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Signal +import Simulation.Aivika.Trans.Resource +import Simulation.Aivika.Trans.Cont +import Simulation.Aivika.Trans.Process +import Simulation.Aivika.Trans.Net +import Simulation.Aivika.Trans.Server +import Simulation.Aivika.Trans.Statistics + +-- | Like 'Server' it models an activity that takes @a@ and provides @b@ having state @s@. +-- But unlike the former the activity is destined for simulation within 'Net' computation. +data Activity m s a b = + Activity { activityInitState :: s, + -- ^ The initial state of the activity. + activityStateRef :: ProtoRef m s, + -- ^ The current state of the activity. + activityProcess :: s -> a -> Process m (s, b), + -- ^ Provide @b@ by specified @a@. + activityTotalUtilisationTimeRef :: ProtoRef m Double, + -- ^ The counted total time of utilising the activity. + activityTotalIdleTimeRef :: ProtoRef m Double, + -- ^ The counted total time, when the activity was idle. + activityUtilisationTimeRef :: ProtoRef m (SamplingStats Double), + -- ^ The statistics for the utilisation time. + activityIdleTimeRef :: ProtoRef m (SamplingStats Double), + -- ^ The statistics for the time, when the activity was idle. + activityUtilisingSource :: SignalSource m a, + -- ^ A signal raised when starting to utilise the activity. + activityUtilisedSource :: SignalSource m (a, b) + -- ^ A signal raised when the activity has been utilised. + } + +-- | Create a new activity that can provide output @b@ by input @a@. +newActivity :: MonadComp m + => (a -> Process m b) + -- ^ provide an output by the specified input + -> Simulation m (Activity m () a b) +newActivity provide = + flip newStateActivity () $ \s a -> + do b <- provide a + return (s, b) + +-- | Create a new activity that can provide output @b@ by input @a@ +-- starting from state @s@. +newStateActivity :: MonadComp m + => (s -> a -> Process m (s, b)) + -- ^ provide a new state and output by the specified + -- old state and input + -> s + -- ^ the initial state + -> Simulation m (Activity m s a b) +newStateActivity provide state = + do sn <- liftParameter simulationSession + r0 <- liftComp $ newProtoRef sn state + r1 <- liftComp $ newProtoRef sn 0 + r2 <- liftComp $ newProtoRef sn 0 + r3 <- liftComp $ newProtoRef sn emptySamplingStats + r4 <- liftComp $ newProtoRef sn emptySamplingStats + s1 <- newSignalSource + s2 <- newSignalSource + return Activity { activityInitState = state, + activityStateRef = r0, + activityProcess = provide, + activityTotalUtilisationTimeRef = r1, + activityTotalIdleTimeRef = r2, + activityUtilisationTimeRef = r3, + activityIdleTimeRef = r4, + activityUtilisingSource = s1, + activityUtilisedSource = s2 } + +-- | Return a network computation for the specified activity. +-- +-- The computation updates the internal state of the activity. The usual case is when +-- the computation is applied only once in a chain of data processing. Otherwise; +-- every time the computation is used, the state of the activity changes. Sometimes +-- it can be indeed useful if you want to aggregate the statistics for different +-- activities simultaneously, but it would be more preferable to avoid this. +-- +-- If you connect different activity computations returned by this function in a chain +-- with help of '>>>' or other category combinator then this chain will act as one +-- whole, where the first activity will take a new task only after the last activity +-- finishes its current task and requests for the next one from the previous activity +-- in the chain. This is not always that thing you might need. +activityNet :: MonadComp m => Activity m s a b -> Net m a b +activityNet act = Net $ loop (activityInitState act) Nothing + where + loop s r a = + do t0 <- liftDynamics time + liftEvent $ + do case r of + Nothing -> return () + Just t' -> + liftComp $ + do modifyProtoRef' (activityTotalIdleTimeRef act) (+ (t0 - t')) + modifyProtoRef' (activityIdleTimeRef act) $ + addSamplingStats (t0 - t') + triggerSignal (activityUtilisingSource act) a + -- utilise the activity + (s', b) <- activityProcess act s a + t1 <- liftDynamics time + liftEvent $ + do liftComp $ + do writeProtoRef (activityStateRef act) $! s' + modifyProtoRef' (activityTotalUtilisationTimeRef act) (+ (t1 - t0)) + modifyProtoRef' (activityUtilisationTimeRef act) $ + addSamplingStats (t1 - t0) + triggerSignal (activityUtilisedSource act) (a, b) + return (b, Net $ loop s' (Just t1)) + +-- | Return the current state of the activity. +-- +-- See also 'activityStateChanged' and 'activityStateChanged_'. +activityState :: MonadComp m => Activity m s a b -> Event m s +activityState act = + Event $ \p -> readProtoRef (activityStateRef act) + +-- | Signal when the 'activityState' property value has changed. +activityStateChanged :: MonadComp m => Activity m s a b -> Signal m s +activityStateChanged act = + mapSignalM (const $ activityState act) (activityStateChanged_ act) + +-- | Signal when the 'activityState' property value has changed. +activityStateChanged_ :: MonadComp m => Activity m s a b -> Signal m () +activityStateChanged_ act = + mapSignal (const ()) (activityUtilised act) + +-- | Return the counted total time when the activity was utilised. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'activityTotalUtilisationTimeChanged' and 'activityTotalUtilisationTimeChanged_'. +activityTotalUtilisationTime :: MonadComp m => Activity m s a b -> Event m Double +activityTotalUtilisationTime act = + Event $ \p -> readProtoRef (activityTotalUtilisationTimeRef act) + +-- | Signal when the 'activityTotalUtilisationTime' property value has changed. +activityTotalUtilisationTimeChanged :: MonadComp m => Activity m s a b -> Signal m Double +activityTotalUtilisationTimeChanged act = + mapSignalM (const $ activityTotalUtilisationTime act) (activityTotalUtilisationTimeChanged_ act) + +-- | Signal when the 'activityTotalUtilisationTime' property value has changed. +activityTotalUtilisationTimeChanged_ :: MonadComp m => Activity m s a b -> Signal m () +activityTotalUtilisationTimeChanged_ act = + mapSignal (const ()) (activityUtilised act) + +-- | Return the counted total time when the activity was idle. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'activityTotalIdleTimeChanged' and 'activityTotalIdleTimeChanged_'. +activityTotalIdleTime :: MonadComp m => Activity m s a b -> Event m Double +activityTotalIdleTime act = + Event $ \p -> readProtoRef (activityTotalIdleTimeRef act) + +-- | Signal when the 'activityTotalIdleTime' property value has changed. +activityTotalIdleTimeChanged :: MonadComp m => Activity m s a b -> Signal m Double +activityTotalIdleTimeChanged act = + mapSignalM (const $ activityTotalIdleTime act) (activityTotalIdleTimeChanged_ act) + +-- | Signal when the 'activityTotalIdleTime' property value has changed. +activityTotalIdleTimeChanged_ :: MonadComp m => Activity m s a b -> Signal m () +activityTotalIdleTimeChanged_ act = + mapSignal (const ()) (activityUtilising act) + +-- | Return the statistics for the time when the activity was utilised. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'activityUtilisationTimeChanged' and 'activityUtilisationTimeChanged_'. +activityUtilisationTime :: MonadComp m => Activity m s a b -> Event m (SamplingStats Double) +activityUtilisationTime act = + Event $ \p -> readProtoRef (activityUtilisationTimeRef act) + +-- | Signal when the 'activityUtilisationTime' property value has changed. +activityUtilisationTimeChanged :: MonadComp m => Activity m s a b -> Signal m (SamplingStats Double) +activityUtilisationTimeChanged act = + mapSignalM (const $ activityUtilisationTime act) (activityUtilisationTimeChanged_ act) + +-- | Signal when the 'activityUtilisationTime' property value has changed. +activityUtilisationTimeChanged_ :: MonadComp m => Activity m s a b -> Signal m () +activityUtilisationTimeChanged_ act = + mapSignal (const ()) (activityUtilised act) + +-- | Return the statistics for the time when the activity was idle. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'activityIdleTimeChanged' and 'activityIdleTimeChanged_'. +activityIdleTime :: MonadComp m => Activity m s a b -> Event m (SamplingStats Double) +activityIdleTime act = + Event $ \p -> readProtoRef (activityIdleTimeRef act) + +-- | Signal when the 'activityIdleTime' property value has changed. +activityIdleTimeChanged :: MonadComp m => Activity m s a b -> Signal m (SamplingStats Double) +activityIdleTimeChanged act = + mapSignalM (const $ activityIdleTime act) (activityIdleTimeChanged_ act) + +-- | Signal when the 'activityIdleTime' property value has changed. +activityIdleTimeChanged_ :: MonadComp m => Activity m s a b -> Signal m () +activityIdleTimeChanged_ act = + mapSignal (const ()) (activityUtilising act) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the activity was utilised. +-- +-- This factor is calculated as +-- +-- @ +-- totalUtilisationTime \/ (totalUtilisationTime + totalIdleTime) +-- @ +-- +-- As before in this module, the value returned changes discretely and +-- it is usually delayed relative to the current simulation time. +-- +-- See also 'activityUtilisationFactorChanged' and 'activityUtilisationFactorChanged_'. +activityUtilisationFactor :: MonadComp m => Activity m s a b -> Event m Double +activityUtilisationFactor act = + Event $ \p -> + do x1 <- readProtoRef (activityTotalUtilisationTimeRef act) + x2 <- readProtoRef (activityTotalIdleTimeRef act) + return (x1 / (x1 + x2)) + +-- | Signal when the 'activityUtilisationFactor' property value has changed. +activityUtilisationFactorChanged :: MonadComp m => Activity m s a b -> Signal m Double +activityUtilisationFactorChanged act = + mapSignalM (const $ activityUtilisationFactor act) (activityUtilisationFactorChanged_ act) + +-- | Signal when the 'activityUtilisationFactor' property value has changed. +activityUtilisationFactorChanged_ :: MonadComp m => Activity m s a b -> Signal m () +activityUtilisationFactorChanged_ act = + mapSignal (const ()) (activityUtilising act) <> + mapSignal (const ()) (activityUtilised act) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the activity was idle. +-- +-- This factor is calculated as +-- +-- @ +-- totalIdleTime \/ (totalUtilisationTime + totalIdleTime) +-- @ +-- +-- As before in this module, the value returned changes discretely and +-- it is usually delayed relative to the current simulation time. +-- +-- See also 'activityIdleFactorChanged' and 'activityIdleFactorChanged_'. +activityIdleFactor :: MonadComp m => Activity m s a b -> Event m Double +activityIdleFactor act = + Event $ \p -> + do x1 <- readProtoRef (activityTotalUtilisationTimeRef act) + x2 <- readProtoRef (activityTotalIdleTimeRef act) + return (x2 / (x1 + x2)) + +-- | Signal when the 'activityIdleFactor' property value has changed. +activityIdleFactorChanged :: MonadComp m => Activity m s a b -> Signal m Double +activityIdleFactorChanged act = + mapSignalM (const $ activityIdleFactor act) (activityIdleFactorChanged_ act) + +-- | Signal when the 'activityIdleFactor' property value has changed. +activityIdleFactorChanged_ :: MonadComp m => Activity m s a b -> Signal m () +activityIdleFactorChanged_ act = + mapSignal (const ()) (activityUtilising act) <> + mapSignal (const ()) (activityUtilised act) + +-- | Raised when starting to utilise the activity after a new input task is received. +activityUtilising :: Activity m s a b -> Signal m a +activityUtilising = publishSignal . activityUtilisingSource + +-- | Raised when the activity has been utilised after the current task is processed. +activityUtilised :: Activity m s a b -> Signal m (a, b) +activityUtilised = publishSignal . activityUtilisedSource + +-- | Signal whenever any property of the activity changes. +activityChanged_ :: MonadComp m => Activity m s a b -> Signal m () +activityChanged_ act = + mapSignal (const ()) (activityUtilising act) <> + mapSignal (const ()) (activityUtilised act) + +-- | Return the summary for the activity with desciption of its +-- properties using the specified indent. +activitySummary :: MonadComp m => Activity m s a b -> Int -> Event m ShowS +activitySummary act indent = + Event $ \p -> + do tx1 <- readProtoRef (activityTotalUtilisationTimeRef act) + tx2 <- readProtoRef (activityTotalIdleTimeRef act) + let xf1 = tx1 / (tx1 + tx2) + xf2 = tx2 / (tx1 + tx2) + xs1 <- readProtoRef (activityUtilisationTimeRef act) + xs2 <- readProtoRef (activityIdleTimeRef act) + let tab = replicate indent ' ' + return $ + showString tab . + showString "total utilisation time = " . shows tx1 . + showString "\n" . + showString tab . + showString "total idle time = " . shows tx2 . + showString "\n" . + showString tab . + showString "utilisation factor (from 0 to 1) = " . shows xf1 . + showString "\n" . + showString tab . + showString "idle factor (from 0 to 1) = " . shows xf2 . + showString "\n" . + showString tab . + showString "utilisation time (locked while awaiting the input):\n\n" . + samplingStatsSummary xs1 (2 + indent) . + showString "\n\n" . + showString tab . + showString "idle time:\n\n" . + samplingStatsSummary xs2 (2 + indent) 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,265 +1,265 @@ - --- | --- Module : Simulation.Aivika.Trans.Agent --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module introduces basic entities for the agent-based modeling. --- -module Simulation.Aivika.Trans.Agent - (Agent, - AgentState, - newAgent, - newState, - newSubstate, - selectedState, - selectedStateChanged, - selectedStateChanged_, - selectState, - stateAgent, - stateParent, - addTimeout, - addTimer, - setStateActivation, - setStateDeactivation, - setStateTransition) where - -import Control.Monad - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Event -import Simulation.Aivika.Trans.Internal.Signal - --- --- Agent-based Modeling --- - --- | Represents an agent. -data Agent m = Agent { agentMarker :: SessionMarker m, - agentModeRef :: ProtoRef m AgentMode, - agentStateRef :: ProtoRef m (Maybe (AgentState m)), - agentStateChangedSource :: SignalSource m (Maybe (AgentState m)) } - --- | Represents the agent state. -data AgentState m = AgentState { stateAgent :: Agent m, - -- ^ Return the corresponded agent. - stateParent :: Maybe (AgentState m), - -- ^ Return the parent state or 'Nothing'. - stateMarker :: SessionMarker m, - stateActivateRef :: ProtoRef m (Event m ()), - stateDeactivateRef :: ProtoRef m (Event m ()), - stateTransitRef :: ProtoRef m (Event m (Maybe (AgentState m))), - stateVersionRef :: ProtoRef m Int } - -data AgentMode = CreationMode - | TransientMode - | ProcessingMode - -instance MonadComp m => Eq (Agent m) where - x == y = agentMarker x == agentMarker y - -instance MonadComp m => Eq (AgentState m) where - x == y = stateMarker x == stateMarker y - -fullPath :: AgentState m -> [AgentState m] -> [AgentState m] -fullPath st acc = - case stateParent st of - Nothing -> st : acc - Just st' -> fullPath st' (st : acc) - -partitionPath :: MonadComp m => [AgentState m] -> [AgentState m] -> ([AgentState m], [AgentState m]) -partitionPath path1 path2 = - case (path1, path2) of - (h1 : t1, [h2]) | h1 == h2 -> - (reverse path1, path2) - (h1 : t1, h2 : t2) | h1 == h2 -> - partitionPath t1 t2 - _ -> - (reverse path1, path2) - -findPath :: MonadComp m => Maybe (AgentState m) -> AgentState m -> ([AgentState m], [AgentState m]) -findPath Nothing target = ([], fullPath target []) -findPath (Just source) target - | stateAgent source /= stateAgent target = - error "Different agents: findPath." - | otherwise = - partitionPath path1 path2 - where - path1 = fullPath source [] - path2 = fullPath target [] - -traversePath :: MonadComp m => Maybe (AgentState m) -> AgentState m -> Event m () -traversePath source target = - let (path1, path2) = findPath source target - agent = stateAgent target - activate st p = invokeEvent p =<< readProtoRef (stateActivateRef st) - deactivate st p = invokeEvent p =<< readProtoRef (stateDeactivateRef st) - transit st p = invokeEvent p =<< readProtoRef (stateTransitRef st) - continue st p = invokeEvent p $ traversePath (Just target) st - in Event $ \p -> - unless (null path1 && null path2) $ - do writeProtoRef (agentModeRef agent) TransientMode - forM_ path1 $ \st -> - do writeProtoRef (agentStateRef agent) (Just st) - deactivate st p - -- it makes all timeout and timer handlers outdated - modifyProtoRef (stateVersionRef st) (1 +) - forM_ path2 $ \st -> - do writeProtoRef (agentStateRef agent) (Just st) - activate st p - st' <- transit target p - case st' of - Nothing -> - do writeProtoRef (agentModeRef agent) ProcessingMode - triggerAgentStateChanged p agent - Just st' -> - continue st' p - --- | Add to the state a timeout handler that will be actuated --- in the specified time period if the state will remain active. -addTimeout :: MonadComp m => AgentState m -> Double -> Event m () -> Event m () -addTimeout st dt action = - Event $ \p -> - do v <- readProtoRef (stateVersionRef st) - let m1 = Event $ \p -> - do v' <- readProtoRef (stateVersionRef st) - when (v == v') $ - invokeEvent p action - m2 = enqueueEvent (pointTime p + dt) m1 - invokeEvent p m2 - --- | Add to the state a timer handler that will be actuated --- in the specified time period and then repeated again many times, --- while the state remains active. -addTimer :: MonadComp m => AgentState m -> Event m Double -> Event m () -> Event m () -addTimer st dt action = - Event $ \p -> - do v <- readProtoRef (stateVersionRef st) - let m1 = Event $ \p -> - do v' <- readProtoRef (stateVersionRef st) - when (v == v') $ - do invokeEvent p m2 - invokeEvent p action - m2 = Event $ \p -> - do dt' <- invokeEvent p dt - invokeEvent p $ enqueueEvent (pointTime p + dt') m1 - invokeEvent p m2 - --- | Create a new state. -newState :: MonadComp m => Agent m -> Simulation m (AgentState m) -newState agent = - Simulation $ \r -> - do let s = runSession r - aref <- newProtoRef s $ return () - dref <- newProtoRef s $ return () - tref <- newProtoRef s $ return Nothing - vref <- newProtoRef s 0 - mrkr <- newSessionMarker s - return AgentState { stateAgent = agent, - stateParent = Nothing, - stateMarker = mrkr, - stateActivateRef = aref, - stateDeactivateRef = dref, - stateTransitRef = tref, - stateVersionRef = vref } - --- | Create a child state. -newSubstate :: MonadComp m => AgentState m -> Simulation m (AgentState m) -newSubstate parent = - Simulation $ \r -> - do let agent = stateAgent parent - s = runSession r - aref <- newProtoRef s $ return () - dref <- newProtoRef s $ return () - tref <- newProtoRef s $ return Nothing - vref <- newProtoRef s 0 - mrkr <- newSessionMarker s - return AgentState { stateAgent = agent, - stateParent = Just parent, - stateMarker = mrkr, - stateActivateRef= aref, - stateDeactivateRef = dref, - stateTransitRef = tref, - stateVersionRef = vref } - --- | Create an agent. -newAgent :: MonadComp m => Simulation m (Agent m) -newAgent = - Simulation $ \r -> - do let s = runSession r - modeRef <- newProtoRef s CreationMode - stateRef <- newProtoRef s Nothing - stateChangedSource <- invokeSimulation r newSignalSource - mrkr <- newSessionMarker s - return Agent { agentMarker = mrkr, - agentModeRef = modeRef, - agentStateRef = stateRef, - agentStateChangedSource = stateChangedSource } - --- | Return the selected active state. -selectedState :: MonadComp m => Agent m -> Event m (Maybe (AgentState m)) -selectedState agent = - Event $ \p -> readProtoRef (agentStateRef agent) - --- | Select the state. The activation and selection are repeated while --- there is the transition state defined by 'setStateTransition'. -selectState :: MonadComp m => AgentState m -> Event m () -selectState st = - Event $ \p -> - do let agent = stateAgent st - mode <- readProtoRef (agentModeRef agent) - case mode of - CreationMode -> - do x0 <- readProtoRef (agentStateRef agent) - invokeEvent p $ traversePath x0 st - TransientMode -> - error $ - "Use the setStateTransition function to define " ++ - "the transition state: activateState." - ProcessingMode -> - do x0 @ (Just st0) <- readProtoRef (agentStateRef agent) - invokeEvent p $ traversePath x0 st - --- | Set the activation computation for the specified state. -setStateActivation :: MonadComp m => AgentState m -> Event m () -> Simulation m () -setStateActivation st action = - Simulation $ \r -> - writeProtoRef (stateActivateRef st) action - --- | Set the deactivation computation for the specified state. -setStateDeactivation :: MonadComp m => AgentState m -> Event m () -> Simulation m () -setStateDeactivation st action = - Simulation $ \r -> - writeProtoRef (stateDeactivateRef st) action - --- | Set the transition state which will be next and which is used only --- when selecting the state directly with help of 'selectState'. --- If the state was activated intermediately, when selecting --- another state, then this computation is not used. -setStateTransition :: MonadComp m => AgentState m -> Event m (Maybe (AgentState m)) -> Simulation m () -setStateTransition st action = - Simulation $ \r -> - writeProtoRef (stateTransitRef st) action - --- | Trigger the signal when the agent state changes. -triggerAgentStateChanged :: MonadComp m => Point m -> Agent m -> m () -triggerAgentStateChanged p agent = - do st <- readProtoRef (agentStateRef agent) - invokeEvent p $ triggerSignal (agentStateChangedSource agent) st - --- | Return a signal that notifies about every change of the selected state. -selectedStateChanged :: Agent m -> Signal m (Maybe (AgentState m)) -selectedStateChanged agent = - publishSignal (agentStateChangedSource agent) - --- | Return a signal that notifies about every change of the selected state. -selectedStateChanged_ :: MonadComp m => Agent m -> Signal m () -selectedStateChanged_ agent = - mapSignal (const ()) $ selectedStateChanged agent + +-- | +-- Module : Simulation.Aivika.Trans.Agent +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module introduces basic entities for the agent-based modeling. +-- +module Simulation.Aivika.Trans.Agent + (Agent, + AgentState, + newAgent, + newState, + newSubstate, + selectedState, + selectedStateChanged, + selectedStateChanged_, + selectState, + stateAgent, + stateParent, + addTimeout, + addTimer, + setStateActivation, + setStateDeactivation, + setStateTransition) where + +import Control.Monad + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Signal + +-- +-- Agent-based Modeling +-- + +-- | Represents an agent. +data Agent m = Agent { agentMarker :: SessionMarker m, + agentModeRef :: ProtoRef m AgentMode, + agentStateRef :: ProtoRef m (Maybe (AgentState m)), + agentStateChangedSource :: SignalSource m (Maybe (AgentState m)) } + +-- | Represents the agent state. +data AgentState m = AgentState { stateAgent :: Agent m, + -- ^ Return the corresponded agent. + stateParent :: Maybe (AgentState m), + -- ^ Return the parent state or 'Nothing'. + stateMarker :: SessionMarker m, + stateActivateRef :: ProtoRef m (Event m ()), + stateDeactivateRef :: ProtoRef m (Event m ()), + stateTransitRef :: ProtoRef m (Event m (Maybe (AgentState m))), + stateVersionRef :: ProtoRef m Int } + +data AgentMode = CreationMode + | TransientMode + | ProcessingMode + +instance MonadComp m => Eq (Agent m) where + x == y = agentMarker x == agentMarker y + +instance MonadComp m => Eq (AgentState m) where + x == y = stateMarker x == stateMarker y + +fullPath :: AgentState m -> [AgentState m] -> [AgentState m] +fullPath st acc = + case stateParent st of + Nothing -> st : acc + Just st' -> fullPath st' (st : acc) + +partitionPath :: MonadComp m => [AgentState m] -> [AgentState m] -> ([AgentState m], [AgentState m]) +partitionPath path1 path2 = + case (path1, path2) of + (h1 : t1, [h2]) | h1 == h2 -> + (reverse path1, path2) + (h1 : t1, h2 : t2) | h1 == h2 -> + partitionPath t1 t2 + _ -> + (reverse path1, path2) + +findPath :: MonadComp m => Maybe (AgentState m) -> AgentState m -> ([AgentState m], [AgentState m]) +findPath Nothing target = ([], fullPath target []) +findPath (Just source) target + | stateAgent source /= stateAgent target = + error "Different agents: findPath." + | otherwise = + partitionPath path1 path2 + where + path1 = fullPath source [] + path2 = fullPath target [] + +traversePath :: MonadComp m => Maybe (AgentState m) -> AgentState m -> Event m () +traversePath source target = + let (path1, path2) = findPath source target + agent = stateAgent target + activate st p = invokeEvent p =<< readProtoRef (stateActivateRef st) + deactivate st p = invokeEvent p =<< readProtoRef (stateDeactivateRef st) + transit st p = invokeEvent p =<< readProtoRef (stateTransitRef st) + continue st p = invokeEvent p $ traversePath (Just target) st + in Event $ \p -> + unless (null path1 && null path2) $ + do writeProtoRef (agentModeRef agent) TransientMode + forM_ path1 $ \st -> + do writeProtoRef (agentStateRef agent) (Just st) + deactivate st p + -- it makes all timeout and timer handlers outdated + modifyProtoRef (stateVersionRef st) (1 +) + forM_ path2 $ \st -> + do writeProtoRef (agentStateRef agent) (Just st) + activate st p + st' <- transit target p + case st' of + Nothing -> + do writeProtoRef (agentModeRef agent) ProcessingMode + triggerAgentStateChanged p agent + Just st' -> + continue st' p + +-- | Add to the state a timeout handler that will be actuated +-- in the specified time period if the state will remain active. +addTimeout :: MonadComp m => AgentState m -> Double -> Event m () -> Event m () +addTimeout st dt action = + Event $ \p -> + do v <- readProtoRef (stateVersionRef st) + let m1 = Event $ \p -> + do v' <- readProtoRef (stateVersionRef st) + when (v == v') $ + invokeEvent p action + m2 = enqueueEvent (pointTime p + dt) m1 + invokeEvent p m2 + +-- | Add to the state a timer handler that will be actuated +-- in the specified time period and then repeated again many times, +-- while the state remains active. +addTimer :: MonadComp m => AgentState m -> Event m Double -> Event m () -> Event m () +addTimer st dt action = + Event $ \p -> + do v <- readProtoRef (stateVersionRef st) + let m1 = Event $ \p -> + do v' <- readProtoRef (stateVersionRef st) + when (v == v') $ + do invokeEvent p m2 + invokeEvent p action + m2 = Event $ \p -> + do dt' <- invokeEvent p dt + invokeEvent p $ enqueueEvent (pointTime p + dt') m1 + invokeEvent p m2 + +-- | Create a new state. +newState :: MonadComp m => Agent m -> Simulation m (AgentState m) +newState agent = + Simulation $ \r -> + do let s = runSession r + aref <- newProtoRef s $ return () + dref <- newProtoRef s $ return () + tref <- newProtoRef s $ return Nothing + vref <- newProtoRef s 0 + mrkr <- newSessionMarker s + return AgentState { stateAgent = agent, + stateParent = Nothing, + stateMarker = mrkr, + stateActivateRef = aref, + stateDeactivateRef = dref, + stateTransitRef = tref, + stateVersionRef = vref } + +-- | Create a child state. +newSubstate :: MonadComp m => AgentState m -> Simulation m (AgentState m) +newSubstate parent = + Simulation $ \r -> + do let agent = stateAgent parent + s = runSession r + aref <- newProtoRef s $ return () + dref <- newProtoRef s $ return () + tref <- newProtoRef s $ return Nothing + vref <- newProtoRef s 0 + mrkr <- newSessionMarker s + return AgentState { stateAgent = agent, + stateParent = Just parent, + stateMarker = mrkr, + stateActivateRef= aref, + stateDeactivateRef = dref, + stateTransitRef = tref, + stateVersionRef = vref } + +-- | Create an agent. +newAgent :: MonadComp m => Simulation m (Agent m) +newAgent = + Simulation $ \r -> + do let s = runSession r + modeRef <- newProtoRef s CreationMode + stateRef <- newProtoRef s Nothing + stateChangedSource <- invokeSimulation r newSignalSource + mrkr <- newSessionMarker s + return Agent { agentMarker = mrkr, + agentModeRef = modeRef, + agentStateRef = stateRef, + agentStateChangedSource = stateChangedSource } + +-- | Return the selected active state. +selectedState :: MonadComp m => Agent m -> Event m (Maybe (AgentState m)) +selectedState agent = + Event $ \p -> readProtoRef (agentStateRef agent) + +-- | Select the state. The activation and selection are repeated while +-- there is the transition state defined by 'setStateTransition'. +selectState :: MonadComp m => AgentState m -> Event m () +selectState st = + Event $ \p -> + do let agent = stateAgent st + mode <- readProtoRef (agentModeRef agent) + case mode of + CreationMode -> + do x0 <- readProtoRef (agentStateRef agent) + invokeEvent p $ traversePath x0 st + TransientMode -> + error $ + "Use the setStateTransition function to define " ++ + "the transition state: activateState." + ProcessingMode -> + do x0 @ (Just st0) <- readProtoRef (agentStateRef agent) + invokeEvent p $ traversePath x0 st + +-- | Set the activation computation for the specified state. +setStateActivation :: MonadComp m => AgentState m -> Event m () -> Simulation m () +setStateActivation st action = + Simulation $ \r -> + writeProtoRef (stateActivateRef st) action + +-- | Set the deactivation computation for the specified state. +setStateDeactivation :: MonadComp m => AgentState m -> Event m () -> Simulation m () +setStateDeactivation st action = + Simulation $ \r -> + writeProtoRef (stateDeactivateRef st) action + +-- | Set the transition state which will be next and which is used only +-- when selecting the state directly with help of 'selectState'. +-- If the state was activated intermediately, when selecting +-- another state, then this computation is not used. +setStateTransition :: MonadComp m => AgentState m -> Event m (Maybe (AgentState m)) -> Simulation m () +setStateTransition st action = + Simulation $ \r -> + writeProtoRef (stateTransitRef st) action + +-- | Trigger the signal when the agent state changes. +triggerAgentStateChanged :: MonadComp m => Point m -> Agent m -> m () +triggerAgentStateChanged p agent = + do st <- readProtoRef (agentStateRef agent) + invokeEvent p $ triggerSignal (agentStateChangedSource agent) st + +-- | Return a signal that notifies about every change of the selected state. +selectedStateChanged :: Agent m -> Signal m (Maybe (AgentState m)) +selectedStateChanged agent = + publishSignal (agentStateChangedSource agent) + +-- | Return a signal that notifies about every change of the selected state. +selectedStateChanged_ :: MonadComp m => Agent m -> Signal m () +selectedStateChanged_ agent = + mapSignal (const ()) $ selectedStateChanged agent 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,84 +1,84 @@ - --- | --- Module : Simulation.Aivika.Trans.Arrival --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines the types and functions for working with the events --- that can represent something that arrive from outside the model, or --- represent other things which computation is delayed and hence is not synchronized. --- --- Therefore, the additional information is provided about the time and delay of arrival. - -module Simulation.Aivika.Trans.Arrival - (Arrival(..), - ArrivalTimer, - newArrivalTimer, - arrivalTimerProcessor, - arrivalProcessingTime, - arrivalProcessingTimeChanged, - arrivalProcessingTimeChanged_) where - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Simulation -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Event -import Simulation.Aivika.Trans.Processor -import Simulation.Aivika.Trans.Stream -import Simulation.Aivika.Trans.Statistics -import Simulation.Aivika.Trans.Ref -import Simulation.Aivika.Trans.Signal -import Simulation.Aivika.Arrival (Arrival(..)) - --- | Accumulates the statistics about that how long the arrived events are processed. -data ArrivalTimer m = - ArrivalTimer { arrivalProcessingTimeRef :: Ref m (SamplingStats Double), - arrivalProcessingTimeChangedSource :: SignalSource m () } - --- | Create a new timer that measures how long the arrived events are processed. -newArrivalTimer :: MonadComp m => Simulation m (ArrivalTimer m) -{-# INLINE newArrivalTimer #-} -newArrivalTimer = - do r <- newRef emptySamplingStats - s <- newSignalSource - return ArrivalTimer { arrivalProcessingTimeRef = r, - arrivalProcessingTimeChangedSource = s } - --- | Return the statistics about that how long the arrived events were processed. -arrivalProcessingTime :: MonadComp m => ArrivalTimer m -> Event m (SamplingStats Double) -{-# INLINE arrivalProcessingTime #-} -arrivalProcessingTime = readRef . arrivalProcessingTimeRef - --- | Return a signal raised when the the processing time statistics changes. -arrivalProcessingTimeChanged :: MonadComp m => ArrivalTimer m -> Signal m (SamplingStats Double) -{-# INLINE arrivalProcessingTimeChanged #-} -arrivalProcessingTimeChanged timer = - mapSignalM (const $ arrivalProcessingTime timer) (arrivalProcessingTimeChanged_ timer) - --- | Return a signal raised when the the processing time statistics changes. -arrivalProcessingTimeChanged_ :: MonadComp m => ArrivalTimer m -> Signal m () -{-# INLINE arrivalProcessingTimeChanged_ #-} -arrivalProcessingTimeChanged_ timer = - publishSignal (arrivalProcessingTimeChangedSource timer) - --- | Return a processor that actually measures how much time has passed from --- the time of arriving the events. -arrivalTimerProcessor :: MonadComp m => ArrivalTimer m -> Processor m (Arrival a) (Arrival a) -{-# INLINABLE arrivalTimerProcessor #-} -{-# SPECIALISE arrivalTimerProcessor :: ArrivalTimer IO -> Processor IO (Arrival a) (Arrival a) #-} -arrivalTimerProcessor timer = - Processor $ \xs -> Cons $ loop xs where - loop xs = - do (a, xs) <- runStream xs - liftEvent $ - do t <- liftDynamics time - modifyRef (arrivalProcessingTimeRef timer) $ - addSamplingStats (t - arrivalTime a) - triggerSignal (arrivalProcessingTimeChangedSource timer) () - return (a, Cons $ loop xs) + +-- | +-- Module : Simulation.Aivika.Trans.Arrival +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the types and functions for working with the events +-- that can represent something that arrive from outside the model, or +-- represent other things which computation is delayed and hence is not synchronized. +-- +-- Therefore, the additional information is provided about the time and delay of arrival. + +module Simulation.Aivika.Trans.Arrival + (Arrival(..), + ArrivalTimer, + newArrivalTimer, + arrivalTimerProcessor, + arrivalProcessingTime, + arrivalProcessingTimeChanged, + arrivalProcessingTimeChanged_) where + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Event +import Simulation.Aivika.Trans.Processor +import Simulation.Aivika.Trans.Stream +import Simulation.Aivika.Trans.Statistics +import Simulation.Aivika.Trans.Ref +import Simulation.Aivika.Trans.Signal +import Simulation.Aivika.Arrival (Arrival(..)) + +-- | Accumulates the statistics about that how long the arrived events are processed. +data ArrivalTimer m = + ArrivalTimer { arrivalProcessingTimeRef :: Ref m (SamplingStats Double), + arrivalProcessingTimeChangedSource :: SignalSource m () } + +-- | Create a new timer that measures how long the arrived events are processed. +newArrivalTimer :: MonadComp m => Simulation m (ArrivalTimer m) +{-# INLINE newArrivalTimer #-} +newArrivalTimer = + do r <- newRef emptySamplingStats + s <- newSignalSource + return ArrivalTimer { arrivalProcessingTimeRef = r, + arrivalProcessingTimeChangedSource = s } + +-- | Return the statistics about that how long the arrived events were processed. +arrivalProcessingTime :: MonadComp m => ArrivalTimer m -> Event m (SamplingStats Double) +{-# INLINE arrivalProcessingTime #-} +arrivalProcessingTime = readRef . arrivalProcessingTimeRef + +-- | Return a signal raised when the the processing time statistics changes. +arrivalProcessingTimeChanged :: MonadComp m => ArrivalTimer m -> Signal m (SamplingStats Double) +{-# INLINE arrivalProcessingTimeChanged #-} +arrivalProcessingTimeChanged timer = + mapSignalM (const $ arrivalProcessingTime timer) (arrivalProcessingTimeChanged_ timer) + +-- | Return a signal raised when the the processing time statistics changes. +arrivalProcessingTimeChanged_ :: MonadComp m => ArrivalTimer m -> Signal m () +{-# INLINE arrivalProcessingTimeChanged_ #-} +arrivalProcessingTimeChanged_ timer = + publishSignal (arrivalProcessingTimeChangedSource timer) + +-- | Return a processor that actually measures how much time has passed from +-- the time of arriving the events. +arrivalTimerProcessor :: MonadComp m => ArrivalTimer m -> Processor m (Arrival a) (Arrival a) +{-# INLINABLE arrivalTimerProcessor #-} +{-# SPECIALISE arrivalTimerProcessor :: ArrivalTimer IO -> Processor IO (Arrival a) (Arrival a) #-} +arrivalTimerProcessor timer = + Processor $ \xs -> Cons $ loop xs where + loop xs = + do (a, xs) <- runStream xs + liftEvent $ + do t <- liftDynamics time + modifyRef (arrivalProcessingTimeRef timer) $ + addSamplingStats (t - arrivalTime a) + triggerSignal (arrivalProcessingTimeChangedSource timer) () + return (a, Cons $ loop xs) diff --git a/Simulation/Aivika/Trans/Circuit.hs b/Simulation/Aivika/Trans/Circuit.hs --- a/Simulation/Aivika/Trans/Circuit.hs +++ b/Simulation/Aivika/Trans/Circuit.hs @@ -1,385 +1,501 @@ - -{-# LANGUAGE RecursiveDo, Arrows #-} - --- | --- Module : Simulation.Aivika.Trans.Circuit --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It represents a circuit synchronized with the event queue. --- Also it allows creating the recursive links with help of --- the proc-notation. --- --- The implementation is based on the . --- -module Simulation.Aivika.Trans.Circuit - (-- * The Circuit Arrow - Circuit(..), - -- * Circuit Primitives - arrCircuit, - accumCircuit, - -- * The Arrival Circuit - arrivalCircuit, - -- * Delaying the Circuit - delayCircuit, - -- * The Time Circuit - timeCircuit, - -- * Conditional Computation - (?>), - filterCircuit, - filterCircuitM, - neverCircuit, - -- * Converting to Signals and Processors - circuitSignaling, - circuitProcessor, - -- * Integrals and Difference Equations - integCircuit, - sumCircuit, - -- * The Circuit Transform - circuitTransform) where - -import qualified Control.Category as C -import Control.Arrow -import Control.Monad.Fix - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Dynamics -import Simulation.Aivika.Trans.Internal.Event -import Simulation.Aivika.Trans.Dynamics.Memo -import Simulation.Aivika.Trans.Transform -import Simulation.Aivika.Trans.SystemDynamics -import Simulation.Aivika.Trans.Signal -import Simulation.Aivika.Trans.Stream -import Simulation.Aivika.Trans.Processor -import Simulation.Aivika.Arrival (Arrival(..)) - --- | Represents a circuit synchronized with the event queue. --- Besides, it allows creating the recursive links with help of --- the proc-notation. --- -newtype Circuit m a b = - Circuit { runCircuit :: a -> Event m (b, Circuit m a b) - -- ^ Run the circuit. - } - -instance MonadComp m => C.Category (Circuit m) where - - id = Circuit $ \a -> return (a, C.id) - - (.) = dot - where - (Circuit g) `dot` (Circuit f) = - Circuit $ \a -> - Event $ \p -> - do (b, cir1) <- invokeEvent p (f a) - (c, cir2) <- invokeEvent p (g b) - return (c, cir2 `dot` cir1) - -instance MonadComp m => Arrow (Circuit m) where - - arr f = Circuit $ \a -> return (f a, arr f) - - first (Circuit f) = - Circuit $ \(b, d) -> - Event $ \p -> - do (c, cir) <- invokeEvent p (f b) - return ((c, d), first cir) - - second (Circuit f) = - Circuit $ \(d, b) -> - Event $ \p -> - do (c, cir) <- invokeEvent p (f b) - return ((d, c), second cir) - - (Circuit f) *** (Circuit g) = - Circuit $ \(b, b') -> - Event $ \p -> - do (c, cir1) <- invokeEvent p (f b) - (c', cir2) <- invokeEvent p (g b') - return ((c, c'), cir1 *** cir2) - - (Circuit f) &&& (Circuit g) = - Circuit $ \b -> - Event $ \p -> - do (c, cir1) <- invokeEvent p (f b) - (c', cir2) <- invokeEvent p (g b) - return ((c, c'), cir1 &&& cir2) - -instance (MonadComp m, MonadFix m) => ArrowLoop (Circuit m) where - - loop (Circuit f) = - Circuit $ \b -> - Event $ \p -> - do rec ((c, d), cir) <- invokeEvent p (f (b, d)) - return (c, loop cir) - -instance MonadComp m => ArrowChoice (Circuit m) where - - left x@(Circuit f) = - Circuit $ \ebd -> - Event $ \p -> - case ebd of - Left b -> - do (c, cir) <- invokeEvent p (f b) - return (Left c, left cir) - Right d -> - return (Right d, left x) - - right x@(Circuit f) = - Circuit $ \edb -> - Event $ \p -> - case edb of - Right b -> - do (c, cir) <- invokeEvent p (f b) - return (Right c, right cir) - Left d -> - return (Left d, right x) - - x@(Circuit f) +++ y@(Circuit g) = - Circuit $ \ebb' -> - Event $ \p -> - case ebb' of - Left b -> - do (c, cir1) <- invokeEvent p (f b) - return (Left c, cir1 +++ y) - Right b' -> - do (c', cir2) <- invokeEvent p (g b') - return (Right c', x +++ cir2) - - x@(Circuit f) ||| y@(Circuit g) = - Circuit $ \ebc -> - Event $ \p -> - case ebc of - Left b -> - do (d, cir1) <- invokeEvent p (f b) - return (d, cir1 ||| y) - Right b' -> - do (d, cir2) <- invokeEvent p (g b') - return (d, x ||| cir2) - --- | Get a signal transform by the specified circuit. -circuitSignaling :: MonadComp m => Circuit m a b -> Signal m a -> Signal m b -circuitSignaling (Circuit cir) sa = - Signal { handleSignal = \f -> - Event $ \p -> - do let s = runSession (pointRun p) - r <- newProtoRef s cir - invokeEvent p $ - handleSignal sa $ \a -> - Event $ \p -> - do cir <- readProtoRef r - (b, Circuit cir') <- invokeEvent p (cir a) - writeProtoRef r cir' - invokeEvent p (f b) } - --- | Transform the circuit to a processor. -circuitProcessor :: MonadComp m => Circuit m a b -> Processor m a b -circuitProcessor (Circuit cir) = Processor $ \sa -> - Cons $ - do (a, xs) <- runStream sa - (b, cir') <- liftEvent (cir a) - let f = runProcessor (circuitProcessor cir') - return (b, f xs) - --- | Create a simple circuit by the specified handling function --- that runs the computation for each input value to get an output. -arrCircuit :: MonadComp m => (a -> Event m b) -> Circuit m a b -arrCircuit f = - let x = - Circuit $ \a -> - Event $ \p -> - do b <- invokeEvent p (f a) - return (b, x) - in x - --- | Accumulator that outputs a value determined by the supplied function. -accumCircuit :: MonadComp m => (acc -> a -> Event m (acc, b)) -> acc -> Circuit m a b -accumCircuit f acc = - Circuit $ \a -> - Event $ \p -> - do (acc', b) <- invokeEvent p (f acc a) - return (b, accumCircuit f acc') - --- | A circuit that adds the information about the time points at which --- the values were received. -arrivalCircuit :: MonadComp m => Circuit m a (Arrival a) -arrivalCircuit = - let loop t0 = - Circuit $ \a -> - Event $ \p -> - let t = pointTime p - b = Arrival { arrivalValue = a, - arrivalTime = t, - arrivalDelay = - case t0 of - Nothing -> Nothing - Just t0 -> Just (t - t0) } - in return (b, loop $ Just t) - in loop Nothing - --- | Delay the input by one step using the specified initial value. -delayCircuit :: MonadComp m => a -> Circuit m a a -delayCircuit a0 = - Circuit $ \a -> - return (a0, delayCircuit a) - --- | A circuit that returns the current modeling time. -timeCircuit :: MonadComp m => Circuit m a Double -timeCircuit = - Circuit $ \a -> - Event $ \p -> - return (pointTime p, timeCircuit) - --- | Like '>>>' but processes only the represented events. -(>?>) :: MonadComp m - => Circuit m a (Maybe b) - -- ^ whether there is an event - -> Circuit m b c - -- ^ process the event if it presents - -> Circuit m a (Maybe c) - -- ^ the resulting circuit that processes only the represented events -whether >?> process = - Circuit $ \a -> - Event $ \p -> - do (b, whether') <- invokeEvent p (runCircuit whether a) - case b of - Nothing -> - return (Nothing, whether' >?> process) - Just b -> - do (c, process') <- invokeEvent p (runCircuit process b) - return (Just c, whether' >?> process') - --- | Like '<<<' but processes only the represented events. -( Circuit m b c - -- ^ process the event if it presents - -> Circuit m a (Maybe b) - -- ^ whether there is an event - -> Circuit m a (Maybe c) - -- ^ the resulting circuit that processes only the represented events -(?>) - --- | Filter the circuit, calculating only those parts of the circuit that satisfy --- the specified predicate. -filterCircuit :: MonadComp m => (a -> Bool) -> Circuit m a b -> Circuit m a (Maybe b) -filterCircuit pred = filterCircuitM (return . pred) - --- | Filter the circuit within the 'Event' computation, calculating only those parts --- of the circuit that satisfy the specified predicate. -filterCircuitM :: MonadComp m => (a -> Event m Bool) -> Circuit m a b -> Circuit m a (Maybe b) -filterCircuitM pred cir = - Circuit $ \a -> - Event $ \p -> - do x <- invokeEvent p (pred a) - if x - then do (b, cir') <- invokeEvent p (runCircuit cir a) - return (Just b, filterCircuitM pred cir') - else return (Nothing, filterCircuitM pred cir) - --- | The source of events that never occur. -neverCircuit :: MonadComp m => Circuit m a (Maybe b) -neverCircuit = - Circuit $ \a -> return (Nothing, neverCircuit) - --- | An approximation of the integral using Euler's method. --- --- This function can be rather inaccurate as it depends on --- the time points at wich the 'Circuit' computation is actuated. --- Also Euler's method per se is not most accurate, although simple --- enough for implementation. --- --- Consider using the 'integ' function whenever possible. --- That function can integrate with help of the Runge-Kutta method by --- the specified integration time points that are passed in the simulation --- specs to every 'Simulation', when running the model. --- --- At the same time, the 'integCircuit' function has no mutable state --- unlike the former. The latter consumes less memory but at the cost --- of inaccuracy and relatively more slow simulation, had we requested --- the integral in the same time points. --- --- Regarding the recursive equations, the both functions allow defining them --- but whithin different computations (either with help of the recursive --- do-notation or the proc-notation). -integCircuit :: MonadComp m - => Double - -- ^ the initial value - -> Circuit m Double Double - -- ^ map the derivative to an integral -integCircuit init = start - where - start = - Circuit $ \a -> - Event $ \p -> - do let t = pointTime p - return (init, next t init a) - next t0 v0 a0 = - Circuit $ \a -> - Event $ \p -> - do let t = pointTime p - dt = t - t0 - v = v0 + a0 * dt - v `seq` return (v, next t v a) - --- | A sum of differences starting from the specified initial value. --- --- Consider using the more accurate 'diffsum' function whener possible as --- it is calculated in every integration time point specified by specs --- passed in to every 'Simulation', when running the model. --- --- At the same time, the 'sumCircuit' function has no mutable state and --- it consumes less memory than the former. --- --- Regarding the recursive equations, the both functions allow defining them --- but whithin different computations (either with help of the recursive --- do-notation or the proc-notation). -sumCircuit :: (MonadComp m, Num a) => - a - -- ^ the initial value - -> Circuit m a a - -- ^ map the difference to a sum -sumCircuit init = start - where - start = - Circuit $ \a -> - Event $ \p -> - return (init, next init a) - next v0 a0 = - Circuit $ \a -> - Event $ \p -> - do let v = v0 + a0 - v `seq` return (v, next v a) - --- | Approximate the circuit as a transform of time varying function, --- calculating the values in the integration time points and then --- interpolating in all other time points. The resulting transform --- computation is synchronized with the event queue. --- --- This procedure consumes memory as the underlying memoization allocates --- an array to store the calculated values. -circuitTransform :: MonadComp m => Circuit m a b -> Transform m a b -circuitTransform cir = Transform start - where - start m = - Simulation $ \r -> - do let s = runSession r - ref <- newProtoRef s cir - invokeSimulation r $ - memo0Dynamics (next ref m) - next ref m = - Dynamics $ \p -> - do a <- invokeDynamics p m - cir <- readProtoRef ref - (b, cir') <- - invokeDynamics p $ - runEvent (runCircuit cir a) - writeProtoRef ref cir' - return b + +{-# LANGUAGE RecursiveDo, Arrows #-} + +-- | +-- Module : Simulation.Aivika.Trans.Circuit +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It represents a circuit synchronized with the event queue. +-- Also it allows creating the recursive links with help of +-- the proc-notation. +-- +-- The implementation is based on the . +-- +module Simulation.Aivika.Trans.Circuit + (-- * The Circuit Arrow + Circuit(..), + iterateCircuitInIntegTimes, + iterateCircuitInIntegTimes_, + iterateCircuitInTimes, + iterateCircuitInTimes_, + -- * Circuit Primitives + arrCircuit, + accumCircuit, + -- * The Arrival Circuit + arrivalCircuit, + -- * Delaying the Circuit + delayCircuit, + -- * The Time Circuit + timeCircuit, + -- * Conditional Computation + (?>), + filterCircuit, + filterCircuitM, + neverCircuit, + -- * Converting to Signals and Processors + circuitSignaling, + circuitProcessor, + -- * Integrals and Difference Equations + integCircuit, + integCircuitEither, + sumCircuit, + sumCircuitEither, + -- * The Circuit Transform + circuitTransform) where + +import qualified Control.Category as C +import Control.Arrow +import Control.Monad.Fix + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Dynamics.Memo +import Simulation.Aivika.Trans.Transform +import Simulation.Aivika.Trans.SystemDynamics +import Simulation.Aivika.Trans.Signal +import Simulation.Aivika.Trans.Stream +import Simulation.Aivika.Trans.Process +import Simulation.Aivika.Trans.Processor +import Simulation.Aivika.Trans.Task +import Simulation.Aivika.Arrival (Arrival(..)) + +-- | Represents a circuit synchronized with the event queue. +-- Besides, it allows creating the recursive links with help of +-- the proc-notation. +-- +newtype Circuit m a b = + Circuit { runCircuit :: a -> Event m (b, Circuit m a b) + -- ^ Run the circuit. + } + +instance MonadComp m => C.Category (Circuit m) where + + id = Circuit $ \a -> return (a, C.id) + + (.) = dot + where + (Circuit g) `dot` (Circuit f) = + Circuit $ \a -> + Event $ \p -> + do (b, cir1) <- invokeEvent p (f a) + (c, cir2) <- invokeEvent p (g b) + return (c, cir2 `dot` cir1) + +instance MonadComp m => Arrow (Circuit m) where + + arr f = Circuit $ \a -> return (f a, arr f) + + first (Circuit f) = + Circuit $ \(b, d) -> + Event $ \p -> + do (c, cir) <- invokeEvent p (f b) + return ((c, d), first cir) + + second (Circuit f) = + Circuit $ \(d, b) -> + Event $ \p -> + do (c, cir) <- invokeEvent p (f b) + return ((d, c), second cir) + + (Circuit f) *** (Circuit g) = + Circuit $ \(b, b') -> + Event $ \p -> + do (c, cir1) <- invokeEvent p (f b) + (c', cir2) <- invokeEvent p (g b') + return ((c, c'), cir1 *** cir2) + + (Circuit f) &&& (Circuit g) = + Circuit $ \b -> + Event $ \p -> + do (c, cir1) <- invokeEvent p (f b) + (c', cir2) <- invokeEvent p (g b) + return ((c, c'), cir1 &&& cir2) + +instance (MonadComp m, MonadFix m) => ArrowLoop (Circuit m) where + + loop (Circuit f) = + Circuit $ \b -> + Event $ \p -> + do rec ((c, d), cir) <- invokeEvent p (f (b, d)) + return (c, loop cir) + +instance MonadComp m => ArrowChoice (Circuit m) where + + left x@(Circuit f) = + Circuit $ \ebd -> + Event $ \p -> + case ebd of + Left b -> + do (c, cir) <- invokeEvent p (f b) + return (Left c, left cir) + Right d -> + return (Right d, left x) + + right x@(Circuit f) = + Circuit $ \edb -> + Event $ \p -> + case edb of + Right b -> + do (c, cir) <- invokeEvent p (f b) + return (Right c, right cir) + Left d -> + return (Left d, right x) + + x@(Circuit f) +++ y@(Circuit g) = + Circuit $ \ebb' -> + Event $ \p -> + case ebb' of + Left b -> + do (c, cir1) <- invokeEvent p (f b) + return (Left c, cir1 +++ y) + Right b' -> + do (c', cir2) <- invokeEvent p (g b') + return (Right c', x +++ cir2) + + x@(Circuit f) ||| y@(Circuit g) = + Circuit $ \ebc -> + Event $ \p -> + case ebc of + Left b -> + do (d, cir1) <- invokeEvent p (f b) + return (d, cir1 ||| y) + Right b' -> + do (d, cir2) <- invokeEvent p (g b') + return (d, x ||| cir2) + +-- | Get a signal transform by the specified circuit. +circuitSignaling :: MonadComp m => Circuit m a b -> Signal m a -> Signal m b +circuitSignaling (Circuit cir) sa = + Signal { handleSignal = \f -> + Event $ \p -> + do let s = runSession (pointRun p) + r <- newProtoRef s cir + invokeEvent p $ + handleSignal sa $ \a -> + Event $ \p -> + do cir <- readProtoRef r + (b, Circuit cir') <- invokeEvent p (cir a) + writeProtoRef r cir' + invokeEvent p (f b) } + +-- | Transform the circuit to a processor. +circuitProcessor :: MonadComp m => Circuit m a b -> Processor m a b +circuitProcessor (Circuit cir) = Processor $ \sa -> + Cons $ + do (a, xs) <- runStream sa + (b, cir') <- liftEvent (cir a) + let f = runProcessor (circuitProcessor cir') + return (b, f xs) + +-- | Create a simple circuit by the specified handling function +-- that runs the computation for each input value to get an output. +arrCircuit :: MonadComp m => (a -> Event m b) -> Circuit m a b +arrCircuit f = + let x = + Circuit $ \a -> + Event $ \p -> + do b <- invokeEvent p (f a) + return (b, x) + in x + +-- | Accumulator that outputs a value determined by the supplied function. +accumCircuit :: MonadComp m => (acc -> a -> Event m (acc, b)) -> acc -> Circuit m a b +accumCircuit f acc = + Circuit $ \a -> + Event $ \p -> + do (acc', b) <- invokeEvent p (f acc a) + return (b, accumCircuit f acc') + +-- | A circuit that adds the information about the time points at which +-- the values were received. +arrivalCircuit :: MonadComp m => Circuit m a (Arrival a) +arrivalCircuit = + let loop t0 = + Circuit $ \a -> + Event $ \p -> + let t = pointTime p + b = Arrival { arrivalValue = a, + arrivalTime = t, + arrivalDelay = + case t0 of + Nothing -> Nothing + Just t0 -> Just (t - t0) } + in return (b, loop $ Just t) + in loop Nothing + +-- | Delay the input by one step using the specified initial value. +delayCircuit :: MonadComp m => a -> Circuit m a a +delayCircuit a0 = + Circuit $ \a -> + return (a0, delayCircuit a) + +-- | A circuit that returns the current modeling time. +timeCircuit :: MonadComp m => Circuit m a Double +timeCircuit = + Circuit $ \a -> + Event $ \p -> + return (pointTime p, timeCircuit) + +-- | Like '>>>' but processes only the represented events. +(>?>) :: MonadComp m + => Circuit m a (Maybe b) + -- ^ whether there is an event + -> Circuit m b c + -- ^ process the event if it presents + -> Circuit m a (Maybe c) + -- ^ the resulting circuit that processes only the represented events +whether >?> process = + Circuit $ \a -> + Event $ \p -> + do (b, whether') <- invokeEvent p (runCircuit whether a) + case b of + Nothing -> + return (Nothing, whether' >?> process) + Just b -> + do (c, process') <- invokeEvent p (runCircuit process b) + return (Just c, whether' >?> process') + +-- | Like '<<<' but processes only the represented events. +( Circuit m b c + -- ^ process the event if it presents + -> Circuit m a (Maybe b) + -- ^ whether there is an event + -> Circuit m a (Maybe c) + -- ^ the resulting circuit that processes only the represented events +(?>) + +-- | Filter the circuit, calculating only those parts of the circuit that satisfy +-- the specified predicate. +filterCircuit :: MonadComp m => (a -> Bool) -> Circuit m a b -> Circuit m a (Maybe b) +filterCircuit pred = filterCircuitM (return . pred) + +-- | Filter the circuit within the 'Event' computation, calculating only those parts +-- of the circuit that satisfy the specified predicate. +filterCircuitM :: MonadComp m => (a -> Event m Bool) -> Circuit m a b -> Circuit m a (Maybe b) +filterCircuitM pred cir = + Circuit $ \a -> + Event $ \p -> + do x <- invokeEvent p (pred a) + if x + then do (b, cir') <- invokeEvent p (runCircuit cir a) + return (Just b, filterCircuitM pred cir') + else return (Nothing, filterCircuitM pred cir) + +-- | The source of events that never occur. +neverCircuit :: MonadComp m => Circuit m a (Maybe b) +neverCircuit = + Circuit $ \a -> return (Nothing, neverCircuit) + +-- | An approximation of the integral using Euler's method. +-- +-- This function can be rather inaccurate as it depends on +-- the time points at wich the 'Circuit' computation is actuated. +-- Also Euler's method per se is not most accurate, although simple +-- enough for implementation. +-- +-- Consider using the 'integ' function whenever possible. +-- That function can integrate with help of the Runge-Kutta method by +-- the specified integration time points that are passed in the simulation +-- specs to every 'Simulation', when running the model. +-- +-- At the same time, the 'integCircuit' function has no mutable state +-- unlike the former. The latter consumes less memory but at the cost +-- of inaccuracy and relatively more slow simulation, had we requested +-- the integral in the same time points. +-- +-- Regarding the recursive equations, the both functions allow defining them +-- but whithin different computations (either with help of the recursive +-- do-notation or the proc-notation). +integCircuit :: MonadComp m + => Double + -- ^ the initial value + -> Circuit m Double Double + -- ^ map the derivative to an integral +integCircuit init = start + where + start = + Circuit $ \a -> + Event $ \p -> + do let t = pointTime p + return (init, next t init a) + next t0 v0 a0 = + Circuit $ \a -> + Event $ \p -> + do let t = pointTime p + dt = t - t0 + v = v0 + a0 * dt + v `seq` return (v, next t v a) + +-- | Like 'integCircuit' but allows either setting a new 'Left' integral value, +-- or using the 'Right' derivative when integrating by Euler's method. +integCircuitEither :: MonadComp m + => Double + -- ^ the initial value + -> Circuit m (Either Double Double) Double + -- ^ map either a new 'Left' value or + -- the 'Right' derivative to an integral +integCircuitEither init = start + where + start = + Circuit $ \a -> + Event $ \p -> + do let t = pointTime p + return (init, next t init a) + next t0 v0 a0 = + Circuit $ \a -> + Event $ \p -> + do let t = pointTime p + case a0 of + Left v -> + v `seq` return (v, next t v a) + Right a0 -> do + let dt = t - t0 + v = v0 + a0 * dt + v `seq` return (v, next t v a) + +-- | A sum of differences starting from the specified initial value. +-- +-- Consider using the more accurate 'diffsum' function whener possible as +-- it is calculated in every integration time point specified by specs +-- passed in to every 'Simulation', when running the model. +-- +-- At the same time, the 'sumCircuit' function has no mutable state and +-- it consumes less memory than the former. +-- +-- Regarding the recursive equations, the both functions allow defining them +-- but whithin different computations (either with help of the recursive +-- do-notation or the proc-notation). +sumCircuit :: (MonadComp m, Num a) + => a + -- ^ the initial value + -> Circuit m a a + -- ^ map the difference to a sum +sumCircuit init = start + where + start = + Circuit $ \a -> + Event $ \p -> + return (init, next init a) + next v0 a0 = + Circuit $ \a -> + Event $ \p -> + do let v = v0 + a0 + v `seq` return (v, next v a) + +-- | Like 'sumCircuit' but allows either setting a new 'Left' value for the sum, or updating it +-- by specifying the 'Right' difference. +sumCircuitEither :: (MonadComp m, Num a) + => a + -- ^ the initial value + -> Circuit m (Either a a) a + -- ^ map either a new 'Left' value or + -- the 'Right' difference to a sum +sumCircuitEither init = start + where + start = + Circuit $ \a -> + Event $ \p -> + return (init, next init a) + next v0 a0 = + Circuit $ \a -> + Event $ \p -> + case a0 of + Left v -> + v `seq` return (v, next v a) + Right a0 -> do + let v = v0 + a0 + v `seq` return (v, next v a) + +-- | Approximate the circuit as a transform of time varying function, +-- calculating the values in the integration time points and then +-- interpolating in all other time points. The resulting transform +-- computation is synchronized with the event queue. +-- +-- This procedure consumes memory as the underlying memoization allocates +-- an array to store the calculated values. +circuitTransform :: MonadComp m => Circuit m a b -> Transform m a b +circuitTransform cir = Transform start + where + start m = + Simulation $ \r -> + do let s = runSession r + ref <- newProtoRef s cir + invokeSimulation r $ + memo0Dynamics (next ref m) + next ref m = + Dynamics $ \p -> + do a <- invokeDynamics p m + cir <- readProtoRef ref + (b, cir') <- + invokeDynamics p $ + runEvent (runCircuit cir a) + writeProtoRef ref cir' + return b + +-- | Iterate the circuit in the specified time points. +iterateCircuitInPoints_ :: MonadComp m => [Point m] -> Circuit m a a -> a -> Event m () +iterateCircuitInPoints_ [] cir a = return () +iterateCircuitInPoints_ (p : ps) cir a = + enqueueEvent (pointTime p) $ + Event $ \p' -> + do (a', cir') <- invokeEvent p $ runCircuit cir a + invokeEvent p $ iterateCircuitInPoints_ ps cir' a' + +-- | Iterate the circuit in the specified time points returning a task +-- which completes after the final output of the circuit is received. +iterateCircuitInPoints :: MonadComp m => [Point m] -> Circuit m a a -> a -> Event m (Task m a) +iterateCircuitInPoints ps cir a = + do let loop [] cir a source = triggerSignal source a + loop (p : ps) cir a source = + enqueueEvent (pointTime p) $ + Event $ \p' -> + do (a', cir') <- invokeEvent p $ runCircuit cir a + invokeEvent p $ loop ps cir' a' source + source <- liftSimulation newSignalSource + loop ps cir a source + runTask $ processAwait $ publishSignal source + +-- | Iterate the circuit in the integration time points. +iterateCircuitInIntegTimes_ :: MonadComp m => Circuit m a a -> a -> Event m () +iterateCircuitInIntegTimes_ cir a = + Event $ \p -> + do let ps = integPoints $ pointRun p + invokeEvent p $ + iterateCircuitInPoints_ ps cir a + +-- | Iterate the circuit in the specified time points. +iterateCircuitInTimes_ :: MonadComp m => [Double] -> Circuit m a a -> a -> Event m () +iterateCircuitInTimes_ ts cir a = + Event $ \p -> + do let ps = map (pointAt $ pointRun p) ts + invokeEvent p $ + iterateCircuitInPoints_ ps cir a + +-- | Iterate the circuit in the integration time points returning a task +-- which completes after the final output of the circuit is received. +iterateCircuitInIntegTimes :: MonadComp m => Circuit m a a -> a -> Event m (Task m a) +iterateCircuitInIntegTimes cir a = + Event $ \p -> + do let ps = integPoints $ pointRun p + invokeEvent p $ + iterateCircuitInPoints ps cir a + +-- | Iterate the circuit in the specified time points returning a task +-- which completes after the final output of the circuit is received. +iterateCircuitInTimes :: MonadComp m => [Double] -> Circuit m a a -> a -> Event m (Task m a) +iterateCircuitInTimes ts cir a = + Event $ \p -> + do let ps = map (pointAt $ pointRun p) ts + invokeEvent p $ + iterateCircuitInPoints ps cir a diff --git a/Simulation/Aivika/Trans/Comp.hs b/Simulation/Aivika/Trans/Comp.hs --- a/Simulation/Aivika/Trans/Comp.hs +++ b/Simulation/Aivika/Trans/Comp.hs @@ -1,52 +1,52 @@ - -{-# LANGUAGE FlexibleContexts #-} - --- | --- Module : Simulation.Aivika.Trans.Comp --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It defines a type class of monads based on which the simulation monads can be built. --- -module Simulation.Aivika.Trans.Comp - (ProtoMonadComp(..), - MonadComp(..), - MonadCompTrans(..)) where - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Trans.Exception -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.ProtoArray -import Simulation.Aivika.Trans.Unboxed -import Simulation.Aivika.Trans.Generator -import Simulation.Aivika.Trans.Internal.Specs - --- | A prototype of the type class of monads based on which the simulation monads can be built. -class (Monad m, - ExceptionHandling m, - SessionMonad m, - ProtoRefMonad m, - ProtoArrayMonad m, - Unboxed m Double, - Unboxed m Float, - Unboxed m Int, - GeneratorMonad m) => ProtoMonadComp m - --- | Such a prototype monad that allows enqueueing events. -class (ProtoMonadComp m, EventQueueing m) => MonadComp m - --- | A variant of the standard 'MonadTrans' type class with one difference: --- the computation that will be lifted into another must be 'MonadComp' instead of --- more general and less restricted 'Monad'. -class MonadCompTrans t where - - -- | Lift the underlying computation into another within simulation. - liftComp :: MonadComp m => m a -> t m a - -instance ProtoMonadComp IO + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.Comp +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It defines a type class of monads based on which the simulation monads can be built. +-- +module Simulation.Aivika.Trans.Comp + (ProtoMonadComp(..), + MonadComp(..), + MonadCompTrans(..)) where + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Exception +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.ProtoArray +import Simulation.Aivika.Trans.Unboxed +import Simulation.Aivika.Trans.Generator +import Simulation.Aivika.Trans.Internal.Specs + +-- | A prototype of the type class of monads based on which the simulation monads can be built. +class (Monad m, + ExceptionHandling m, + SessionMonad m, + ProtoRefMonad m, + ProtoArrayMonad m, + Unboxed m Double, + Unboxed m Float, + Unboxed m Int, + GeneratorMonad m) => ProtoMonadComp m + +-- | Such a prototype monad that allows enqueueing events. +class (ProtoMonadComp m, EventQueueing m) => MonadComp m + +-- | A variant of the standard 'MonadTrans' type class with one difference: +-- the computation that will be lifted into another must be 'MonadComp' instead of +-- more general and less restricted 'Monad'. +class MonadCompTrans t where + + -- | Lift the underlying computation into another within simulation. + liftComp :: MonadComp m => m a -> t m a + +instance ProtoMonadComp IO diff --git a/Simulation/Aivika/Trans/Comp/IO.hs b/Simulation/Aivika/Trans/Comp/IO.hs --- a/Simulation/Aivika/Trans/Comp/IO.hs +++ b/Simulation/Aivika/Trans/Comp/IO.hs @@ -1,128 +1,128 @@ - -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Simulation.Aivika.Trans.Comp.IO --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines the event queue within monad 'IO'. --- -module Simulation.Aivika.Trans.Comp.IO() where - -import Control.Monad - -import qualified Simulation.Aivika.Trans.PriorityQueue as PQ - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs - -instance EventQueueing IO where - - data EventQueue IO = - EventQueue { queuePQ :: PQ.PriorityQueue IO (Point IO -> IO ()), - -- ^ the underlying priority queue - queueBusy :: ProtoRef IO Bool, - -- ^ whether the queue is currently processing events - queueTime :: ProtoRef IO Double - -- ^ the actual time of the event queue - } - - newEventQueue session specs = - do f <- newProtoRef session False - t <- newProtoRef session $ spcStartTime specs - pq <- PQ.newQueue session - return EventQueue { queuePQ = pq, - queueBusy = f, - queueTime = t } - - enqueueEvent t (Event m) = - Event $ \p -> - let pq = queuePQ $ runEventQueue $ pointRun p - in PQ.enqueue pq t m - - runEventWith processing (Event e) = - Dynamics $ \p -> - do invokeDynamics p $ processEvents processing - e p - - eventQueueCount = - Event $ PQ.queueCount . queuePQ . runEventQueue . pointRun - -instance MonadComp IO - --- | Process the pending events. -processPendingEventsCore :: Bool -> Dynamics IO () -processPendingEventsCore includingCurrentEvents = Dynamics r where - r p = - do let q = runEventQueue $ pointRun p - f = queueBusy q - f' <- readProtoRef f - unless f' $ - do writeProtoRef f True - call q p - writeProtoRef f False - call q p = - do let pq = queuePQ q - r = pointRun p - f <- PQ.queueNull pq - unless f $ - do (t2, c2) <- PQ.queueFront pq - let t = queueTime q - t' <- readProtoRef t - when (t2 < t') $ - error "The time value is too small: processPendingEventsCore" - when ((t2 < pointTime p) || - (includingCurrentEvents && (t2 == pointTime p))) $ - do writeProtoRef t t2 - PQ.dequeue pq - let sc = pointSpecs p - t0 = spcStartTime sc - dt = spcDT sc - n2 = fromIntegral $ floor ((t2 - t0) / dt) - c2 $ p { pointTime = t2, - pointIteration = n2, - pointPhase = -1 } - call q p - --- | Process the pending events synchronously, i.e. without past. -processPendingEvents :: Bool -> Dynamics IO () -processPendingEvents includingCurrentEvents = Dynamics r where - r p = - do let q = runEventQueue $ pointRun p - t = queueTime q - t' <- readProtoRef t - if pointTime p < t' - then error $ - "The current time is less than " ++ - "the time in the queue: processPendingEvents" - else invokeDynamics p m - m = processPendingEventsCore includingCurrentEvents - --- | A memoized value. -processEventsIncludingCurrent :: Dynamics IO () -processEventsIncludingCurrent = processPendingEvents True - --- | A memoized value. -processEventsIncludingEarlier :: Dynamics IO () -processEventsIncludingEarlier = processPendingEvents False - --- | A memoized value. -processEventsIncludingCurrentCore :: Dynamics IO () -processEventsIncludingCurrentCore = processPendingEventsCore True - --- | A memoized value. -processEventsIncludingEarlierCore :: Dynamics IO () -processEventsIncludingEarlierCore = processPendingEventsCore True - --- | Process the events. -processEvents :: EventProcessing -> Dynamics IO () -processEvents CurrentEvents = processEventsIncludingCurrent -processEvents EarlierEvents = processEventsIncludingEarlier -processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore -processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore + +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Simulation.Aivika.Trans.Comp.IO +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the event queue within monad 'IO'. +-- +module Simulation.Aivika.Trans.Comp.IO() where + +import Control.Monad + +import qualified Simulation.Aivika.Trans.PriorityQueue as PQ + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs + +instance EventQueueing IO where + + data EventQueue IO = + EventQueue { queuePQ :: PQ.PriorityQueue IO (Point IO -> IO ()), + -- ^ the underlying priority queue + queueBusy :: ProtoRef IO Bool, + -- ^ whether the queue is currently processing events + queueTime :: ProtoRef IO Double + -- ^ the actual time of the event queue + } + + newEventQueue session specs = + do f <- newProtoRef session False + t <- newProtoRef session $ spcStartTime specs + pq <- PQ.newQueue session + return EventQueue { queuePQ = pq, + queueBusy = f, + queueTime = t } + + enqueueEvent t (Event m) = + Event $ \p -> + let pq = queuePQ $ runEventQueue $ pointRun p + in PQ.enqueue pq t m + + runEventWith processing (Event e) = + Dynamics $ \p -> + do invokeDynamics p $ processEvents processing + e p + + eventQueueCount = + Event $ PQ.queueCount . queuePQ . runEventQueue . pointRun + +instance MonadComp IO + +-- | Process the pending events. +processPendingEventsCore :: Bool -> Dynamics IO () +processPendingEventsCore includingCurrentEvents = Dynamics r where + r p = + do let q = runEventQueue $ pointRun p + f = queueBusy q + f' <- readProtoRef f + unless f' $ + do writeProtoRef f True + call q p + writeProtoRef f False + call q p = + do let pq = queuePQ q + r = pointRun p + f <- PQ.queueNull pq + unless f $ + do (t2, c2) <- PQ.queueFront pq + let t = queueTime q + t' <- readProtoRef t + when (t2 < t') $ + error "The time value is too small: processPendingEventsCore" + when ((t2 < pointTime p) || + (includingCurrentEvents && (t2 == pointTime p))) $ + do writeProtoRef t t2 + PQ.dequeue pq + let sc = pointSpecs p + t0 = spcStartTime sc + dt = spcDT sc + n2 = fromIntegral $ floor ((t2 - t0) / dt) + c2 $ p { pointTime = t2, + pointIteration = n2, + pointPhase = -1 } + call q p + +-- | Process the pending events synchronously, i.e. without past. +processPendingEvents :: Bool -> Dynamics IO () +processPendingEvents includingCurrentEvents = Dynamics r where + r p = + do let q = runEventQueue $ pointRun p + t = queueTime q + t' <- readProtoRef t + if pointTime p < t' + then error $ + "The current time is less than " ++ + "the time in the queue: processPendingEvents" + else invokeDynamics p m + m = processPendingEventsCore includingCurrentEvents + +-- | A memoized value. +processEventsIncludingCurrent :: Dynamics IO () +processEventsIncludingCurrent = processPendingEvents True + +-- | A memoized value. +processEventsIncludingEarlier :: Dynamics IO () +processEventsIncludingEarlier = processPendingEvents False + +-- | A memoized value. +processEventsIncludingCurrentCore :: Dynamics IO () +processEventsIncludingCurrentCore = processPendingEventsCore True + +-- | A memoized value. +processEventsIncludingEarlierCore :: Dynamics IO () +processEventsIncludingEarlierCore = processPendingEventsCore True + +-- | Process the events. +processEvents :: EventProcessing -> Dynamics IO () +processEvents CurrentEvents = processEventsIncludingCurrent +processEvents EarlierEvents = processEventsIncludingEarlier +processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore +processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore diff --git a/Simulation/Aivika/Trans/Comp/Template.hs b/Simulation/Aivika/Trans/Comp/Template.hs --- a/Simulation/Aivika/Trans/Comp/Template.hs +++ b/Simulation/Aivika/Trans/Comp/Template.hs @@ -1,130 +1,130 @@ - -{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} - --- | --- Module : Simulation.Aivika.Trans.Comp.Template --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines the event queue. --- -module Simulation.Aivika.Trans.Comp.Template - (TemplateEventQueueing(..)) where - -import Control.Monad - -import qualified Simulation.Aivika.Trans.PriorityQueue as PQ - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs - --- | A template-based implementation of the 'EventQueueing' class type. -class ProtoMonadComp m => TemplateEventQueueing m - -instance TemplateEventQueueing m => EventQueueing m where - - data EventQueue m = - EventQueue { queuePQ :: PQ.PriorityQueue m (Point m -> m ()), - -- ^ the underlying priority queue - queueBusy :: ProtoRef m Bool, - -- ^ whether the queue is currently processing events - queueTime :: ProtoRef m Double - -- ^ the actual time of the event queue - } - - newEventQueue session specs = - do f <- newProtoRef session False - t <- newProtoRef session $ spcStartTime specs - pq <- PQ.newQueue session - return EventQueue { queuePQ = pq, - queueBusy = f, - queueTime = t } - - enqueueEvent t (Event m) = - Event $ \p -> - let pq = queuePQ $ runEventQueue $ pointRun p - in PQ.enqueue pq t m - - runEventWith processing (Event e) = - Dynamics $ \p -> - do invokeDynamics p $ processEvents processing - e p - - eventQueueCount = - Event $ PQ.queueCount . queuePQ . runEventQueue . pointRun - --- | Process the pending events. -processPendingEventsCore :: ProtoMonadComp m => Bool -> Dynamics m () -processPendingEventsCore includingCurrentEvents = Dynamics r where - r p = - do let q = runEventQueue $ pointRun p - f = queueBusy q - f' <- readProtoRef f - unless f' $ - do writeProtoRef f True - call q p - writeProtoRef f False - call q p = - do let pq = queuePQ q - r = pointRun p - f <- PQ.queueNull pq - unless f $ - do (t2, c2) <- PQ.queueFront pq - let t = queueTime q - t' <- readProtoRef t - when (t2 < t') $ - error "The time value is too small: processPendingEventsCore" - when ((t2 < pointTime p) || - (includingCurrentEvents && (t2 == pointTime p))) $ - do writeProtoRef t t2 - PQ.dequeue pq - let sc = pointSpecs p - t0 = spcStartTime sc - dt = spcDT sc - n2 = fromIntegral $ floor ((t2 - t0) / dt) - c2 $ p { pointTime = t2, - pointIteration = n2, - pointPhase = -1 } - call q p - --- | Process the pending events synchronously, i.e. without past. -processPendingEvents :: ProtoMonadComp m => Bool -> Dynamics m () -processPendingEvents includingCurrentEvents = Dynamics r where - r p = - do let q = runEventQueue $ pointRun p - t = queueTime q - t' <- readProtoRef t - if pointTime p < t' - then error $ - "The current time is less than " ++ - "the time in the queue: processPendingEvents" - else invokeDynamics p m - m = processPendingEventsCore includingCurrentEvents - --- | A memoized value. -processEventsIncludingCurrent :: ProtoMonadComp m => Dynamics m () -processEventsIncludingCurrent = processPendingEvents True - --- | A memoized value. -processEventsIncludingEarlier :: ProtoMonadComp m => Dynamics m () -processEventsIncludingEarlier = processPendingEvents False - --- | A memoized value. -processEventsIncludingCurrentCore :: ProtoMonadComp m => Dynamics m () -processEventsIncludingCurrentCore = processPendingEventsCore True - --- | A memoized value. -processEventsIncludingEarlierCore :: ProtoMonadComp m => Dynamics m () -processEventsIncludingEarlierCore = processPendingEventsCore True - --- | Process the events. -processEvents :: ProtoMonadComp m => EventProcessing -> Dynamics m () -processEvents CurrentEvents = processEventsIncludingCurrent -processEvents EarlierEvents = processEventsIncludingEarlier -processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore -processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore + +{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.Trans.Comp.Template +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the event queue. +-- +module Simulation.Aivika.Trans.Comp.Template + (TemplateEventQueueing(..)) where + +import Control.Monad + +import qualified Simulation.Aivika.Trans.PriorityQueue as PQ + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs + +-- | A template-based implementation of the 'EventQueueing' class type. +class ProtoMonadComp m => TemplateEventQueueing m + +instance TemplateEventQueueing m => EventQueueing m where + + data EventQueue m = + EventQueue { queuePQ :: PQ.PriorityQueue m (Point m -> m ()), + -- ^ the underlying priority queue + queueBusy :: ProtoRef m Bool, + -- ^ whether the queue is currently processing events + queueTime :: ProtoRef m Double + -- ^ the actual time of the event queue + } + + newEventQueue session specs = + do f <- newProtoRef session False + t <- newProtoRef session $ spcStartTime specs + pq <- PQ.newQueue session + return EventQueue { queuePQ = pq, + queueBusy = f, + queueTime = t } + + enqueueEvent t (Event m) = + Event $ \p -> + let pq = queuePQ $ runEventQueue $ pointRun p + in PQ.enqueue pq t m + + runEventWith processing (Event e) = + Dynamics $ \p -> + do invokeDynamics p $ processEvents processing + e p + + eventQueueCount = + Event $ PQ.queueCount . queuePQ . runEventQueue . pointRun + +-- | Process the pending events. +processPendingEventsCore :: ProtoMonadComp m => Bool -> Dynamics m () +processPendingEventsCore includingCurrentEvents = Dynamics r where + r p = + do let q = runEventQueue $ pointRun p + f = queueBusy q + f' <- readProtoRef f + unless f' $ + do writeProtoRef f True + call q p + writeProtoRef f False + call q p = + do let pq = queuePQ q + r = pointRun p + f <- PQ.queueNull pq + unless f $ + do (t2, c2) <- PQ.queueFront pq + let t = queueTime q + t' <- readProtoRef t + when (t2 < t') $ + error "The time value is too small: processPendingEventsCore" + when ((t2 < pointTime p) || + (includingCurrentEvents && (t2 == pointTime p))) $ + do writeProtoRef t t2 + PQ.dequeue pq + let sc = pointSpecs p + t0 = spcStartTime sc + dt = spcDT sc + n2 = fromIntegral $ floor ((t2 - t0) / dt) + c2 $ p { pointTime = t2, + pointIteration = n2, + pointPhase = -1 } + call q p + +-- | Process the pending events synchronously, i.e. without past. +processPendingEvents :: ProtoMonadComp m => Bool -> Dynamics m () +processPendingEvents includingCurrentEvents = Dynamics r where + r p = + do let q = runEventQueue $ pointRun p + t = queueTime q + t' <- readProtoRef t + if pointTime p < t' + then error $ + "The current time is less than " ++ + "the time in the queue: processPendingEvents" + else invokeDynamics p m + m = processPendingEventsCore includingCurrentEvents + +-- | A memoized value. +processEventsIncludingCurrent :: ProtoMonadComp m => Dynamics m () +processEventsIncludingCurrent = processPendingEvents True + +-- | A memoized value. +processEventsIncludingEarlier :: ProtoMonadComp m => Dynamics m () +processEventsIncludingEarlier = processPendingEvents False + +-- | A memoized value. +processEventsIncludingCurrentCore :: ProtoMonadComp m => Dynamics m () +processEventsIncludingCurrentCore = processPendingEventsCore True + +-- | A memoized value. +processEventsIncludingEarlierCore :: ProtoMonadComp m => Dynamics m () +processEventsIncludingEarlierCore = processPendingEventsCore True + +-- | Process the events. +processEvents :: ProtoMonadComp m => EventProcessing -> Dynamics m () +processEvents CurrentEvents = processEventsIncludingCurrent +processEvents EarlierEvents = processEventsIncludingEarlier +processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore +processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore diff --git a/Simulation/Aivika/Trans/Cont.hs b/Simulation/Aivika/Trans/Cont.hs --- a/Simulation/Aivika/Trans/Cont.hs +++ b/Simulation/Aivika/Trans/Cont.hs @@ -1,18 +1,18 @@ - --- | --- Module : Simulation.Aivika.Trans.Cont --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The 'Cont' monad is a variation of the standard Cont monad --- and F# async workflow, where the result of applying --- the continuations is the 'Event' computation. --- -module Simulation.Aivika.Trans.Cont - (ContCancellation(..), - Cont) where - -import Simulation.Aivika.Trans.Internal.Cont + +-- | +-- Module : Simulation.Aivika.Trans.Cont +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The 'Cont' monad is a variation of the standard Cont monad +-- and F# async workflow, where the result of applying +-- the continuations is the 'Event' computation. +-- +module Simulation.Aivika.Trans.Cont + (ContCancellation(..), + Cont) where + +import Simulation.Aivika.Trans.Internal.Cont 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,172 +1,172 @@ - --- | --- Module : Simulation.Aivika.Trans.DoubleLinkedList --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- An imperative double-linked list. --- -module Simulation.Aivika.Trans.DoubleLinkedList - (DoubleLinkedList, - listNull, - listCount, - newList, - listInsertFirst, - listAddLast, - listRemoveFirst, - listRemoveLast, - listFirst, - listLast) where - -import Control.Monad - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp - --- | A cell of the double-linked list. -data DoubleLinkedItem m a = - DoubleLinkedItem { itemVal :: a, - itemPrev :: ProtoRef m (Maybe (DoubleLinkedItem m a)), - itemNext :: ProtoRef m (Maybe (DoubleLinkedItem m a)) } - --- | The 'DoubleLinkedList' type represents an imperative double-linked list. -data DoubleLinkedList m a = - DoubleLinkedList { listSession :: Session m, - listHead :: ProtoRef m (Maybe (DoubleLinkedItem m a)), - listTail :: ProtoRef m (Maybe (DoubleLinkedItem m a)), - listSize :: ProtoRef m Int } - --- | Test whether the list is empty. -listNull :: ProtoRefMonad m => DoubleLinkedList m a -> m Bool -listNull x = - do head <- readProtoRef (listHead x) - case head of - Nothing -> return True - Just _ -> return False - --- | Return the number of elements in the list. -listCount :: ProtoRefMonad m => DoubleLinkedList m a -> m Int -listCount x = readProtoRef (listSize x) - --- | Create a new list. -newList :: ProtoRefMonad m => Session m -> m (DoubleLinkedList m a) -newList s = - do head <- newProtoRef s Nothing - tail <- newProtoRef s Nothing - size <- newProtoRef s 0 - return DoubleLinkedList { listSession = s, - listHead = head, - listTail = tail, - listSize = size } - --- | Insert a new element in the beginning. -listInsertFirst :: ProtoRefMonad m => DoubleLinkedList m a -> a -> m () -listInsertFirst x v = - do let s = listSession x - size <- readProtoRef (listSize x) - writeProtoRef (listSize x) (size + 1) - head <- readProtoRef (listHead x) - case head of - Nothing -> - do prev <- newProtoRef s Nothing - next <- newProtoRef s Nothing - let item = Just DoubleLinkedItem { itemVal = v, - itemPrev = prev, - itemNext = next } - writeProtoRef (listHead x) item - writeProtoRef (listTail x) item - Just h -> - do prev <- newProtoRef s Nothing - next <- newProtoRef s head - let item = Just DoubleLinkedItem { itemVal = v, - itemPrev = prev, - itemNext = next } - writeProtoRef (itemPrev h) item - writeProtoRef (listHead x) item - --- | Add a new element to the end. -listAddLast :: ProtoRefMonad m => DoubleLinkedList m a -> a -> m () -listAddLast x v = - do let s = listSession x - size <- readProtoRef (listSize x) - writeProtoRef (listSize x) (size + 1) - tail <- readProtoRef (listTail x) - case tail of - Nothing -> - do prev <- newProtoRef s Nothing - next <- newProtoRef s Nothing - let item = Just DoubleLinkedItem { itemVal = v, - itemPrev = prev, - itemNext = next } - writeProtoRef (listHead x) item - writeProtoRef (listTail x) item - Just t -> - do prev <- newProtoRef s tail - next <- newProtoRef s Nothing - let item = Just DoubleLinkedItem { itemVal = v, - itemPrev = prev, - itemNext = next } - writeProtoRef (itemNext t) item - writeProtoRef (listTail x) item - --- | Remove the first element. -listRemoveFirst :: ProtoRefMonad m => DoubleLinkedList m a -> m () -listRemoveFirst x = - do head <- readProtoRef (listHead x) - case head of - Nothing -> - error "Empty list: listRemoveFirst" - Just h -> - do size <- readProtoRef (listSize x) - writeProtoRef (listSize x) (size - 1) - head' <- readProtoRef (itemNext h) - case head' of - Nothing -> - do writeProtoRef (listHead x) Nothing - writeProtoRef (listTail x) Nothing - Just h' -> - do writeProtoRef (itemPrev h') Nothing - writeProtoRef (listHead x) head' - --- | Remove the last element. -listRemoveLast :: ProtoRefMonad m => DoubleLinkedList m a -> m () -listRemoveLast x = - do tail <- readProtoRef (listTail x) - case tail of - Nothing -> - error "Empty list: listRemoveLast" - Just t -> - do size <- readProtoRef (listSize x) - writeProtoRef (listSize x) (size - 1) - tail' <- readProtoRef (itemPrev t) - case tail' of - Nothing -> - do writeProtoRef (listHead x) Nothing - writeProtoRef (listTail x) Nothing - Just t' -> - do writeProtoRef (itemNext t') Nothing - writeProtoRef (listTail x) tail' - --- | Return the first element. -listFirst :: ProtoRefMonad m => DoubleLinkedList m a -> m a -listFirst x = - do head <- readProtoRef (listHead x) - case head of - Nothing -> - error "Empty list: listFirst" - Just h -> - return $ itemVal h - --- | Return the last element. -listLast :: ProtoRefMonad m => DoubleLinkedList m a -> m a -listLast x = - do tail <- readProtoRef (listTail x) - case tail of - Nothing -> - error "Empty list: listLast" - Just t -> - return $ itemVal t + +-- | +-- Module : Simulation.Aivika.Trans.DoubleLinkedList +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- An imperative double-linked list. +-- +module Simulation.Aivika.Trans.DoubleLinkedList + (DoubleLinkedList, + listNull, + listCount, + newList, + listInsertFirst, + listAddLast, + listRemoveFirst, + listRemoveLast, + listFirst, + listLast) where + +import Control.Monad + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp + +-- | A cell of the double-linked list. +data DoubleLinkedItem m a = + DoubleLinkedItem { itemVal :: a, + itemPrev :: ProtoRef m (Maybe (DoubleLinkedItem m a)), + itemNext :: ProtoRef m (Maybe (DoubleLinkedItem m a)) } + +-- | The 'DoubleLinkedList' type represents an imperative double-linked list. +data DoubleLinkedList m a = + DoubleLinkedList { listSession :: Session m, + listHead :: ProtoRef m (Maybe (DoubleLinkedItem m a)), + listTail :: ProtoRef m (Maybe (DoubleLinkedItem m a)), + listSize :: ProtoRef m Int } + +-- | Test whether the list is empty. +listNull :: ProtoRefMonad m => DoubleLinkedList m a -> m Bool +listNull x = + do head <- readProtoRef (listHead x) + case head of + Nothing -> return True + Just _ -> return False + +-- | Return the number of elements in the list. +listCount :: ProtoRefMonad m => DoubleLinkedList m a -> m Int +listCount x = readProtoRef (listSize x) + +-- | Create a new list. +newList :: ProtoRefMonad m => Session m -> m (DoubleLinkedList m a) +newList s = + do head <- newProtoRef s Nothing + tail <- newProtoRef s Nothing + size <- newProtoRef s 0 + return DoubleLinkedList { listSession = s, + listHead = head, + listTail = tail, + listSize = size } + +-- | Insert a new element in the beginning. +listInsertFirst :: ProtoRefMonad m => DoubleLinkedList m a -> a -> m () +listInsertFirst x v = + do let s = listSession x + size <- readProtoRef (listSize x) + writeProtoRef (listSize x) (size + 1) + head <- readProtoRef (listHead x) + case head of + Nothing -> + do prev <- newProtoRef s Nothing + next <- newProtoRef s Nothing + let item = Just DoubleLinkedItem { itemVal = v, + itemPrev = prev, + itemNext = next } + writeProtoRef (listHead x) item + writeProtoRef (listTail x) item + Just h -> + do prev <- newProtoRef s Nothing + next <- newProtoRef s head + let item = Just DoubleLinkedItem { itemVal = v, + itemPrev = prev, + itemNext = next } + writeProtoRef (itemPrev h) item + writeProtoRef (listHead x) item + +-- | Add a new element to the end. +listAddLast :: ProtoRefMonad m => DoubleLinkedList m a -> a -> m () +listAddLast x v = + do let s = listSession x + size <- readProtoRef (listSize x) + writeProtoRef (listSize x) (size + 1) + tail <- readProtoRef (listTail x) + case tail of + Nothing -> + do prev <- newProtoRef s Nothing + next <- newProtoRef s Nothing + let item = Just DoubleLinkedItem { itemVal = v, + itemPrev = prev, + itemNext = next } + writeProtoRef (listHead x) item + writeProtoRef (listTail x) item + Just t -> + do prev <- newProtoRef s tail + next <- newProtoRef s Nothing + let item = Just DoubleLinkedItem { itemVal = v, + itemPrev = prev, + itemNext = next } + writeProtoRef (itemNext t) item + writeProtoRef (listTail x) item + +-- | Remove the first element. +listRemoveFirst :: ProtoRefMonad m => DoubleLinkedList m a -> m () +listRemoveFirst x = + do head <- readProtoRef (listHead x) + case head of + Nothing -> + error "Empty list: listRemoveFirst" + Just h -> + do size <- readProtoRef (listSize x) + writeProtoRef (listSize x) (size - 1) + head' <- readProtoRef (itemNext h) + case head' of + Nothing -> + do writeProtoRef (listHead x) Nothing + writeProtoRef (listTail x) Nothing + Just h' -> + do writeProtoRef (itemPrev h') Nothing + writeProtoRef (listHead x) head' + +-- | Remove the last element. +listRemoveLast :: ProtoRefMonad m => DoubleLinkedList m a -> m () +listRemoveLast x = + do tail <- readProtoRef (listTail x) + case tail of + Nothing -> + error "Empty list: listRemoveLast" + Just t -> + do size <- readProtoRef (listSize x) + writeProtoRef (listSize x) (size - 1) + tail' <- readProtoRef (itemPrev t) + case tail' of + Nothing -> + do writeProtoRef (listHead x) Nothing + writeProtoRef (listTail x) Nothing + Just t' -> + do writeProtoRef (itemNext t') Nothing + writeProtoRef (listTail x) tail' + +-- | Return the first element. +listFirst :: ProtoRefMonad m => DoubleLinkedList m a -> m a +listFirst x = + do head <- readProtoRef (listHead x) + case head of + Nothing -> + error "Empty list: listFirst" + Just h -> + return $ itemVal h + +-- | Return the last element. +listLast :: ProtoRefMonad m => DoubleLinkedList m a -> m a +listLast x = + do tail <- readProtoRef (listTail x) + case tail of + Nothing -> + error "Empty list: listLast" + Just t -> + return $ itemVal t 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,32 +1,32 @@ - --- | --- Module : Simulation.Aivika.Trans.Dynamics --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines the 'DynamicsT' monad tranformer representing a time varying polymorphic function. --- -module Simulation.Aivika.Trans.Dynamics - (-- * Dynamics Monad - Dynamics, - DynamicsLift(..), - runDynamicsInStartTime, - runDynamicsInStopTime, - runDynamicsInIntegTimes, - runDynamicsInTime, - runDynamicsInTimes, - -- * Error Handling - catchDynamics, - finallyDynamics, - throwDynamics, - -- * Simulation Time - time, - isTimeInteg, - integIteration, - integPhase) where - -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Dynamics + +-- | +-- Module : Simulation.Aivika.Trans.Dynamics +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the 'DynamicsT' monad tranformer representing a time varying polymorphic function. +-- +module Simulation.Aivika.Trans.Dynamics + (-- * Dynamics Monad + Dynamics, + DynamicsLift(..), + runDynamicsInStartTime, + runDynamicsInStopTime, + runDynamicsInIntegTimes, + runDynamicsInTime, + runDynamicsInTimes, + -- * Error Handling + catchDynamics, + finallyDynamics, + throwDynamics, + -- * Simulation Time + time, + isTimeInteg, + integIteration, + integPhase) where + +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Dynamics diff --git a/Simulation/Aivika/Trans/Dynamics/Extra.hs b/Simulation/Aivika/Trans/Dynamics/Extra.hs --- a/Simulation/Aivika/Trans/Dynamics/Extra.hs +++ b/Simulation/Aivika/Trans/Dynamics/Extra.hs @@ -1,114 +1,114 @@ - -{-# LANGUAGE RecursiveDo #-} - --- | --- Module : Simulation.Aivika.Trans.Dynamics.Extra --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines auxiliary functions such as interpolation ones --- that complement the memoization, for example. There are scan functions too. --- - -module Simulation.Aivika.Trans.Dynamics.Extra - (-- * Interpolation - initDynamics, - discreteDynamics, - interpolateDynamics, - -- * Scans - scanDynamics, - scan1Dynamics) where - -import Control.Monad.Fix - -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Dynamics - --- | Return the initial value. -initDynamics :: Dynamics m a -> Dynamics m a -{-# INLINE initDynamics #-} -initDynamics (Dynamics m) = - Dynamics $ \p -> - let sc = pointSpecs p - in m $ p { pointTime = basicTime sc 0 0, - pointIteration = 0, - pointPhase = 0 } - --- | Discretize the computation in the integration time points. -discreteDynamics :: Dynamics m a -> Dynamics m a -{-# INLINE discreteDynamics #-} -discreteDynamics (Dynamics m) = - Dynamics $ \p -> - if pointPhase p == 0 then - m p - else - let sc = pointSpecs p - n = pointIteration p - in m $ p { pointTime = basicTime sc n 0, - pointPhase = 0 } - --- | Interpolate the computation based on the integration time points only. --- Unlike the 'discreteDynamics' function it knows about the intermediate --- time points that are used in the Runge-Kutta method. -interpolateDynamics :: Dynamics m a -> Dynamics m a -{-# INLINE interpolateDynamics #-} -interpolateDynamics (Dynamics m) = - Dynamics $ \p -> - if pointPhase p >= 0 then - m p - else - let sc = pointSpecs p - n = pointIteration p - in m $ p { pointTime = basicTime sc n 0, - pointPhase = 0 } - --- | Like the standard 'scanl1' function but applied to values in --- the integration time points. The accumulator values are transformed --- according to the second argument, which should be either function --- 'memo0Dynamics' or its unboxed version. -scan1Dynamics :: (MonadComp m, MonadFix m) - => (a -> a -> a) - -> (Dynamics m a -> Simulation m (Dynamics m a)) - -> (Dynamics m a -> Simulation m (Dynamics m a)) -scan1Dynamics f tr m = - mdo y <- tr $ Dynamics $ \p -> - case pointIteration p of - 0 -> - invokeDynamics p m - n -> do - let sc = pointSpecs p - ty = basicTime sc (n - 1) 0 - py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } - s <- invokeDynamics py y - x <- invokeDynamics p m - return $! f s x - return y - --- | Like the standard 'scanl' function but applied to values in --- the integration time points. The accumulator values are transformed --- according to the third argument, which should be either function --- 'memo0Dynamics' or its unboxed version. -scanDynamics :: (MonadComp m, MonadFix m) - => (a -> b -> a) - -> a - -> (Dynamics m a -> Simulation m (Dynamics m a)) - -> (Dynamics m b -> Simulation m (Dynamics m a)) -scanDynamics f acc tr m = - mdo y <- tr $ Dynamics $ \p -> - case pointIteration p of - 0 -> do - x <- invokeDynamics p m - return $! f acc x - n -> do - let sc = pointSpecs p - ty = basicTime sc (n - 1) 0 - py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } - s <- invokeDynamics py y - x <- invokeDynamics p m - return $! f s x - return y + +{-# LANGUAGE RecursiveDo #-} + +-- | +-- Module : Simulation.Aivika.Trans.Dynamics.Extra +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines auxiliary functions such as interpolation ones +-- that complement the memoization, for example. There are scan functions too. +-- + +module Simulation.Aivika.Trans.Dynamics.Extra + (-- * Interpolation + initDynamics, + discreteDynamics, + interpolateDynamics, + -- * Scans + scanDynamics, + scan1Dynamics) where + +import Control.Monad.Fix + +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics + +-- | Return the initial value. +initDynamics :: Dynamics m a -> Dynamics m a +{-# INLINE initDynamics #-} +initDynamics (Dynamics m) = + Dynamics $ \p -> + let sc = pointSpecs p + in m $ p { pointTime = basicTime sc 0 0, + pointIteration = 0, + pointPhase = 0 } + +-- | Discretize the computation in the integration time points. +discreteDynamics :: Dynamics m a -> Dynamics m a +{-# INLINE discreteDynamics #-} +discreteDynamics (Dynamics m) = + Dynamics $ \p -> + if pointPhase p == 0 then + m p + else + let sc = pointSpecs p + n = pointIteration p + in m $ p { pointTime = basicTime sc n 0, + pointPhase = 0 } + +-- | Interpolate the computation based on the integration time points only. +-- Unlike the 'discreteDynamics' function it knows about the intermediate +-- time points that are used in the Runge-Kutta method. +interpolateDynamics :: Dynamics m a -> Dynamics m a +{-# INLINE interpolateDynamics #-} +interpolateDynamics (Dynamics m) = + Dynamics $ \p -> + if pointPhase p >= 0 then + m p + else + let sc = pointSpecs p + n = pointIteration p + in m $ p { pointTime = basicTime sc n 0, + pointPhase = 0 } + +-- | Like the standard 'scanl1' function but applied to values in +-- the integration time points. The accumulator values are transformed +-- according to the second argument, which should be either function +-- 'memo0Dynamics' or its unboxed version. +scan1Dynamics :: (MonadComp m, MonadFix m) + => (a -> a -> a) + -> (Dynamics m a -> Simulation m (Dynamics m a)) + -> (Dynamics m a -> Simulation m (Dynamics m a)) +scan1Dynamics f tr m = + mdo y <- tr $ Dynamics $ \p -> + case pointIteration p of + 0 -> + invokeDynamics p m + n -> do + let sc = pointSpecs p + ty = basicTime sc (n - 1) 0 + py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } + s <- invokeDynamics py y + x <- invokeDynamics p m + return $! f s x + return y + +-- | Like the standard 'scanl' function but applied to values in +-- the integration time points. The accumulator values are transformed +-- according to the third argument, which should be either function +-- 'memo0Dynamics' or its unboxed version. +scanDynamics :: (MonadComp m, MonadFix m) + => (a -> b -> a) + -> a + -> (Dynamics m a -> Simulation m (Dynamics m a)) + -> (Dynamics m b -> Simulation m (Dynamics m a)) +scanDynamics f acc tr m = + mdo y <- tr $ Dynamics $ \p -> + case pointIteration p of + 0 -> do + x <- invokeDynamics p m + return $! f acc x + n -> do + let sc = pointSpecs p + ty = basicTime sc (n - 1) 0 + py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } + s <- invokeDynamics py y + x <- invokeDynamics p m + return $! f s x + return y 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,158 +1,158 @@ - --- | --- Module : Simulation.Aivika.Trans.Dynamics.Memo --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines memo functions. The memoization creates such 'Dynamics' --- computations, which values are cached in the integration time points. Then --- these values are interpolated in all other time points. --- - -module Simulation.Aivika.Trans.Dynamics.Memo - (memoDynamics, - memo0Dynamics, - iterateDynamics, - unzipDynamics, - unzip0Dynamics) where - -import Control.Monad - -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.ProtoArray -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Parameter -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Dynamics -import Simulation.Aivika.Trans.Dynamics.Extra - --- | Memoize and order the computation in the integration time points using --- the interpolation that knows of the Runge-Kutta method. The values are --- calculated sequentially starting from 'starttime'. -memoDynamics :: MonadComp m => Dynamics m e -> Simulation m (Dynamics m e) -{-# INLINABLE memoDynamics #-} -memoDynamics (Dynamics m) = - Simulation $ \r -> - do let sc = runSpecs r - s = runSession r - phs = 1 + integPhaseHiBnd sc - ns = 1 + integIterationHiBnd sc - arr <- newProtoArray_ s (ns * phs) - nref <- newProtoRef s 0 - phref <- newProtoRef s 0 - let r p = - do let n = pointIteration p - ph = pointPhase p - i = n * phs + ph - loop n' ph' = - if (n' > n) || ((n' == n) && (ph' > ph)) - then - readProtoArray arr i - else - let p' = p { pointIteration = n', pointPhase = ph', - pointTime = basicTime sc n' ph' } - i' = n' * phs + ph' - in do a <- m p' - a `seq` writeProtoArray arr i' a - if ph' >= phs - 1 - then do writeProtoRef phref 0 - writeProtoRef nref (n' + 1) - loop (n' + 1) 0 - else do writeProtoRef phref (ph' + 1) - loop n' (ph' + 1) - n' <- readProtoRef nref - ph' <- readProtoRef phref - loop n' ph' - return $ interpolateDynamics $ Dynamics r - --- | Memoize and order the computation in the integration time points using --- the 'discreteDynamics' interpolation. It consumes less memory than the 'memoDynamics' --- function but it is not aware of the Runge-Kutta method. There is a subtle --- difference when we request for values in the intermediate time points --- that are used by this method to integrate. In general case you should --- prefer the 'memo0Dynamics' function above 'memoDynamics'. -memo0Dynamics :: MonadComp m => Dynamics m e -> Simulation m (Dynamics m e) -{-# INLINABLE memo0Dynamics #-} -memo0Dynamics (Dynamics m) = - Simulation $ \r -> - do let sc = runSpecs r - s = runSession r - ns = 1 + integIterationHiBnd sc - arr <- newProtoArray_ s ns - nref <- newProtoRef s 0 - let r p = - do let sc = pointSpecs p - n = pointIteration p - loop n' = - if n' > n - then - readProtoArray arr n - else - let p' = p { pointIteration = n', pointPhase = 0, - pointTime = basicTime sc n' 0 } - in do a <- m p' - a `seq` writeProtoArray arr n' a - writeProtoRef nref (n' + 1) - loop (n' + 1) - n' <- readProtoRef nref - loop n' - return $ discreteDynamics $ Dynamics r - --- | Iterate sequentially the dynamic process with side effects in --- the integration time points. It is equivalent to a call of the --- 'memo0Dynamics' function but significantly more efficient, for the array --- is not created. -iterateDynamics :: MonadComp m => Dynamics m () -> Simulation m (Dynamics m ()) -{-# INLINABLE iterateDynamics #-} -iterateDynamics (Dynamics m) = - Simulation $ \r -> - do let sc = runSpecs r - s = runSession r - nref <- newProtoRef s 0 - let r p = - do let sc = pointSpecs p - n = pointIteration p - loop n' = - unless (n' > n) $ - let p' = p { pointIteration = n', pointPhase = 0, - pointTime = basicTime sc n' 0 } - in do a <- m p' - a `seq` writeProtoRef nref (n' + 1) - loop (n' + 1) - n' <- readProtoRef nref - loop n' - return $ discreteDynamics $ Dynamics r - --- | Memoize and unzip the computation of pairs, applying the 'memoDynamics' function. -unzipDynamics :: MonadComp m => Dynamics m (a, b) -> Simulation m (Dynamics m a, Dynamics m b) -unzipDynamics m = - Simulation $ \r -> - do m' <- invokeSimulation r (memoDynamics m) - let ma = - Dynamics $ \p -> - do (a, _) <- invokeDynamics p m' - return a - mb = - Dynamics $ \p -> - do (_, b) <- invokeDynamics p m' - return b - return (ma, mb) - --- | Memoize and unzip the computation of pairs, applying the 'memo0Dynamics' function. -unzip0Dynamics :: MonadComp m => Dynamics m (a, b) -> Simulation m (Dynamics m a, Dynamics m b) -unzip0Dynamics m = - Simulation $ \r -> - do m' <- invokeSimulation r (memo0Dynamics m) - let ma = - Dynamics $ \p -> - do (a, _) <- invokeDynamics p m' - return a - mb = - Dynamics $ \p -> - do (_, b) <- invokeDynamics p m' - return b - return (ma, mb) + +-- | +-- Module : Simulation.Aivika.Trans.Dynamics.Memo +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines memo functions. The memoization creates such 'Dynamics' +-- computations, which values are cached in the integration time points. Then +-- these values are interpolated in all other time points. +-- + +module Simulation.Aivika.Trans.Dynamics.Memo + (memoDynamics, + memo0Dynamics, + iterateDynamics, + unzipDynamics, + unzip0Dynamics) where + +import Control.Monad + +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.ProtoArray +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics +import Simulation.Aivika.Trans.Dynamics.Extra + +-- | Memoize and order the computation in the integration time points using +-- the interpolation that knows of the Runge-Kutta method. The values are +-- calculated sequentially starting from 'starttime'. +memoDynamics :: MonadComp m => Dynamics m e -> Simulation m (Dynamics m e) +{-# INLINABLE memoDynamics #-} +memoDynamics (Dynamics m) = + Simulation $ \r -> + do let sc = runSpecs r + s = runSession r + phs = 1 + integPhaseHiBnd sc + ns = 1 + integIterationHiBnd sc + arr <- newProtoArray_ s (ns * phs) + nref <- newProtoRef s 0 + phref <- newProtoRef s 0 + let r p = + do let n = pointIteration p + ph = pointPhase p + i = n * phs + ph + loop n' ph' = + if (n' > n) || ((n' == n) && (ph' > ph)) + then + readProtoArray arr i + else + let p' = p { pointIteration = n', pointPhase = ph', + pointTime = basicTime sc n' ph' } + i' = n' * phs + ph' + in do a <- m p' + a `seq` writeProtoArray arr i' a + if ph' >= phs - 1 + then do writeProtoRef phref 0 + writeProtoRef nref (n' + 1) + loop (n' + 1) 0 + else do writeProtoRef phref (ph' + 1) + loop n' (ph' + 1) + n' <- readProtoRef nref + ph' <- readProtoRef phref + loop n' ph' + return $ interpolateDynamics $ Dynamics r + +-- | Memoize and order the computation in the integration time points using +-- the 'discreteDynamics' interpolation. It consumes less memory than the 'memoDynamics' +-- function but it is not aware of the Runge-Kutta method. There is a subtle +-- difference when we request for values in the intermediate time points +-- that are used by this method to integrate. In general case you should +-- prefer the 'memo0Dynamics' function above 'memoDynamics'. +memo0Dynamics :: MonadComp m => Dynamics m e -> Simulation m (Dynamics m e) +{-# INLINABLE memo0Dynamics #-} +memo0Dynamics (Dynamics m) = + Simulation $ \r -> + do let sc = runSpecs r + s = runSession r + ns = 1 + integIterationHiBnd sc + arr <- newProtoArray_ s ns + nref <- newProtoRef s 0 + let r p = + do let sc = pointSpecs p + n = pointIteration p + loop n' = + if n' > n + then + readProtoArray arr n + else + let p' = p { pointIteration = n', pointPhase = 0, + pointTime = basicTime sc n' 0 } + in do a <- m p' + a `seq` writeProtoArray arr n' a + writeProtoRef nref (n' + 1) + loop (n' + 1) + n' <- readProtoRef nref + loop n' + return $ discreteDynamics $ Dynamics r + +-- | Iterate sequentially the dynamic process with side effects in +-- the integration time points. It is equivalent to a call of the +-- 'memo0Dynamics' function but significantly more efficient, for the array +-- is not created. +iterateDynamics :: MonadComp m => Dynamics m () -> Simulation m (Dynamics m ()) +{-# INLINABLE iterateDynamics #-} +iterateDynamics (Dynamics m) = + Simulation $ \r -> + do let sc = runSpecs r + s = runSession r + nref <- newProtoRef s 0 + let r p = + do let sc = pointSpecs p + n = pointIteration p + loop n' = + unless (n' > n) $ + let p' = p { pointIteration = n', pointPhase = 0, + pointTime = basicTime sc n' 0 } + in do a <- m p' + a `seq` writeProtoRef nref (n' + 1) + loop (n' + 1) + n' <- readProtoRef nref + loop n' + return $ discreteDynamics $ Dynamics r + +-- | Memoize and unzip the computation of pairs, applying the 'memoDynamics' function. +unzipDynamics :: MonadComp m => Dynamics m (a, b) -> Simulation m (Dynamics m a, Dynamics m b) +unzipDynamics m = + Simulation $ \r -> + do m' <- invokeSimulation r (memoDynamics m) + let ma = + Dynamics $ \p -> + do (a, _) <- invokeDynamics p m' + return a + mb = + Dynamics $ \p -> + do (_, b) <- invokeDynamics p m' + return b + return (ma, mb) + +-- | Memoize and unzip the computation of pairs, applying the 'memo0Dynamics' function. +unzip0Dynamics :: MonadComp m => Dynamics m (a, b) -> Simulation m (Dynamics m a, Dynamics m b) +unzip0Dynamics m = + Simulation $ \r -> + do m' <- invokeSimulation r (memo0Dynamics m) + let ma = + Dynamics $ \p -> + do (a, _) <- invokeDynamics p m' + return a + mb = + Dynamics $ \p -> + do (_, b) <- invokeDynamics p m' + return b + return (ma, mb) diff --git a/Simulation/Aivika/Trans/Dynamics/Memo/Unboxed.hs b/Simulation/Aivika/Trans/Dynamics/Memo/Unboxed.hs --- a/Simulation/Aivika/Trans/Dynamics/Memo/Unboxed.hs +++ b/Simulation/Aivika/Trans/Dynamics/Memo/Unboxed.hs @@ -1,105 +1,105 @@ - -{-# LANGUAGE FlexibleContexts #-} - --- | --- Module : Simulation.Aivika.Trans.Dynamics.Memo.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines the unboxed memo functions. The memoization creates such 'DynamicsT' --- computations, which values are cached in the integration time points. Then --- these values are interpolated in all other time points. --- - -module Simulation.Aivika.Trans.Dynamics.Memo.Unboxed - (memoDynamics, - memo0Dynamics) where - -import Control.Monad - -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.ProtoArray.Unboxed -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Comp.IO -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Parameter -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Dynamics -import Simulation.Aivika.Trans.Dynamics.Extra -import Simulation.Aivika.Trans.Unboxed - --- | Memoize and order the computation in the integration time points using --- the interpolation that knows of the Runge-Kutta method. The values are --- calculated sequentially starting from 'starttime'. -memoDynamics :: (Unboxed m e, MonadComp m) => Dynamics m e -> Simulation m (Dynamics m e) -{-# INLINABLE memoDynamics #-} -memoDynamics (Dynamics m) = - Simulation $ \r -> - do let sc = runSpecs r - s = runSession r - phs = 1 + integPhaseHiBnd sc - ns = 1 + integIterationHiBnd sc - arr <- newProtoArray_ s (phs * ns) - nref <- newProtoRef s 0 - phref <- newProtoRef s 0 - let r p = - do let n = pointIteration p - ph = pointPhase p - i = n * phs + ph - loop n' ph' = - if (n' > n) || ((n' == n) && (ph' > ph)) - then - readProtoArray arr i - else - let p' = p { pointIteration = n', - pointPhase = ph', - pointTime = basicTime sc n' ph' } - i' = n' * phs + ph' - in do a <- m p' - a `seq` writeProtoArray arr i' a - if ph' >= phs - 1 - then do writeProtoRef phref 0 - writeProtoRef nref (n' + 1) - loop (n' + 1) 0 - else do writeProtoRef phref (ph' + 1) - loop n' (ph' + 1) - n' <- readProtoRef nref - ph' <- readProtoRef phref - loop n' ph' - return $ interpolateDynamics $ Dynamics r - --- | Memoize and order the computation in the integration time points using --- the 'discreteDynamics' interpolation. It consumes less memory than the 'memoDynamics' --- function but it is not aware of the Runge-Kutta method. There is a subtle --- difference when we request for values in the intermediate time points --- that are used by this method to integrate. In general case you should --- prefer the 'memo0Dynamics' function above 'memoDynamics'. -memo0Dynamics :: (Unboxed m e, MonadComp m) => Dynamics m e -> Simulation m (Dynamics m e) -{-# INLINABLE memo0Dynamics #-} -memo0Dynamics (Dynamics m) = - Simulation $ \r -> - do let sc = runSpecs r - s = runSession r - ns = 1 + integIterationHiBnd sc - arr <- newProtoArray_ s ns - nref <- newProtoRef s 0 - let r p = - do let sc = pointSpecs p - n = pointIteration p - loop n' = - if n' > n - then - readProtoArray arr n - else - let p' = p { pointIteration = n', pointPhase = 0, - pointTime = basicTime sc n' 0 } - in do a <- m p' - a `seq` writeProtoArray arr n' a - writeProtoRef nref (n' + 1) - loop (n' + 1) - n' <- readProtoRef nref - loop n' - return $ discreteDynamics $ Dynamics r + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.Dynamics.Memo.Unboxed +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the unboxed memo functions. The memoization creates such 'DynamicsT' +-- computations, which values are cached in the integration time points. Then +-- these values are interpolated in all other time points. +-- + +module Simulation.Aivika.Trans.Dynamics.Memo.Unboxed + (memoDynamics, + memo0Dynamics) where + +import Control.Monad + +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.ProtoArray.Unboxed +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Comp.IO +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics +import Simulation.Aivika.Trans.Dynamics.Extra +import Simulation.Aivika.Trans.Unboxed + +-- | Memoize and order the computation in the integration time points using +-- the interpolation that knows of the Runge-Kutta method. The values are +-- calculated sequentially starting from 'starttime'. +memoDynamics :: (Unboxed m e, MonadComp m) => Dynamics m e -> Simulation m (Dynamics m e) +{-# INLINABLE memoDynamics #-} +memoDynamics (Dynamics m) = + Simulation $ \r -> + do let sc = runSpecs r + s = runSession r + phs = 1 + integPhaseHiBnd sc + ns = 1 + integIterationHiBnd sc + arr <- newProtoArray_ s (phs * ns) + nref <- newProtoRef s 0 + phref <- newProtoRef s 0 + let r p = + do let n = pointIteration p + ph = pointPhase p + i = n * phs + ph + loop n' ph' = + if (n' > n) || ((n' == n) && (ph' > ph)) + then + readProtoArray arr i + else + let p' = p { pointIteration = n', + pointPhase = ph', + pointTime = basicTime sc n' ph' } + i' = n' * phs + ph' + in do a <- m p' + a `seq` writeProtoArray arr i' a + if ph' >= phs - 1 + then do writeProtoRef phref 0 + writeProtoRef nref (n' + 1) + loop (n' + 1) 0 + else do writeProtoRef phref (ph' + 1) + loop n' (ph' + 1) + n' <- readProtoRef nref + ph' <- readProtoRef phref + loop n' ph' + return $ interpolateDynamics $ Dynamics r + +-- | Memoize and order the computation in the integration time points using +-- the 'discreteDynamics' interpolation. It consumes less memory than the 'memoDynamics' +-- function but it is not aware of the Runge-Kutta method. There is a subtle +-- difference when we request for values in the intermediate time points +-- that are used by this method to integrate. In general case you should +-- prefer the 'memo0Dynamics' function above 'memoDynamics'. +memo0Dynamics :: (Unboxed m e, MonadComp m) => Dynamics m e -> Simulation m (Dynamics m e) +{-# INLINABLE memo0Dynamics #-} +memo0Dynamics (Dynamics m) = + Simulation $ \r -> + do let sc = runSpecs r + s = runSession r + ns = 1 + integIterationHiBnd sc + arr <- newProtoArray_ s ns + nref <- newProtoRef s 0 + let r p = + do let sc = pointSpecs p + n = pointIteration p + loop n' = + if n' > n + then + readProtoArray arr n + else + let p' = p { pointIteration = n', pointPhase = 0, + pointTime = basicTime sc n' 0 } + in do a <- m p' + a `seq` writeProtoArray arr n' a + writeProtoRef nref (n' + 1) + loop (n' + 1) + n' <- readProtoRef nref + loop n' + return $ discreteDynamics $ Dynamics r 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,140 +1,140 @@ - --- | --- Module : Simulation.Aivika.Trans.Dynamics.Random --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines the random functions that always return the same values --- in the integration time points within a single simulation run. The values --- for another simulation run will be regenerated anew. --- --- For example, the computations returned by these functions can be used in --- the equations of System Dynamics. --- --- Also it is worth noting that the values are generated in a strong order starting --- from 'starttime' with step 'dt'. This is how the 'memo0Dynamics' function --- actually works. --- - -module Simulation.Aivika.Trans.Dynamics.Random - (memoRandomUniformDynamics, - memoRandomUniformIntDynamics, - memoRandomNormalDynamics, - memoRandomExponentialDynamics, - memoRandomErlangDynamics, - memoRandomPoissonDynamics, - memoRandomBinomialDynamics) where - -import System.Random - -import Control.Monad.Trans - -import Simulation.Aivika.Trans.Generator -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Parameter -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Dynamics -import Simulation.Aivika.Trans.Dynamics.Memo.Unboxed - --- | Computation that generates random numbers distributed uniformly and --- memoizes them in the integration time points. -memoRandomUniformDynamics :: MonadComp m - => Dynamics m Double -- ^ minimum - -> Dynamics m Double -- ^ maximum - -> Simulation m (Dynamics m Double) -memoRandomUniformDynamics min max = - memo0Dynamics $ - Dynamics $ \p -> - do let g = runGenerator $ pointRun p - min' <- invokeDynamics p min - max' <- invokeDynamics p max - generateUniform g min' max' - --- | Computation that generates random integer numbers distributed uniformly and --- memoizes them in the integration time points. -memoRandomUniformIntDynamics :: MonadComp m - => Dynamics m Int -- ^ minimum - -> Dynamics m Int -- ^ maximum - -> Simulation m (Dynamics m Int) -memoRandomUniformIntDynamics min max = - memo0Dynamics $ - Dynamics $ \p -> - do let g = runGenerator $ pointRun p - min' <- invokeDynamics p min - max' <- invokeDynamics p max - generateUniformInt g min' max' - --- | Computation that generates random numbers distributed normally and --- memoizes them in the integration time points. -memoRandomNormalDynamics :: MonadComp m - => Dynamics m Double -- ^ mean - -> Dynamics m Double -- ^ deviation - -> Simulation m (Dynamics m Double) -memoRandomNormalDynamics mu nu = - memo0Dynamics $ - Dynamics $ \p -> - do let g = runGenerator $ pointRun p - mu' <- invokeDynamics p mu - nu' <- invokeDynamics p nu - generateNormal g mu' nu' - --- | Computation that generates exponential random numbers with the specified mean --- (the reciprocal of the rate) and memoizes them in the integration time points. -memoRandomExponentialDynamics :: MonadComp m - => Dynamics m Double - -- ^ the mean (the reciprocal of the rate) - -> Simulation m (Dynamics m Double) -memoRandomExponentialDynamics mu = - memo0Dynamics $ - Dynamics $ \p -> - do let g = runGenerator $ pointRun p - mu' <- invokeDynamics p mu - generateExponential g mu' - --- | Computation that generates the Erlang random numbers with the specified scale --- (the reciprocal of the rate) and integer shape but memoizes them in the integration --- time points. -memoRandomErlangDynamics :: MonadComp m - => Dynamics m Double - -- ^ the scale (the reciprocal of the rate) - -> Dynamics m Int - -- ^ the shape - -> Simulation m (Dynamics m Double) -memoRandomErlangDynamics beta m = - memo0Dynamics $ - Dynamics $ \p -> - do let g = runGenerator $ pointRun p - beta' <- invokeDynamics p beta - m' <- invokeDynamics p m - generateErlang g beta' m' - --- | Computation that generats the Poisson random numbers with the specified mean --- and memoizes them in the integration time points. -memoRandomPoissonDynamics :: MonadComp m - => Dynamics m Double - -- ^ the mean - -> Simulation m (Dynamics m Int) -memoRandomPoissonDynamics mu = - memo0Dynamics $ - Dynamics $ \p -> - do let g = runGenerator $ pointRun p - mu' <- invokeDynamics p mu - generatePoisson g mu' - --- | Computation that generates binomial random numbers with the specified --- probability and trials but memoizes them in the integration time points. -memoRandomBinomialDynamics :: MonadComp m - => Dynamics m Double -- ^ the probability - -> Dynamics m Int -- ^ the number of trials - -> Simulation m (Dynamics m Int) -memoRandomBinomialDynamics prob trials = - memo0Dynamics $ - Dynamics $ \p -> - do let g = runGenerator $ pointRun p - prob' <- invokeDynamics p prob - trials' <- invokeDynamics p trials - generateBinomial g prob' trials' + +-- | +-- Module : Simulation.Aivika.Trans.Dynamics.Random +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the random functions that always return the same values +-- in the integration time points within a single simulation run. The values +-- for another simulation run will be regenerated anew. +-- +-- For example, the computations returned by these functions can be used in +-- the equations of System Dynamics. +-- +-- Also it is worth noting that the values are generated in a strong order starting +-- from 'starttime' with step 'dt'. This is how the 'memo0Dynamics' function +-- actually works. +-- + +module Simulation.Aivika.Trans.Dynamics.Random + (memoRandomUniformDynamics, + memoRandomUniformIntDynamics, + memoRandomNormalDynamics, + memoRandomExponentialDynamics, + memoRandomErlangDynamics, + memoRandomPoissonDynamics, + memoRandomBinomialDynamics) where + +import System.Random + +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Generator +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics +import Simulation.Aivika.Trans.Dynamics.Memo.Unboxed + +-- | Computation that generates random numbers distributed uniformly and +-- memoizes them in the integration time points. +memoRandomUniformDynamics :: MonadComp m + => Dynamics m Double -- ^ minimum + -> Dynamics m Double -- ^ maximum + -> Simulation m (Dynamics m Double) +memoRandomUniformDynamics min max = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + min' <- invokeDynamics p min + max' <- invokeDynamics p max + generateUniform g min' max' + +-- | Computation that generates random integer numbers distributed uniformly and +-- memoizes them in the integration time points. +memoRandomUniformIntDynamics :: MonadComp m + => Dynamics m Int -- ^ minimum + -> Dynamics m Int -- ^ maximum + -> Simulation m (Dynamics m Int) +memoRandomUniformIntDynamics min max = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + min' <- invokeDynamics p min + max' <- invokeDynamics p max + generateUniformInt g min' max' + +-- | Computation that generates random numbers distributed normally and +-- memoizes them in the integration time points. +memoRandomNormalDynamics :: MonadComp m + => Dynamics m Double -- ^ mean + -> Dynamics m Double -- ^ deviation + -> Simulation m (Dynamics m Double) +memoRandomNormalDynamics mu nu = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + mu' <- invokeDynamics p mu + nu' <- invokeDynamics p nu + generateNormal g mu' nu' + +-- | Computation that generates exponential random numbers with the specified mean +-- (the reciprocal of the rate) and memoizes them in the integration time points. +memoRandomExponentialDynamics :: MonadComp m + => Dynamics m Double + -- ^ the mean (the reciprocal of the rate) + -> Simulation m (Dynamics m Double) +memoRandomExponentialDynamics mu = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + mu' <- invokeDynamics p mu + generateExponential g mu' + +-- | Computation that generates the Erlang random numbers with the specified scale +-- (the reciprocal of the rate) and integer shape but memoizes them in the integration +-- time points. +memoRandomErlangDynamics :: MonadComp m + => Dynamics m Double + -- ^ the scale (the reciprocal of the rate) + -> Dynamics m Int + -- ^ the shape + -> Simulation m (Dynamics m Double) +memoRandomErlangDynamics beta m = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + beta' <- invokeDynamics p beta + m' <- invokeDynamics p m + generateErlang g beta' m' + +-- | Computation that generats the Poisson random numbers with the specified mean +-- and memoizes them in the integration time points. +memoRandomPoissonDynamics :: MonadComp m + => Dynamics m Double + -- ^ the mean + -> Simulation m (Dynamics m Int) +memoRandomPoissonDynamics mu = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + mu' <- invokeDynamics p mu + generatePoisson g mu' + +-- | Computation that generates binomial random numbers with the specified +-- probability and trials but memoizes them in the integration time points. +memoRandomBinomialDynamics :: MonadComp m + => Dynamics m Double -- ^ the probability + -> Dynamics m Int -- ^ the number of trials + -> Simulation m (Dynamics m Int) +memoRandomBinomialDynamics prob trials = + memo0Dynamics $ + Dynamics $ \p -> + do let g = runGenerator $ pointRun p + prob' <- invokeDynamics p prob + trials' <- invokeDynamics p trials + generateBinomial g prob' trials' 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,42 +1,42 @@ - --- | --- Module : Simulation.Aivika.Trans.Event --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines the 'Event' monad which is very similar to the 'Dynamics' --- monad but only now the computation is strongly synchronized with the event queue. --- -module Simulation.Aivika.Trans.Event - (-- * Event Monad - Event, - EventLift(..), - EventProcessing(..), - runEventInStartTime, - runEventInStopTime, - -- * Event Queue - EventQueueing(..), - enqueueEventWithCancellation, - enqueueEventWithTimes, - enqueueEventWithIntegTimes, - yieldEvent, - -- * Cancelling Event - EventCancellation, - cancelEvent, - eventCancelled, - eventFinished, - -- * Error Handling - catchEvent, - finallyEvent, - throwEvent, - -- * Memoization - memoEvent, - memoEventInTime, - -- * Disposable - DisposableEvent(..)) where - -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Event + +-- | +-- Module : Simulation.Aivika.Trans.Event +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the 'Event' monad which is very similar to the 'Dynamics' +-- monad but only now the computation is strongly synchronized with the event queue. +-- +module Simulation.Aivika.Trans.Event + (-- * Event Monad + Event, + EventLift(..), + EventProcessing(..), + runEventInStartTime, + runEventInStopTime, + -- * Event Queue + EventQueueing(..), + enqueueEventWithCancellation, + enqueueEventWithTimes, + enqueueEventWithIntegTimes, + yieldEvent, + -- * Cancelling Event + EventCancellation, + cancelEvent, + eventCancelled, + eventFinished, + -- * Error Handling + catchEvent, + finallyEvent, + throwEvent, + -- * Memoization + memoEvent, + memoEventInTime, + -- * Disposable + DisposableEvent(..)) where + +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Event diff --git a/Simulation/Aivika/Trans/Exception.hs b/Simulation/Aivika/Trans/Exception.hs --- a/Simulation/Aivika/Trans/Exception.hs +++ b/Simulation/Aivika/Trans/Exception.hs @@ -1,46 +1,46 @@ - --- | --- Module : Simulation.Aivika.Trans.Exception --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It defines a type class of monads with 'IO' exception handling capabilities. --- -module Simulation.Aivika.Trans.Exception - (ExceptionThrowing(..), - ExceptionHandling(..)) where - -import Control.Monad.Trans -import Control.Exception - --- | A computation within which we can throw an exception. -class ExceptionThrowing m where - - -- | Throw an exception. - throwComp :: Exception e => e -> m a - --- | A computation within which we can handle 'IO' exceptions --- as well as define finalisation blocks. -class (ExceptionThrowing m, MonadIO m) => ExceptionHandling m where - - -- | Catch an 'IO' exception within the computation. - catchComp :: (Exception e, MonadIO m) => m a -> (e -> m a) -> m a - - -- | Introduce a finalisation block. - finallyComp :: MonadIO m => m a -> m b -> m a - -instance ExceptionThrowing IO where - - {-# INLINE throwComp #-} - throwComp = throw - -instance ExceptionHandling IO where - - {-# INLINE catchComp #-} - catchComp = catch - - {-# INLINE finallyComp #-} - finallyComp = finally + +-- | +-- Module : Simulation.Aivika.Trans.Exception +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It defines a type class of monads with 'IO' exception handling capabilities. +-- +module Simulation.Aivika.Trans.Exception + (ExceptionThrowing(..), + ExceptionHandling(..)) where + +import Control.Monad.Trans +import Control.Exception + +-- | A computation within which we can throw an exception. +class ExceptionThrowing m where + + -- | Throw an exception. + throwComp :: Exception e => e -> m a + +-- | A computation within which we can handle 'IO' exceptions +-- as well as define finalisation blocks. +class (ExceptionThrowing m, MonadIO m) => ExceptionHandling m where + + -- | Catch an 'IO' exception within the computation. + catchComp :: (Exception e, MonadIO m) => m a -> (e -> m a) -> m a + + -- | Introduce a finalisation block. + finallyComp :: MonadIO m => m a -> m b -> m a + +instance ExceptionThrowing IO where + + {-# INLINE throwComp #-} + throwComp = throw + +instance ExceptionHandling IO where + + {-# INLINE catchComp #-} + catchComp = catch + + {-# INLINE finallyComp #-} + finallyComp = finally 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 @@ -1,269 +1,269 @@ - -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Simulation.Aivika.Trans.Generator --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- Below is defined a random number generator. --- -module Simulation.Aivika.Trans.Generator - (GeneratorMonad(..), - GeneratorType(..)) where - -import System.Random - -import Data.IORef - -import Simulation.Aivika.Trans.Session - --- | Defines a monad whithin which computation the random number generator can work. -class (Functor m, Monad m) => GeneratorMonad m where - - -- | Defines a random number generator. - data Generator m :: * - - -- | Generate an uniform random number - -- with the specified minimum and maximum. - generateUniform :: Generator m -> Double -> Double -> m Double - - -- | Generate an uniform integer random number - -- with the specified minimum and maximum. - generateUniformInt :: Generator m -> Int -> Int -> m Int - - -- | Generate a normal random number - -- with the specified mean and deviation. - generateNormal :: Generator m -> Double -> Double -> m Double - - -- | Generate a random number distributed exponentially - -- with the specified mean (the reciprocal of the rate). - generateExponential :: Generator m -> Double -> m Double - - -- | Generate the Erlang random number - -- with the specified scale (the reciprocal of the rate) - -- and integer shape. - generateErlang :: Generator m -> Double -> Int -> m Double - - -- | Generate the Poisson random number with the specified mean. - generatePoisson :: Generator m -> Double -> m Int - - -- | Generate the binomial random number - -- with the specified probability and number of trials. - generateBinomial :: Generator m -> Double -> Int -> m Int - - -- | Create a new random number generator by the specified type with current session. - newGenerator :: Session m -> GeneratorType m -> m (Generator m) - - -- | Create a new random generator by the specified standard generator within current session. - newRandomGenerator :: RandomGen g => Session m -> g -> m (Generator m) - - -- | Create a new random generator by the specified uniform generator of numbers - -- from 0 to 1 within current session. - newRandomGenerator01 :: Session m -> m Double -> m (Generator m) - -instance GeneratorMonad IO where - - data Generator IO = - Generator { generator01 :: IO Double, - -- ^ the generator of uniform numbers from 0 to 1 - generatorNormal01 :: IO Double - -- ^ the generator of normal numbers with mean 0 and variance 1 - } - - {-# SPECIALISE INLINE generateUniform :: Generator IO -> Double -> Double -> IO Double #-} - generateUniform = generateUniform01 . generator01 - - {-# SPECIALISE INLINE generateUniformInt :: Generator IO -> Int -> Int -> IO Int #-} - generateUniformInt = generateUniformInt01 . generator01 - - {-# SPECIALISE INLINE generateUniform :: Generator IO -> Double -> Double -> IO Double #-} - generateNormal = generateNormal01 . generatorNormal01 - - {-# SPECIALISE INLINE generateExponential :: Generator IO -> Double -> IO Double #-} - generateExponential = generateExponential01 . generator01 - - {-# SPECIALISE INLINE generateErlang :: Generator IO -> Double -> Int -> IO Double #-} - generateErlang = generateErlang01 . generator01 - - {-# SPECIALISE INLINE generatePoisson :: Generator IO -> Double -> IO Int #-} - generatePoisson = generatePoisson01 . generator01 - - {-# SPECIALISE INLINE generateBinomial :: Generator IO -> Double -> Int -> IO Int #-} - generateBinomial = generateBinomial01 . generator01 - - newGenerator session tp = - case tp of - SimpleGenerator -> - newStdGen >>= newRandomGenerator session - SimpleGeneratorWithSeed x -> - newRandomGenerator session $ mkStdGen x - CustomGenerator g -> - g - CustomGenerator01 g -> - newRandomGenerator01 session g - - newRandomGenerator session g = - do r <- newIORef g - let g01 = do g <- readIORef r - let (x, g') = random g - writeIORef r g' - return x - newRandomGenerator01 session g01 - - newRandomGenerator01 session g01 = - do gNormal01 <- newNormalGenerator01 g01 - return Generator { generator01 = g01, - generatorNormal01 = gNormal01 } - --- | Defines a type of the random number generator. -data GeneratorType m = SimpleGenerator - -- ^ The simple random number generator. - | SimpleGeneratorWithSeed Int - -- ^ The simple random number generator with the specified seed. - | CustomGenerator (m (Generator m)) - -- ^ The custom random number generator. - | CustomGenerator01 (m Double) - -- ^ The custom random number generator by the specified uniform - -- generator of numbers from 0 to 1. - --- | Generate an uniform random number with the specified minimum and maximum. -generateUniform01 :: IO Double - -- ^ the generator - -> Double - -- ^ minimum - -> Double - -- ^ maximum - -> IO Double -generateUniform01 g min max = - do x <- g - return $ min + x * (max - min) - --- | Generate an uniform random number with the specified minimum and maximum. -generateUniformInt01 :: IO Double - -- ^ the generator - -> Int - -- ^ minimum - -> Int - -- ^ maximum - -> IO Int -generateUniformInt01 g min max = - do x <- g - let min' = fromIntegral min - max' = fromIntegral max - return $ round (min' + x * (max' - min')) - --- | Generate a normal random number by the specified generator, mean and variance. -generateNormal01 :: IO Double - -- ^ normal random numbers with mean 0 and variance 1 - -> Double - -- ^ mean - -> Double - -- ^ variance - -> IO Double -generateNormal01 g mu nu = - do x <- g - return $ mu + nu * x - --- | Create a normal random number generator with mean 0 and variance 1 --- by the specified generator of uniform random numbers from 0 to 1. -newNormalGenerator01 :: IO Double - -- ^ the generator - -> IO (IO Double) -newNormalGenerator01 g = - do nextRef <- newIORef 0.0 - flagRef <- newIORef False - xi1Ref <- newIORef 0.0 - xi2Ref <- newIORef 0.0 - psiRef <- newIORef 0.0 - let loop = - do psi <- readIORef psiRef - if (psi >= 1.0) || (psi == 0.0) - then do g1 <- g - g2 <- g - let xi1 = 2.0 * g1 - 1.0 - xi2 = 2.0 * g2 - 1.0 - psi = xi1 * xi1 + xi2 * xi2 - writeIORef xi1Ref xi1 - writeIORef xi2Ref xi2 - writeIORef psiRef psi - loop - else writeIORef psiRef $ sqrt (- 2.0 * log psi / psi) - return $ - do flag <- readIORef flagRef - if flag - then do writeIORef flagRef False - readIORef nextRef - else do writeIORef xi1Ref 0.0 - writeIORef xi2Ref 0.0 - writeIORef psiRef 0.0 - loop - xi1 <- readIORef xi1Ref - xi2 <- readIORef xi2Ref - psi <- readIORef psiRef - writeIORef flagRef True - writeIORef nextRef $ xi2 * psi - return $ xi1 * psi - --- | Return the exponential random number with the specified mean. -generateExponential01 :: IO Double - -- ^ the generator - -> Double - -- ^ the mean - -> IO Double -generateExponential01 g mu = - do x <- g - return (- log x * mu) - --- | Return the Erlang random number. -generateErlang01 :: IO Double - -- ^ the generator - -> Double - -- ^ the scale - -> Int - -- ^ the shape - -> IO Double -generateErlang01 g beta m = - do x <- loop m 1 - return (- log x * beta) - where loop m acc - | m < 0 = error "Negative shape: generateErlang." - | m == 0 = return acc - | otherwise = do x <- g - loop (m - 1) (x * acc) - --- | Generate the Poisson random number with the specified mean. -generatePoisson01 :: IO Double - -- ^ the generator - -> Double - -- ^ the mean - -> IO Int -generatePoisson01 g mu = - do prob0 <- g - let loop prob prod acc - | prob <= prod = return acc - | otherwise = loop - (prob - prod) - (prod * mu / fromIntegral (acc + 1)) - (acc + 1) - loop prob0 (exp (- mu)) 0 - --- | Generate a binomial random number with the specified probability and number of trials. -generateBinomial01 :: IO Double - -- ^ the generator - -> Double - -- ^ the probability - -> Int - -- ^ the number of trials - -> IO Int -generateBinomial01 g prob trials = loop trials 0 where - loop n acc - | n < 0 = error "Negative number of trials: generateBinomial." - | n == 0 = return acc - | otherwise = do x <- g - if x <= prob - then loop (n - 1) (acc + 1) - else loop (n - 1) acc + +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Simulation.Aivika.Trans.Generator +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- Below is defined a random number generator. +-- +module Simulation.Aivika.Trans.Generator + (GeneratorMonad(..), + GeneratorType(..)) where + +import System.Random + +import Data.IORef + +import Simulation.Aivika.Trans.Session + +-- | Defines a monad whithin which computation the random number generator can work. +class (Functor m, Monad m) => GeneratorMonad m where + + -- | Defines a random number generator. + data Generator m :: * + + -- | Generate an uniform random number + -- with the specified minimum and maximum. + generateUniform :: Generator m -> Double -> Double -> m Double + + -- | Generate an uniform integer random number + -- with the specified minimum and maximum. + generateUniformInt :: Generator m -> Int -> Int -> m Int + + -- | Generate a normal random number + -- with the specified mean and deviation. + generateNormal :: Generator m -> Double -> Double -> m Double + + -- | Generate a random number distributed exponentially + -- with the specified mean (the reciprocal of the rate). + generateExponential :: Generator m -> Double -> m Double + + -- | Generate the Erlang random number + -- with the specified scale (the reciprocal of the rate) + -- and integer shape. + generateErlang :: Generator m -> Double -> Int -> m Double + + -- | Generate the Poisson random number with the specified mean. + generatePoisson :: Generator m -> Double -> m Int + + -- | Generate the binomial random number + -- with the specified probability and number of trials. + generateBinomial :: Generator m -> Double -> Int -> m Int + + -- | Create a new random number generator by the specified type with current session. + newGenerator :: Session m -> GeneratorType m -> m (Generator m) + + -- | Create a new random generator by the specified standard generator within current session. + newRandomGenerator :: RandomGen g => Session m -> g -> m (Generator m) + + -- | Create a new random generator by the specified uniform generator of numbers + -- from 0 to 1 within current session. + newRandomGenerator01 :: Session m -> m Double -> m (Generator m) + +instance GeneratorMonad IO where + + data Generator IO = + Generator { generator01 :: IO Double, + -- ^ the generator of uniform numbers from 0 to 1 + generatorNormal01 :: IO Double + -- ^ the generator of normal numbers with mean 0 and variance 1 + } + + {-# SPECIALISE INLINE generateUniform :: Generator IO -> Double -> Double -> IO Double #-} + generateUniform = generateUniform01 . generator01 + + {-# SPECIALISE INLINE generateUniformInt :: Generator IO -> Int -> Int -> IO Int #-} + generateUniformInt = generateUniformInt01 . generator01 + + {-# SPECIALISE INLINE generateUniform :: Generator IO -> Double -> Double -> IO Double #-} + generateNormal = generateNormal01 . generatorNormal01 + + {-# SPECIALISE INLINE generateExponential :: Generator IO -> Double -> IO Double #-} + generateExponential = generateExponential01 . generator01 + + {-# SPECIALISE INLINE generateErlang :: Generator IO -> Double -> Int -> IO Double #-} + generateErlang = generateErlang01 . generator01 + + {-# SPECIALISE INLINE generatePoisson :: Generator IO -> Double -> IO Int #-} + generatePoisson = generatePoisson01 . generator01 + + {-# SPECIALISE INLINE generateBinomial :: Generator IO -> Double -> Int -> IO Int #-} + generateBinomial = generateBinomial01 . generator01 + + newGenerator session tp = + case tp of + SimpleGenerator -> + newStdGen >>= newRandomGenerator session + SimpleGeneratorWithSeed x -> + newRandomGenerator session $ mkStdGen x + CustomGenerator g -> + g + CustomGenerator01 g -> + newRandomGenerator01 session g + + newRandomGenerator session g = + do r <- newIORef g + let g01 = do g <- readIORef r + let (x, g') = random g + writeIORef r g' + return x + newRandomGenerator01 session g01 + + newRandomGenerator01 session g01 = + do gNormal01 <- newNormalGenerator01 g01 + return Generator { generator01 = g01, + generatorNormal01 = gNormal01 } + +-- | Defines a type of the random number generator. +data GeneratorType m = SimpleGenerator + -- ^ The simple random number generator. + | SimpleGeneratorWithSeed Int + -- ^ The simple random number generator with the specified seed. + | CustomGenerator (m (Generator m)) + -- ^ The custom random number generator. + | CustomGenerator01 (m Double) + -- ^ The custom random number generator by the specified uniform + -- generator of numbers from 0 to 1. + +-- | Generate an uniform random number with the specified minimum and maximum. +generateUniform01 :: IO Double + -- ^ the generator + -> Double + -- ^ minimum + -> Double + -- ^ maximum + -> IO Double +generateUniform01 g min max = + do x <- g + return $ min + x * (max - min) + +-- | Generate an uniform random number with the specified minimum and maximum. +generateUniformInt01 :: IO Double + -- ^ the generator + -> Int + -- ^ minimum + -> Int + -- ^ maximum + -> IO Int +generateUniformInt01 g min max = + do x <- g + let min' = fromIntegral min + max' = fromIntegral max + return $ round (min' + x * (max' - min')) + +-- | Generate a normal random number by the specified generator, mean and variance. +generateNormal01 :: IO Double + -- ^ normal random numbers with mean 0 and variance 1 + -> Double + -- ^ mean + -> Double + -- ^ variance + -> IO Double +generateNormal01 g mu nu = + do x <- g + return $ mu + nu * x + +-- | Create a normal random number generator with mean 0 and variance 1 +-- by the specified generator of uniform random numbers from 0 to 1. +newNormalGenerator01 :: IO Double + -- ^ the generator + -> IO (IO Double) +newNormalGenerator01 g = + do nextRef <- newIORef 0.0 + flagRef <- newIORef False + xi1Ref <- newIORef 0.0 + xi2Ref <- newIORef 0.0 + psiRef <- newIORef 0.0 + let loop = + do psi <- readIORef psiRef + if (psi >= 1.0) || (psi == 0.0) + then do g1 <- g + g2 <- g + let xi1 = 2.0 * g1 - 1.0 + xi2 = 2.0 * g2 - 1.0 + psi = xi1 * xi1 + xi2 * xi2 + writeIORef xi1Ref xi1 + writeIORef xi2Ref xi2 + writeIORef psiRef psi + loop + else writeIORef psiRef $ sqrt (- 2.0 * log psi / psi) + return $ + do flag <- readIORef flagRef + if flag + then do writeIORef flagRef False + readIORef nextRef + else do writeIORef xi1Ref 0.0 + writeIORef xi2Ref 0.0 + writeIORef psiRef 0.0 + loop + xi1 <- readIORef xi1Ref + xi2 <- readIORef xi2Ref + psi <- readIORef psiRef + writeIORef flagRef True + writeIORef nextRef $ xi2 * psi + return $ xi1 * psi + +-- | Return the exponential random number with the specified mean. +generateExponential01 :: IO Double + -- ^ the generator + -> Double + -- ^ the mean + -> IO Double +generateExponential01 g mu = + do x <- g + return (- log x * mu) + +-- | Return the Erlang random number. +generateErlang01 :: IO Double + -- ^ the generator + -> Double + -- ^ the scale + -> Int + -- ^ the shape + -> IO Double +generateErlang01 g beta m = + do x <- loop m 1 + return (- log x * beta) + where loop m acc + | m < 0 = error "Negative shape: generateErlang." + | m == 0 = return acc + | otherwise = do x <- g + loop (m - 1) (x * acc) + +-- | Generate the Poisson random number with the specified mean. +generatePoisson01 :: IO Double + -- ^ the generator + -> Double + -- ^ the mean + -> IO Int +generatePoisson01 g mu = + do prob0 <- g + let loop prob prod acc + | prob <= prod = return acc + | otherwise = loop + (prob - prod) + (prod * mu / fromIntegral (acc + 1)) + (acc + 1) + loop prob0 (exp (- mu)) 0 + +-- | Generate a binomial random number with the specified probability and number of trials. +generateBinomial01 :: IO Double + -- ^ the generator + -> Double + -- ^ the probability + -> Int + -- ^ the number of trials + -> IO Int +generateBinomial01 g prob trials = loop trials 0 where + loop n acc + | n < 0 = error "Negative number of trials: generateBinomial." + | n == 0 = return acc + | otherwise = do x <- g + if x <= prob + then loop (n - 1) (acc + 1) + else loop (n - 1) acc diff --git a/Simulation/Aivika/Trans/Internal/Cont.hs b/Simulation/Aivika/Trans/Internal/Cont.hs --- a/Simulation/Aivika/Trans/Internal/Cont.hs +++ b/Simulation/Aivika/Trans/Internal/Cont.hs @@ -1,687 +1,687 @@ - --- | --- Module : Simulation.Aivika.Trans.Internal.Cont --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The 'Cont' monad is a variation of the standard Cont monad --- and F# async workflow, where the result of applying --- the continuations is the 'Event' computation. --- -module Simulation.Aivika.Trans.Internal.Cont - (ContCancellationSource, - ContParams, - ContCancellation(..), - Cont(..), - newContCancellationSource, - contCancellationInitiated, - contCancellationInitiate, - contCancellationInitiating, - contCancellationBind, - contCancellationConnect, - invokeCont, - runCont, - rerunCont, - spawnCont, - contParallel, - contParallel_, - catchCont, - finallyCont, - throwCont, - resumeCont, - resumeECont, - contCanceled, - contFreeze, - contAwait) where - -import Data.Array -import Data.Monoid - -import Control.Exception -import Control.Monad -import Control.Monad.Trans -import Control.Applicative - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.ProtoArray -import Simulation.Aivika.Trans.Exception -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Parameter -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Dynamics -import Simulation.Aivika.Trans.Internal.Event -import Simulation.Aivika.Trans.Internal.Signal - --- | It defines how the parent and child computations should be cancelled. -data ContCancellation = CancelTogether - -- ^ Cancel the both computations together. - | CancelChildAfterParent - -- ^ Cancel the child if its parent is cancelled. - | CancelParentAfterChild - -- ^ Cancel the parent if its child is cancelled. - | CancelInIsolation - -- ^ Cancel the computations in isolation. - --- | It manages the cancellation process. -data ContCancellationSource m = - ContCancellationSource { contCancellationInitiatedRef :: ProtoRef m Bool, - contCancellationActivatedRef :: ProtoRef m Bool, - contCancellationInitiatingSource :: SignalSource m () - } - --- | Create the cancellation source. -newContCancellationSource :: MonadComp m => Simulation m (ContCancellationSource m) -newContCancellationSource = - Simulation $ \r -> - do let sn = runSession r - r1 <- newProtoRef sn False - r2 <- newProtoRef sn False - s <- invokeSimulation r newSignalSource - return ContCancellationSource { contCancellationInitiatedRef = r1, - contCancellationActivatedRef = r2, - contCancellationInitiatingSource = s - } - --- | Signal when the cancellation is intiating. -contCancellationInitiating :: ContCancellationSource m -> Signal m () -contCancellationInitiating = - publishSignal . contCancellationInitiatingSource - --- | Whether the cancellation was initiated. -contCancellationInitiated :: MonadComp m => ContCancellationSource m -> (Event m Bool) -contCancellationInitiated x = - Event $ \p -> readProtoRef (contCancellationInitiatedRef x) - --- | Whether the cancellation was activated. -contCancellationActivated :: MonadComp m => ContCancellationSource m -> m Bool -contCancellationActivated = - readProtoRef . contCancellationActivatedRef - --- | Deactivate the cancellation. -contCancellationDeactivate :: MonadComp m => ContCancellationSource m -> m () -contCancellationDeactivate x = - writeProtoRef (contCancellationActivatedRef x) False - --- | If the main computation is cancelled then all the nested ones will be cancelled too. -contCancellationBind :: MonadComp m => ContCancellationSource m -> [ContCancellationSource m] -> Event m (DisposableEvent m) -contCancellationBind x ys = - Event $ \p -> - do hs1 <- forM ys $ \y -> - invokeEvent p $ - handleSignal (contCancellationInitiating x) $ \_ -> - contCancellationInitiate y - hs2 <- forM ys $ \y -> - invokeEvent p $ - handleSignal (contCancellationInitiating y) $ \_ -> - contCancellationInitiate x - return $ mconcat hs1 <> mconcat hs2 - --- | Connect the parent computation to the child one. -contCancellationConnect :: MonadComp m - => ContCancellationSource m - -- ^ the parent - -> ContCancellation - -- ^ how to connect - -> ContCancellationSource m - -- ^ the child - -> Event m (DisposableEvent m) - -- ^ computation of the disposable handler -contCancellationConnect parent cancellation child = - Event $ \p -> - do let m1 = - handleSignal (contCancellationInitiating parent) $ \_ -> - contCancellationInitiate child - m2 = - handleSignal (contCancellationInitiating child) $ \_ -> - contCancellationInitiate parent - h1 <- - case cancellation of - CancelTogether -> invokeEvent p m1 - CancelChildAfterParent -> invokeEvent p m1 - CancelParentAfterChild -> return mempty - CancelInIsolation -> return mempty - h2 <- - case cancellation of - CancelTogether -> invokeEvent p m2 - CancelChildAfterParent -> return mempty - CancelParentAfterChild -> invokeEvent p m2 - CancelInIsolation -> return mempty - return $ h1 <> h2 - --- | Initiate the cancellation. -contCancellationInitiate :: MonadComp m => ContCancellationSource m -> Event m () -contCancellationInitiate x = - Event $ \p -> - do f <- readProtoRef (contCancellationInitiatedRef x) - unless f $ - do writeProtoRef (contCancellationInitiatedRef x) True - writeProtoRef (contCancellationActivatedRef x) True - invokeEvent p $ triggerSignal (contCancellationInitiatingSource x) () - --- | The 'Cont' type is similar to the standard Cont monad --- and F# async workflow but only the result of applying --- the continuations return the 'Event' computation. -newtype Cont m a = Cont (ContParams m a -> Event m ()) - --- | The continuation parameters. -data ContParams m a = - ContParams { contCont :: a -> Event m (), - contAux :: ContParamsAux m } - --- | The auxiliary continuation parameters. -data ContParamsAux m = - ContParamsAux { contECont :: SomeException -> Event m (), - contCCont :: () -> Event m (), - contCancelSource :: ContCancellationSource m, - contCancelFlag :: m Bool, - contCatchFlag :: Bool } - -instance MonadComp m => Monad (Cont m) where - - {-# INLINE return #-} - return a = - Cont $ \c -> - Event $ \p -> - do z <- contCanceled c - if z - then cancelCont p c - else invokeEvent p $ contCont c a - - {-# INLINE (>>=) #-} - (Cont m) >>= k = - Cont $ \c -> - Event $ \p -> - do z <- contCanceled c - if z - then cancelCont p c - else invokeEvent p $ m $ - let cont a = invokeCont c (k a) - in c { contCont = cont } - -instance MonadCompTrans Cont where - - {-# INLINE liftComp #-} - liftComp m = - Cont $ \c -> - Event $ \p -> - if contCatchFlag . contAux $ c - then liftWithCatching m p c - else liftWithoutCatching m p c - -instance ParameterLift Cont where - - {-# INLINE liftParameter #-} - liftParameter (Parameter m) = - Cont $ \c -> - Event $ \p -> - if contCatchFlag . contAux $ c - then liftWithCatching (m $ pointRun p) p c - else liftWithoutCatching (m $ pointRun p) p c - -instance SimulationLift Cont where - - {-# INLINE liftSimulation #-} - liftSimulation (Simulation m) = - Cont $ \c -> - Event $ \p -> - if contCatchFlag . contAux $ c - then liftWithCatching (m $ pointRun p) p c - else liftWithoutCatching (m $ pointRun p) p c - -instance DynamicsLift Cont where - - {-# INLINE liftDynamics #-} - liftDynamics (Dynamics m) = - Cont $ \c -> - Event $ \p -> - if contCatchFlag . contAux $ c - then liftWithCatching (m p) p c - else liftWithoutCatching (m p) p c - -instance EventLift Cont where - - {-# INLINE liftEvent #-} - liftEvent (Event m) = - Cont $ \c -> - Event $ \p -> - if contCatchFlag . contAux $ c - then liftWithCatching (m p) p c - else liftWithoutCatching (m p) p c - -instance (MonadComp m, MonadIO m) => MonadIO (Cont m) where - - {-# INLINE liftIO #-} - liftIO m = - Cont $ \c -> - Event $ \p -> - if contCatchFlag . contAux $ c - then liftWithCatching (liftIO m) p c - else liftWithoutCatching (liftIO m) p c - -instance MonadComp m => Functor (Cont m) where - - {-# INLINE fmap #-} - fmap = liftM - -instance MonadComp m => Applicative (Cont m) where - - {-# INLINE pure #-} - pure = return - - {-# INLINE (<*>) #-} - (<*>) = ap - --- | Invoke the computation. -invokeCont :: ContParams m a -> Cont m a -> Event m () -{-# INLINE invokeCont #-} -invokeCont p (Cont m) = m p - --- | Cancel the computation. -cancelCont :: MonadComp m => Point m -> ContParams m a -> m () -{-# NOINLINE cancelCont #-} -cancelCont p c = - do contCancellationDeactivate (contCancelSource $ contAux c) - invokeEvent p $ (contCCont $ contAux c) () - --- | Like @return a >>= k@. -callCont :: MonadComp m => (a -> Cont m b) -> a -> ContParams m b -> Event m () -callCont k a c = - Event $ \p -> - do z <- contCanceled c - if z - then cancelCont p c - else invokeEvent p $ invokeCont c (k a) - --- | Exception handling within 'Cont' computations. -catchCont :: (MonadComp m, Exception e) => Cont m a -> (e -> Cont m a) -> Cont m a -catchCont (Cont m) h = - Cont $ \c0 -> - Event $ \p -> - do let c = c0 { contAux = (contAux c0) { contCatchFlag = True } } - z <- contCanceled c - if z - then cancelCont p c - else invokeEvent p $ m $ - let econt e0 = - case fromException e0 of - Just e -> callCont h e c - Nothing -> (contECont . contAux $ c) e0 - in c { contAux = (contAux c) { contECont = econt } } - --- | A computation with finalization part. -finallyCont :: MonadComp m => Cont m a -> Cont m b -> Cont m a -finallyCont (Cont m) (Cont m') = - Cont $ \c0 -> - Event $ \p -> - do let c = c0 { contAux = (contAux c0) { contCatchFlag = True } } - z <- contCanceled c - if z - then cancelCont p c - else invokeEvent p $ m $ - let cont a = - Event $ \p -> - invokeEvent p $ m' $ - let cont b = contCont c a - in c { contCont = cont } - econt e = - Event $ \p -> - invokeEvent p $ m' $ - let cont b = (contECont . contAux $ c) e - in c { contCont = cont } - ccont () = - Event $ \p -> - invokeEvent p $ m' $ - let cont b = (contCCont . contAux $ c) () - econt e = (contCCont . contAux $ c) () - in c { contCont = cont, - contAux = (contAux c) { contECont = econt } } - in c { contCont = cont, - contAux = (contAux c) { contECont = econt, - contCCont = ccont } } - --- | Throw the exception with the further exception handling. --- --- By some reason, an exception raised with help of the standard 'throw' function --- is not handled properly within 'Cont' computation, altough it will be still handled --- if it will be wrapped in the 'IO' monad. Therefore, you should use specialised --- functions like the stated one that use the 'throw' function but within the 'IO' computation, --- which allows already handling the exception. -throwCont :: (MonadComp m, Exception e) => e -> Cont m a -throwCont = liftEvent . throwEvent - --- | Run the 'Cont' computation with the specified cancelation source --- and flag indicating whether to catch exceptions from the beginning. -runCont :: MonadComp m - => Cont m a - -- ^ the computation to run - -> (a -> Event m ()) - -- ^ the main branch - -> (SomeException -> Event m ()) - -- ^ the branch for handing exceptions - -> (() -> Event m ()) - -- ^ the branch for cancellation - -> ContCancellationSource m - -- ^ the cancellation source - -> Bool - -- ^ whether to support the exception handling from the beginning - -> Event m () -runCont (Cont m) cont econt ccont cancelSource catchFlag = - m ContParams { contCont = cont, - contAux = - ContParamsAux { contECont = econt, - contCCont = ccont, - contCancelSource = cancelSource, - contCancelFlag = contCancellationActivated cancelSource, - contCatchFlag = catchFlag } } - -liftWithoutCatching :: MonadComp m => m a -> Point m -> ContParams m a -> m () -{-# INLINE liftWithoutCatching #-} -liftWithoutCatching m p c = - do z <- contCanceled c - if z - then cancelCont p c - else do a <- m - invokeEvent p $ contCont c a - -liftWithCatching :: MonadComp m => m a -> Point m -> ContParams m a -> m () -{-# NOINLINE liftWithCatching #-} -liftWithCatching m p c = - do z <- contCanceled c - if z - then cancelCont p c - else do let s = runSession $ pointRun p - aref <- newProtoRef s undefined - eref <- newProtoRef s Nothing - catchComp - (m >>= writeProtoRef aref) - (writeProtoRef eref . Just) - e <- readProtoRef eref - case e of - Nothing -> - do a <- readProtoRef aref - -- tail recursive - invokeEvent p $ contCont c a - Just e -> - -- tail recursive - invokeEvent p $ (contECont . contAux) c e - --- | Resume the computation by the specified parameters. -resumeCont :: MonadComp m => ContParams m a -> a -> Event m () -{-# INLINE resumeCont #-} -resumeCont c a = - Event $ \p -> - do z <- contCanceled c - if z - then cancelCont p c - else invokeEvent p $ contCont c a - --- | Resume the exception handling by the specified parameters. -resumeECont :: MonadComp m => ContParams m a -> SomeException -> Event m () -{-# INLINE resumeECont #-} -resumeECont c e = - Event $ \p -> - do z <- contCanceled c - if z - then cancelCont p c - else invokeEvent p $ (contECont $ contAux c) e - --- | Test whether the computation is canceled. -contCanceled :: ContParams m a -> m Bool -{-# INLINE contCanceled #-} -contCanceled c = contCancelFlag $ contAux c - --- | Execute the specified computations in parallel within --- the current computation and return their results. The cancellation --- of any of the nested computations affects the current computation. --- The exception raised in any of the nested computations is propogated --- to the current computation as well (if the exception handling is --- supported). --- --- Here word @parallel@ literally means that the computations are --- actually executed on a single operating system thread but --- they are processed simultaneously by the event queue. -contParallel :: MonadComp m - => [(Cont m a, ContCancellationSource m)] - -- ^ the list of pairs: - -- the nested computation, - -- the cancellation source - -> Cont m [a] -contParallel xs = - Cont $ \c -> - Event $ \p -> - do let n = length xs - s = runSession $ pointRun p - worker = - do results <- newProtoArray_ s n - counter <- newProtoRef s 0 - catchRef <- newProtoRef s Nothing - hs <- invokeEvent p $ - contCancellationBind (contCancelSource $ contAux c) $ - map snd xs - let propagate = - Event $ \p -> - do n' <- readProtoRef counter - when (n' == n) $ - do invokeEvent p $ disposeEvent hs -- unbind the cancellation sources - f1 <- contCanceled c - f2 <- readProtoRef catchRef - case (f1, f2) of - (False, Nothing) -> - do rs <- protoArrayToList results - invokeEvent p $ resumeCont c rs - (False, Just e) -> - invokeEvent p $ resumeECont c e - (True, _) -> - cancelCont p c - cont i a = - Event $ \p -> - do modifyProtoRef counter (+ 1) - writeProtoArray results i a - invokeEvent p propagate - econt e = - Event $ \p -> - do modifyProtoRef counter (+ 1) - r <- readProtoRef catchRef - case r of - Nothing -> writeProtoRef catchRef $ Just e - Just e' -> return () -- ignore the next error - invokeEvent p propagate - ccont e = - Event $ \p -> - do modifyProtoRef counter (+ 1) - -- the main computation was automatically canceled - invokeEvent p propagate - forM_ (zip [0..n-1] xs) $ \(i, (x, cancelSource)) -> - invokeEvent p $ - runCont x (cont i) econt ccont cancelSource (contCatchFlag $ contAux c) - z <- contCanceled c - if z - then cancelCont p c - else if n == 0 - then invokeEvent p $ contCont c [] - else worker - --- | A partial case of 'contParallel' when we are not interested in --- the results but we are interested in the actions to be peformed by --- the nested computations. -contParallel_ :: MonadComp m - => [(Cont m a, ContCancellationSource m)] - -- ^ the list of pairs: - -- the nested computation, - -- the cancellation source - -> Cont m () -contParallel_ xs = - Cont $ \c -> - Event $ \p -> - do let n = length xs - s = runSession $ pointRun p - worker = - do counter <- newProtoRef s 0 - catchRef <- newProtoRef s Nothing - hs <- invokeEvent p $ - contCancellationBind (contCancelSource $ contAux c) $ - map snd xs - let propagate = - Event $ \p -> - do n' <- readProtoRef counter - when (n' == n) $ - do invokeEvent p $ disposeEvent hs -- unbind the cancellation sources - f1 <- contCanceled c - f2 <- readProtoRef catchRef - case (f1, f2) of - (False, Nothing) -> - invokeEvent p $ resumeCont c () - (False, Just e) -> - invokeEvent p $ resumeECont c e - (True, _) -> - cancelCont p c - cont i a = - Event $ \p -> - do modifyProtoRef counter (+ 1) - -- ignore the result - invokeEvent p propagate - econt e = - Event $ \p -> - do modifyProtoRef counter (+ 1) - r <- readProtoRef catchRef - case r of - Nothing -> writeProtoRef catchRef $ Just e - Just e' -> return () -- ignore the next error - invokeEvent p propagate - ccont e = - Event $ \p -> - do modifyProtoRef counter (+ 1) - -- the main computation was automatically canceled - invokeEvent p propagate - forM_ (zip [0..n-1] xs) $ \(i, (x, cancelSource)) -> - invokeEvent p $ - runCont x (cont i) econt ccont cancelSource (contCatchFlag $ contAux c) - z <- contCanceled c - if z - then cancelCont p c - else if n == 0 - then invokeEvent p $ contCont c () - else worker - --- | Rerun the 'Cont' computation with the specified cancellation source. -rerunCont :: MonadComp m => Cont m a -> ContCancellationSource m -> Cont m a -rerunCont x cancelSource = - Cont $ \c -> - Event $ \p -> - do let worker = - do hs <- invokeEvent p $ - contCancellationBind (contCancelSource $ contAux c) [cancelSource] - let cont a = - Event $ \p -> - do invokeEvent p $ disposeEvent hs -- unbind the cancellation source - invokeEvent p $ resumeCont c a - econt e = - Event $ \p -> - do invokeEvent p $ disposeEvent hs -- unbind the cancellation source - invokeEvent p $ resumeECont c e - ccont e = - Event $ \p -> - do invokeEvent p $ disposeEvent hs -- unbind the cancellation source - cancelCont p c - invokeEvent p $ - runCont x cont econt ccont cancelSource (contCatchFlag $ contAux c) - z <- contCanceled c - if z - then cancelCont p c - else worker - --- | Run the 'Cont' computation in parallel but connect the cancellation sources. -spawnCont :: MonadComp m => ContCancellation -> Cont m () -> ContCancellationSource m -> Cont m () -spawnCont cancellation x cancelSource = - Cont $ \c -> - Event $ \p -> - do let worker = - do hs <- invokeEvent p $ - contCancellationConnect - (contCancelSource $ contAux c) cancellation cancelSource - let cont a = - Event $ \p -> - do invokeEvent p $ disposeEvent hs -- unbind the cancellation source - -- do nothing and it will finish the computation - econt e = - Event $ \p -> - do invokeEvent p $ disposeEvent hs -- unbind the cancellation source - invokeEvent p $ throwEvent e -- this is all we can do - ccont e = - Event $ \p -> - do invokeEvent p $ disposeEvent hs -- unbind the cancellation source - -- do nothing and it will finish the computation - invokeEvent p $ - enqueueEvent (pointTime p) $ - runCont x cont econt ccont cancelSource False - invokeEvent p $ - resumeCont c () - z <- contCanceled c - if z - then cancelCont p c - else worker - --- | Freeze the computation parameters temporarily. -contFreeze :: MonadComp m => ContParams m a -> Event m (Event m (Maybe (ContParams m a))) -contFreeze c = - Event $ \p -> - do let s = runSession $ pointRun p - rh <- newProtoRef s Nothing - rc <- newProtoRef s $ Just c - h <- invokeEvent p $ - handleSignal (contCancellationInitiating $ - contCancelSource $ - contAux c) $ \a -> - Event $ \p -> - do h <- readProtoRef rh - case h of - Nothing -> - error "The handler was lost: contFreeze." - Just h -> - do invokeEvent p $ disposeEvent h - c <- readProtoRef rc - case c of - Nothing -> return () - Just c -> - do writeProtoRef rc Nothing - invokeEvent p $ - enqueueEvent (pointTime p) $ - Event $ \p -> - do z <- contCanceled c - when z $ cancelCont p c - writeProtoRef rh (Just h) - return $ - Event $ \p -> - do invokeEvent p $ disposeEvent h - c <- readProtoRef rc - writeProtoRef rc Nothing - return c - --- | Await the signal. -contAwait :: MonadComp m => Signal m a -> Cont m a -contAwait signal = - Cont $ \c -> - Event $ \p -> - do let s = runSession $ pointRun p - c <- invokeEvent p $ contFreeze c - r <- newProtoRef s Nothing - h <- invokeEvent p $ - handleSignal signal $ - \a -> Event $ - \p -> do x <- readProtoRef r - case x of - Nothing -> - error "The signal was lost: contAwait." - Just x -> - do invokeEvent p $ disposeEvent x - c <- invokeEvent p c - case c of - Nothing -> return () - Just c -> - invokeEvent p $ resumeCont c a - writeProtoRef r $ Just h + +-- | +-- Module : Simulation.Aivika.Trans.Internal.Cont +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The 'Cont' monad is a variation of the standard Cont monad +-- and F# async workflow, where the result of applying +-- the continuations is the 'Event' computation. +-- +module Simulation.Aivika.Trans.Internal.Cont + (ContCancellationSource, + ContParams, + ContCancellation(..), + Cont(..), + newContCancellationSource, + contCancellationInitiated, + contCancellationInitiate, + contCancellationInitiating, + contCancellationBind, + contCancellationConnect, + invokeCont, + runCont, + rerunCont, + spawnCont, + contParallel, + contParallel_, + catchCont, + finallyCont, + throwCont, + resumeCont, + resumeECont, + contCanceled, + contFreeze, + contAwait) where + +import Data.Array +import Data.Monoid + +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Control.Applicative + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.ProtoArray +import Simulation.Aivika.Trans.Exception +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Signal + +-- | It defines how the parent and child computations should be cancelled. +data ContCancellation = CancelTogether + -- ^ Cancel the both computations together. + | CancelChildAfterParent + -- ^ Cancel the child if its parent is cancelled. + | CancelParentAfterChild + -- ^ Cancel the parent if its child is cancelled. + | CancelInIsolation + -- ^ Cancel the computations in isolation. + +-- | It manages the cancellation process. +data ContCancellationSource m = + ContCancellationSource { contCancellationInitiatedRef :: ProtoRef m Bool, + contCancellationActivatedRef :: ProtoRef m Bool, + contCancellationInitiatingSource :: SignalSource m () + } + +-- | Create the cancellation source. +newContCancellationSource :: MonadComp m => Simulation m (ContCancellationSource m) +newContCancellationSource = + Simulation $ \r -> + do let sn = runSession r + r1 <- newProtoRef sn False + r2 <- newProtoRef sn False + s <- invokeSimulation r newSignalSource + return ContCancellationSource { contCancellationInitiatedRef = r1, + contCancellationActivatedRef = r2, + contCancellationInitiatingSource = s + } + +-- | Signal when the cancellation is intiating. +contCancellationInitiating :: ContCancellationSource m -> Signal m () +contCancellationInitiating = + publishSignal . contCancellationInitiatingSource + +-- | Whether the cancellation was initiated. +contCancellationInitiated :: MonadComp m => ContCancellationSource m -> (Event m Bool) +contCancellationInitiated x = + Event $ \p -> readProtoRef (contCancellationInitiatedRef x) + +-- | Whether the cancellation was activated. +contCancellationActivated :: MonadComp m => ContCancellationSource m -> m Bool +contCancellationActivated = + readProtoRef . contCancellationActivatedRef + +-- | Deactivate the cancellation. +contCancellationDeactivate :: MonadComp m => ContCancellationSource m -> m () +contCancellationDeactivate x = + writeProtoRef (contCancellationActivatedRef x) False + +-- | If the main computation is cancelled then all the nested ones will be cancelled too. +contCancellationBind :: MonadComp m => ContCancellationSource m -> [ContCancellationSource m] -> Event m (DisposableEvent m) +contCancellationBind x ys = + Event $ \p -> + do hs1 <- forM ys $ \y -> + invokeEvent p $ + handleSignal (contCancellationInitiating x) $ \_ -> + contCancellationInitiate y + hs2 <- forM ys $ \y -> + invokeEvent p $ + handleSignal (contCancellationInitiating y) $ \_ -> + contCancellationInitiate x + return $ mconcat hs1 <> mconcat hs2 + +-- | Connect the parent computation to the child one. +contCancellationConnect :: MonadComp m + => ContCancellationSource m + -- ^ the parent + -> ContCancellation + -- ^ how to connect + -> ContCancellationSource m + -- ^ the child + -> Event m (DisposableEvent m) + -- ^ computation of the disposable handler +contCancellationConnect parent cancellation child = + Event $ \p -> + do let m1 = + handleSignal (contCancellationInitiating parent) $ \_ -> + contCancellationInitiate child + m2 = + handleSignal (contCancellationInitiating child) $ \_ -> + contCancellationInitiate parent + h1 <- + case cancellation of + CancelTogether -> invokeEvent p m1 + CancelChildAfterParent -> invokeEvent p m1 + CancelParentAfterChild -> return mempty + CancelInIsolation -> return mempty + h2 <- + case cancellation of + CancelTogether -> invokeEvent p m2 + CancelChildAfterParent -> return mempty + CancelParentAfterChild -> invokeEvent p m2 + CancelInIsolation -> return mempty + return $ h1 <> h2 + +-- | Initiate the cancellation. +contCancellationInitiate :: MonadComp m => ContCancellationSource m -> Event m () +contCancellationInitiate x = + Event $ \p -> + do f <- readProtoRef (contCancellationInitiatedRef x) + unless f $ + do writeProtoRef (contCancellationInitiatedRef x) True + writeProtoRef (contCancellationActivatedRef x) True + invokeEvent p $ triggerSignal (contCancellationInitiatingSource x) () + +-- | The 'Cont' type is similar to the standard Cont monad +-- and F# async workflow but only the result of applying +-- the continuations return the 'Event' computation. +newtype Cont m a = Cont (ContParams m a -> Event m ()) + +-- | The continuation parameters. +data ContParams m a = + ContParams { contCont :: a -> Event m (), + contAux :: ContParamsAux m } + +-- | The auxiliary continuation parameters. +data ContParamsAux m = + ContParamsAux { contECont :: SomeException -> Event m (), + contCCont :: () -> Event m (), + contCancelSource :: ContCancellationSource m, + contCancelFlag :: m Bool, + contCatchFlag :: Bool } + +instance MonadComp m => Monad (Cont m) where + + {-# INLINE return #-} + return a = + Cont $ \c -> + Event $ \p -> + do z <- contCanceled c + if z + then cancelCont p c + else invokeEvent p $ contCont c a + + {-# INLINE (>>=) #-} + (Cont m) >>= k = + Cont $ \c -> + Event $ \p -> + do z <- contCanceled c + if z + then cancelCont p c + else invokeEvent p $ m $ + let cont a = invokeCont c (k a) + in c { contCont = cont } + +instance MonadCompTrans Cont where + + {-# INLINE liftComp #-} + liftComp m = + Cont $ \c -> + Event $ \p -> + if contCatchFlag . contAux $ c + then liftWithCatching m p c + else liftWithoutCatching m p c + +instance ParameterLift Cont where + + {-# INLINE liftParameter #-} + liftParameter (Parameter m) = + Cont $ \c -> + Event $ \p -> + if contCatchFlag . contAux $ c + then liftWithCatching (m $ pointRun p) p c + else liftWithoutCatching (m $ pointRun p) p c + +instance SimulationLift Cont where + + {-# INLINE liftSimulation #-} + liftSimulation (Simulation m) = + Cont $ \c -> + Event $ \p -> + if contCatchFlag . contAux $ c + then liftWithCatching (m $ pointRun p) p c + else liftWithoutCatching (m $ pointRun p) p c + +instance DynamicsLift Cont where + + {-# INLINE liftDynamics #-} + liftDynamics (Dynamics m) = + Cont $ \c -> + Event $ \p -> + if contCatchFlag . contAux $ c + then liftWithCatching (m p) p c + else liftWithoutCatching (m p) p c + +instance EventLift Cont where + + {-# INLINE liftEvent #-} + liftEvent (Event m) = + Cont $ \c -> + Event $ \p -> + if contCatchFlag . contAux $ c + then liftWithCatching (m p) p c + else liftWithoutCatching (m p) p c + +instance (MonadComp m, MonadIO m) => MonadIO (Cont m) where + + {-# INLINE liftIO #-} + liftIO m = + Cont $ \c -> + Event $ \p -> + if contCatchFlag . contAux $ c + then liftWithCatching (liftIO m) p c + else liftWithoutCatching (liftIO m) p c + +instance MonadComp m => Functor (Cont m) where + + {-# INLINE fmap #-} + fmap = liftM + +instance MonadComp m => Applicative (Cont m) where + + {-# INLINE pure #-} + pure = return + + {-# INLINE (<*>) #-} + (<*>) = ap + +-- | Invoke the computation. +invokeCont :: ContParams m a -> Cont m a -> Event m () +{-# INLINE invokeCont #-} +invokeCont p (Cont m) = m p + +-- | Cancel the computation. +cancelCont :: MonadComp m => Point m -> ContParams m a -> m () +{-# NOINLINE cancelCont #-} +cancelCont p c = + do contCancellationDeactivate (contCancelSource $ contAux c) + invokeEvent p $ (contCCont $ contAux c) () + +-- | Like @return a >>= k@. +callCont :: MonadComp m => (a -> Cont m b) -> a -> ContParams m b -> Event m () +callCont k a c = + Event $ \p -> + do z <- contCanceled c + if z + then cancelCont p c + else invokeEvent p $ invokeCont c (k a) + +-- | Exception handling within 'Cont' computations. +catchCont :: (MonadComp m, Exception e) => Cont m a -> (e -> Cont m a) -> Cont m a +catchCont (Cont m) h = + Cont $ \c0 -> + Event $ \p -> + do let c = c0 { contAux = (contAux c0) { contCatchFlag = True } } + z <- contCanceled c + if z + then cancelCont p c + else invokeEvent p $ m $ + let econt e0 = + case fromException e0 of + Just e -> callCont h e c + Nothing -> (contECont . contAux $ c) e0 + in c { contAux = (contAux c) { contECont = econt } } + +-- | A computation with finalization part. +finallyCont :: MonadComp m => Cont m a -> Cont m b -> Cont m a +finallyCont (Cont m) (Cont m') = + Cont $ \c0 -> + Event $ \p -> + do let c = c0 { contAux = (contAux c0) { contCatchFlag = True } } + z <- contCanceled c + if z + then cancelCont p c + else invokeEvent p $ m $ + let cont a = + Event $ \p -> + invokeEvent p $ m' $ + let cont b = contCont c a + in c { contCont = cont } + econt e = + Event $ \p -> + invokeEvent p $ m' $ + let cont b = (contECont . contAux $ c) e + in c { contCont = cont } + ccont () = + Event $ \p -> + invokeEvent p $ m' $ + let cont b = (contCCont . contAux $ c) () + econt e = (contCCont . contAux $ c) () + in c { contCont = cont, + contAux = (contAux c) { contECont = econt } } + in c { contCont = cont, + contAux = (contAux c) { contECont = econt, + contCCont = ccont } } + +-- | Throw the exception with the further exception handling. +-- +-- By some reason, an exception raised with help of the standard 'throw' function +-- is not handled properly within 'Cont' computation, altough it will be still handled +-- if it will be wrapped in the 'IO' monad. Therefore, you should use specialised +-- functions like the stated one that use the 'throw' function but within the 'IO' computation, +-- which allows already handling the exception. +throwCont :: (MonadComp m, Exception e) => e -> Cont m a +throwCont = liftEvent . throwEvent + +-- | Run the 'Cont' computation with the specified cancelation source +-- and flag indicating whether to catch exceptions from the beginning. +runCont :: MonadComp m + => Cont m a + -- ^ the computation to run + -> (a -> Event m ()) + -- ^ the main branch + -> (SomeException -> Event m ()) + -- ^ the branch for handing exceptions + -> (() -> Event m ()) + -- ^ the branch for cancellation + -> ContCancellationSource m + -- ^ the cancellation source + -> Bool + -- ^ whether to support the exception handling from the beginning + -> Event m () +runCont (Cont m) cont econt ccont cancelSource catchFlag = + m ContParams { contCont = cont, + contAux = + ContParamsAux { contECont = econt, + contCCont = ccont, + contCancelSource = cancelSource, + contCancelFlag = contCancellationActivated cancelSource, + contCatchFlag = catchFlag } } + +liftWithoutCatching :: MonadComp m => m a -> Point m -> ContParams m a -> m () +{-# INLINE liftWithoutCatching #-} +liftWithoutCatching m p c = + do z <- contCanceled c + if z + then cancelCont p c + else do a <- m + invokeEvent p $ contCont c a + +liftWithCatching :: MonadComp m => m a -> Point m -> ContParams m a -> m () +{-# NOINLINE liftWithCatching #-} +liftWithCatching m p c = + do z <- contCanceled c + if z + then cancelCont p c + else do let s = runSession $ pointRun p + aref <- newProtoRef s undefined + eref <- newProtoRef s Nothing + catchComp + (m >>= writeProtoRef aref) + (writeProtoRef eref . Just) + e <- readProtoRef eref + case e of + Nothing -> + do a <- readProtoRef aref + -- tail recursive + invokeEvent p $ contCont c a + Just e -> + -- tail recursive + invokeEvent p $ (contECont . contAux) c e + +-- | Resume the computation by the specified parameters. +resumeCont :: MonadComp m => ContParams m a -> a -> Event m () +{-# INLINE resumeCont #-} +resumeCont c a = + Event $ \p -> + do z <- contCanceled c + if z + then cancelCont p c + else invokeEvent p $ contCont c a + +-- | Resume the exception handling by the specified parameters. +resumeECont :: MonadComp m => ContParams m a -> SomeException -> Event m () +{-# INLINE resumeECont #-} +resumeECont c e = + Event $ \p -> + do z <- contCanceled c + if z + then cancelCont p c + else invokeEvent p $ (contECont $ contAux c) e + +-- | Test whether the computation is canceled. +contCanceled :: ContParams m a -> m Bool +{-# INLINE contCanceled #-} +contCanceled c = contCancelFlag $ contAux c + +-- | Execute the specified computations in parallel within +-- the current computation and return their results. The cancellation +-- of any of the nested computations affects the current computation. +-- The exception raised in any of the nested computations is propogated +-- to the current computation as well (if the exception handling is +-- supported). +-- +-- Here word @parallel@ literally means that the computations are +-- actually executed on a single operating system thread but +-- they are processed simultaneously by the event queue. +contParallel :: MonadComp m + => [(Cont m a, ContCancellationSource m)] + -- ^ the list of pairs: + -- the nested computation, + -- the cancellation source + -> Cont m [a] +contParallel xs = + Cont $ \c -> + Event $ \p -> + do let n = length xs + s = runSession $ pointRun p + worker = + do results <- newProtoArray_ s n + counter <- newProtoRef s 0 + catchRef <- newProtoRef s Nothing + hs <- invokeEvent p $ + contCancellationBind (contCancelSource $ contAux c) $ + map snd xs + let propagate = + Event $ \p -> + do n' <- readProtoRef counter + when (n' == n) $ + do invokeEvent p $ disposeEvent hs -- unbind the cancellation sources + f1 <- contCanceled c + f2 <- readProtoRef catchRef + case (f1, f2) of + (False, Nothing) -> + do rs <- protoArrayToList results + invokeEvent p $ resumeCont c rs + (False, Just e) -> + invokeEvent p $ resumeECont c e + (True, _) -> + cancelCont p c + cont i a = + Event $ \p -> + do modifyProtoRef counter (+ 1) + writeProtoArray results i a + invokeEvent p propagate + econt e = + Event $ \p -> + do modifyProtoRef counter (+ 1) + r <- readProtoRef catchRef + case r of + Nothing -> writeProtoRef catchRef $ Just e + Just e' -> return () -- ignore the next error + invokeEvent p propagate + ccont e = + Event $ \p -> + do modifyProtoRef counter (+ 1) + -- the main computation was automatically canceled + invokeEvent p propagate + forM_ (zip [0..n-1] xs) $ \(i, (x, cancelSource)) -> + invokeEvent p $ + runCont x (cont i) econt ccont cancelSource (contCatchFlag $ contAux c) + z <- contCanceled c + if z + then cancelCont p c + else if n == 0 + then invokeEvent p $ contCont c [] + else worker + +-- | A partial case of 'contParallel' when we are not interested in +-- the results but we are interested in the actions to be peformed by +-- the nested computations. +contParallel_ :: MonadComp m + => [(Cont m a, ContCancellationSource m)] + -- ^ the list of pairs: + -- the nested computation, + -- the cancellation source + -> Cont m () +contParallel_ xs = + Cont $ \c -> + Event $ \p -> + do let n = length xs + s = runSession $ pointRun p + worker = + do counter <- newProtoRef s 0 + catchRef <- newProtoRef s Nothing + hs <- invokeEvent p $ + contCancellationBind (contCancelSource $ contAux c) $ + map snd xs + let propagate = + Event $ \p -> + do n' <- readProtoRef counter + when (n' == n) $ + do invokeEvent p $ disposeEvent hs -- unbind the cancellation sources + f1 <- contCanceled c + f2 <- readProtoRef catchRef + case (f1, f2) of + (False, Nothing) -> + invokeEvent p $ resumeCont c () + (False, Just e) -> + invokeEvent p $ resumeECont c e + (True, _) -> + cancelCont p c + cont i a = + Event $ \p -> + do modifyProtoRef counter (+ 1) + -- ignore the result + invokeEvent p propagate + econt e = + Event $ \p -> + do modifyProtoRef counter (+ 1) + r <- readProtoRef catchRef + case r of + Nothing -> writeProtoRef catchRef $ Just e + Just e' -> return () -- ignore the next error + invokeEvent p propagate + ccont e = + Event $ \p -> + do modifyProtoRef counter (+ 1) + -- the main computation was automatically canceled + invokeEvent p propagate + forM_ (zip [0..n-1] xs) $ \(i, (x, cancelSource)) -> + invokeEvent p $ + runCont x (cont i) econt ccont cancelSource (contCatchFlag $ contAux c) + z <- contCanceled c + if z + then cancelCont p c + else if n == 0 + then invokeEvent p $ contCont c () + else worker + +-- | Rerun the 'Cont' computation with the specified cancellation source. +rerunCont :: MonadComp m => Cont m a -> ContCancellationSource m -> Cont m a +rerunCont x cancelSource = + Cont $ \c -> + Event $ \p -> + do let worker = + do hs <- invokeEvent p $ + contCancellationBind (contCancelSource $ contAux c) [cancelSource] + let cont a = + Event $ \p -> + do invokeEvent p $ disposeEvent hs -- unbind the cancellation source + invokeEvent p $ resumeCont c a + econt e = + Event $ \p -> + do invokeEvent p $ disposeEvent hs -- unbind the cancellation source + invokeEvent p $ resumeECont c e + ccont e = + Event $ \p -> + do invokeEvent p $ disposeEvent hs -- unbind the cancellation source + cancelCont p c + invokeEvent p $ + runCont x cont econt ccont cancelSource (contCatchFlag $ contAux c) + z <- contCanceled c + if z + then cancelCont p c + else worker + +-- | Run the 'Cont' computation in parallel but connect the cancellation sources. +spawnCont :: MonadComp m => ContCancellation -> Cont m () -> ContCancellationSource m -> Cont m () +spawnCont cancellation x cancelSource = + Cont $ \c -> + Event $ \p -> + do let worker = + do hs <- invokeEvent p $ + contCancellationConnect + (contCancelSource $ contAux c) cancellation cancelSource + let cont a = + Event $ \p -> + do invokeEvent p $ disposeEvent hs -- unbind the cancellation source + -- do nothing and it will finish the computation + econt e = + Event $ \p -> + do invokeEvent p $ disposeEvent hs -- unbind the cancellation source + invokeEvent p $ throwEvent e -- this is all we can do + ccont e = + Event $ \p -> + do invokeEvent p $ disposeEvent hs -- unbind the cancellation source + -- do nothing and it will finish the computation + invokeEvent p $ + enqueueEvent (pointTime p) $ + runCont x cont econt ccont cancelSource False + invokeEvent p $ + resumeCont c () + z <- contCanceled c + if z + then cancelCont p c + else worker + +-- | Freeze the computation parameters temporarily. +contFreeze :: MonadComp m => ContParams m a -> Event m (Event m (Maybe (ContParams m a))) +contFreeze c = + Event $ \p -> + do let s = runSession $ pointRun p + rh <- newProtoRef s Nothing + rc <- newProtoRef s $ Just c + h <- invokeEvent p $ + handleSignal (contCancellationInitiating $ + contCancelSource $ + contAux c) $ \a -> + Event $ \p -> + do h <- readProtoRef rh + case h of + Nothing -> + error "The handler was lost: contFreeze." + Just h -> + do invokeEvent p $ disposeEvent h + c <- readProtoRef rc + case c of + Nothing -> return () + Just c -> + do writeProtoRef rc Nothing + invokeEvent p $ + enqueueEvent (pointTime p) $ + Event $ \p -> + do z <- contCanceled c + when z $ cancelCont p c + writeProtoRef rh (Just h) + return $ + Event $ \p -> + do invokeEvent p $ disposeEvent h + c <- readProtoRef rc + writeProtoRef rc Nothing + return c + +-- | Await the signal. +contAwait :: MonadComp m => Signal m a -> Cont m a +contAwait signal = + Cont $ \c -> + Event $ \p -> + do let s = runSession $ pointRun p + c <- invokeEvent p $ contFreeze c + r <- newProtoRef s Nothing + h <- invokeEvent p $ + handleSignal signal $ + \a -> Event $ + \p -> do x <- readProtoRef r + case x of + Nothing -> + error "The signal was lost: contAwait." + Just x -> + do invokeEvent p $ disposeEvent x + c <- invokeEvent p c + case c of + Nothing -> return () + Just c -> + invokeEvent p $ resumeCont c a + writeProtoRef r $ Just h diff --git a/Simulation/Aivika/Trans/Internal/Dynamics.hs b/Simulation/Aivika/Trans/Internal/Dynamics.hs --- a/Simulation/Aivika/Trans/Internal/Dynamics.hs +++ b/Simulation/Aivika/Trans/Internal/Dynamics.hs @@ -1,270 +1,270 @@ - -{-# LANGUAGE RecursiveDo #-} - --- | --- Module : Simulation.Aivika.Trans.Internal.Dynamics --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines the 'Dynamics' monad transformer representing a time varying polymorphic function. --- -module Simulation.Aivika.Trans.Internal.Dynamics - (-- * Dynamics - DynamicsLift(..), - runDynamicsInStartTime, - runDynamicsInStopTime, - runDynamicsInIntegTimes, - runDynamicsInTime, - runDynamicsInTimes, - -- * Error Handling - catchDynamics, - finallyDynamics, - throwDynamics, - -- * Simulation Time - time, - isTimeInteg, - integIteration, - integPhase) where - -import Control.Exception -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Fix -import Control.Applicative - -import Simulation.Aivika.Trans.Exception -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Parameter -import Simulation.Aivika.Trans.Internal.Simulation - -instance Monad m => Monad (Dynamics m) where - - {-# INLINE return #-} - return a = Dynamics $ \p -> return a - - {-# INLINE (>>=) #-} - (Dynamics m) >>= k = - Dynamics $ \p -> - do a <- m p - let Dynamics m' = k a - m' p - --- | Run the 'Dynamics' computation in the initial time point. -runDynamicsInStartTime :: Dynamics m a -> Simulation m a -runDynamicsInStartTime (Dynamics m) = - Simulation $ m . integStartPoint - --- | Run the 'Dynamics' computation in the final time point. -runDynamicsInStopTime :: Dynamics m a -> Simulation m a -runDynamicsInStopTime (Dynamics m) = - Simulation $ m . integStopPoint - --- | Run the 'Dynamics' computation in all integration time points. -runDynamicsInIntegTimes :: Monad m => Dynamics m a -> Simulation m [m a] -runDynamicsInIntegTimes (Dynamics m) = - Simulation $ return . map m . integPoints - --- | Run the 'Dynamics' computation in the specified time point. -runDynamicsInTime :: Double -> Dynamics m a -> Simulation m a -runDynamicsInTime t (Dynamics m) = - Simulation $ \r -> m $ pointAt r t - --- | Run the 'Dynamics' computation in the specified time points. -runDynamicsInTimes :: Monad m => [Double] -> Dynamics m a -> Simulation m [m a] -runDynamicsInTimes ts (Dynamics m) = - Simulation $ \r -> return $ map (m . pointAt r) ts - -instance Functor m => Functor (Dynamics m) where - - {-# INLINE fmap #-} - fmap f (Dynamics x) = Dynamics $ \p -> fmap f $ x p - -instance Applicative m => Applicative (Dynamics m) where - - {-# INLINE pure #-} - pure = Dynamics . const . pure - - {-# INLINE (<*>) #-} - (Dynamics x) <*> (Dynamics y) = Dynamics $ \p -> x p <*> y p - -liftMD :: Monad m => (a -> b) -> Dynamics m a -> Dynamics m b -{-# INLINE liftMD #-} -liftMD f (Dynamics x) = - Dynamics $ \p -> do { a <- x p; return $ f a } - -liftM2D :: Monad m => (a -> b -> c) -> Dynamics m a -> Dynamics m b -> Dynamics m c -{-# INLINE liftM2D #-} -liftM2D f (Dynamics x) (Dynamics y) = - Dynamics $ \p -> do { a <- x p; b <- y p; return $ f a b } - -instance (Num a, Monad m) => Num (Dynamics m a) where - - {-# INLINE (+) #-} - x + y = liftM2D (+) x y - - {-# INLINE (-) #-} - x - y = liftM2D (-) x y - - {-# INLINE (*) #-} - x * y = liftM2D (*) x y - - {-# INLINE negate #-} - negate = liftMD negate - - {-# INLINE abs #-} - abs = liftMD abs - - {-# INLINE signum #-} - signum = liftMD signum - - {-# INLINE fromInteger #-} - fromInteger i = return $ fromInteger i - -instance (Fractional a, Monad m) => Fractional (Dynamics m a) where - - {-# INLINE (/) #-} - x / y = liftM2D (/) x y - - {-# INLINE recip #-} - recip = liftMD recip - - {-# INLINE fromRational #-} - fromRational t = return $ fromRational t - -instance (Floating a, Monad m) => Floating (Dynamics m a) where - - {-# INLINE pi #-} - pi = return pi - - {-# INLINE exp #-} - exp = liftMD exp - - {-# INLINE log #-} - log = liftMD log - - {-# INLINE sqrt #-} - sqrt = liftMD sqrt - - {-# INLINE (**) #-} - x ** y = liftM2D (**) x y - - {-# INLINE sin #-} - sin = liftMD sin - - {-# INLINE cos #-} - cos = liftMD cos - - {-# INLINE tan #-} - tan = liftMD tan - - {-# INLINE asin #-} - asin = liftMD asin - - {-# INLINE acos #-} - acos = liftMD acos - - {-# INLINE atan #-} - atan = liftMD atan - - {-# INLINE sinh #-} - sinh = liftMD sinh - - {-# INLINE cosh #-} - cosh = liftMD cosh - - {-# INLINE tanh #-} - tanh = liftMD tanh - - {-# INLINE asinh #-} - asinh = liftMD asinh - - {-# INLINE acosh #-} - acosh = liftMD acosh - - {-# INLINE atanh #-} - atanh = liftMD atanh - -instance MonadTrans Dynamics where - - {-# INLINE lift #-} - lift = Dynamics . const - -instance MonadIO m => MonadIO (Dynamics m) where - - {-# INLINE liftIO #-} - liftIO = Dynamics . const . liftIO - -instance MonadCompTrans Dynamics where - - {-# INLINE liftComp #-} - liftComp = Dynamics . const - --- | A type class to lift the 'Dynamics' computations into other computations. -class DynamicsLift t where - - -- | Lift the specified 'Dynamics' computation into another computation. - liftDynamics :: MonadComp m => Dynamics m a -> t m a - -instance DynamicsLift Dynamics where - - {-# INLINE liftDynamics #-} - liftDynamics = id - -instance SimulationLift Dynamics where - - {-# INLINE liftSimulation #-} - liftSimulation (Simulation x) = Dynamics $ x . pointRun - -instance ParameterLift Dynamics where - - {-# INLINE liftParameter #-} - liftParameter (Parameter x) = Dynamics $ x . pointRun - --- | Exception handling within 'Dynamics' computations. -catchDynamics :: (MonadComp m, Exception e) => Dynamics m a -> (e -> Dynamics m a) -> Dynamics m a -catchDynamics (Dynamics m) h = - Dynamics $ \p -> - catchComp (m p) $ \e -> - let Dynamics m' = h e in m' p - --- | A computation with finalization part like the 'finally' function. -finallyDynamics :: MonadComp m => Dynamics m a -> Dynamics m b -> Dynamics m a -finallyDynamics (Dynamics m) (Dynamics m') = - Dynamics $ \p -> - finallyComp (m p) (m' p) - --- | Like the standard 'throw' function. -throwDynamics :: (MonadComp m, Exception e) => e -> Dynamics m a -throwDynamics = throw - -instance MonadFix m => MonadFix (Dynamics m) where - - {-# INLINE mfix #-} - mfix f = - Dynamics $ \p -> - do { rec { a <- invokeDynamics p (f a) }; return a } - --- | Computation that returns the current simulation time. -time :: Monad m => Dynamics m Double -{-# INLINE time #-} -time = Dynamics $ return . pointTime - --- | Whether the current time is an integration time. -isTimeInteg :: Monad m => Dynamics m Bool -{-# INLINE isTimeInteg #-} -isTimeInteg = Dynamics $ \p -> return $ pointPhase p >= 0 - --- | Return the integration iteration closest to the current simulation time. -integIteration :: Monad m => Dynamics m Int -{-# INLINE integIteration #-} -integIteration = Dynamics $ return . pointIteration - --- | Return the integration phase for the current simulation time. --- It is @(-1)@ for non-integration time points. -integPhase :: Monad m => Dynamics m Int -{-# INLINE integPhase #-} -integPhase = Dynamics $ return . pointPhase + +{-# LANGUAGE RecursiveDo #-} + +-- | +-- Module : Simulation.Aivika.Trans.Internal.Dynamics +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the 'Dynamics' monad transformer representing a time varying polymorphic function. +-- +module Simulation.Aivika.Trans.Internal.Dynamics + (-- * Dynamics + DynamicsLift(..), + runDynamicsInStartTime, + runDynamicsInStopTime, + runDynamicsInIntegTimes, + runDynamicsInTime, + runDynamicsInTimes, + -- * Error Handling + catchDynamics, + finallyDynamics, + throwDynamics, + -- * Simulation Time + time, + isTimeInteg, + integIteration, + integPhase) where + +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Fix +import Control.Applicative + +import Simulation.Aivika.Trans.Exception +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter +import Simulation.Aivika.Trans.Internal.Simulation + +instance Monad m => Monad (Dynamics m) where + + {-# INLINE return #-} + return a = Dynamics $ \p -> return a + + {-# INLINE (>>=) #-} + (Dynamics m) >>= k = + Dynamics $ \p -> + do a <- m p + let Dynamics m' = k a + m' p + +-- | Run the 'Dynamics' computation in the initial time point. +runDynamicsInStartTime :: Dynamics m a -> Simulation m a +runDynamicsInStartTime (Dynamics m) = + Simulation $ m . integStartPoint + +-- | Run the 'Dynamics' computation in the final time point. +runDynamicsInStopTime :: Dynamics m a -> Simulation m a +runDynamicsInStopTime (Dynamics m) = + Simulation $ m . integStopPoint + +-- | Run the 'Dynamics' computation in all integration time points. +runDynamicsInIntegTimes :: Monad m => Dynamics m a -> Simulation m [m a] +runDynamicsInIntegTimes (Dynamics m) = + Simulation $ return . map m . integPoints + +-- | Run the 'Dynamics' computation in the specified time point. +runDynamicsInTime :: Double -> Dynamics m a -> Simulation m a +runDynamicsInTime t (Dynamics m) = + Simulation $ \r -> m $ pointAt r t + +-- | Run the 'Dynamics' computation in the specified time points. +runDynamicsInTimes :: Monad m => [Double] -> Dynamics m a -> Simulation m [m a] +runDynamicsInTimes ts (Dynamics m) = + Simulation $ \r -> return $ map (m . pointAt r) ts + +instance Functor m => Functor (Dynamics m) where + + {-# INLINE fmap #-} + fmap f (Dynamics x) = Dynamics $ \p -> fmap f $ x p + +instance Applicative m => Applicative (Dynamics m) where + + {-# INLINE pure #-} + pure = Dynamics . const . pure + + {-# INLINE (<*>) #-} + (Dynamics x) <*> (Dynamics y) = Dynamics $ \p -> x p <*> y p + +liftMD :: Monad m => (a -> b) -> Dynamics m a -> Dynamics m b +{-# INLINE liftMD #-} +liftMD f (Dynamics x) = + Dynamics $ \p -> do { a <- x p; return $ f a } + +liftM2D :: Monad m => (a -> b -> c) -> Dynamics m a -> Dynamics m b -> Dynamics m c +{-# INLINE liftM2D #-} +liftM2D f (Dynamics x) (Dynamics y) = + Dynamics $ \p -> do { a <- x p; b <- y p; return $ f a b } + +instance (Num a, Monad m) => Num (Dynamics m a) where + + {-# INLINE (+) #-} + x + y = liftM2D (+) x y + + {-# INLINE (-) #-} + x - y = liftM2D (-) x y + + {-# INLINE (*) #-} + x * y = liftM2D (*) x y + + {-# INLINE negate #-} + negate = liftMD negate + + {-# INLINE abs #-} + abs = liftMD abs + + {-# INLINE signum #-} + signum = liftMD signum + + {-# INLINE fromInteger #-} + fromInteger i = return $ fromInteger i + +instance (Fractional a, Monad m) => Fractional (Dynamics m a) where + + {-# INLINE (/) #-} + x / y = liftM2D (/) x y + + {-# INLINE recip #-} + recip = liftMD recip + + {-# INLINE fromRational #-} + fromRational t = return $ fromRational t + +instance (Floating a, Monad m) => Floating (Dynamics m a) where + + {-# INLINE pi #-} + pi = return pi + + {-# INLINE exp #-} + exp = liftMD exp + + {-# INLINE log #-} + log = liftMD log + + {-# INLINE sqrt #-} + sqrt = liftMD sqrt + + {-# INLINE (**) #-} + x ** y = liftM2D (**) x y + + {-# INLINE sin #-} + sin = liftMD sin + + {-# INLINE cos #-} + cos = liftMD cos + + {-# INLINE tan #-} + tan = liftMD tan + + {-# INLINE asin #-} + asin = liftMD asin + + {-# INLINE acos #-} + acos = liftMD acos + + {-# INLINE atan #-} + atan = liftMD atan + + {-# INLINE sinh #-} + sinh = liftMD sinh + + {-# INLINE cosh #-} + cosh = liftMD cosh + + {-# INLINE tanh #-} + tanh = liftMD tanh + + {-# INLINE asinh #-} + asinh = liftMD asinh + + {-# INLINE acosh #-} + acosh = liftMD acosh + + {-# INLINE atanh #-} + atanh = liftMD atanh + +instance MonadTrans Dynamics where + + {-# INLINE lift #-} + lift = Dynamics . const + +instance MonadIO m => MonadIO (Dynamics m) where + + {-# INLINE liftIO #-} + liftIO = Dynamics . const . liftIO + +instance MonadCompTrans Dynamics where + + {-# INLINE liftComp #-} + liftComp = Dynamics . const + +-- | A type class to lift the 'Dynamics' computations into other computations. +class DynamicsLift t where + + -- | Lift the specified 'Dynamics' computation into another computation. + liftDynamics :: MonadComp m => Dynamics m a -> t m a + +instance DynamicsLift Dynamics where + + {-# INLINE liftDynamics #-} + liftDynamics = id + +instance SimulationLift Dynamics where + + {-# INLINE liftSimulation #-} + liftSimulation (Simulation x) = Dynamics $ x . pointRun + +instance ParameterLift Dynamics where + + {-# INLINE liftParameter #-} + liftParameter (Parameter x) = Dynamics $ x . pointRun + +-- | Exception handling within 'Dynamics' computations. +catchDynamics :: (MonadComp m, Exception e) => Dynamics m a -> (e -> Dynamics m a) -> Dynamics m a +catchDynamics (Dynamics m) h = + Dynamics $ \p -> + catchComp (m p) $ \e -> + let Dynamics m' = h e in m' p + +-- | A computation with finalization part like the 'finally' function. +finallyDynamics :: MonadComp m => Dynamics m a -> Dynamics m b -> Dynamics m a +finallyDynamics (Dynamics m) (Dynamics m') = + Dynamics $ \p -> + finallyComp (m p) (m' p) + +-- | Like the standard 'throw' function. +throwDynamics :: (MonadComp m, Exception e) => e -> Dynamics m a +throwDynamics = throw + +instance MonadFix m => MonadFix (Dynamics m) where + + {-# INLINE mfix #-} + mfix f = + Dynamics $ \p -> + do { rec { a <- invokeDynamics p (f a) }; return a } + +-- | Computation that returns the current simulation time. +time :: Monad m => Dynamics m Double +{-# INLINE time #-} +time = Dynamics $ return . pointTime + +-- | Whether the current time is an integration time. +isTimeInteg :: Monad m => Dynamics m Bool +{-# INLINE isTimeInteg #-} +isTimeInteg = Dynamics $ \p -> return $ pointPhase p >= 0 + +-- | Return the integration iteration closest to the current simulation time. +integIteration :: Monad m => Dynamics m Int +{-# INLINE integIteration #-} +integIteration = Dynamics $ return . pointIteration + +-- | Return the integration phase for the current simulation time. +-- It is @(-1)@ for non-integration time points. +integPhase :: Monad m => Dynamics m Int +{-# INLINE integPhase #-} +integPhase = Dynamics $ return . pointPhase diff --git a/Simulation/Aivika/Trans/Internal/Event.hs b/Simulation/Aivika/Trans/Internal/Event.hs --- a/Simulation/Aivika/Trans/Internal/Event.hs +++ b/Simulation/Aivika/Trans/Internal/Event.hs @@ -1,277 +1,277 @@ - -{-# LANGUAGE RecursiveDo #-} - --- | --- Module : Simulation.Aivika.Trans.Internal.Event --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines the 'Event' monad transformer which is very similar to the 'Dynamics' --- monad transformer but only now the computation is strongly synchronized with the event queue. --- -module Simulation.Aivika.Trans.Internal.Event - (-- * Event Monad - EventLift(..), - runEventInStartTime, - runEventInStopTime, - -- * Event Queue - enqueueEventWithCancellation, - enqueueEventWithTimes, - enqueueEventWithPoints, - enqueueEventWithIntegTimes, - yieldEvent, - -- * Cancelling Event - EventCancellation, - cancelEvent, - eventCancelled, - eventFinished, - -- * Error Handling - catchEvent, - finallyEvent, - throwEvent, - -- * Memoization - memoEvent, - memoEventInTime, - -- * Disposable - DisposableEvent(..)) where - -import Data.Monoid - -import Control.Exception -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Fix -import Control.Applicative - -import Simulation.Aivika.Trans.Exception -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Parameter -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Dynamics - -instance Monad m => Monad (Event m) where - - {-# INLINE return #-} - return a = Event $ \p -> return a - - {-# INLINE (>>=) #-} - (Event m) >>= k = - Event $ \p -> - do a <- m p - let Event m' = k a - m' p - -instance Functor m => Functor (Event m) where - - {-# INLINE fmap #-} - fmap f (Event x) = Event $ \p -> fmap f $ x p - -instance Applicative m => Applicative (Event m) where - - {-# INLINE pure #-} - pure = Event . const . pure - - {-# INLINE (<*>) #-} - (Event x) <*> (Event y) = Event $ \p -> x p <*> y p - -instance MonadTrans Event where - - {-# INLINE lift #-} - lift = Event . const - -instance MonadIO m => MonadIO (Event m) where - - {-# INLINE liftIO #-} - liftIO = Event . const . liftIO - -instance MonadCompTrans Event where - - {-# INLINE liftComp #-} - liftComp = Event . const - --- | A type class to lift the 'Event' computations into other computations. -class EventLift t where - - -- | Lift the specified 'Event' computation into another computation. - liftEvent :: MonadComp m => Event m a -> t m a - -instance EventLift Event where - - {-# INLINE liftEvent #-} - liftEvent = id - -instance DynamicsLift Event where - - {-# INLINE liftDynamics #-} - liftDynamics (Dynamics x) = Event x - -instance SimulationLift Event where - - {-# INLINE liftSimulation #-} - liftSimulation (Simulation x) = Event $ x . pointRun - -instance ParameterLift Event where - - {-# INLINE liftParameter #-} - liftParameter (Parameter x) = Event $ x . pointRun - --- | Exception handling within 'Event' computations. -catchEvent :: (MonadComp m, Exception e) => Event m a -> (e -> Event m a) -> Event m a -catchEvent (Event m) h = - Event $ \p -> - catchComp (m p) $ \e -> - let Event m' = h e in m' p - --- | A computation with finalization part like the 'finally' function. -finallyEvent :: MonadComp m => Event m a -> Event m b -> Event m a -finallyEvent (Event m) (Event m') = - Event $ \p -> - finallyComp (m p) (m' p) - --- | Like the standard 'throw' function. -throwEvent :: (MonadComp m, Exception e) => e -> Event m a -throwEvent = throw - -instance MonadFix m => MonadFix (Event m) where - - {-# INLINE mfix #-} - mfix f = - Event $ \p -> - do { rec { a <- invokeEvent p (f a) }; return a } - --- | Run the 'Event' computation in the start time involving all --- pending 'CurrentEvents' in the processing too. -runEventInStartTime :: MonadComp m => Event m a -> Simulation m a -runEventInStartTime = runDynamicsInStartTime . runEvent - --- | Run the 'Event' computation in the stop time involving all --- pending 'CurrentEvents' in the processing too. -runEventInStopTime :: MonadComp m => Event m a -> Simulation m a -runEventInStopTime = runDynamicsInStopTime . runEvent - --- | Actuate the event handler in the specified time points. -enqueueEventWithTimes :: MonadComp m => [Double] -> Event m () -> Event m () -enqueueEventWithTimes ts e = loop ts - where loop [] = return () - loop (t : ts) = enqueueEvent t $ e >> loop ts - --- | Actuate the event handler in the specified time points. -enqueueEventWithPoints :: MonadComp m => [Point m] -> Event m () -> Event m () -enqueueEventWithPoints xs (Event e) = loop xs - where loop [] = return () - loop (x : xs) = enqueueEvent (pointTime x) $ - Event $ \p -> - do e x -- N.B. we substitute the time point! - invokeEvent p $ loop xs - --- | Actuate the event handler in the integration time points. -enqueueEventWithIntegTimes :: MonadComp m => Event m () -> Event m () -enqueueEventWithIntegTimes e = - Event $ \p -> - let points = integPoints $ pointRun p - in invokeEvent p $ enqueueEventWithPoints points e - --- | It allows cancelling the event. -data EventCancellation m = - EventCancellation { cancelEvent :: Event m (), - -- ^ Cancel the event. - eventCancelled :: Event m Bool, - -- ^ Test whether the event was cancelled. - eventFinished :: Event m Bool - -- ^ Test whether the event was processed and finished. - } - --- | Enqueue the event with an ability to cancel it. -enqueueEventWithCancellation :: MonadComp m => Double -> Event m () -> Event m (EventCancellation m) -enqueueEventWithCancellation t e = - Event $ \p -> - do let s = runSession $ pointRun p - cancelledRef <- newProtoRef s False - cancellableRef <- newProtoRef s True - finishedRef <- newProtoRef s False - let cancel = - Event $ \p -> - do x <- readProtoRef cancellableRef - when x $ - writeProtoRef cancelledRef True - cancelled = - Event $ \p -> readProtoRef cancelledRef - finished = - Event $ \p -> readProtoRef finishedRef - invokeEvent p $ - enqueueEvent t $ - Event $ \p -> - do writeProtoRef cancellableRef False - x <- readProtoRef cancelledRef - unless x $ - do invokeEvent p e - writeProtoRef finishedRef True - return EventCancellation { cancelEvent = cancel, - eventCancelled = cancelled, - eventFinished = finished } - --- | Memoize the 'Event' computation, always returning the same value --- within a simulation run. -memoEvent :: MonadComp m => Event m a -> Simulation m (Event m a) -memoEvent m = - Simulation $ \r -> - do let s = runSession r - ref <- newProtoRef s Nothing - return $ Event $ \p -> - do x <- readProtoRef ref - case x of - Just v -> return v - Nothing -> - do v <- invokeEvent p m - writeProtoRef ref (Just v) - return v - --- | Memoize the 'Event' computation, always returning the same value --- in the same modeling time. After the time changes, the value is --- recalculated by demand. --- --- It is possible to implement this function efficiently, for the 'Event' --- computation is always synchronized with the event queue which time --- flows in one direction only. This synchronization is a key difference --- between the 'Event' and 'Dynamics' computations. -memoEventInTime :: MonadComp m => Event m a -> Simulation m (Event m a) -memoEventInTime m = - Simulation $ \r -> - do let s = runSession r - ref <- newProtoRef s Nothing - return $ Event $ \p -> - do x <- readProtoRef ref - case x of - Just (t, v) | t == pointTime p -> - return v - _ -> - do v <- invokeEvent p m - writeProtoRef ref (Just (pointTime p, v)) - return v - --- | Enqueue the event which must be actuated with the current modeling time but later. -yieldEvent :: MonadComp m => Event m () -> Event m () -yieldEvent m = - Event $ \p -> - invokeEvent p $ - enqueueEvent (pointTime p) m - --- | Defines a computation disposing some entity. -newtype DisposableEvent m = - DisposableEvent { disposeEvent :: Event m () - -- ^ Dispose something within the 'Event' computation. - } - -instance Monad m => Monoid (DisposableEvent m) where - - {-# INLINE mempty #-} - mempty = DisposableEvent $ return () - - {-# INLINE mappend #-} - mappend (DisposableEvent x) (DisposableEvent y) = DisposableEvent $ x >> y + +{-# LANGUAGE RecursiveDo #-} + +-- | +-- Module : Simulation.Aivika.Trans.Internal.Event +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the 'Event' monad transformer which is very similar to the 'Dynamics' +-- monad transformer but only now the computation is strongly synchronized with the event queue. +-- +module Simulation.Aivika.Trans.Internal.Event + (-- * Event Monad + EventLift(..), + runEventInStartTime, + runEventInStopTime, + -- * Event Queue + enqueueEventWithCancellation, + enqueueEventWithTimes, + enqueueEventWithPoints, + enqueueEventWithIntegTimes, + yieldEvent, + -- * Cancelling Event + EventCancellation, + cancelEvent, + eventCancelled, + eventFinished, + -- * Error Handling + catchEvent, + finallyEvent, + throwEvent, + -- * Memoization + memoEvent, + memoEventInTime, + -- * Disposable + DisposableEvent(..)) where + +import Data.Monoid + +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Fix +import Control.Applicative + +import Simulation.Aivika.Trans.Exception +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics + +instance Monad m => Monad (Event m) where + + {-# INLINE return #-} + return a = Event $ \p -> return a + + {-# INLINE (>>=) #-} + (Event m) >>= k = + Event $ \p -> + do a <- m p + let Event m' = k a + m' p + +instance Functor m => Functor (Event m) where + + {-# INLINE fmap #-} + fmap f (Event x) = Event $ \p -> fmap f $ x p + +instance Applicative m => Applicative (Event m) where + + {-# INLINE pure #-} + pure = Event . const . pure + + {-# INLINE (<*>) #-} + (Event x) <*> (Event y) = Event $ \p -> x p <*> y p + +instance MonadTrans Event where + + {-# INLINE lift #-} + lift = Event . const + +instance MonadIO m => MonadIO (Event m) where + + {-# INLINE liftIO #-} + liftIO = Event . const . liftIO + +instance MonadCompTrans Event where + + {-# INLINE liftComp #-} + liftComp = Event . const + +-- | A type class to lift the 'Event' computations into other computations. +class EventLift t where + + -- | Lift the specified 'Event' computation into another computation. + liftEvent :: MonadComp m => Event m a -> t m a + +instance EventLift Event where + + {-# INLINE liftEvent #-} + liftEvent = id + +instance DynamicsLift Event where + + {-# INLINE liftDynamics #-} + liftDynamics (Dynamics x) = Event x + +instance SimulationLift Event where + + {-# INLINE liftSimulation #-} + liftSimulation (Simulation x) = Event $ x . pointRun + +instance ParameterLift Event where + + {-# INLINE liftParameter #-} + liftParameter (Parameter x) = Event $ x . pointRun + +-- | Exception handling within 'Event' computations. +catchEvent :: (MonadComp m, Exception e) => Event m a -> (e -> Event m a) -> Event m a +catchEvent (Event m) h = + Event $ \p -> + catchComp (m p) $ \e -> + let Event m' = h e in m' p + +-- | A computation with finalization part like the 'finally' function. +finallyEvent :: MonadComp m => Event m a -> Event m b -> Event m a +finallyEvent (Event m) (Event m') = + Event $ \p -> + finallyComp (m p) (m' p) + +-- | Like the standard 'throw' function. +throwEvent :: (MonadComp m, Exception e) => e -> Event m a +throwEvent = throw + +instance MonadFix m => MonadFix (Event m) where + + {-# INLINE mfix #-} + mfix f = + Event $ \p -> + do { rec { a <- invokeEvent p (f a) }; return a } + +-- | Run the 'Event' computation in the start time involving all +-- pending 'CurrentEvents' in the processing too. +runEventInStartTime :: MonadComp m => Event m a -> Simulation m a +runEventInStartTime = runDynamicsInStartTime . runEvent + +-- | Run the 'Event' computation in the stop time involving all +-- pending 'CurrentEvents' in the processing too. +runEventInStopTime :: MonadComp m => Event m a -> Simulation m a +runEventInStopTime = runDynamicsInStopTime . runEvent + +-- | Actuate the event handler in the specified time points. +enqueueEventWithTimes :: MonadComp m => [Double] -> Event m () -> Event m () +enqueueEventWithTimes ts e = loop ts + where loop [] = return () + loop (t : ts) = enqueueEvent t $ e >> loop ts + +-- | Actuate the event handler in the specified time points. +enqueueEventWithPoints :: MonadComp m => [Point m] -> Event m () -> Event m () +enqueueEventWithPoints xs (Event e) = loop xs + where loop [] = return () + loop (x : xs) = enqueueEvent (pointTime x) $ + Event $ \p -> + do e x -- N.B. we substitute the time point! + invokeEvent p $ loop xs + +-- | Actuate the event handler in the integration time points. +enqueueEventWithIntegTimes :: MonadComp m => Event m () -> Event m () +enqueueEventWithIntegTimes e = + Event $ \p -> + let points = integPoints $ pointRun p + in invokeEvent p $ enqueueEventWithPoints points e + +-- | It allows cancelling the event. +data EventCancellation m = + EventCancellation { cancelEvent :: Event m (), + -- ^ Cancel the event. + eventCancelled :: Event m Bool, + -- ^ Test whether the event was cancelled. + eventFinished :: Event m Bool + -- ^ Test whether the event was processed and finished. + } + +-- | Enqueue the event with an ability to cancel it. +enqueueEventWithCancellation :: MonadComp m => Double -> Event m () -> Event m (EventCancellation m) +enqueueEventWithCancellation t e = + Event $ \p -> + do let s = runSession $ pointRun p + cancelledRef <- newProtoRef s False + cancellableRef <- newProtoRef s True + finishedRef <- newProtoRef s False + let cancel = + Event $ \p -> + do x <- readProtoRef cancellableRef + when x $ + writeProtoRef cancelledRef True + cancelled = + Event $ \p -> readProtoRef cancelledRef + finished = + Event $ \p -> readProtoRef finishedRef + invokeEvent p $ + enqueueEvent t $ + Event $ \p -> + do writeProtoRef cancellableRef False + x <- readProtoRef cancelledRef + unless x $ + do invokeEvent p e + writeProtoRef finishedRef True + return EventCancellation { cancelEvent = cancel, + eventCancelled = cancelled, + eventFinished = finished } + +-- | Memoize the 'Event' computation, always returning the same value +-- within a simulation run. +memoEvent :: MonadComp m => Event m a -> Simulation m (Event m a) +memoEvent m = + Simulation $ \r -> + do let s = runSession r + ref <- newProtoRef s Nothing + return $ Event $ \p -> + do x <- readProtoRef ref + case x of + Just v -> return v + Nothing -> + do v <- invokeEvent p m + writeProtoRef ref (Just v) + return v + +-- | Memoize the 'Event' computation, always returning the same value +-- in the same modeling time. After the time changes, the value is +-- recalculated by demand. +-- +-- It is possible to implement this function efficiently, for the 'Event' +-- computation is always synchronized with the event queue which time +-- flows in one direction only. This synchronization is a key difference +-- between the 'Event' and 'Dynamics' computations. +memoEventInTime :: MonadComp m => Event m a -> Simulation m (Event m a) +memoEventInTime m = + Simulation $ \r -> + do let s = runSession r + ref <- newProtoRef s Nothing + return $ Event $ \p -> + do x <- readProtoRef ref + case x of + Just (t, v) | t == pointTime p -> + return v + _ -> + do v <- invokeEvent p m + writeProtoRef ref (Just (pointTime p, v)) + return v + +-- | Enqueue the event which must be actuated with the current modeling time but later. +yieldEvent :: MonadComp m => Event m () -> Event m () +yieldEvent m = + Event $ \p -> + invokeEvent p $ + enqueueEvent (pointTime p) m + +-- | Defines a computation disposing some entity. +newtype DisposableEvent m = + DisposableEvent { disposeEvent :: Event m () + -- ^ Dispose something within the 'Event' computation. + } + +instance Monad m => Monoid (DisposableEvent m) where + + {-# INLINE mempty #-} + mempty = DisposableEvent $ return () + + {-# INLINE mappend #-} + mappend (DisposableEvent x) (DisposableEvent y) = DisposableEvent $ x >> y 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 @@ -1,341 +1,341 @@ - -{-# LANGUAGE RecursiveDo, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} - --- | --- Module : Simulation.Aivika.Trans.Internal.Parameter --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines the 'Parameter' monad transformer that allows representing the model --- parameters. For example, they can be used when running the Monte-Carlo simulation. --- --- In general, this monad is very useful for representing a computation which is external --- relative to the model itself. --- -module Simulation.Aivika.Trans.Internal.Parameter - (-- * Parameter - ParameterLift(..), - runParameter, - runParameters, - -- * Error Handling - catchParameter, - finallyParameter, - throwParameter, - -- * Predefined Parameters - simulationIndex, - simulationCount, - simulationSpecs, - simulationSession, - simulationEventQueue, - starttime, - stoptime, - dt, - generatorParameter, - -- * Memoization - memoParameter, - -- * Utilities - tableParameter) where - -import Control.Exception -import Control.Concurrent.MVar -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Fix -import Control.Applicative - -import Data.IORef -import qualified Data.IntMap as M -import Data.Array - -import Simulation.Aivika.Trans.Exception -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.Generator -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Comp.IO -import Simulation.Aivika.Trans.Internal.Specs - -instance Monad m => Monad (Parameter m) where - - {-# INLINE return #-} - return a = Parameter $ \r -> return a - - {-# INLINE (>>=) #-} - (Parameter m) >>= k = - Parameter $ \r -> - do a <- m r - let Parameter m' = k a - m' r - --- | Run the parameter using the specified specs. -runParameter :: MonadComp m => Parameter m a -> Specs m -> m a -runParameter (Parameter m) sc = - do s <- newSession - q <- newEventQueue s sc - g <- newGenerator s $ spcGeneratorType sc - m Run { runSpecs = sc, - runSession = s, - runIndex = 1, - runCount = 1, - runEventQueue = q, - runGenerator = g } - --- | Run the given number of parameters using the specified specs, --- where each parameter is distinguished by its index 'parameterIndex'. -runParameters :: MonadComp m => Parameter m a -> Specs m -> Int -> [m a] -runParameters (Parameter m) sc runs = map f [1 .. runs] - where f i = do s <- newSession - q <- newEventQueue s sc - g <- newGenerator s $ spcGeneratorType sc - m Run { runSpecs = sc, - runSession = s, - runIndex = i, - runCount = runs, - runEventQueue = q, - runGenerator = g } - --- | Return the run index for the current simulation. -simulationIndex :: Monad m => Parameter m Int -{-# INLINE simulationIndex #-} -simulationIndex = Parameter $ return . runIndex - --- | Return the number of simulations currently run. -simulationCount :: Monad m => Parameter m Int -{-# INLINE simulationCount #-} -simulationCount = Parameter $ return . runCount - --- | Return the simulation specs. -simulationSpecs :: Monad m => Parameter m (Specs m) -{-# INLINE simulationSpecs #-} -simulationSpecs = Parameter $ return . runSpecs - --- | Return the random number generator for the simulation run. -generatorParameter :: Monad m => Parameter m (Generator m) -{-# INLINE generatorParameter #-} -generatorParameter = Parameter $ return . runGenerator - -instance Functor m => Functor (Parameter m) where - - {-# INLINE fmap #-} - fmap f (Parameter x) = Parameter $ \r -> fmap f $ x r - -instance Applicative m => Applicative (Parameter m) where - - {-# INLINE pure #-} - pure = Parameter . const . pure - - {-# INLINE (<*>) #-} - (Parameter x) <*> (Parameter y) = Parameter $ \r -> x r <*> y r - -liftMP :: Monad m => (a -> b) -> Parameter m a -> Parameter m b -{-# INLINE liftMP #-} -liftMP f (Parameter x) = - Parameter $ \r -> do { a <- x r; return $ f a } - -liftM2P :: Monad m => (a -> b -> c) -> Parameter m a -> Parameter m b -> Parameter m c -{-# INLINE liftM2P #-} -liftM2P f (Parameter x) (Parameter y) = - Parameter $ \r -> do { a <- x r; b <- y r; return $ f a b } - -instance (Num a, Monad m) => Num (Parameter m a) where - - {-# INLINE (+) #-} - x + y = liftM2P (+) x y - - {-# INLINE (-) #-} - x - y = liftM2P (-) x y - - {-# INLINE (*) #-} - x * y = liftM2P (*) x y - - {-# INLINE negate #-} - negate = liftMP negate - - {-# INLINE abs #-} - abs = liftMP abs - - {-# INLINE signum #-} - signum = liftMP signum - - {-# INLINE fromInteger #-} - fromInteger i = return $ fromInteger i - -instance (Fractional a, Monad m) => Fractional (Parameter m a) where - - {-# INLINE (/) #-} - x / y = liftM2P (/) x y - - {-# INLINE recip #-} - recip = liftMP recip - - {-# INLINE fromRational #-} - fromRational t = return $ fromRational t - -instance (Floating a, Monad m) => Floating (Parameter m a) where - - {-# INLINE pi #-} - pi = return pi - - {-# INLINE exp #-} - exp = liftMP exp - - {-# INLINE log #-} - log = liftMP log - - {-# INLINE sqrt #-} - sqrt = liftMP sqrt - - {-# INLINE (**) #-} - x ** y = liftM2P (**) x y - - {-# INLINE sin #-} - sin = liftMP sin - - {-# INLINE cos #-} - cos = liftMP cos - - {-# INLINE tan #-} - tan = liftMP tan - - {-# INLINE asin #-} - asin = liftMP asin - - {-# INLINE acos #-} - acos = liftMP acos - - {-# INLINE atan #-} - atan = liftMP atan - - {-# INLINE sinh #-} - sinh = liftMP sinh - - {-# INLINE cosh #-} - cosh = liftMP cosh - - {-# INLINE tanh #-} - tanh = liftMP tanh - - {-# INLINE asinh #-} - asinh = liftMP asinh - - {-# INLINE acosh #-} - acosh = liftMP acosh - - {-# INLINE atanh #-} - atanh = liftMP atanh - -instance MonadTrans Parameter where - - {-# INLINE lift #-} - lift = Parameter . const - -instance MonadIO m => MonadIO (Parameter m) where - - {-# INLINE liftIO #-} - liftIO = Parameter . const . liftIO - -instance MonadCompTrans Parameter where - - {-# INLINE liftComp #-} - liftComp = Parameter . const - --- | A type class to lift the parameters into other computations. -class ParameterLift t where - - -- | Lift the specified 'Parameter' computation into another computation. - liftParameter :: MonadComp m => Parameter m a -> t m a - -instance ParameterLift Parameter where - - {-# INLINE liftParameter #-} - liftParameter = id - --- | Exception handling within 'Parameter' computations. -catchParameter :: (MonadComp m, Exception e) => Parameter m a -> (e -> Parameter m a) -> Parameter m a -catchParameter (Parameter m) h = - Parameter $ \r -> - catchComp (m r) $ \e -> - let Parameter m' = h e in m' r - --- | A computation with finalization part like the 'finally' function. -finallyParameter :: MonadComp m => Parameter m a -> Parameter m b -> Parameter m a -finallyParameter (Parameter m) (Parameter m') = - Parameter $ \r -> - finallyComp (m r) (m' r) - --- | Like the standard 'throw' function. -throwParameter :: (MonadComp m, Exception e) => e -> Parameter m a -throwParameter = throw - -instance MonadFix m => MonadFix (Parameter m) where - - {-# INLINE mfix #-} - mfix f = - Parameter $ \r -> - do { rec { a <- invokeParameter r (f a) }; return a } - --- | Memoize the 'Parameter' computation, always returning the same value --- within a simulation run. However, the value will be recalculated for other --- simulation runs. Also it is thread-safe when different simulation runs --- are executed in parallel on physically different operating system threads. -memoParameter :: Parameter IO a -> IO (Parameter IO a) -memoParameter x = - do lock <- newMVar () - dict <- newIORef M.empty - return $ Parameter $ \r -> - do let i = runIndex r - m <- readIORef dict - if M.member i m - then do let Just v = M.lookup i m - return v - else withMVar lock $ - \() -> do { m <- readIORef dict; - if M.member i m - then do let Just v = M.lookup i m - return v - else do v <- invokeParameter r x - writeIORef dict $ M.insert i v m - return v } - --- | Return a parameter which value is taken consequently from the specified table --- based on the run index of the current simulation starting from zero. After all --- values from the table are used, it takes again the first value of the table, --- then the second one and so on. -tableParameter :: Monad m => Array Int a -> Parameter m a -tableParameter t = - do i <- simulationIndex - return $ t ! (((i - i1) `mod` n) + i1) - where (i1, i2) = bounds t - n = i2 - i1 + 1 - --- | Computation that returns the start simulation time. -starttime :: Monad m => Parameter m Double -{-# INLINE starttime #-} -starttime = - Parameter $ return . spcStartTime . runSpecs - --- | Computation that returns the final simulation time. -stoptime :: Monad m => Parameter m Double -{-# INLINE stoptime #-} -stoptime = - Parameter $ return . spcStopTime . runSpecs - --- | Computation that returns the integration time step. -dt :: Monad m => Parameter m Double -{-# INLINE dt #-} -dt = - Parameter $ return . spcDT . runSpecs - --- | Return the event queue. -simulationEventQueue :: Monad m => Parameter m (EventQueue m) -{-# INLINE simulationEventQueue #-} -simulationEventQueue = - Parameter $ return . runEventQueue - --- | Return the simulation session. -simulationSession :: Monad m => Parameter m (Session m) -{-# INLINE simulationSession #-} -simulationSession = - Parameter $ return . runSession + +{-# LANGUAGE RecursiveDo, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} + +-- | +-- Module : Simulation.Aivika.Trans.Internal.Parameter +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the 'Parameter' monad transformer that allows representing the model +-- parameters. For example, they can be used when running the Monte-Carlo simulation. +-- +-- In general, this monad is very useful for representing a computation which is external +-- relative to the model itself. +-- +module Simulation.Aivika.Trans.Internal.Parameter + (-- * Parameter + ParameterLift(..), + runParameter, + runParameters, + -- * Error Handling + catchParameter, + finallyParameter, + throwParameter, + -- * Predefined Parameters + simulationIndex, + simulationCount, + simulationSpecs, + simulationSession, + simulationEventQueue, + starttime, + stoptime, + dt, + generatorParameter, + -- * Memoization + memoParameter, + -- * Utilities + tableParameter) where + +import Control.Exception +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Fix +import Control.Applicative + +import Data.IORef +import qualified Data.IntMap as M +import Data.Array + +import Simulation.Aivika.Trans.Exception +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.Generator +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Comp.IO +import Simulation.Aivika.Trans.Internal.Specs + +instance Monad m => Monad (Parameter m) where + + {-# INLINE return #-} + return a = Parameter $ \r -> return a + + {-# INLINE (>>=) #-} + (Parameter m) >>= k = + Parameter $ \r -> + do a <- m r + let Parameter m' = k a + m' r + +-- | Run the parameter using the specified specs. +runParameter :: MonadComp m => Parameter m a -> Specs m -> m a +runParameter (Parameter m) sc = + do s <- newSession + q <- newEventQueue s sc + g <- newGenerator s $ spcGeneratorType sc + m Run { runSpecs = sc, + runSession = s, + runIndex = 1, + runCount = 1, + runEventQueue = q, + runGenerator = g } + +-- | Run the given number of parameters using the specified specs, +-- where each parameter is distinguished by its index 'parameterIndex'. +runParameters :: MonadComp m => Parameter m a -> Specs m -> Int -> [m a] +runParameters (Parameter m) sc runs = map f [1 .. runs] + where f i = do s <- newSession + q <- newEventQueue s sc + g <- newGenerator s $ spcGeneratorType sc + m Run { runSpecs = sc, + runSession = s, + runIndex = i, + runCount = runs, + runEventQueue = q, + runGenerator = g } + +-- | Return the run index for the current simulation. +simulationIndex :: Monad m => Parameter m Int +{-# INLINE simulationIndex #-} +simulationIndex = Parameter $ return . runIndex + +-- | Return the number of simulations currently run. +simulationCount :: Monad m => Parameter m Int +{-# INLINE simulationCount #-} +simulationCount = Parameter $ return . runCount + +-- | Return the simulation specs. +simulationSpecs :: Monad m => Parameter m (Specs m) +{-# INLINE simulationSpecs #-} +simulationSpecs = Parameter $ return . runSpecs + +-- | Return the random number generator for the simulation run. +generatorParameter :: Monad m => Parameter m (Generator m) +{-# INLINE generatorParameter #-} +generatorParameter = Parameter $ return . runGenerator + +instance Functor m => Functor (Parameter m) where + + {-# INLINE fmap #-} + fmap f (Parameter x) = Parameter $ \r -> fmap f $ x r + +instance Applicative m => Applicative (Parameter m) where + + {-# INLINE pure #-} + pure = Parameter . const . pure + + {-# INLINE (<*>) #-} + (Parameter x) <*> (Parameter y) = Parameter $ \r -> x r <*> y r + +liftMP :: Monad m => (a -> b) -> Parameter m a -> Parameter m b +{-# INLINE liftMP #-} +liftMP f (Parameter x) = + Parameter $ \r -> do { a <- x r; return $ f a } + +liftM2P :: Monad m => (a -> b -> c) -> Parameter m a -> Parameter m b -> Parameter m c +{-# INLINE liftM2P #-} +liftM2P f (Parameter x) (Parameter y) = + Parameter $ \r -> do { a <- x r; b <- y r; return $ f a b } + +instance (Num a, Monad m) => Num (Parameter m a) where + + {-# INLINE (+) #-} + x + y = liftM2P (+) x y + + {-# INLINE (-) #-} + x - y = liftM2P (-) x y + + {-# INLINE (*) #-} + x * y = liftM2P (*) x y + + {-# INLINE negate #-} + negate = liftMP negate + + {-# INLINE abs #-} + abs = liftMP abs + + {-# INLINE signum #-} + signum = liftMP signum + + {-# INLINE fromInteger #-} + fromInteger i = return $ fromInteger i + +instance (Fractional a, Monad m) => Fractional (Parameter m a) where + + {-# INLINE (/) #-} + x / y = liftM2P (/) x y + + {-# INLINE recip #-} + recip = liftMP recip + + {-# INLINE fromRational #-} + fromRational t = return $ fromRational t + +instance (Floating a, Monad m) => Floating (Parameter m a) where + + {-# INLINE pi #-} + pi = return pi + + {-# INLINE exp #-} + exp = liftMP exp + + {-# INLINE log #-} + log = liftMP log + + {-# INLINE sqrt #-} + sqrt = liftMP sqrt + + {-# INLINE (**) #-} + x ** y = liftM2P (**) x y + + {-# INLINE sin #-} + sin = liftMP sin + + {-# INLINE cos #-} + cos = liftMP cos + + {-# INLINE tan #-} + tan = liftMP tan + + {-# INLINE asin #-} + asin = liftMP asin + + {-# INLINE acos #-} + acos = liftMP acos + + {-# INLINE atan #-} + atan = liftMP atan + + {-# INLINE sinh #-} + sinh = liftMP sinh + + {-# INLINE cosh #-} + cosh = liftMP cosh + + {-# INLINE tanh #-} + tanh = liftMP tanh + + {-# INLINE asinh #-} + asinh = liftMP asinh + + {-# INLINE acosh #-} + acosh = liftMP acosh + + {-# INLINE atanh #-} + atanh = liftMP atanh + +instance MonadTrans Parameter where + + {-# INLINE lift #-} + lift = Parameter . const + +instance MonadIO m => MonadIO (Parameter m) where + + {-# INLINE liftIO #-} + liftIO = Parameter . const . liftIO + +instance MonadCompTrans Parameter where + + {-# INLINE liftComp #-} + liftComp = Parameter . const + +-- | A type class to lift the parameters into other computations. +class ParameterLift t where + + -- | Lift the specified 'Parameter' computation into another computation. + liftParameter :: MonadComp m => Parameter m a -> t m a + +instance ParameterLift Parameter where + + {-# INLINE liftParameter #-} + liftParameter = id + +-- | Exception handling within 'Parameter' computations. +catchParameter :: (MonadComp m, Exception e) => Parameter m a -> (e -> Parameter m a) -> Parameter m a +catchParameter (Parameter m) h = + Parameter $ \r -> + catchComp (m r) $ \e -> + let Parameter m' = h e in m' r + +-- | A computation with finalization part like the 'finally' function. +finallyParameter :: MonadComp m => Parameter m a -> Parameter m b -> Parameter m a +finallyParameter (Parameter m) (Parameter m') = + Parameter $ \r -> + finallyComp (m r) (m' r) + +-- | Like the standard 'throw' function. +throwParameter :: (MonadComp m, Exception e) => e -> Parameter m a +throwParameter = throw + +instance MonadFix m => MonadFix (Parameter m) where + + {-# INLINE mfix #-} + mfix f = + Parameter $ \r -> + do { rec { a <- invokeParameter r (f a) }; return a } + +-- | Memoize the 'Parameter' computation, always returning the same value +-- within a simulation run. However, the value will be recalculated for other +-- simulation runs. Also it is thread-safe when different simulation runs +-- are executed in parallel on physically different operating system threads. +memoParameter :: Parameter IO a -> IO (Parameter IO a) +memoParameter x = + do lock <- newMVar () + dict <- newIORef M.empty + return $ Parameter $ \r -> + do let i = runIndex r + m <- readIORef dict + if M.member i m + then do let Just v = M.lookup i m + return v + else withMVar lock $ + \() -> do { m <- readIORef dict; + if M.member i m + then do let Just v = M.lookup i m + return v + else do v <- invokeParameter r x + writeIORef dict $ M.insert i v m + return v } + +-- | Return a parameter which value is taken consequently from the specified table +-- based on the run index of the current simulation starting from zero. After all +-- values from the table are used, it takes again the first value of the table, +-- then the second one and so on. +tableParameter :: Monad m => Array Int a -> Parameter m a +tableParameter t = + do i <- simulationIndex + return $ t ! (((i - i1) `mod` n) + i1) + where (i1, i2) = bounds t + n = i2 - i1 + 1 + +-- | Computation that returns the start simulation time. +starttime :: Monad m => Parameter m Double +{-# INLINE starttime #-} +starttime = + Parameter $ return . spcStartTime . runSpecs + +-- | Computation that returns the final simulation time. +stoptime :: Monad m => Parameter m Double +{-# INLINE stoptime #-} +stoptime = + Parameter $ return . spcStopTime . runSpecs + +-- | Computation that returns the integration time step. +dt :: Monad m => Parameter m Double +{-# INLINE dt #-} +dt = + Parameter $ return . spcDT . runSpecs + +-- | Return the event queue. +simulationEventQueue :: Monad m => Parameter m (EventQueue m) +{-# INLINE simulationEventQueue #-} +simulationEventQueue = + Parameter $ return . runEventQueue + +-- | Return the simulation session. +simulationSession :: Monad m => Parameter m (Session m) +{-# INLINE simulationSession #-} +simulationSession = + Parameter $ return . runSession diff --git a/Simulation/Aivika/Trans/Internal/Process.hs b/Simulation/Aivika/Trans/Internal/Process.hs --- a/Simulation/Aivika/Trans/Internal/Process.hs +++ b/Simulation/Aivika/Trans/Internal/Process.hs @@ -1,641 +1,653 @@ - --- | --- Module : Simulation.Aivika.Trans.Internal.Process --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- A value in the 'Process' monad represents a discontinuous process that --- can suspend in any simulation time point and then resume later in the same --- or another time point. --- --- The process of this type can involve the 'Event', 'Dynamics' and 'Simulation' --- computations. Moreover, a value in the @Process@ monad can be run within --- the @Event@ computation. --- --- A value of the 'ProcessId' type is just an identifier of such a process. --- -module Simulation.Aivika.Trans.Internal.Process - (-- * Process Monad - ProcessId, - Process(..), - ProcessLift(..), - invokeProcess, - -- * Running Process - runProcess, - runProcessUsingId, - runProcessInStartTime, - runProcessInStartTimeUsingId, - runProcessInStopTime, - runProcessInStopTimeUsingId, - -- * Spawning Processes - spawnProcess, - spawnProcessUsingId, - -- * Enqueuing Process - enqueueProcess, - enqueueProcessUsingId, - -- * Creating Process Identifier - newProcessId, - processId, - processUsingId, - -- * Holding, Interrupting, Passivating and Canceling Process - holdProcess, - interruptProcess, - processInterrupted, - passivateProcess, - processPassive, - reactivateProcess, - cancelProcessWithId, - cancelProcess, - processCancelled, - processCancelling, - whenCancellingProcess, - -- * Awaiting Signal - processAwait, - -- * Yield of Process - processYield, - -- * Process Timeout - timeoutProcess, - timeoutProcessUsingId, - -- * Parallelizing Processes - processParallel, - processParallelUsingIds, - processParallel_, - processParallelUsingIds_, - -- * Exception Handling - catchProcess, - finallyProcess, - throwProcess, - -- * Utilities - zipProcessParallel, - zip3ProcessParallel, - unzipProcess, - -- * Memoizing Process - memoProcess, - -- * Never Ending Process - neverProcess) where - -import Data.Maybe - -import Control.Exception -import Control.Monad -import Control.Monad.Trans -import Control.Applicative - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Parameter -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Dynamics -import Simulation.Aivika.Trans.Internal.Event -import Simulation.Aivika.Trans.Internal.Cont -import Simulation.Aivika.Trans.Internal.Signal - --- | Represents a process identifier. -data ProcessId m = - ProcessId { processStarted :: ProtoRef m Bool, - processMarker :: SessionMarker m, - processReactCont :: ProtoRef m (Maybe (ContParams m ())), - processCancelSource :: ContCancellationSource m, - processInterruptRef :: ProtoRef m Bool, - processInterruptCont :: ProtoRef m (Maybe (ContParams m ())), - processInterruptVersion :: ProtoRef m Int } - --- | Specifies a discontinuous process that can suspend at any time --- and then resume later. -newtype Process m a = Process (ProcessId m -> Cont m a) - --- | A type class to lift the 'Process' computation into other computations. -class ProcessLift t where - - -- | Lift the specified 'Process' computation into another computation. - liftProcess :: MonadComp m => Process m a -> t m a - --- | Invoke the process computation. -invokeProcess :: ProcessId m -> Process m a -> Cont m a -{-# INLINE invokeProcess #-} -invokeProcess pid (Process m) = m pid - --- | Hold the process for the specified time period. -holdProcess :: MonadComp m => Double -> Process m () -holdProcess dt = - Process $ \pid -> - Cont $ \c -> - Event $ \p -> - do let x = processInterruptCont pid - writeProtoRef x $ Just c - writeProtoRef (processInterruptRef pid) False - v <- readProtoRef (processInterruptVersion pid) - invokeEvent p $ - enqueueEvent (pointTime p + dt) $ - Event $ \p -> - do v' <- readProtoRef (processInterruptVersion pid) - when (v == v') $ - do writeProtoRef x Nothing - invokeEvent p $ resumeCont c () - --- | Interrupt a process with the specified identifier if the process --- is held by computation 'holdProcess'. -interruptProcess :: MonadComp m => ProcessId m -> Event m () -interruptProcess pid = - Event $ \p -> - do let x = processInterruptCont pid - a <- readProtoRef x - case a of - Nothing -> return () - Just c -> - do writeProtoRef x Nothing - writeProtoRef (processInterruptRef pid) True - modifyProtoRef (processInterruptVersion pid) $ (+) 1 - invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c () - --- | Test whether the process with the specified identifier was interrupted. -processInterrupted :: MonadComp m => ProcessId m -> Event m Bool -processInterrupted pid = - Event $ \p -> - readProtoRef (processInterruptRef pid) - --- | Passivate the process. -passivateProcess :: MonadComp m => Process m () -passivateProcess = - Process $ \pid -> - Cont $ \c -> - Event $ \p -> - do let x = processReactCont pid - a <- readProtoRef x - case a of - Nothing -> writeProtoRef x $ Just c - Just _ -> error "Cannot passivate the process twice: passivateProcess" - --- | Test whether the process with the specified identifier is passivated. -processPassive :: MonadComp m => ProcessId m -> Event m Bool -processPassive pid = - Event $ \p -> - do let x = processReactCont pid - a <- readProtoRef x - return $ isJust a - --- | Reactivate a process with the specified identifier. -reactivateProcess :: MonadComp m => ProcessId m -> Event m () -reactivateProcess pid = - Event $ \p -> - do let x = processReactCont pid - a <- readProtoRef x - case a of - Nothing -> - return () - Just c -> - do writeProtoRef x Nothing - invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c () - --- | Prepare the processes identifier for running. -processIdPrepare :: MonadComp m => ProcessId m -> Event m () -processIdPrepare pid = - Event $ \p -> - do y <- readProtoRef (processStarted pid) - if y - then error $ - "Another process with the specified identifier " ++ - "has been started already: processIdPrepare" - else writeProtoRef (processStarted pid) True - let signal = processCancelling pid - invokeEvent p $ - handleSignal_ signal $ \_ -> - do interruptProcess pid - reactivateProcess pid - --- | Run immediately the process. A new 'ProcessId' identifier will be --- assigned to the process. --- --- To run the process at the specified time, you can use --- the 'enqueueProcess' function. -runProcess :: MonadComp m => Process m () -> Event m () -runProcess p = - do pid <- liftSimulation newProcessId - runProcessUsingId pid p - --- | Run immediately the process with the specified identifier. --- It will be more efficient than as you would specify the process identifier --- with help of the 'processUsingId' combinator and then would call 'runProcess'. --- --- To run the process at the specified time, you can use --- the 'enqueueProcessUsingId' function. -runProcessUsingId :: MonadComp m => ProcessId m -> Process m () -> Event m () -runProcessUsingId pid p = - do processIdPrepare pid - runCont m cont econt ccont (processCancelSource pid) False - where cont = return - econt = throwEvent - ccont = return - m = invokeProcess pid p - --- | Run the process in the start time immediately involving all pending --- 'CurrentEvents' in the computation too. -runProcessInStartTime :: MonadComp m => Process m () -> Simulation m () -runProcessInStartTime = runEventInStartTime . runProcess - --- | Run the process in the start time immediately using the specified identifier --- and involving all pending 'CurrentEvents' in the computation too. -runProcessInStartTimeUsingId :: MonadComp m => ProcessId m -> Process m () -> Simulation m () -runProcessInStartTimeUsingId pid p = - runEventInStartTime $ runProcessUsingId pid p - --- | Run the process in the final simulation time immediately involving all --- pending 'CurrentEvents' in the computation too. -runProcessInStopTime :: MonadComp m => Process m () -> Simulation m () -runProcessInStopTime = runEventInStopTime . runProcess - --- | Run the process in the final simulation time immediately using --- the specified identifier and involving all pending 'CurrentEvents' --- in the computation too. -runProcessInStopTimeUsingId :: MonadComp m => ProcessId m -> Process m () -> Simulation m () -runProcessInStopTimeUsingId pid p = - runEventInStopTime $ runProcessUsingId pid p - --- | Enqueue the process that will be then started at the specified time --- from the event queue. -enqueueProcess :: MonadComp m => Double -> Process m () -> Event m () -enqueueProcess t p = - enqueueEvent t $ runProcess p - --- | Enqueue the process that will be then started at the specified time --- from the event queue. -enqueueProcessUsingId :: MonadComp m => Double -> ProcessId m -> Process m () -> Event m () -enqueueProcessUsingId t pid p = - enqueueEvent t $ runProcessUsingId pid p - --- | Return the current process identifier. -processId :: MonadComp m => Process m (ProcessId m) -processId = Process return - --- | Create a new process identifier. -newProcessId :: MonadComp m => Simulation m (ProcessId m) -newProcessId = - Simulation $ \r -> - do let s = runSession r - m <- newSessionMarker s - x <- newProtoRef s Nothing - y <- newProtoRef s False - c <- invokeSimulation r newContCancellationSource - i <- newProtoRef s False - z <- newProtoRef s Nothing - v <- newProtoRef s 0 - return ProcessId { processStarted = y, - processMarker = m, - processReactCont = x, - processCancelSource = c, - processInterruptRef = i, - processInterruptCont = z, - processInterruptVersion = v } - --- | Cancel a process with the specified identifier, interrupting it if needed. -cancelProcessWithId :: MonadComp m => ProcessId m -> Event m () -cancelProcessWithId pid = contCancellationInitiate (processCancelSource pid) - --- | The process cancels itself. -cancelProcess :: (MonadComp m, MonadIO m) => Process m a -cancelProcess = - do pid <- processId - liftEvent $ cancelProcessWithId pid - throwProcess $ - (error "The process must be cancelled already: cancelProcess." :: SomeException) - --- | Test whether the process with the specified identifier was cancelled. -processCancelled :: MonadComp m => ProcessId m -> Event m Bool -processCancelled pid = contCancellationInitiated (processCancelSource pid) - --- | Return a signal that notifies about cancelling the process with --- the specified identifier. -processCancelling :: ProcessId m -> Signal m () -processCancelling pid = contCancellationInitiating (processCancelSource pid) - --- | Register a handler that will be invoked in case of cancelling the current process. -whenCancellingProcess :: MonadComp m => Event m () -> Process m () -whenCancellingProcess h = - Process $ \pid -> - liftEvent $ - handleSignal_ (processCancelling pid) $ \() -> h - -instance MonadComp m => Eq (ProcessId m) where - - {-# INLINE (==) #-} - x == y = processMarker x == processMarker y - -instance MonadComp m => Monad (Process m) where - - {-# INLINE return #-} - return a = Process $ \pid -> return a - - {-# INLINE (>>=) #-} - (Process m) >>= k = - Process $ \pid -> - do a <- m pid - let Process m' = k a - m' pid - -instance MonadCompTrans Process where - - {-# INLINE liftComp #-} - liftComp = Process . const . liftComp - -instance MonadComp m => Functor (Process m) where - - {-# INLINE fmap #-} - fmap f (Process x) = Process $ \pid -> fmap f $ x pid - -instance MonadComp m => Applicative (Process m) where - - {-# INLINE pure #-} - pure = Process . const . pure - - {-# INLINE (<*>) #-} - (Process x) <*> (Process y) = Process $ \pid -> x pid <*> y pid - -instance (MonadComp m, MonadIO m) => MonadIO (Process m) where - - {-# INLINE liftIO #-} - liftIO = Process . const . liftIO - -instance ParameterLift Process where - - {-# INLINE liftParameter #-} - liftParameter = Process . const . liftParameter - -instance SimulationLift Process where - - {-# INLINE liftSimulation #-} - liftSimulation = Process . const . liftSimulation - -instance DynamicsLift Process where - - {-# INLINE liftDynamics #-} - liftDynamics = Process . const . liftDynamics - -instance EventLift Process where - - {-# INLINE liftEvent #-} - liftEvent = Process . const . liftEvent - -instance ProcessLift Process where - - {-# INLINE liftProcess #-} - liftProcess = id - --- | Exception handling within 'Process' computations. -catchProcess :: (MonadComp m, Exception e) => Process m a -> (e -> Process m a) -> Process m a -catchProcess (Process m) h = - Process $ \pid -> - catchCont (m pid) $ \e -> - let Process m' = h e in m' pid - --- | A computation with finalization part. -finallyProcess :: MonadComp m => Process m a -> Process m b -> Process m a -finallyProcess (Process m) (Process m') = - Process $ \pid -> - finallyCont (m pid) (m' pid) - --- | Throw the exception with the further exception handling. --- --- By some reason, an exception raised with help of the standard 'throw' function --- is not handled properly within 'Process' computation, altough it will be still handled --- if it will be wrapped in the 'IO' monad. Therefore, you should use specialised --- functions like the stated one that use the 'throw' function but within the 'IO' computation, --- which allows already handling the exception. -throwProcess :: (MonadComp m, Exception e) => e -> Process m a -throwProcess = liftIO . throw - --- | Execute the specified computations in parallel within --- the current computation and return their results. The cancellation --- of any of the nested computations affects the current computation. --- The exception raised in any of the nested computations is propagated --- to the current computation as well. --- --- Here word @parallel@ literally means that the computations are --- actually executed on a single operating system thread but --- they are processed simultaneously by the event queue. --- --- New 'ProcessId' identifiers will be assigned to the started processes. -processParallel :: MonadComp m => [Process m a] -> Process m [a] -processParallel xs = - liftSimulation (processParallelCreateIds xs) >>= processParallelUsingIds - --- | Like 'processParallel' but allows specifying the process identifiers. --- It will be more efficient than as you would specify the process identifiers --- with help of the 'processUsingId' combinator and then would call 'processParallel'. -processParallelUsingIds :: MonadComp m => [(ProcessId m, Process m a)] -> Process m [a] -processParallelUsingIds xs = - Process $ \pid -> - do liftEvent $ processParallelPrepare xs - contParallel $ - flip map xs $ \(pid, m) -> - (invokeProcess pid m, processCancelSource pid) - --- | Like 'processParallel' but ignores the result. -processParallel_ :: MonadComp m => [Process m a] -> Process m () -processParallel_ xs = - liftSimulation (processParallelCreateIds xs) >>= processParallelUsingIds_ - --- | Like 'processParallelUsingIds' but ignores the result. -processParallelUsingIds_ :: MonadComp m => [(ProcessId m, Process m a)] -> Process m () -processParallelUsingIds_ xs = - Process $ \pid -> - do liftEvent $ processParallelPrepare xs - contParallel_ $ - flip map xs $ \(pid, m) -> - (invokeProcess pid m, processCancelSource pid) - --- | Create the new process identifiers. -processParallelCreateIds :: MonadComp m => [Process m a] -> Simulation m [(ProcessId m, Process m a)] -processParallelCreateIds xs = - do pids <- liftSimulation $ forM xs $ const newProcessId - return $ zip pids xs - --- | Prepare the processes for parallel execution. -processParallelPrepare :: MonadComp m => [(ProcessId m, Process m a)] -> Event m () -processParallelPrepare xs = - Event $ \p -> - forM_ xs $ invokeEvent p . processIdPrepare . fst - --- | Allow calling the process with the specified identifier. --- It creates a nested process when canceling any of two, or raising an --- @IO@ exception in any of the both, affects the 'Process' computation. --- --- At the same time, the interruption has no such effect as it requires --- explicit specifying the 'ProcessId' identifier of the nested process itself, --- that is the nested process cannot be interrupted using only the parent --- process identifier. -processUsingId :: MonadComp m => ProcessId m -> Process m a -> Process m a -processUsingId pid x = - Process $ \pid' -> - do liftEvent $ processIdPrepare pid - rerunCont (invokeProcess pid x) (processCancelSource pid) - --- | Spawn the child process specifying how the child and parent processes --- should be cancelled in case of need. -spawnProcess :: MonadComp m => ContCancellation -> Process m () -> Process m () -spawnProcess cancellation x = - do pid <- liftSimulation newProcessId - spawnProcessUsingId cancellation pid x - --- | Spawn the child process specifying how the child and parent processes --- should be cancelled in case of need. -spawnProcessUsingId :: MonadComp m => ContCancellation -> ProcessId m -> Process m () -> Process m () -spawnProcessUsingId cancellation pid x = - Process $ \pid' -> - do liftEvent $ processIdPrepare pid - spawnCont cancellation (invokeProcess pid x) (processCancelSource pid) - --- | Await the signal. -processAwait :: MonadComp m => Signal m a -> Process m a -processAwait signal = - Process $ \pid -> contAwait signal - --- | The result of memoization. -data MemoResult a = MemoComputed a - | MemoError IOException - | MemoCancelled - --- | Memoize the process so that it would always return the same value --- within the simulation run. -memoProcess :: MonadComp m => Process m a -> Simulation m (Process m a) -memoProcess x = - Simulation $ \r -> - do let s = runSession r - started <- newProtoRef s False - computed <- invokeSimulation r newSignalSource - value <- newProtoRef s Nothing - let result = - do Just x <- liftComp $ readProtoRef value - case x of - MemoComputed a -> return a - MemoError e -> throwProcess e - MemoCancelled -> cancelProcess - return $ - do v <- liftComp $ readProtoRef value - case v of - Just _ -> result - Nothing -> - do f <- liftComp $ readProtoRef started - case f of - True -> - do processAwait $ publishSignal computed - result - False -> - do liftComp $ writeProtoRef started True - r <- liftComp $ newProtoRef s MemoCancelled - finallyProcess - (catchProcess - (do a <- x -- compute only once! - liftComp $ writeProtoRef r (MemoComputed a)) - (\e -> - liftComp $ writeProtoRef r (MemoError e))) - (liftEvent $ - do liftComp $ - do x <- readProtoRef r - writeProtoRef value (Just x) - triggerSignal computed ()) - result - --- | Zip two parallel processes waiting for the both. -zipProcessParallel :: MonadComp m => Process m a -> Process m b -> Process m (a, b) -zipProcessParallel x y = - do [Left a, Right b] <- processParallel [fmap Left x, fmap Right y] - return (a, b) - --- | Zip three parallel processes waiting for their results. -zip3ProcessParallel :: MonadComp m => Process m a -> Process m b -> Process m c -> Process m (a, b, c) -zip3ProcessParallel x y z = - do [Left a, - Right (Left b), - Right (Right c)] <- - processParallel [fmap Left x, - fmap (Right . Left) y, - fmap (Right . Right) z] - return (a, b, c) - --- | Unzip the process using memoization so that the both returned --- processes could be applied independently, although they will refer --- to the same pair of values. -unzipProcess :: (MonadComp m, MonadIO m) => Process m (a, b) -> Simulation m (Process m a, Process m b) -unzipProcess xy = - do xy' <- memoProcess xy - return (fmap fst xy', fmap snd xy') - --- | Try to run the child process within the specified timeout. --- If the process will finish successfully within this time interval then --- the result wrapped in 'Just' will be returned; otherwise, the child process --- will be cancelled and 'Nothing' will be returned. --- --- If an exception is raised in the child process then it is propagated to --- the parent computation as well. --- --- A cancellation of the child process doesn't lead to cancelling the parent process. --- Then 'Nothing' is returned within the computation. -timeoutProcess :: (MonadComp m, MonadIO m) => Double -> Process m a -> Process m (Maybe a) -timeoutProcess timeout p = - do pid <- liftSimulation newProcessId - timeoutProcessUsingId timeout pid p - --- | Try to run the child process with the given identifier within the specified timeout. --- If the process will finish successfully within this time interval then --- the result wrapped in 'Just' will be returned; otherwise, the child process --- will be cancelled and 'Nothing' will be returned. --- --- If an exception is raised in the child process then it is propagated to --- the parent computation as well. --- --- A cancellation of the child process doesn't lead to cancelling the parent process. --- Then 'Nothing' is returned within the computation. -timeoutProcessUsingId :: (MonadComp m, MonadIO m) => Double -> ProcessId m -> Process m a -> Process m (Maybe a) -timeoutProcessUsingId timeout pid p = - do s <- liftSimulation newSignalSource - timeoutPid <- liftSimulation newProcessId - spawnProcessUsingId CancelChildAfterParent timeoutPid $ - finallyProcess - (holdProcess timeout) - (liftEvent $ - cancelProcessWithId pid) - spawnProcessUsingId CancelChildAfterParent pid $ - do sn <- liftParameter simulationSession - r <- liftComp $ newProtoRef sn Nothing - finallyProcess - (catchProcess - (do a <- p - liftComp $ writeProtoRef r $ Just (Right a)) - (\e -> - liftComp $ writeProtoRef r $ Just (Left e))) - (liftEvent $ - do x <- liftComp $ readProtoRef r - triggerSignal s x) - x <- processAwait $ publishSignal s - case x of - Nothing -> return Nothing - Just (Right a) -> return (Just a) - Just (Left (SomeException e)) -> throwProcess e - --- | Yield to allow other 'Process' and 'Event' computations to run --- at the current simulation time point. -processYield :: MonadComp m => Process m () -processYield = - Process $ \pid -> - Cont $ \c -> - Event $ \p -> - invokeEvent p $ - enqueueEvent (pointTime p) $ - resumeCont c () - --- | A computation that never computes the result. It behaves like a black hole for --- the discontinuous process, although such a process can still be canceled outside --- (see 'cancelProcessWithId'), but then only its finalization parts (see 'finallyProcess') --- will be called, usually, to release the resources acquired before. -neverProcess :: MonadComp m => Process m a -neverProcess = - Process $ \pid -> - Cont $ \c -> - let signal = processCancelling pid - in handleSignal_ signal $ \_ -> - resumeCont c $ error "It must never be computed: neverProcess" + +-- | +-- Module : Simulation.Aivika.Trans.Internal.Process +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- A value in the 'Process' monad represents a discontinuous process that +-- can suspend in any simulation time point and then resume later in the same +-- or another time point. +-- +-- The process of this type can involve the 'Event', 'Dynamics' and 'Simulation' +-- computations. Moreover, a value in the @Process@ monad can be run within +-- the @Event@ computation. +-- +-- A value of the 'ProcessId' type is just an identifier of such a process. +-- +module Simulation.Aivika.Trans.Internal.Process + (-- * Process Monad + ProcessId, + Process(..), + ProcessLift(..), + invokeProcess, + -- * Running Process + runProcess, + runProcessUsingId, + runProcessInStartTime, + runProcessInStartTimeUsingId, + runProcessInStopTime, + runProcessInStopTimeUsingId, + -- * Spawning Processes + spawnProcess, + spawnProcessUsingId, + spawnProcessWith, + spawnProcessUsingIdWith, + -- * Enqueuing Process + enqueueProcess, + enqueueProcessUsingId, + -- * Creating Process Identifier + newProcessId, + processId, + processUsingId, + -- * Holding, Interrupting, Passivating and Canceling Process + holdProcess, + interruptProcess, + processInterrupted, + passivateProcess, + processPassive, + reactivateProcess, + cancelProcessWithId, + cancelProcess, + processCancelled, + processCancelling, + whenCancellingProcess, + -- * Awaiting Signal + processAwait, + -- * Yield of Process + processYield, + -- * Process Timeout + timeoutProcess, + timeoutProcessUsingId, + -- * Parallelizing Processes + processParallel, + processParallelUsingIds, + processParallel_, + processParallelUsingIds_, + -- * Exception Handling + catchProcess, + finallyProcess, + throwProcess, + -- * Utilities + zipProcessParallel, + zip3ProcessParallel, + unzipProcess, + -- * Memoizing Process + memoProcess, + -- * Never Ending Process + neverProcess) where + +import Data.Maybe + +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Control.Applicative + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Cont +import Simulation.Aivika.Trans.Internal.Signal + +-- | Represents a process identifier. +data ProcessId m = + ProcessId { processStarted :: ProtoRef m Bool, + processMarker :: SessionMarker m, + processReactCont :: ProtoRef m (Maybe (ContParams m ())), + processCancelSource :: ContCancellationSource m, + processInterruptRef :: ProtoRef m Bool, + processInterruptCont :: ProtoRef m (Maybe (ContParams m ())), + processInterruptVersion :: ProtoRef m Int } + +-- | Specifies a discontinuous process that can suspend at any time +-- and then resume later. +newtype Process m a = Process (ProcessId m -> Cont m a) + +-- | A type class to lift the 'Process' computation into other computations. +class ProcessLift t where + + -- | Lift the specified 'Process' computation into another computation. + liftProcess :: MonadComp m => Process m a -> t m a + +-- | Invoke the process computation. +invokeProcess :: ProcessId m -> Process m a -> Cont m a +{-# INLINE invokeProcess #-} +invokeProcess pid (Process m) = m pid + +-- | Hold the process for the specified time period. +holdProcess :: MonadComp m => Double -> Process m () +holdProcess dt = + Process $ \pid -> + Cont $ \c -> + Event $ \p -> + do let x = processInterruptCont pid + writeProtoRef x $ Just c + writeProtoRef (processInterruptRef pid) False + v <- readProtoRef (processInterruptVersion pid) + invokeEvent p $ + enqueueEvent (pointTime p + dt) $ + Event $ \p -> + do v' <- readProtoRef (processInterruptVersion pid) + when (v == v') $ + do writeProtoRef x Nothing + invokeEvent p $ resumeCont c () + +-- | Interrupt a process with the specified identifier if the process +-- is held by computation 'holdProcess'. +interruptProcess :: MonadComp m => ProcessId m -> Event m () +interruptProcess pid = + Event $ \p -> + do let x = processInterruptCont pid + a <- readProtoRef x + case a of + Nothing -> return () + Just c -> + do writeProtoRef x Nothing + writeProtoRef (processInterruptRef pid) True + modifyProtoRef (processInterruptVersion pid) $ (+) 1 + invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c () + +-- | Test whether the process with the specified identifier was interrupted. +processInterrupted :: MonadComp m => ProcessId m -> Event m Bool +processInterrupted pid = + Event $ \p -> + readProtoRef (processInterruptRef pid) + +-- | Passivate the process. +passivateProcess :: MonadComp m => Process m () +passivateProcess = + Process $ \pid -> + Cont $ \c -> + Event $ \p -> + do let x = processReactCont pid + a <- readProtoRef x + case a of + Nothing -> writeProtoRef x $ Just c + Just _ -> error "Cannot passivate the process twice: passivateProcess" + +-- | Test whether the process with the specified identifier is passivated. +processPassive :: MonadComp m => ProcessId m -> Event m Bool +processPassive pid = + Event $ \p -> + do let x = processReactCont pid + a <- readProtoRef x + return $ isJust a + +-- | Reactivate a process with the specified identifier. +reactivateProcess :: MonadComp m => ProcessId m -> Event m () +reactivateProcess pid = + Event $ \p -> + do let x = processReactCont pid + a <- readProtoRef x + case a of + Nothing -> + return () + Just c -> + do writeProtoRef x Nothing + invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c () + +-- | Prepare the processes identifier for running. +processIdPrepare :: MonadComp m => ProcessId m -> Event m () +processIdPrepare pid = + Event $ \p -> + do y <- readProtoRef (processStarted pid) + if y + then error $ + "Another process with the specified identifier " ++ + "has been started already: processIdPrepare" + else writeProtoRef (processStarted pid) True + let signal = processCancelling pid + invokeEvent p $ + handleSignal_ signal $ \_ -> + do interruptProcess pid + reactivateProcess pid + +-- | Run immediately the process. A new 'ProcessId' identifier will be +-- assigned to the process. +-- +-- To run the process at the specified time, you can use +-- the 'enqueueProcess' function. +runProcess :: MonadComp m => Process m () -> Event m () +runProcess p = + do pid <- liftSimulation newProcessId + runProcessUsingId pid p + +-- | Run immediately the process with the specified identifier. +-- It will be more efficient than as you would specify the process identifier +-- with help of the 'processUsingId' combinator and then would call 'runProcess'. +-- +-- To run the process at the specified time, you can use +-- the 'enqueueProcessUsingId' function. +runProcessUsingId :: MonadComp m => ProcessId m -> Process m () -> Event m () +runProcessUsingId pid p = + do processIdPrepare pid + runCont m cont econt ccont (processCancelSource pid) False + where cont = return + econt = throwEvent + ccont = return + m = invokeProcess pid p + +-- | Run the process in the start time immediately involving all pending +-- 'CurrentEvents' in the computation too. +runProcessInStartTime :: MonadComp m => Process m () -> Simulation m () +runProcessInStartTime = runEventInStartTime . runProcess + +-- | Run the process in the start time immediately using the specified identifier +-- and involving all pending 'CurrentEvents' in the computation too. +runProcessInStartTimeUsingId :: MonadComp m => ProcessId m -> Process m () -> Simulation m () +runProcessInStartTimeUsingId pid p = + runEventInStartTime $ runProcessUsingId pid p + +-- | Run the process in the final simulation time immediately involving all +-- pending 'CurrentEvents' in the computation too. +runProcessInStopTime :: MonadComp m => Process m () -> Simulation m () +runProcessInStopTime = runEventInStopTime . runProcess + +-- | Run the process in the final simulation time immediately using +-- the specified identifier and involving all pending 'CurrentEvents' +-- in the computation too. +runProcessInStopTimeUsingId :: MonadComp m => ProcessId m -> Process m () -> Simulation m () +runProcessInStopTimeUsingId pid p = + runEventInStopTime $ runProcessUsingId pid p + +-- | Enqueue the process that will be then started at the specified time +-- from the event queue. +enqueueProcess :: MonadComp m => Double -> Process m () -> Event m () +enqueueProcess t p = + enqueueEvent t $ runProcess p + +-- | Enqueue the process that will be then started at the specified time +-- from the event queue. +enqueueProcessUsingId :: MonadComp m => Double -> ProcessId m -> Process m () -> Event m () +enqueueProcessUsingId t pid p = + enqueueEvent t $ runProcessUsingId pid p + +-- | Return the current process identifier. +processId :: MonadComp m => Process m (ProcessId m) +processId = Process return + +-- | Create a new process identifier. +newProcessId :: MonadComp m => Simulation m (ProcessId m) +newProcessId = + Simulation $ \r -> + do let s = runSession r + m <- newSessionMarker s + x <- newProtoRef s Nothing + y <- newProtoRef s False + c <- invokeSimulation r newContCancellationSource + i <- newProtoRef s False + z <- newProtoRef s Nothing + v <- newProtoRef s 0 + return ProcessId { processStarted = y, + processMarker = m, + processReactCont = x, + processCancelSource = c, + processInterruptRef = i, + processInterruptCont = z, + processInterruptVersion = v } + +-- | Cancel a process with the specified identifier, interrupting it if needed. +cancelProcessWithId :: MonadComp m => ProcessId m -> Event m () +cancelProcessWithId pid = contCancellationInitiate (processCancelSource pid) + +-- | The process cancels itself. +cancelProcess :: (MonadComp m, MonadIO m) => Process m a +cancelProcess = + do pid <- processId + liftEvent $ cancelProcessWithId pid + throwProcess $ + (error "The process must be cancelled already: cancelProcess." :: SomeException) + +-- | Test whether the process with the specified identifier was cancelled. +processCancelled :: MonadComp m => ProcessId m -> Event m Bool +processCancelled pid = contCancellationInitiated (processCancelSource pid) + +-- | Return a signal that notifies about cancelling the process with +-- the specified identifier. +processCancelling :: ProcessId m -> Signal m () +processCancelling pid = contCancellationInitiating (processCancelSource pid) + +-- | Register a handler that will be invoked in case of cancelling the current process. +whenCancellingProcess :: MonadComp m => Event m () -> Process m () +whenCancellingProcess h = + Process $ \pid -> + liftEvent $ + handleSignal_ (processCancelling pid) $ \() -> h + +instance MonadComp m => Eq (ProcessId m) where + + {-# INLINE (==) #-} + x == y = processMarker x == processMarker y + +instance MonadComp m => Monad (Process m) where + + {-# INLINE return #-} + return a = Process $ \pid -> return a + + {-# INLINE (>>=) #-} + (Process m) >>= k = + Process $ \pid -> + do a <- m pid + let Process m' = k a + m' pid + +instance MonadCompTrans Process where + + {-# INLINE liftComp #-} + liftComp = Process . const . liftComp + +instance MonadComp m => Functor (Process m) where + + {-# INLINE fmap #-} + fmap f (Process x) = Process $ \pid -> fmap f $ x pid + +instance MonadComp m => Applicative (Process m) where + + {-# INLINE pure #-} + pure = Process . const . pure + + {-# INLINE (<*>) #-} + (Process x) <*> (Process y) = Process $ \pid -> x pid <*> y pid + +instance (MonadComp m, MonadIO m) => MonadIO (Process m) where + + {-# INLINE liftIO #-} + liftIO = Process . const . liftIO + +instance ParameterLift Process where + + {-# INLINE liftParameter #-} + liftParameter = Process . const . liftParameter + +instance SimulationLift Process where + + {-# INLINE liftSimulation #-} + liftSimulation = Process . const . liftSimulation + +instance DynamicsLift Process where + + {-# INLINE liftDynamics #-} + liftDynamics = Process . const . liftDynamics + +instance EventLift Process where + + {-# INLINE liftEvent #-} + liftEvent = Process . const . liftEvent + +instance ProcessLift Process where + + {-# INLINE liftProcess #-} + liftProcess = id + +-- | Exception handling within 'Process' computations. +catchProcess :: (MonadComp m, Exception e) => Process m a -> (e -> Process m a) -> Process m a +catchProcess (Process m) h = + Process $ \pid -> + catchCont (m pid) $ \e -> + let Process m' = h e in m' pid + +-- | A computation with finalization part. +finallyProcess :: MonadComp m => Process m a -> Process m b -> Process m a +finallyProcess (Process m) (Process m') = + Process $ \pid -> + finallyCont (m pid) (m' pid) + +-- | Throw the exception with the further exception handling. +-- +-- By some reason, an exception raised with help of the standard 'throw' function +-- is not handled properly within 'Process' computation, altough it will be still handled +-- if it will be wrapped in the 'IO' monad. Therefore, you should use specialised +-- functions like the stated one that use the 'throw' function but within the 'IO' computation, +-- which allows already handling the exception. +throwProcess :: (MonadComp m, Exception e) => e -> Process m a +throwProcess = liftIO . throw + +-- | Execute the specified computations in parallel within +-- the current computation and return their results. The cancellation +-- of any of the nested computations affects the current computation. +-- The exception raised in any of the nested computations is propagated +-- to the current computation as well. +-- +-- Here word @parallel@ literally means that the computations are +-- actually executed on a single operating system thread but +-- they are processed simultaneously by the event queue. +-- +-- New 'ProcessId' identifiers will be assigned to the started processes. +processParallel :: MonadComp m => [Process m a] -> Process m [a] +processParallel xs = + liftSimulation (processParallelCreateIds xs) >>= processParallelUsingIds + +-- | Like 'processParallel' but allows specifying the process identifiers. +-- It will be more efficient than as you would specify the process identifiers +-- with help of the 'processUsingId' combinator and then would call 'processParallel'. +processParallelUsingIds :: MonadComp m => [(ProcessId m, Process m a)] -> Process m [a] +processParallelUsingIds xs = + Process $ \pid -> + do liftEvent $ processParallelPrepare xs + contParallel $ + flip map xs $ \(pid, m) -> + (invokeProcess pid m, processCancelSource pid) + +-- | Like 'processParallel' but ignores the result. +processParallel_ :: MonadComp m => [Process m a] -> Process m () +processParallel_ xs = + liftSimulation (processParallelCreateIds xs) >>= processParallelUsingIds_ + +-- | Like 'processParallelUsingIds' but ignores the result. +processParallelUsingIds_ :: MonadComp m => [(ProcessId m, Process m a)] -> Process m () +processParallelUsingIds_ xs = + Process $ \pid -> + do liftEvent $ processParallelPrepare xs + contParallel_ $ + flip map xs $ \(pid, m) -> + (invokeProcess pid m, processCancelSource pid) + +-- | Create the new process identifiers. +processParallelCreateIds :: MonadComp m => [Process m a] -> Simulation m [(ProcessId m, Process m a)] +processParallelCreateIds xs = + do pids <- liftSimulation $ forM xs $ const newProcessId + return $ zip pids xs + +-- | Prepare the processes for parallel execution. +processParallelPrepare :: MonadComp m => [(ProcessId m, Process m a)] -> Event m () +processParallelPrepare xs = + Event $ \p -> + forM_ xs $ invokeEvent p . processIdPrepare . fst + +-- | Allow calling the process with the specified identifier. +-- It creates a nested process when canceling any of two, or raising an +-- @IO@ exception in any of the both, affects the 'Process' computation. +-- +-- At the same time, the interruption has no such effect as it requires +-- explicit specifying the 'ProcessId' identifier of the nested process itself, +-- that is the nested process cannot be interrupted using only the parent +-- process identifier. +processUsingId :: MonadComp m => ProcessId m -> Process m a -> Process m a +processUsingId pid x = + Process $ \pid' -> + do liftEvent $ processIdPrepare pid + rerunCont (invokeProcess pid x) (processCancelSource pid) + +-- | Spawn the child process. In case of cancelling one of the processes, +-- other process will be cancelled too. +spawnProcess :: MonadComp m => Process m () -> Process m () +spawnProcess = spawnProcessWith CancelTogether + +-- | Spawn the child process specifying the process identifier. +-- In case of cancelling one of the processes, other process will be cancelled too. +spawnProcessUsingId :: MonadComp m => ProcessId m -> Process m () -> Process m () +spawnProcessUsingId = spawnProcessUsingIdWith CancelTogether + +-- | Spawn the child process specifying how the child and parent processes +-- should be cancelled in case of need. +spawnProcessWith :: MonadComp m => ContCancellation -> Process m () -> Process m () +spawnProcessWith cancellation x = + do pid <- liftSimulation newProcessId + spawnProcessUsingIdWith cancellation pid x + +-- | Spawn the child process specifying how the child and parent processes +-- should be cancelled in case of need. +spawnProcessUsingIdWith :: MonadComp m => ContCancellation -> ProcessId m -> Process m () -> Process m () +spawnProcessUsingIdWith cancellation pid x = + Process $ \pid' -> + do liftEvent $ processIdPrepare pid + spawnCont cancellation (invokeProcess pid x) (processCancelSource pid) + +-- | Await the signal. +processAwait :: MonadComp m => Signal m a -> Process m a +processAwait signal = + Process $ \pid -> contAwait signal + +-- | The result of memoization. +data MemoResult a = MemoComputed a + | MemoError IOException + | MemoCancelled + +-- | Memoize the process so that it would always return the same value +-- within the simulation run. +memoProcess :: MonadComp m => Process m a -> Simulation m (Process m a) +memoProcess x = + Simulation $ \r -> + do let s = runSession r + started <- newProtoRef s False + computed <- invokeSimulation r newSignalSource + value <- newProtoRef s Nothing + let result = + do Just x <- liftComp $ readProtoRef value + case x of + MemoComputed a -> return a + MemoError e -> throwProcess e + MemoCancelled -> cancelProcess + return $ + do v <- liftComp $ readProtoRef value + case v of + Just _ -> result + Nothing -> + do f <- liftComp $ readProtoRef started + case f of + True -> + do processAwait $ publishSignal computed + result + False -> + do liftComp $ writeProtoRef started True + r <- liftComp $ newProtoRef s MemoCancelled + finallyProcess + (catchProcess + (do a <- x -- compute only once! + liftComp $ writeProtoRef r (MemoComputed a)) + (\e -> + liftComp $ writeProtoRef r (MemoError e))) + (liftEvent $ + do liftComp $ + do x <- readProtoRef r + writeProtoRef value (Just x) + triggerSignal computed ()) + result + +-- | Zip two parallel processes waiting for the both. +zipProcessParallel :: MonadComp m => Process m a -> Process m b -> Process m (a, b) +zipProcessParallel x y = + do [Left a, Right b] <- processParallel [fmap Left x, fmap Right y] + return (a, b) + +-- | Zip three parallel processes waiting for their results. +zip3ProcessParallel :: MonadComp m => Process m a -> Process m b -> Process m c -> Process m (a, b, c) +zip3ProcessParallel x y z = + do [Left a, + Right (Left b), + Right (Right c)] <- + processParallel [fmap Left x, + fmap (Right . Left) y, + fmap (Right . Right) z] + return (a, b, c) + +-- | Unzip the process using memoization so that the both returned +-- processes could be applied independently, although they will refer +-- to the same pair of values. +unzipProcess :: (MonadComp m, MonadIO m) => Process m (a, b) -> Simulation m (Process m a, Process m b) +unzipProcess xy = + do xy' <- memoProcess xy + return (fmap fst xy', fmap snd xy') + +-- | Try to run the child process within the specified timeout. +-- If the process will finish successfully within this time interval then +-- the result wrapped in 'Just' will be returned; otherwise, the child process +-- will be cancelled and 'Nothing' will be returned. +-- +-- If an exception is raised in the child process then it is propagated to +-- the parent computation as well. +-- +-- A cancellation of the child process doesn't lead to cancelling the parent process. +-- Then 'Nothing' is returned within the computation. +timeoutProcess :: (MonadComp m, MonadIO m) => Double -> Process m a -> Process m (Maybe a) +timeoutProcess timeout p = + do pid <- liftSimulation newProcessId + timeoutProcessUsingId timeout pid p + +-- | Try to run the child process with the given identifier within the specified timeout. +-- If the process will finish successfully within this time interval then +-- the result wrapped in 'Just' will be returned; otherwise, the child process +-- will be cancelled and 'Nothing' will be returned. +-- +-- If an exception is raised in the child process then it is propagated to +-- the parent computation as well. +-- +-- A cancellation of the child process doesn't lead to cancelling the parent process. +-- Then 'Nothing' is returned within the computation. +timeoutProcessUsingId :: (MonadComp m, MonadIO m) => Double -> ProcessId m -> Process m a -> Process m (Maybe a) +timeoutProcessUsingId timeout pid p = + do s <- liftSimulation newSignalSource + timeoutPid <- liftSimulation newProcessId + spawnProcessUsingIdWith CancelChildAfterParent timeoutPid $ + finallyProcess + (holdProcess timeout) + (liftEvent $ + cancelProcessWithId pid) + spawnProcessUsingIdWith CancelChildAfterParent pid $ + do sn <- liftParameter simulationSession + r <- liftComp $ newProtoRef sn Nothing + finallyProcess + (catchProcess + (do a <- p + liftComp $ writeProtoRef r $ Just (Right a)) + (\e -> + liftComp $ writeProtoRef r $ Just (Left e))) + (liftEvent $ + do x <- liftComp $ readProtoRef r + triggerSignal s x) + x <- processAwait $ publishSignal s + case x of + Nothing -> return Nothing + Just (Right a) -> return (Just a) + Just (Left (SomeException e)) -> throwProcess e + +-- | Yield to allow other 'Process' and 'Event' computations to run +-- at the current simulation time point. +processYield :: MonadComp m => Process m () +processYield = + Process $ \pid -> + Cont $ \c -> + Event $ \p -> + invokeEvent p $ + enqueueEvent (pointTime p) $ + resumeCont c () + +-- | A computation that never computes the result. It behaves like a black hole for +-- the discontinuous process, although such a process can still be canceled outside +-- (see 'cancelProcessWithId'), but then only its finalization parts (see 'finallyProcess') +-- will be called, usually, to release the resources acquired before. +neverProcess :: MonadComp m => Process m a +neverProcess = + Process $ \pid -> + Cont $ \c -> + let signal = processCancelling pid + in handleSignal_ signal $ \_ -> + resumeCont c $ error "It must never be computed: neverProcess" diff --git a/Simulation/Aivika/Trans/Internal/Signal.hs b/Simulation/Aivika/Trans/Internal/Signal.hs --- a/Simulation/Aivika/Trans/Internal/Signal.hs +++ b/Simulation/Aivika/Trans/Internal/Signal.hs @@ -1,396 +1,396 @@ - --- | --- Module : Simulation.Aivika.Trans.Internal.Signal --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines the signal which we can subscribe handlers to. --- These handlers can be disposed. The signal is triggered in the --- current time point actuating the corresponded computations from --- the handlers. --- - -module Simulation.Aivika.Trans.Internal.Signal - (-- * Handling and Triggering Signal - Signal(..), - handleSignal_, - SignalSource, - newSignalSource, - publishSignal, - triggerSignal, - -- * Useful Combinators - mapSignal, - mapSignalM, - apSignal, - filterSignal, - filterSignalM, - emptySignal, - merge2Signals, - merge3Signals, - merge4Signals, - merge5Signals, - -- * Signal Arriving - arrivalSignal, - -- * Creating Signal in Time Points - newSignalInTimes, - newSignalInIntegTimes, - newSignalInStartTime, - newSignalInStopTime, - -- * Signal History - SignalHistory, - signalHistorySignal, - newSignalHistory, - newSignalHistoryStartingWith, - readSignalHistory, - -- * Signalable Computations - Signalable(..), - signalableChanged, - emptySignalable, - appendSignalable) where - -import Data.Monoid -import Data.List -import Data.Array - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import qualified Simulation.Aivika.Trans.Vector as V -import qualified Simulation.Aivika.Trans.Vector.Unboxed as UV -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Parameter -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Event -import Simulation.Aivika.Arrival (Arrival(..)) - --- | The signal source that can publish its signal. -data SignalSource m a = - SignalSource { publishSignal :: Signal m a, - -- ^ Publish the signal. - triggerSignal :: a -> Event m () - -- ^ Trigger the signal actuating - -- all its handlers at the current - -- simulation time point. - } - --- | The signal that can have disposable handlers. -data Signal m a = - Signal { handleSignal :: (a -> Event m ()) -> Event m (DisposableEvent m) - -- ^ Subscribe the handler to the specified - -- signal and return a nested computation - -- within a disposable object that, being applied, - -- unsubscribes the handler from this signal. - } - --- | The queue of signal handlers. -data SignalHandlerQueue m a = - SignalHandlerQueue { queueList :: ProtoRef m [SignalHandler m a] } - --- | It contains the information about the disposable queue handler. -data SignalHandler m a = - SignalHandler { handlerComp :: a -> Event m (), - handlerMarker :: SessionMarker m } - -instance SessionMonad m => Eq (SignalHandler m a) where - - {-# INLINE (==) #-} - x == y = (handlerMarker x) == (handlerMarker y) - --- | Subscribe the handler to the specified signal forever. --- To subscribe the disposable handlers, use function 'handleSignal'. -handleSignal_ :: MonadComp m => Signal m a -> (a -> Event m ()) -> Event m () -{-# INLINE handleSignal_ #-} -handleSignal_ signal h = - do x <- handleSignal signal h - return () - --- | Create a new signal source. -newSignalSource :: MonadComp m => Simulation m (SignalSource m a) -newSignalSource = - Simulation $ \r -> - do let s = runSession r - list <- newProtoRef s [] - let queue = SignalHandlerQueue { queueList = list } - signal = Signal { handleSignal = handle } - source = SignalSource { publishSignal = signal, - triggerSignal = trigger } - handle h = - Event $ \p -> - do m <- newSessionMarker s - x <- enqueueSignalHandler queue h m - return $ - DisposableEvent $ - Event $ \p -> dequeueSignalHandler queue x - trigger a = - Event $ \p -> triggerSignalHandlers queue a p - return source - --- | Trigger all next signal handlers. -triggerSignalHandlers :: MonadComp m => SignalHandlerQueue m a -> a -> Point m -> m () -triggerSignalHandlers q a p = - do hs <- readProtoRef (queueList q) - forM_ hs $ \h -> - invokeEvent p $ handlerComp h a - --- | Enqueue the handler and return its representative in the queue. -enqueueSignalHandler :: MonadComp m => SignalHandlerQueue m a -> (a -> Event m ()) -> SessionMarker m -> m (SignalHandler m a) -enqueueSignalHandler q h m = - do let handler = SignalHandler { handlerComp = h, - handlerMarker = m } - modifyProtoRef (queueList q) (handler :) - return handler - --- | Dequeue the handler representative. -dequeueSignalHandler :: MonadComp m => SignalHandlerQueue m a -> SignalHandler m a -> m () -dequeueSignalHandler q h = - modifyProtoRef (queueList q) (delete h) - -instance MonadComp m => Functor (Signal m) where - - {-# INLINE fmap #-} - fmap = mapSignal - -instance MonadComp m => Monoid (Signal m a) where - - {-# INLINE mempty #-} - mempty = emptySignal - - {-# INLINE mappend #-} - mappend = merge2Signals - - {-# INLINE mconcat #-} - mconcat [] = emptySignal - mconcat [x1] = x1 - mconcat [x1, x2] = merge2Signals x1 x2 - mconcat [x1, x2, x3] = merge3Signals x1 x2 x3 - mconcat [x1, x2, x3, x4] = merge4Signals x1 x2 x3 x4 - mconcat [x1, x2, x3, x4, x5] = merge5Signals x1 x2 x3 x4 x5 - mconcat (x1 : x2 : x3 : x4 : x5 : xs) = - mconcat $ merge5Signals x1 x2 x3 x4 x5 : xs - --- | Map the signal according the specified function. -mapSignal :: MonadComp m => (a -> b) -> Signal m a -> Signal m b -mapSignal f m = - Signal { handleSignal = \h -> - handleSignal m $ h . f } - --- | Filter only those signal values that satisfy to --- the specified predicate. -filterSignal :: MonadComp m => (a -> Bool) -> Signal m a -> Signal m a -filterSignal p m = - Signal { handleSignal = \h -> - handleSignal m $ \a -> - when (p a) $ h a } - --- | Filter only those signal values that satisfy to --- the specified predicate. -filterSignalM :: MonadComp m => (a -> Event m Bool) -> Signal m a -> Signal m a -filterSignalM p m = - Signal { handleSignal = \h -> - handleSignal m $ \a -> - do x <- p a - when x $ h a } - --- | Merge two signals. -merge2Signals :: MonadComp m => Signal m a -> Signal m a -> Signal m a -merge2Signals m1 m2 = - Signal { handleSignal = \h -> - do x1 <- handleSignal m1 h - x2 <- handleSignal m2 h - return $ x1 <> x2 } - --- | Merge three signals. -merge3Signals :: MonadComp m => Signal m a -> Signal m a -> Signal m a -> Signal m a -merge3Signals m1 m2 m3 = - Signal { handleSignal = \h -> - do x1 <- handleSignal m1 h - x2 <- handleSignal m2 h - x3 <- handleSignal m3 h - return $ x1 <> x2 <> x3 } - --- | Merge four signals. -merge4Signals :: MonadComp m - => Signal m a -> Signal m a -> Signal m a - -> Signal m a -> Signal m a -merge4Signals m1 m2 m3 m4 = - Signal { handleSignal = \h -> - do x1 <- handleSignal m1 h - x2 <- handleSignal m2 h - x3 <- handleSignal m3 h - x4 <- handleSignal m4 h - return $ x1 <> x2 <> x3 <> x4 } - --- | Merge five signals. -merge5Signals :: MonadComp m - => Signal m a -> Signal m a -> Signal m a - -> Signal m a -> Signal m a -> Signal m a -merge5Signals m1 m2 m3 m4 m5 = - Signal { handleSignal = \h -> - do x1 <- handleSignal m1 h - x2 <- handleSignal m2 h - x3 <- handleSignal m3 h - x4 <- handleSignal m4 h - x5 <- handleSignal m5 h - return $ x1 <> x2 <> x3 <> x4 <> x5 } - --- | Compose the signal. -mapSignalM :: MonadComp m => (a -> Event m b) -> Signal m a -> Signal m b -mapSignalM f m = - Signal { handleSignal = \h -> - handleSignal m (f >=> h) } - --- | Transform the signal. -apSignal :: MonadComp m => Event m (a -> b) -> Signal m a -> Signal m b -apSignal f m = - Signal { handleSignal = \h -> - handleSignal m $ \a -> do { x <- f; h (x a) } } - --- | An empty signal which is never triggered. -emptySignal :: MonadComp m => Signal m a -emptySignal = - Signal { handleSignal = \h -> return mempty } - --- | Represents the history of the signal values. -data SignalHistory m a = - SignalHistory { signalHistorySignal :: Signal m a, - -- ^ The signal for which the history is created. - signalHistoryTimes :: UV.Vector m Double, - signalHistoryValues :: V.Vector m a } - --- | Create a history of the signal values. -newSignalHistory :: MonadComp m => Signal m a -> Event m (SignalHistory m a) -newSignalHistory = - newSignalHistoryStartingWith Nothing - --- | Create a history of the signal values starting with --- the optional initial value. -newSignalHistoryStartingWith :: MonadComp m => Maybe a -> Signal m a -> Event m (SignalHistory m a) -newSignalHistoryStartingWith init signal = - Event $ \p -> - do let s = runSession $ pointRun p - ts <- UV.newVector s - xs <- V.newVector s - case init of - Nothing -> return () - Just a -> - do UV.appendVector ts (pointTime p) - V.appendVector xs a - invokeEvent p $ - handleSignal_ signal $ \a -> - Event $ \p -> - do UV.appendVector ts (pointTime p) - V.appendVector xs a - return SignalHistory { signalHistorySignal = signal, - signalHistoryTimes = ts, - signalHistoryValues = xs } - --- | Read the history of signal values. -readSignalHistory :: MonadComp m => SignalHistory m a -> Event m (Array Int Double, Array Int a) -readSignalHistory history = - Event $ \p -> - do xs <- UV.freezeVector (signalHistoryTimes history) - ys <- V.freezeVector (signalHistoryValues history) - return (xs, ys) - --- | Trigger the signal with the current time. -triggerSignalWithCurrentTime :: MonadComp m => SignalSource m Double -> Event m () -triggerSignalWithCurrentTime s = - Event $ \p -> invokeEvent p $ triggerSignal s (pointTime p) - --- | Return a signal that is triggered in the specified time points. -newSignalInTimes :: MonadComp m => [Double] -> Event m (Signal m Double) -newSignalInTimes xs = - do s <- liftSimulation newSignalSource - enqueueEventWithTimes xs $ triggerSignalWithCurrentTime s - return $ publishSignal s - --- | Return a signal that is triggered in the integration time points. --- It should be called with help of 'runEventInStartTime'. -newSignalInIntegTimes :: MonadComp m => Event m (Signal m Double) -newSignalInIntegTimes = - do s <- liftSimulation newSignalSource - enqueueEventWithIntegTimes $ triggerSignalWithCurrentTime s - return $ publishSignal s - --- | Return a signal that is triggered in the start time. --- It should be called with help of 'runEventInStartTime'. -newSignalInStartTime :: MonadComp m => Event m (Signal m Double) -newSignalInStartTime = - do s <- liftSimulation newSignalSource - t <- liftParameter starttime - enqueueEvent t $ triggerSignalWithCurrentTime s - return $ publishSignal s - --- | Return a signal that is triggered in the final time. -newSignalInStopTime :: MonadComp m => Event m (Signal m Double) -newSignalInStopTime = - do s <- liftSimulation newSignalSource - t <- liftParameter stoptime - enqueueEvent t $ triggerSignalWithCurrentTime s - return $ publishSignal s - --- | Describes a computation that also signals when changing its value. -data Signalable m a = - Signalable { readSignalable :: Event m a, - -- ^ Return a computation of the value. - signalableChanged_ :: Signal m () - -- ^ Return a signal notifying that the value has changed - -- but without providing the information about the changed value. - } - --- | Return a signal notifying that the value has changed. -signalableChanged :: MonadComp m => Signalable m a -> Signal m a -signalableChanged x = mapSignalM (const $ readSignalable x) $ signalableChanged_ x - -instance Functor m => Functor (Signalable m) where - - {-# INLINE fmap #-} - fmap f x = x { readSignalable = fmap f (readSignalable x) } - -instance (MonadComp m, Monoid a) => Monoid (Signalable m a) where - - {-# INLINE mempty #-} - mempty = emptySignalable - - {-# INLINE mappend #-} - mappend = appendSignalable - --- | Return an identity. -emptySignalable :: (MonadComp m, Monoid a) => Signalable m a -emptySignalable = - Signalable { readSignalable = return mempty, - signalableChanged_ = mempty } - --- | An associative operation. -appendSignalable :: (MonadComp m, Monoid a) => Signalable m a -> Signalable m a -> Signalable m a -appendSignalable m1 m2 = - Signalable { readSignalable = liftM2 (<>) (readSignalable m1) (readSignalable m2), - signalableChanged_ = (signalableChanged_ m1) <> (signalableChanged_ m2) } - --- | Transform a signal so that the resulting signal returns a sequence of arrivals --- saving the information about the time points at which the original signal was received. -arrivalSignal :: MonadComp m => Signal m a -> Signal m (Arrival a) -arrivalSignal m = - Signal { handleSignal = \h -> - Event $ \p -> - do let s = runSession $ pointRun p - r <- newProtoRef s Nothing - invokeEvent p $ - handleSignal m $ \a -> - Event $ \p -> - do t0 <- readProtoRef r - let t = pointTime p - writeProtoRef r (Just t) - invokeEvent p $ - h Arrival { arrivalValue = a, - arrivalTime = t, - arrivalDelay = - case t0 of - Nothing -> Nothing - Just t0 -> Just (t - t0) } } + +-- | +-- Module : Simulation.Aivika.Trans.Internal.Signal +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the signal which we can subscribe handlers to. +-- These handlers can be disposed. The signal is triggered in the +-- current time point actuating the corresponded computations from +-- the handlers. +-- + +module Simulation.Aivika.Trans.Internal.Signal + (-- * Handling and Triggering Signal + Signal(..), + handleSignal_, + SignalSource, + newSignalSource, + publishSignal, + triggerSignal, + -- * Useful Combinators + mapSignal, + mapSignalM, + apSignal, + filterSignal, + filterSignalM, + emptySignal, + merge2Signals, + merge3Signals, + merge4Signals, + merge5Signals, + -- * Signal Arriving + arrivalSignal, + -- * Creating Signal in Time Points + newSignalInTimes, + newSignalInIntegTimes, + newSignalInStartTime, + newSignalInStopTime, + -- * Signal History + SignalHistory, + signalHistorySignal, + newSignalHistory, + newSignalHistoryStartingWith, + readSignalHistory, + -- * Signalable Computations + Signalable(..), + signalableChanged, + emptySignalable, + appendSignalable) where + +import Data.Monoid +import Data.List +import Data.Array + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import qualified Simulation.Aivika.Trans.Vector as V +import qualified Simulation.Aivika.Trans.Vector.Unboxed as UV +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Arrival (Arrival(..)) + +-- | The signal source that can publish its signal. +data SignalSource m a = + SignalSource { publishSignal :: Signal m a, + -- ^ Publish the signal. + triggerSignal :: a -> Event m () + -- ^ Trigger the signal actuating + -- all its handlers at the current + -- simulation time point. + } + +-- | The signal that can have disposable handlers. +data Signal m a = + Signal { handleSignal :: (a -> Event m ()) -> Event m (DisposableEvent m) + -- ^ Subscribe the handler to the specified + -- signal and return a nested computation + -- within a disposable object that, being applied, + -- unsubscribes the handler from this signal. + } + +-- | The queue of signal handlers. +data SignalHandlerQueue m a = + SignalHandlerQueue { queueList :: ProtoRef m [SignalHandler m a] } + +-- | It contains the information about the disposable queue handler. +data SignalHandler m a = + SignalHandler { handlerComp :: a -> Event m (), + handlerMarker :: SessionMarker m } + +instance SessionMonad m => Eq (SignalHandler m a) where + + {-# INLINE (==) #-} + x == y = (handlerMarker x) == (handlerMarker y) + +-- | Subscribe the handler to the specified signal forever. +-- To subscribe the disposable handlers, use function 'handleSignal'. +handleSignal_ :: MonadComp m => Signal m a -> (a -> Event m ()) -> Event m () +{-# INLINE handleSignal_ #-} +handleSignal_ signal h = + do x <- handleSignal signal h + return () + +-- | Create a new signal source. +newSignalSource :: MonadComp m => Simulation m (SignalSource m a) +newSignalSource = + Simulation $ \r -> + do let s = runSession r + list <- newProtoRef s [] + let queue = SignalHandlerQueue { queueList = list } + signal = Signal { handleSignal = handle } + source = SignalSource { publishSignal = signal, + triggerSignal = trigger } + handle h = + Event $ \p -> + do m <- newSessionMarker s + x <- enqueueSignalHandler queue h m + return $ + DisposableEvent $ + Event $ \p -> dequeueSignalHandler queue x + trigger a = + Event $ \p -> triggerSignalHandlers queue a p + return source + +-- | Trigger all next signal handlers. +triggerSignalHandlers :: MonadComp m => SignalHandlerQueue m a -> a -> Point m -> m () +triggerSignalHandlers q a p = + do hs <- readProtoRef (queueList q) + forM_ hs $ \h -> + invokeEvent p $ handlerComp h a + +-- | Enqueue the handler and return its representative in the queue. +enqueueSignalHandler :: MonadComp m => SignalHandlerQueue m a -> (a -> Event m ()) -> SessionMarker m -> m (SignalHandler m a) +enqueueSignalHandler q h m = + do let handler = SignalHandler { handlerComp = h, + handlerMarker = m } + modifyProtoRef (queueList q) (handler :) + return handler + +-- | Dequeue the handler representative. +dequeueSignalHandler :: MonadComp m => SignalHandlerQueue m a -> SignalHandler m a -> m () +dequeueSignalHandler q h = + modifyProtoRef (queueList q) (delete h) + +instance MonadComp m => Functor (Signal m) where + + {-# INLINE fmap #-} + fmap = mapSignal + +instance MonadComp m => Monoid (Signal m a) where + + {-# INLINE mempty #-} + mempty = emptySignal + + {-# INLINE mappend #-} + mappend = merge2Signals + + {-# INLINE mconcat #-} + mconcat [] = emptySignal + mconcat [x1] = x1 + mconcat [x1, x2] = merge2Signals x1 x2 + mconcat [x1, x2, x3] = merge3Signals x1 x2 x3 + mconcat [x1, x2, x3, x4] = merge4Signals x1 x2 x3 x4 + mconcat [x1, x2, x3, x4, x5] = merge5Signals x1 x2 x3 x4 x5 + mconcat (x1 : x2 : x3 : x4 : x5 : xs) = + mconcat $ merge5Signals x1 x2 x3 x4 x5 : xs + +-- | Map the signal according the specified function. +mapSignal :: MonadComp m => (a -> b) -> Signal m a -> Signal m b +mapSignal f m = + Signal { handleSignal = \h -> + handleSignal m $ h . f } + +-- | Filter only those signal values that satisfy to +-- the specified predicate. +filterSignal :: MonadComp m => (a -> Bool) -> Signal m a -> Signal m a +filterSignal p m = + Signal { handleSignal = \h -> + handleSignal m $ \a -> + when (p a) $ h a } + +-- | Filter only those signal values that satisfy to +-- the specified predicate. +filterSignalM :: MonadComp m => (a -> Event m Bool) -> Signal m a -> Signal m a +filterSignalM p m = + Signal { handleSignal = \h -> + handleSignal m $ \a -> + do x <- p a + when x $ h a } + +-- | Merge two signals. +merge2Signals :: MonadComp m => Signal m a -> Signal m a -> Signal m a +merge2Signals m1 m2 = + Signal { handleSignal = \h -> + do x1 <- handleSignal m1 h + x2 <- handleSignal m2 h + return $ x1 <> x2 } + +-- | Merge three signals. +merge3Signals :: MonadComp m => Signal m a -> Signal m a -> Signal m a -> Signal m a +merge3Signals m1 m2 m3 = + Signal { handleSignal = \h -> + do x1 <- handleSignal m1 h + x2 <- handleSignal m2 h + x3 <- handleSignal m3 h + return $ x1 <> x2 <> x3 } + +-- | Merge four signals. +merge4Signals :: MonadComp m + => Signal m a -> Signal m a -> Signal m a + -> Signal m a -> Signal m a +merge4Signals m1 m2 m3 m4 = + Signal { handleSignal = \h -> + do x1 <- handleSignal m1 h + x2 <- handleSignal m2 h + x3 <- handleSignal m3 h + x4 <- handleSignal m4 h + return $ x1 <> x2 <> x3 <> x4 } + +-- | Merge five signals. +merge5Signals :: MonadComp m + => Signal m a -> Signal m a -> Signal m a + -> Signal m a -> Signal m a -> Signal m a +merge5Signals m1 m2 m3 m4 m5 = + Signal { handleSignal = \h -> + do x1 <- handleSignal m1 h + x2 <- handleSignal m2 h + x3 <- handleSignal m3 h + x4 <- handleSignal m4 h + x5 <- handleSignal m5 h + return $ x1 <> x2 <> x3 <> x4 <> x5 } + +-- | Compose the signal. +mapSignalM :: MonadComp m => (a -> Event m b) -> Signal m a -> Signal m b +mapSignalM f m = + Signal { handleSignal = \h -> + handleSignal m (f >=> h) } + +-- | Transform the signal. +apSignal :: MonadComp m => Event m (a -> b) -> Signal m a -> Signal m b +apSignal f m = + Signal { handleSignal = \h -> + handleSignal m $ \a -> do { x <- f; h (x a) } } + +-- | An empty signal which is never triggered. +emptySignal :: MonadComp m => Signal m a +emptySignal = + Signal { handleSignal = \h -> return mempty } + +-- | Represents the history of the signal values. +data SignalHistory m a = + SignalHistory { signalHistorySignal :: Signal m a, + -- ^ The signal for which the history is created. + signalHistoryTimes :: UV.Vector m Double, + signalHistoryValues :: V.Vector m a } + +-- | Create a history of the signal values. +newSignalHistory :: MonadComp m => Signal m a -> Event m (SignalHistory m a) +newSignalHistory = + newSignalHistoryStartingWith Nothing + +-- | Create a history of the signal values starting with +-- the optional initial value. +newSignalHistoryStartingWith :: MonadComp m => Maybe a -> Signal m a -> Event m (SignalHistory m a) +newSignalHistoryStartingWith init signal = + Event $ \p -> + do let s = runSession $ pointRun p + ts <- UV.newVector s + xs <- V.newVector s + case init of + Nothing -> return () + Just a -> + do UV.appendVector ts (pointTime p) + V.appendVector xs a + invokeEvent p $ + handleSignal_ signal $ \a -> + Event $ \p -> + do UV.appendVector ts (pointTime p) + V.appendVector xs a + return SignalHistory { signalHistorySignal = signal, + signalHistoryTimes = ts, + signalHistoryValues = xs } + +-- | Read the history of signal values. +readSignalHistory :: MonadComp m => SignalHistory m a -> Event m (Array Int Double, Array Int a) +readSignalHistory history = + Event $ \p -> + do xs <- UV.freezeVector (signalHistoryTimes history) + ys <- V.freezeVector (signalHistoryValues history) + return (xs, ys) + +-- | Trigger the signal with the current time. +triggerSignalWithCurrentTime :: MonadComp m => SignalSource m Double -> Event m () +triggerSignalWithCurrentTime s = + Event $ \p -> invokeEvent p $ triggerSignal s (pointTime p) + +-- | Return a signal that is triggered in the specified time points. +newSignalInTimes :: MonadComp m => [Double] -> Event m (Signal m Double) +newSignalInTimes xs = + do s <- liftSimulation newSignalSource + enqueueEventWithTimes xs $ triggerSignalWithCurrentTime s + return $ publishSignal s + +-- | Return a signal that is triggered in the integration time points. +-- It should be called with help of 'runEventInStartTime'. +newSignalInIntegTimes :: MonadComp m => Event m (Signal m Double) +newSignalInIntegTimes = + do s <- liftSimulation newSignalSource + enqueueEventWithIntegTimes $ triggerSignalWithCurrentTime s + return $ publishSignal s + +-- | Return a signal that is triggered in the start time. +-- It should be called with help of 'runEventInStartTime'. +newSignalInStartTime :: MonadComp m => Event m (Signal m Double) +newSignalInStartTime = + do s <- liftSimulation newSignalSource + t <- liftParameter starttime + enqueueEvent t $ triggerSignalWithCurrentTime s + return $ publishSignal s + +-- | Return a signal that is triggered in the final time. +newSignalInStopTime :: MonadComp m => Event m (Signal m Double) +newSignalInStopTime = + do s <- liftSimulation newSignalSource + t <- liftParameter stoptime + enqueueEvent t $ triggerSignalWithCurrentTime s + return $ publishSignal s + +-- | Describes a computation that also signals when changing its value. +data Signalable m a = + Signalable { readSignalable :: Event m a, + -- ^ Return a computation of the value. + signalableChanged_ :: Signal m () + -- ^ Return a signal notifying that the value has changed + -- but without providing the information about the changed value. + } + +-- | Return a signal notifying that the value has changed. +signalableChanged :: MonadComp m => Signalable m a -> Signal m a +signalableChanged x = mapSignalM (const $ readSignalable x) $ signalableChanged_ x + +instance Functor m => Functor (Signalable m) where + + {-# INLINE fmap #-} + fmap f x = x { readSignalable = fmap f (readSignalable x) } + +instance (MonadComp m, Monoid a) => Monoid (Signalable m a) where + + {-# INLINE mempty #-} + mempty = emptySignalable + + {-# INLINE mappend #-} + mappend = appendSignalable + +-- | Return an identity. +emptySignalable :: (MonadComp m, Monoid a) => Signalable m a +emptySignalable = + Signalable { readSignalable = return mempty, + signalableChanged_ = mempty } + +-- | An associative operation. +appendSignalable :: (MonadComp m, Monoid a) => Signalable m a -> Signalable m a -> Signalable m a +appendSignalable m1 m2 = + Signalable { readSignalable = liftM2 (<>) (readSignalable m1) (readSignalable m2), + signalableChanged_ = (signalableChanged_ m1) <> (signalableChanged_ m2) } + +-- | Transform a signal so that the resulting signal returns a sequence of arrivals +-- saving the information about the time points at which the original signal was received. +arrivalSignal :: MonadComp m => Signal m a -> Signal m (Arrival a) +arrivalSignal m = + Signal { handleSignal = \h -> + Event $ \p -> + do let s = runSession $ pointRun p + r <- newProtoRef s Nothing + invokeEvent p $ + handleSignal m $ \a -> + Event $ \p -> + do t0 <- readProtoRef r + let t = pointTime p + writeProtoRef r (Just t) + invokeEvent p $ + h Arrival { arrivalValue = a, + arrivalTime = t, + arrivalDelay = + case t0 of + Nothing -> Nothing + Just t0 -> Just (t - t0) } } diff --git a/Simulation/Aivika/Trans/Internal/Simulation.hs b/Simulation/Aivika/Trans/Internal/Simulation.hs --- a/Simulation/Aivika/Trans/Internal/Simulation.hs +++ b/Simulation/Aivika/Trans/Internal/Simulation.hs @@ -1,167 +1,167 @@ - -{-# LANGUAGE RecursiveDo, TypeSynonymInstances #-} - --- | --- Module : Simulation.Aivika.Trans.Internal.Simulation --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines the 'Simulation' monad transformer that represents a computation --- within the simulation run. --- -module Simulation.Aivika.Trans.Internal.Simulation - (-- * Simulation - SimulationLift(..), - runSimulation, - runSimulations, - -- * Error Handling - catchSimulation, - finallySimulation, - throwSimulation, - -- * Memoization - memoSimulation) where - -import Control.Exception -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Fix -import Control.Applicative - -import Simulation.Aivika.Trans.Exception -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Generator -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Parameter - -instance Monad m => Monad (Simulation m) where - - {-# INLINE return #-} - return a = Simulation $ \r -> return a - - {-# INLINE (>>=) #-} - (Simulation m) >>= k = - Simulation $ \r -> - do a <- m r - let Simulation m' = k a - m' r - --- | Run the simulation using the specified specs. -runSimulation :: MonadComp m => Simulation m a -> Specs m -> m a -runSimulation (Simulation m) sc = - do s <- newSession - q <- newEventQueue s sc - g <- newGenerator s $ spcGeneratorType sc - m Run { runSpecs = sc, - runSession = s, - runIndex = 1, - runCount = 1, - runEventQueue = q, - runGenerator = g } - --- | Run the given number of simulations using the specified specs, --- where each simulation is distinguished by its index 'simulationIndex'. -runSimulations :: MonadComp m => Simulation m a -> Specs m -> Int -> [m a] -runSimulations (Simulation m) sc runs = map f [1 .. runs] - where f i = do s <- newSession - q <- newEventQueue s sc - g <- newGenerator s $ spcGeneratorType sc - m Run { runSpecs = sc, - runSession = s, - runIndex = i, - runCount = runs, - runEventQueue = q, - runGenerator = g } - -instance Functor m => Functor (Simulation m) where - - {-# INLINE fmap #-} - fmap f (Simulation x) = Simulation $ \r -> fmap f $ x r - -instance Applicative m => Applicative (Simulation m) where - - {-# INLINE pure #-} - pure = Simulation . const . pure - - {-# INLINE (<*>) #-} - (Simulation x) <*> (Simulation y) = Simulation $ \r -> x r <*> y r - -liftMS :: Monad m => (a -> b) -> Simulation m a -> Simulation m b -{-# INLINE liftMS #-} -liftMS f (Simulation x) = - Simulation $ \r -> do { a <- x r; return $ f a } - -instance MonadTrans Simulation where - - {-# INLINE lift #-} - lift = Simulation . const - -instance MonadCompTrans Simulation where - - {-# INLINE liftComp #-} - liftComp = Simulation . const - -instance MonadIO m => MonadIO (Simulation m) where - - {-# INLINE liftIO #-} - liftIO = Simulation . const . liftIO - --- | A type class to lift the simulation computations into other computations. -class SimulationLift t where - - -- | Lift the specified 'Simulation' computation into another computation. - liftSimulation :: MonadComp m => Simulation m a -> t m a - -instance SimulationLift Simulation where - - {-# INLINE liftSimulation #-} - liftSimulation = id - -instance ParameterLift Simulation where - - {-# INLINE liftParameter #-} - liftParameter (Parameter x) = Simulation x - --- | Exception handling within 'Simulation' computations. -catchSimulation :: (MonadComp m, Exception e) => Simulation m a -> (e -> Simulation m a) -> Simulation m a -catchSimulation (Simulation m) h = - Simulation $ \r -> - catchComp (m r) $ \e -> - let Simulation m' = h e in m' r - --- | A computation with finalization part like the 'finally' function. -finallySimulation :: MonadComp m => Simulation m a -> Simulation m b -> Simulation m a -finallySimulation (Simulation m) (Simulation m') = - Simulation $ \r -> - finallyComp (m r) (m' r) - --- | Like the standard 'throw' function. -throwSimulation :: (MonadComp m, Exception e) => e -> Simulation m a -throwSimulation = throw - -instance MonadFix m => MonadFix (Simulation m) where - - {-# INLINE mfix #-} - mfix f = - Simulation $ \r -> - do { rec { a <- invokeSimulation r (f a) }; return a } - --- | Memoize the 'Simulation' computation, always returning the same value --- within a simulation run. -memoSimulation :: MonadComp m => Simulation m a -> Simulation m (Simulation m a) -memoSimulation m = - Simulation $ \r -> - do let s = runSession r - ref <- newProtoRef s Nothing - return $ Simulation $ \r -> - do x <- readProtoRef ref - case x of - Just v -> return v - Nothing -> - do v <- invokeSimulation r m - writeProtoRef ref (Just v) - return v + +{-# LANGUAGE RecursiveDo, TypeSynonymInstances #-} + +-- | +-- Module : Simulation.Aivika.Trans.Internal.Simulation +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the 'Simulation' monad transformer that represents a computation +-- within the simulation run. +-- +module Simulation.Aivika.Trans.Internal.Simulation + (-- * Simulation + SimulationLift(..), + runSimulation, + runSimulations, + -- * Error Handling + catchSimulation, + finallySimulation, + throwSimulation, + -- * Memoization + memoSimulation) where + +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Fix +import Control.Applicative + +import Simulation.Aivika.Trans.Exception +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Generator +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter + +instance Monad m => Monad (Simulation m) where + + {-# INLINE return #-} + return a = Simulation $ \r -> return a + + {-# INLINE (>>=) #-} + (Simulation m) >>= k = + Simulation $ \r -> + do a <- m r + let Simulation m' = k a + m' r + +-- | Run the simulation using the specified specs. +runSimulation :: MonadComp m => Simulation m a -> Specs m -> m a +runSimulation (Simulation m) sc = + do s <- newSession + q <- newEventQueue s sc + g <- newGenerator s $ spcGeneratorType sc + m Run { runSpecs = sc, + runSession = s, + runIndex = 1, + runCount = 1, + runEventQueue = q, + runGenerator = g } + +-- | Run the given number of simulations using the specified specs, +-- where each simulation is distinguished by its index 'simulationIndex'. +runSimulations :: MonadComp m => Simulation m a -> Specs m -> Int -> [m a] +runSimulations (Simulation m) sc runs = map f [1 .. runs] + where f i = do s <- newSession + q <- newEventQueue s sc + g <- newGenerator s $ spcGeneratorType sc + m Run { runSpecs = sc, + runSession = s, + runIndex = i, + runCount = runs, + runEventQueue = q, + runGenerator = g } + +instance Functor m => Functor (Simulation m) where + + {-# INLINE fmap #-} + fmap f (Simulation x) = Simulation $ \r -> fmap f $ x r + +instance Applicative m => Applicative (Simulation m) where + + {-# INLINE pure #-} + pure = Simulation . const . pure + + {-# INLINE (<*>) #-} + (Simulation x) <*> (Simulation y) = Simulation $ \r -> x r <*> y r + +liftMS :: Monad m => (a -> b) -> Simulation m a -> Simulation m b +{-# INLINE liftMS #-} +liftMS f (Simulation x) = + Simulation $ \r -> do { a <- x r; return $ f a } + +instance MonadTrans Simulation where + + {-# INLINE lift #-} + lift = Simulation . const + +instance MonadCompTrans Simulation where + + {-# INLINE liftComp #-} + liftComp = Simulation . const + +instance MonadIO m => MonadIO (Simulation m) where + + {-# INLINE liftIO #-} + liftIO = Simulation . const . liftIO + +-- | A type class to lift the simulation computations into other computations. +class SimulationLift t where + + -- | Lift the specified 'Simulation' computation into another computation. + liftSimulation :: MonadComp m => Simulation m a -> t m a + +instance SimulationLift Simulation where + + {-# INLINE liftSimulation #-} + liftSimulation = id + +instance ParameterLift Simulation where + + {-# INLINE liftParameter #-} + liftParameter (Parameter x) = Simulation x + +-- | Exception handling within 'Simulation' computations. +catchSimulation :: (MonadComp m, Exception e) => Simulation m a -> (e -> Simulation m a) -> Simulation m a +catchSimulation (Simulation m) h = + Simulation $ \r -> + catchComp (m r) $ \e -> + let Simulation m' = h e in m' r + +-- | A computation with finalization part like the 'finally' function. +finallySimulation :: MonadComp m => Simulation m a -> Simulation m b -> Simulation m a +finallySimulation (Simulation m) (Simulation m') = + Simulation $ \r -> + finallyComp (m r) (m' r) + +-- | Like the standard 'throw' function. +throwSimulation :: (MonadComp m, Exception e) => e -> Simulation m a +throwSimulation = throw + +instance MonadFix m => MonadFix (Simulation m) where + + {-# INLINE mfix #-} + mfix f = + Simulation $ \r -> + do { rec { a <- invokeSimulation r (f a) }; return a } + +-- | Memoize the 'Simulation' computation, always returning the same value +-- within a simulation run. +memoSimulation :: MonadComp m => Simulation m a -> Simulation m (Simulation m a) +memoSimulation m = + Simulation $ \r -> + do let s = runSession r + ref <- newProtoRef s Nothing + return $ Simulation $ \r -> + do x <- readProtoRef ref + case x of + Just v -> return v + Nothing -> + do v <- invokeSimulation r m + writeProtoRef ref (Just v) + return v diff --git a/Simulation/Aivika/Trans/Internal/Specs.hs b/Simulation/Aivika/Trans/Internal/Specs.hs --- a/Simulation/Aivika/Trans/Internal/Specs.hs +++ b/Simulation/Aivika/Trans/Internal/Specs.hs @@ -1,307 +1,295 @@ - -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Simulation.Aivika.Trans.Internal.Specs --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It defines the simulation specs and related stuff. -module Simulation.Aivika.Trans.Internal.Specs - (Specs(..), - Method(..), - Run(..), - Point(..), - Parameter(..), - Simulation(..), - Dynamics(..), - Event(..), - EventProcessing(..), - EventQueueing(..), - invokeParameter, - invokeSimulation, - invokeDynamics, - invokeEvent, - basicTime, - integIterationBnds, - integIterationHiBnd, - integIterationLoBnd, - integPhaseBnds, - integPhaseHiBnd, - integPhaseLoBnd, - integTimes, - integPoints, - integStartPoint, - integStopPoint, - pointAt) where - -import Data.IORef - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.Generator - --- | It defines the simulation specs. -data Specs m = Specs { spcStartTime :: Double, -- ^ the start time - spcStopTime :: Double, -- ^ the stop time - spcDT :: Double, -- ^ the integration time step - spcMethod :: Method, -- ^ the integration method - spcGeneratorType :: GeneratorType m - -- ^ the type of the random number generator - } - --- | It defines the integration method. -data Method = Euler -- ^ Euler's method - | RungeKutta2 -- ^ the 2nd order Runge-Kutta method - | RungeKutta4 -- ^ the 4th order Runge-Kutta method - deriving (Eq, Ord, Show) - --- | It indentifies the simulation run. -data Run m = Run { runSpecs :: Specs m, -- ^ the simulation specs - runSession :: Session m, -- ^ the simulation session - runIndex :: Int, -- ^ the current simulation run index - runCount :: Int, -- ^ the total number of runs in this experiment - runEventQueue :: EventQueue m, -- ^ the event queue - runGenerator :: Generator m -- ^ the random number generator - } - --- | It defines the simulation point appended with the additional information. -data Point m = Point { pointSpecs :: Specs m, -- ^ the simulation specs - pointRun :: Run m, -- ^ the simulation run - pointTime :: Double, -- ^ the current time - pointIteration :: Int, -- ^ the current iteration - pointPhase :: Int -- ^ the current phase - } - --- | The 'Parameter' monad that allows specifying the model parameters. --- For example, they can be used when running the Monte-Carlo simulation. --- --- In general, this monad is very useful for representing a computation which is external --- relative to the model itself. -newtype Parameter m a = Parameter (Run m -> m a) - --- | A value in the 'Simulation' monad represents a computation --- within the simulation run. -newtype Simulation m a = Simulation (Run m -> m a) - --- | A value in the 'Dynamics' monad represents a polymorphic time varying function --- defined in the whole spectrum of time values as a single entity. It is ideal for --- numerical approximating integrals. -newtype Dynamics m a = Dynamics (Point m -> m a) - --- | A value in the 'Event' monad transformer represents a polymorphic time varying --- function which is strongly synchronized with the event queue. -newtype Event m a = Event (Point m -> m a) - --- | Invoke the 'Parameter' computation. -invokeParameter :: Run m -> Parameter m a -> m a -{-# INLINE invokeParameter #-} -invokeParameter r (Parameter m) = m r - --- | Invoke the 'Simulation' computation. -invokeSimulation :: Run m -> Simulation m a -> m a -{-# INLINE invokeSimulation #-} -invokeSimulation r (Simulation m) = m r - --- | Invoke the 'Dynamics' computation. -invokeDynamics :: Point m -> Dynamics m a -> m a -{-# INLINE invokeDynamics #-} -invokeDynamics p (Dynamics m) = m p - --- | Invoke the 'Event' computation. -invokeEvent :: Point m -> Event m a -> m a -{-# INLINE invokeEvent #-} -invokeEvent p (Event m) = m p - --- | Defines how the events are processed. -data EventProcessing = CurrentEvents - -- ^ either process all earlier and then current events, - -- or raise an error if the current simulation time is less - -- than the actual time of the event queue (safe within - -- the 'Event' computation as this is protected by the type system) - | EarlierEvents - -- ^ either process all earlier events not affecting - -- the events at the current simulation time, - -- or raise an error if the current simulation time is less - -- than the actual time of the event queue (safe within - -- the 'Event' computation as this is protected by the type system) - | CurrentEventsOrFromPast - -- ^ either process all earlier and then current events, - -- or do nothing if the current simulation time is less - -- than the actual time of the event queue - -- (do not use unless the documentation states the opposite) - | EarlierEventsOrFromPast - -- ^ either process all earlier events, - -- or do nothing if the current simulation time is less - -- than the actual time of the event queue - -- (do not use unless the documentation states the opposite) - deriving (Eq, Ord, Show) - --- | A type class of monads that allow enqueueing the events. -class EventQueueing m where - - -- | It represents the event queue. - data EventQueue m :: * - - -- | Create a new event queue by the specified specs with simulation session. - newEventQueue :: Session m -> Specs m -> m (EventQueue m) - - -- | Enqueue the event which must be actuated at the specified time. - -- - -- The events are processed when calling the 'runEvent' function. So, - -- if you want to insist on their immediate execution then you can apply - -- something like - -- - -- @ - -- liftDynamics $ runEvent IncludingCurrentEvents $ return () - -- @ - -- - -- although this is generally not good idea. - enqueueEvent :: Double -> Event m () -> Event m () - - -- | Run the 'EventT' computation in the current simulation time - -- within the 'DynamicsT' computation involving all pending - -- 'CurrentEvents' in the processing too. - runEvent :: Event m a -> Dynamics m a - {-# INLINE runEvent #-} - runEvent = runEventWith CurrentEvents - - -- | Run the 'EventT' computation in the current simulation time - -- within the 'DynamicsT' computation specifying what pending events - -- should be involved in the processing. - runEventWith :: EventProcessing -> Event m a -> Dynamics m a - - -- | Return the number of pending events that should - -- be yet actuated. - eventQueueCount :: Event m Int - --- | Returns the integration iterations starting from zero. -integIterations :: Specs m -> [Int] -integIterations sc = [i1 .. i2] where - i1 = integIterationLoBnd sc - i2 = integIterationHiBnd sc - --- | Returns the first and last integration iterations. -integIterationBnds :: Specs m -> (Int, Int) -integIterationBnds sc = (i1, i2) where - i1 = integIterationLoBnd sc - i2 = integIterationHiBnd sc - --- | Returns the first integration iteration, i.e. zero. -integIterationLoBnd :: Specs m -> Int -integIterationLoBnd sc = 0 - --- | Returns the last integration iteration. -integIterationHiBnd :: Specs m -> Int -integIterationHiBnd sc = - let n = round ((spcStopTime sc - - spcStartTime sc) / spcDT sc) - in if n < 0 - then - error $ - "Either the simulation specs are incorrect, " ++ - "or a step time is too small, because of which " ++ - "a floating point overflow occurred on 32-bit Haskell implementation." - else n - --- | Returns the phases for the specified simulation specs starting from zero. -integPhases :: Specs m -> [Int] -integPhases sc = - case spcMethod sc of - Euler -> [0] - RungeKutta2 -> [0, 1] - RungeKutta4 -> [0, 1, 2, 3] - --- | Returns the first and last integration phases. -integPhaseBnds :: Specs m -> (Int, Int) -integPhaseBnds sc = - case spcMethod sc of - Euler -> (0, 0) - RungeKutta2 -> (0, 1) - RungeKutta4 -> (0, 3) - --- | Returns the first integration phase, i.e. zero. -integPhaseLoBnd :: Specs m -> Int -integPhaseLoBnd sc = 0 - --- | Returns the last integration phase, 0 for Euler's method, 1 for RK2 and 3 for RK4. -integPhaseHiBnd :: Specs m -> Int -integPhaseHiBnd sc = - case spcMethod sc of - Euler -> 0 - RungeKutta2 -> 1 - RungeKutta4 -> 3 - --- | Returns a simulation time for the integration point specified by --- the specs, iteration and phase. -basicTime :: Specs m -> Int -> Int -> Double -{-# INLINE basicTime #-} -basicTime sc n ph = - if ph < 0 then - error "Incorrect phase: basicTime" - else - spcStartTime sc + n' * spcDT sc + delta (spcMethod sc) ph - where n' = fromIntegral n - delta Euler 0 = 0 - delta RungeKutta2 0 = 0 - delta RungeKutta2 1 = spcDT sc - delta RungeKutta4 0 = 0 - delta RungeKutta4 1 = spcDT sc / 2 - delta RungeKutta4 2 = spcDT sc / 2 - delta RungeKutta4 3 = spcDT sc - --- | Return the integration time values. -integTimes :: Specs m -> [Double] -integTimes sc = map t [nl .. nu] - where (nl, nu) = integIterationBnds sc - t n = basicTime sc n 0 - --- | Return the integration time points. -integPoints :: Run m -> [Point m] -integPoints r = points - where sc = runSpecs r - (nl, nu) = integIterationBnds sc - points = map point [nl .. nu] - point n = Point { pointSpecs = sc, - pointRun = r, - pointTime = basicTime sc n 0, - pointIteration = n, - pointPhase = 0 } - --- | Return the start time point. -integStartPoint :: Run m -> Point m -integStartPoint r = point nl - where sc = runSpecs r - (nl, nu) = integIterationBnds sc - point n = Point { pointSpecs = sc, - pointRun = r, - pointTime = basicTime sc n 0, - pointIteration = n, - pointPhase = 0 } - --- | Return the stop time point. -integStopPoint :: Run m -> Point m -integStopPoint r = point nu - where sc = runSpecs r - (nl, nu) = integIterationBnds sc - point n = Point { pointSpecs = sc, - pointRun = r, - pointTime = basicTime sc n 0, - pointIteration = n, - pointPhase = 0 } - --- | Return the point at the specified time. -pointAt :: Run m -> Double -> Point m -{-# INLINABLE pointAt #-} -pointAt r t = p - where sc = runSpecs r - t0 = spcStartTime sc - dt = spcDT sc - n = fromIntegral $ floor ((t - t0) / dt) - p = Point { pointSpecs = sc, - pointRun = r, - pointTime = t, - pointIteration = n, - pointPhase = -1 } + +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Simulation.Aivika.Trans.Internal.Specs +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It defines the simulation specs and related stuff. +module Simulation.Aivika.Trans.Internal.Specs + (Specs(..), + Method(..), + Run(..), + Point(..), + Parameter(..), + Simulation(..), + Dynamics(..), + Event(..), + EventProcessing(..), + EventQueueing(..), + invokeParameter, + invokeSimulation, + invokeDynamics, + invokeEvent, + basicTime, + integIterationBnds, + integIterationHiBnd, + integIterationLoBnd, + integPhaseBnds, + integPhaseHiBnd, + integPhaseLoBnd, + integTimes, + integPoints, + integStartPoint, + integStopPoint, + pointAt) where + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.Generator + +-- | It defines the simulation specs. +data Specs m = Specs { spcStartTime :: Double, -- ^ the start time + spcStopTime :: Double, -- ^ the stop time + spcDT :: Double, -- ^ the integration time step + spcMethod :: Method, -- ^ the integration method + spcGeneratorType :: GeneratorType m + -- ^ the type of the random number generator + } + +-- | It defines the integration method. +data Method = Euler -- ^ Euler's method + | RungeKutta2 -- ^ the 2nd order Runge-Kutta method + | RungeKutta4 -- ^ the 4th order Runge-Kutta method + deriving (Eq, Ord, Show) + +-- | It indentifies the simulation run. +data Run m = Run { runSpecs :: Specs m, -- ^ the simulation specs + runSession :: Session m, -- ^ the simulation session + runIndex :: Int, -- ^ the current simulation run index + runCount :: Int, -- ^ the total number of runs in this experiment + runEventQueue :: EventQueue m, -- ^ the event queue + runGenerator :: Generator m -- ^ the random number generator + } + +-- | It defines the simulation point appended with the additional information. +data Point m = Point { pointSpecs :: Specs m, -- ^ the simulation specs + pointRun :: Run m, -- ^ the simulation run + pointTime :: Double, -- ^ the current time + pointIteration :: Int, -- ^ the current iteration + pointPhase :: Int -- ^ the current phase + } + +-- | The 'Parameter' monad that allows specifying the model parameters. +-- For example, they can be used when running the Monte-Carlo simulation. +-- +-- In general, this monad is very useful for representing a computation which is external +-- relative to the model itself. +newtype Parameter m a = Parameter (Run m -> m a) + +-- | A value in the 'Simulation' monad represents a computation +-- within the simulation run. +newtype Simulation m a = Simulation (Run m -> m a) + +-- | A value in the 'Dynamics' monad represents a polymorphic time varying function +-- defined in the whole spectrum of time values as a single entity. It is ideal for +-- numerical approximating integrals. +newtype Dynamics m a = Dynamics (Point m -> m a) + +-- | A value in the 'Event' monad transformer represents a polymorphic time varying +-- function which is strongly synchronized with the event queue. +newtype Event m a = Event (Point m -> m a) + +-- | Invoke the 'Parameter' computation. +invokeParameter :: Run m -> Parameter m a -> m a +{-# INLINE invokeParameter #-} +invokeParameter r (Parameter m) = m r + +-- | Invoke the 'Simulation' computation. +invokeSimulation :: Run m -> Simulation m a -> m a +{-# INLINE invokeSimulation #-} +invokeSimulation r (Simulation m) = m r + +-- | Invoke the 'Dynamics' computation. +invokeDynamics :: Point m -> Dynamics m a -> m a +{-# INLINE invokeDynamics #-} +invokeDynamics p (Dynamics m) = m p + +-- | Invoke the 'Event' computation. +invokeEvent :: Point m -> Event m a -> m a +{-# INLINE invokeEvent #-} +invokeEvent p (Event m) = m p + +-- | Defines how the events are processed. +data EventProcessing = CurrentEvents + -- ^ either process all earlier and then current events, + -- or raise an error if the current simulation time is less + -- than the actual time of the event queue (safe within + -- the 'Event' computation as this is protected by the type system) + | EarlierEvents + -- ^ either process all earlier events not affecting + -- the events at the current simulation time, + -- or raise an error if the current simulation time is less + -- than the actual time of the event queue (safe within + -- the 'Event' computation as this is protected by the type system) + | CurrentEventsOrFromPast + -- ^ either process all earlier and then current events, + -- or do nothing if the current simulation time is less + -- than the actual time of the event queue + -- (do not use unless the documentation states the opposite) + | EarlierEventsOrFromPast + -- ^ either process all earlier events, + -- or do nothing if the current simulation time is less + -- than the actual time of the event queue + -- (do not use unless the documentation states the opposite) + deriving (Eq, Ord, Show) + +-- | A type class of monads that allow enqueueing the events. +class EventQueueing m where + + -- | It represents the event queue. + data EventQueue m :: * + + -- | Create a new event queue by the specified specs with simulation session. + newEventQueue :: Session m -> Specs m -> m (EventQueue m) + + -- | Enqueue the event which must be actuated at the specified time. + enqueueEvent :: Double -> Event m () -> Event m () + + -- | Run the 'EventT' computation in the current simulation time + -- within the 'DynamicsT' computation involving all pending + -- 'CurrentEvents' in the processing too. + runEvent :: Event m a -> Dynamics m a + {-# INLINE runEvent #-} + runEvent = runEventWith CurrentEvents + + -- | Run the 'EventT' computation in the current simulation time + -- within the 'DynamicsT' computation specifying what pending events + -- should be involved in the processing. + runEventWith :: EventProcessing -> Event m a -> Dynamics m a + + -- | Return the number of pending events that should + -- be yet actuated. + eventQueueCount :: Event m Int + +-- | Returns the integration iterations starting from zero. +integIterations :: Specs m -> [Int] +integIterations sc = [i1 .. i2] where + i1 = integIterationLoBnd sc + i2 = integIterationHiBnd sc + +-- | Returns the first and last integration iterations. +integIterationBnds :: Specs m -> (Int, Int) +integIterationBnds sc = (i1, i2) where + i1 = integIterationLoBnd sc + i2 = integIterationHiBnd sc + +-- | Returns the first integration iteration, i.e. zero. +integIterationLoBnd :: Specs m -> Int +integIterationLoBnd sc = 0 + +-- | Returns the last integration iteration. +integIterationHiBnd :: Specs m -> Int +integIterationHiBnd sc = + let n = round ((spcStopTime sc - + spcStartTime sc) / spcDT sc) + in if n < 0 + then + error $ + "Either the simulation specs are incorrect, " ++ + "or a step time is too small, because of which " ++ + "a floating point overflow occurred on 32-bit Haskell implementation." + else n + +-- | Returns the phases for the specified simulation specs starting from zero. +integPhases :: Specs m -> [Int] +integPhases sc = + case spcMethod sc of + Euler -> [0] + RungeKutta2 -> [0, 1] + RungeKutta4 -> [0, 1, 2, 3] + +-- | Returns the first and last integration phases. +integPhaseBnds :: Specs m -> (Int, Int) +integPhaseBnds sc = + case spcMethod sc of + Euler -> (0, 0) + RungeKutta2 -> (0, 1) + RungeKutta4 -> (0, 3) + +-- | Returns the first integration phase, i.e. zero. +integPhaseLoBnd :: Specs m -> Int +integPhaseLoBnd sc = 0 + +-- | Returns the last integration phase, 0 for Euler's method, 1 for RK2 and 3 for RK4. +integPhaseHiBnd :: Specs m -> Int +integPhaseHiBnd sc = + case spcMethod sc of + Euler -> 0 + RungeKutta2 -> 1 + RungeKutta4 -> 3 + +-- | Returns a simulation time for the integration point specified by +-- the specs, iteration and phase. +basicTime :: Specs m -> Int -> Int -> Double +{-# INLINE basicTime #-} +basicTime sc n ph = + if ph < 0 then + error "Incorrect phase: basicTime" + else + spcStartTime sc + n' * spcDT sc + delta (spcMethod sc) ph + where n' = fromIntegral n + delta Euler 0 = 0 + delta RungeKutta2 0 = 0 + delta RungeKutta2 1 = spcDT sc + delta RungeKutta4 0 = 0 + delta RungeKutta4 1 = spcDT sc / 2 + delta RungeKutta4 2 = spcDT sc / 2 + delta RungeKutta4 3 = spcDT sc + +-- | Return the integration time values. +integTimes :: Specs m -> [Double] +integTimes sc = map t [nl .. nu] + where (nl, nu) = integIterationBnds sc + t n = basicTime sc n 0 + +-- | Return the integration time points. +integPoints :: Run m -> [Point m] +integPoints r = points + where sc = runSpecs r + (nl, nu) = integIterationBnds sc + points = map point [nl .. nu] + point n = Point { pointSpecs = sc, + pointRun = r, + pointTime = basicTime sc n 0, + pointIteration = n, + pointPhase = 0 } + +-- | Return the start time point. +integStartPoint :: Run m -> Point m +integStartPoint r = point nl + where sc = runSpecs r + (nl, nu) = integIterationBnds sc + point n = Point { pointSpecs = sc, + pointRun = r, + pointTime = basicTime sc n 0, + pointIteration = n, + pointPhase = 0 } + +-- | Return the stop time point. +integStopPoint :: Run m -> Point m +integStopPoint r = point nu + where sc = runSpecs r + (nl, nu) = integIterationBnds sc + point n = Point { pointSpecs = sc, + pointRun = r, + pointTime = basicTime sc n 0, + pointIteration = n, + pointPhase = 0 } + +-- | Return the point at the specified time. +pointAt :: Run m -> Double -> Point m +{-# INLINABLE pointAt #-} +pointAt r t = p + where sc = runSpecs r + t0 = spcStartTime sc + dt = spcDT sc + n = fromIntegral $ floor ((t - t0) / dt) + p = Point { pointSpecs = sc, + pointRun = r, + pointTime = t, + pointIteration = n, + pointPhase = -1 } 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,245 +1,252 @@ - --- | --- Module : Simulation.Aivika.Trans.Net --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines a 'Net' arrow that can be applied to modeling the queue networks --- like the 'Processor' arrow from another module. Only the former has a more efficient --- implementation of the 'Arrow' interface than the latter, although at the cost of --- some decreasing in generality. --- --- While the @Processor@ type is just a function that transforms the input 'Stream' into another, --- the @Net@ type is actually an automaton that has an implementation very similar to that one --- which the 'Circuit' type has, only the computations occur in the 'Process' monad. But unlike --- the @Circuit@ type, the @Net@ type doesn't allow declaring recursive definitions, being based on --- continuations. --- --- In a nutshell, the @Net@ type is an interchangeable alternative to the @Processor@ type --- with its weaknesses and strengths. The @Net@ arrow is useful for constructing computations --- with help of the proc-notation to be transformed then to the @Processor@ computations that --- are more general in nature and more easy-to-use but which computations created with help of --- the proc-notation are not so efficient. --- -module Simulation.Aivika.Trans.Net - (-- * Net Arrow - Net(..), - -- * Net Primitives - emptyNet, - arrNet, - accumNet, - -- * Specifying Identifier - netUsingId, - -- * Arrival Net - arrivalNet, - -- * Delaying Net - delayNet, - -- * Interchanging Nets with Processors - netProcessor, - processorNet) where - -import qualified Control.Category as C -import Control.Arrow -import Control.Monad.Trans - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Parameter -import Simulation.Aivika.Trans.Simulation -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Event -import Simulation.Aivika.Trans.Cont -import Simulation.Aivika.Trans.Process -import Simulation.Aivika.Trans.Stream -import Simulation.Aivika.Trans.QueueStrategy -import Simulation.Aivika.Trans.Resource -import Simulation.Aivika.Trans.Processor -import Simulation.Aivika.Trans.Ref -import Simulation.Aivika.Trans.Circuit -import Simulation.Aivika.Arrival (Arrival(..)) - --- | Represents the net as an automaton working within the 'Process' computation. -newtype Net m a b = - Net { runNet :: a -> Process m (b, Net m a b) - -- ^ Run the net. - } - -instance MonadComp m => C.Category (Net m) where - - id = Net $ \a -> return (a, C.id) - - (.) = dot - where - (Net g) `dot` (Net f) = - Net $ \a -> - do (b, p1) <- f a - (c, p2) <- g b - return (c, p2 `dot` p1) - -instance MonadComp m => Arrow (Net m) where - - arr f = Net $ \a -> return (f a, arr f) - - first (Net f) = - Net $ \(b, d) -> - do (c, p) <- f b - return ((c, d), first p) - - second (Net f) = - Net $ \(d, b) -> - do (c, p) <- f b - return ((d, c), second p) - - (Net f) *** (Net g) = - Net $ \(b, b') -> - do (c, p1) <- f b - (c', p2) <- g b' - return ((c, c'), p1 *** p2) - - (Net f) &&& (Net g) = - Net $ \b -> - do (c, p1) <- f b - (c', p2) <- g b - return ((c, c'), p1 &&& p2) - -instance MonadComp m => ArrowChoice (Net m) where - - left x@(Net f) = - Net $ \ebd -> - case ebd of - Left b -> - do (c, p) <- f b - return (Left c, left p) - Right d -> - return (Right d, left x) - - right x@(Net f) = - Net $ \edb -> - case edb of - Right b -> - do (c, p) <- f b - return (Right c, right p) - Left d -> - return (Left d, right x) - - x@(Net f) +++ y@(Net g) = - Net $ \ebb' -> - case ebb' of - Left b -> - do (c, p1) <- f b - return (Left c, p1 +++ y) - Right b' -> - do (c', p2) <- g b' - return (Right c', x +++ p2) - - x@(Net f) ||| y@(Net g) = - Net $ \ebc -> - case ebc of - Left b -> - do (d, p1) <- f b - return (d, p1 ||| y) - Right b' -> - do (d, p2) <- g b' - return (d, x ||| p2) - --- | A net that never finishes its work. -emptyNet :: MonadComp m => Net m a b -emptyNet = Net $ const neverProcess - --- | Create a simple net by the specified handling function --- that runs the discontinuous process for each input value to get an output. -arrNet :: MonadComp m => (a -> Process m b) -> Net m a b -arrNet f = - let x = - Net $ \a -> - do b <- f a - return (b, x) - in x - --- | Accumulator that outputs a value determined by the supplied function. -accumNet :: MonadComp m => (acc -> a -> Process m (acc, b)) -> acc -> Net m a b -accumNet f acc = - Net $ \a -> - do (acc', b) <- f acc a - return (b, accumNet f acc') - --- | Create a net that will use the specified process identifier. --- It can be useful to refer to the underlying 'Process' computation which --- can be passivated, interrupted, canceled and so on. See also the --- 'processUsingId' function for more details. -netUsingId :: MonadComp m => ProcessId m -> Net m a b -> Net m a b -netUsingId pid (Net f) = - Net $ processUsingId pid . f - --- | Transform the net to an equivalent processor (a rather cheap transformation). -netProcessor :: MonadComp m => Net m a b -> Processor m a b -netProcessor = Processor . loop - where loop x as = - Cons $ - do (a, as') <- runStream as - (b, x') <- runNet x a - return (b, loop x' as') - --- | Transform the processor to a similar net (a more costly transformation). -processorNet :: MonadComp m => Processor m a b -> Net m a b -processorNet x = - Net $ \a -> - do readingA <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - writingA <- liftSimulation $ newResourceWithMaxCount FCFS 1 (Just 1) - readingB <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - writingB <- liftSimulation $ newResourceWithMaxCount FCFS 1 (Just 1) - conting <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - sn <- liftParameter simulationSession - refA <- liftComp $ newProtoRef sn Nothing - refB <- liftComp $ newProtoRef sn Nothing - let input = - do requestResource readingA - Just a <- liftComp $ readProtoRef refA - liftComp $ writeProtoRef refA Nothing - releaseResource writingA - return (a, Cons input) - consume bs = - do (b, bs') <- runStream bs - requestResource writingB - liftComp $ writeProtoRef refB (Just b) - releaseResource readingB - requestResource conting - consume bs' - loop a = - do requestResource writingA - liftComp $ writeProtoRef refA (Just a) - releaseResource readingA - requestResource readingB - Just b <- liftComp $ readProtoRef refB - liftComp $ writeProtoRef refB Nothing - releaseResource writingB - return (b, Net $ \a -> releaseResource conting >> loop a) - spawnProcess CancelTogether $ - consume $ runProcessor x (Cons input) - loop a - --- | A net that adds the information about the time points at which --- the values were received. -arrivalNet :: MonadComp m => Net m a (Arrival a) -arrivalNet = - let loop t0 = - Net $ \a -> - do t <- liftDynamics time - let b = Arrival { arrivalValue = a, - arrivalTime = t, - arrivalDelay = - case t0 of - Nothing -> Nothing - Just t0 -> Just (t - t0) } - return (b, loop $ Just t) - in loop Nothing - --- | Delay the input by one step using the specified initial value. -delayNet :: MonadComp m => a -> Net m a a -delayNet a0 = - Net $ \a -> - return (a0, delayNet a) + +-- | +-- Module : Simulation.Aivika.Trans.Net +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines a 'Net' arrow that can be applied to modeling the queue networks +-- like the 'Processor' arrow from another module. Only the former has a more efficient +-- implementation of the 'Arrow' interface than the latter, although at the cost of +-- some decreasing in generality. +-- +-- While the @Processor@ type is just a function that transforms the input 'Stream' into another, +-- the @Net@ type is actually an automaton that has an implementation very similar to that one +-- which the 'Circuit' type has, only the computations occur in the 'Process' monad. But unlike +-- the @Circuit@ type, the @Net@ type doesn't allow declaring recursive definitions, being based on +-- continuations. +-- +-- In a nutshell, the @Net@ type is an interchangeable alternative to the @Processor@ type +-- with its weaknesses and strengths. The @Net@ arrow is useful for constructing computations +-- with help of the proc-notation to be transformed then to the @Processor@ computations that +-- are more general in nature and more easy-to-use but which computations created with help of +-- the proc-notation are not so efficient. +-- +module Simulation.Aivika.Trans.Net + (-- * Net Arrow + Net(..), + iterateNet, + -- * Net Primitives + emptyNet, + arrNet, + accumNet, + -- * Specifying Identifier + netUsingId, + -- * Arrival Net + arrivalNet, + -- * Delaying Net + delayNet, + -- * Interchanging Nets with Processors + netProcessor, + processorNet) where + +import qualified Control.Category as C +import Control.Arrow +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Parameter +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Event +import Simulation.Aivika.Trans.Cont +import Simulation.Aivika.Trans.Process +import Simulation.Aivika.Trans.Stream +import Simulation.Aivika.Trans.QueueStrategy +import Simulation.Aivika.Trans.Resource +import Simulation.Aivika.Trans.Processor +import Simulation.Aivika.Trans.Ref +import Simulation.Aivika.Trans.Circuit +import Simulation.Aivika.Arrival (Arrival(..)) + +-- | Represents the net as an automaton working within the 'Process' computation. +newtype Net m a b = + Net { runNet :: a -> Process m (b, Net m a b) + -- ^ Run the net. + } + +instance MonadComp m => C.Category (Net m) where + + id = Net $ \a -> return (a, C.id) + + (.) = dot + where + (Net g) `dot` (Net f) = + Net $ \a -> + do (b, p1) <- f a + (c, p2) <- g b + return (c, p2 `dot` p1) + +instance MonadComp m => Arrow (Net m) where + + arr f = Net $ \a -> return (f a, arr f) + + first (Net f) = + Net $ \(b, d) -> + do (c, p) <- f b + return ((c, d), first p) + + second (Net f) = + Net $ \(d, b) -> + do (c, p) <- f b + return ((d, c), second p) + + (Net f) *** (Net g) = + Net $ \(b, b') -> + do (c, p1) <- f b + (c', p2) <- g b' + return ((c, c'), p1 *** p2) + + (Net f) &&& (Net g) = + Net $ \b -> + do (c, p1) <- f b + (c', p2) <- g b + return ((c, c'), p1 &&& p2) + +instance MonadComp m => ArrowChoice (Net m) where + + left x@(Net f) = + Net $ \ebd -> + case ebd of + Left b -> + do (c, p) <- f b + return (Left c, left p) + Right d -> + return (Right d, left x) + + right x@(Net f) = + Net $ \edb -> + case edb of + Right b -> + do (c, p) <- f b + return (Right c, right p) + Left d -> + return (Left d, right x) + + x@(Net f) +++ y@(Net g) = + Net $ \ebb' -> + case ebb' of + Left b -> + do (c, p1) <- f b + return (Left c, p1 +++ y) + Right b' -> + do (c', p2) <- g b' + return (Right c', x +++ p2) + + x@(Net f) ||| y@(Net g) = + Net $ \ebc -> + case ebc of + Left b -> + do (d, p1) <- f b + return (d, p1 ||| y) + Right b' -> + do (d, p2) <- g b' + return (d, x ||| p2) + +-- | A net that never finishes its work. +emptyNet :: MonadComp m => Net m a b +emptyNet = Net $ const neverProcess + +-- | Create a simple net by the specified handling function +-- that runs the discontinuous process for each input value to get an output. +arrNet :: MonadComp m => (a -> Process m b) -> Net m a b +arrNet f = + let x = + Net $ \a -> + do b <- f a + return (b, x) + in x + +-- | Accumulator that outputs a value determined by the supplied function. +accumNet :: MonadComp m => (acc -> a -> Process m (acc, b)) -> acc -> Net m a b +accumNet f acc = + Net $ \a -> + do (acc', b) <- f acc a + return (b, accumNet f acc') + +-- | Create a net that will use the specified process identifier. +-- It can be useful to refer to the underlying 'Process' computation which +-- can be passivated, interrupted, canceled and so on. See also the +-- 'processUsingId' function for more details. +netUsingId :: MonadComp m => ProcessId m -> Net m a b -> Net m a b +netUsingId pid (Net f) = + Net $ processUsingId pid . f + +-- | Transform the net to an equivalent processor (a rather cheap transformation). +netProcessor :: MonadComp m => Net m a b -> Processor m a b +netProcessor = Processor . loop + where loop x as = + Cons $ + do (a, as') <- runStream as + (b, x') <- runNet x a + return (b, loop x' as') + +-- | Transform the processor to a similar net (a more costly transformation). +processorNet :: MonadComp m => Processor m a b -> Net m a b +processorNet x = + Net $ \a -> + do readingA <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + writingA <- liftSimulation $ newResourceWithMaxCount FCFS 1 (Just 1) + readingB <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + writingB <- liftSimulation $ newResourceWithMaxCount FCFS 1 (Just 1) + conting <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + sn <- liftParameter simulationSession + refA <- liftComp $ newProtoRef sn Nothing + refB <- liftComp $ newProtoRef sn Nothing + let input = + do requestResource readingA + Just a <- liftComp $ readProtoRef refA + liftComp $ writeProtoRef refA Nothing + releaseResource writingA + return (a, Cons input) + consume bs = + do (b, bs') <- runStream bs + requestResource writingB + liftComp $ writeProtoRef refB (Just b) + releaseResource readingB + requestResource conting + consume bs' + loop a = + do requestResource writingA + liftComp $ writeProtoRef refA (Just a) + releaseResource readingA + requestResource readingB + Just b <- liftComp $ readProtoRef refB + liftComp $ writeProtoRef refB Nothing + releaseResource writingB + return (b, Net $ \a -> releaseResource conting >> loop a) + spawnProcess $ + consume $ runProcessor x (Cons input) + loop a + +-- | A net that adds the information about the time points at which +-- the values were received. +arrivalNet :: MonadComp m => Net m a (Arrival a) +arrivalNet = + let loop t0 = + Net $ \a -> + do t <- liftDynamics time + let b = Arrival { arrivalValue = a, + arrivalTime = t, + arrivalDelay = + case t0 of + Nothing -> Nothing + Just t0 -> Just (t - t0) } + return (b, loop $ Just t) + in loop Nothing + +-- | Delay the input by one step using the specified initial value. +delayNet :: MonadComp m => a -> Net m a a +delayNet a0 = + Net $ \a -> + return (a0, delayNet a) + +-- | Iterate infinitely using the specified initial value. +iterateNet :: MonadComp m => Net m a a -> a -> Process m () +iterateNet (Net f) a = + do (a', x) <- f a + iterateNet x a' 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,40 +1,40 @@ --- | --- Module : Simulation.Aivika.Trans.Parameter --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines the 'ParameterT' monad transformer that allows representing the model --- parameters. For example, they can be used when running the Monte-Carlo simulation. --- --- In general, this monad tranformer is very useful for representing a computation which is external --- relative to the model itself. --- -module Simulation.Aivika.Trans.Parameter - (-- * Parameter - Parameter, - ParameterLift(..), - runParameter, - runParameters, - -- * Error Handling - catchParameter, - finallyParameter, - throwParameter, - -- * Predefined Parameters - simulationIndex, - simulationCount, - simulationSpecs, - simulationSession, - generatorParameter, - starttime, - stoptime, - dt, - -- * Memoization - memoParameter, - -- * Utilities - tableParameter) where - -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Parameter +-- | +-- Module : Simulation.Aivika.Trans.Parameter +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the 'ParameterT' monad transformer that allows representing the model +-- parameters. For example, they can be used when running the Monte-Carlo simulation. +-- +-- In general, this monad tranformer is very useful for representing a computation which is external +-- relative to the model itself. +-- +module Simulation.Aivika.Trans.Parameter + (-- * Parameter + Parameter, + ParameterLift(..), + runParameter, + runParameters, + -- * Error Handling + catchParameter, + finallyParameter, + throwParameter, + -- * Predefined Parameters + simulationIndex, + simulationCount, + simulationSpecs, + simulationSession, + generatorParameter, + starttime, + stoptime, + dt, + -- * Memoization + memoParameter, + -- * Utilities + tableParameter) where + +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter diff --git a/Simulation/Aivika/Trans/Parameter/Random.hs b/Simulation/Aivika/Trans/Parameter/Random.hs --- a/Simulation/Aivika/Trans/Parameter/Random.hs +++ b/Simulation/Aivika/Trans/Parameter/Random.hs @@ -1,142 +1,142 @@ - --- | --- Module : Simulation.Aivika.Trans.Parameter.Random --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines the random parameters of simulation experiments. --- --- To create a parameter that would return the same value within the simulation run, --- you should memoize the computation with help of 'memoParameter', which is important --- for the Monte-Carlo simulation. --- --- To create a random function that would return the same values in the integration --- time points within the simulation run, you should either lift the computation to --- the 'Dynamics' computation and then memoize it too but using the 'memo0Dynamics' --- function for that computation, or just take the predefined function that does --- namely this. - -module Simulation.Aivika.Trans.Parameter.Random - (randomUniform, - randomUniformInt, - randomNormal, - randomExponential, - randomErlang, - randomPoisson, - randomBinomial, - randomTrue, - randomFalse) where - -import System.Random - -import Control.Monad.Trans - -import Simulation.Aivika.Trans.Generator -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Parameter -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Dynamics.Memo.Unboxed - --- | Computation that generates a new random number distributed uniformly. -randomUniform :: MonadComp m - => Double -- ^ minimum - -> Double -- ^ maximum - -> Parameter m Double -{-# INLINE randomUniform #-} -randomUniform min max = - Parameter $ \r -> - let g = runGenerator r - in generateUniform g min max - --- | Computation that generates a new random integer number distributed uniformly. -randomUniformInt :: MonadComp m - => Int -- ^ minimum - -> Int -- ^ maximum - -> Parameter m Int -{-# INLINE randomUniformInt #-} -randomUniformInt min max = - Parameter $ \r -> - let g = runGenerator r - in generateUniformInt g min max - --- | Computation that generates a new random number distributed normally. -randomNormal :: MonadComp m - => Double -- ^ mean - -> Double -- ^ deviation - -> Parameter m Double -{-# INLINE randomNormal #-} -randomNormal mu nu = - Parameter $ \r -> - let g = runGenerator r - in generateNormal g mu nu - --- | Computation that returns a new exponential random number with the specified mean --- (the reciprocal of the rate). -randomExponential :: MonadComp m - => Double - -- ^ the mean (the reciprocal of the rate) - -> Parameter m Double -{-# INLINE randomExponential #-} -randomExponential mu = - Parameter $ \r -> - let g = runGenerator r - in generateExponential g mu - --- | Computation that returns a new Erlang random number with the specified scale --- (the reciprocal of the rate) and integer shape. -randomErlang :: MonadComp m - => Double - -- ^ the scale (the reciprocal of the rate) - -> Int - -- ^ the shape - -> Parameter m Double -{-# INLINE randomErlang #-} -randomErlang beta m = - Parameter $ \r -> - let g = runGenerator r - in generateErlang g beta m - --- | Computation that returns a new Poisson random number with the specified mean. -randomPoisson :: MonadComp m - => Double - -- ^ the mean - -> Parameter m Int -{-# INLINE randomPoisson #-} -randomPoisson mu = - Parameter $ \r -> - let g = runGenerator r - in generatePoisson g mu - --- | Computation that returns a new binomial random number with the specified --- probability and trials. -randomBinomial :: MonadComp m - => Double -- ^ the probability - -> Int -- ^ the number of trials - -> Parameter m Int -{-# INLINE randomBinomial #-} -randomBinomial prob trials = - Parameter $ \r -> - let g = runGenerator r - in generateBinomial g prob trials - --- | Computation that returns 'True' in case of success. -randomTrue :: MonadComp m - => Double -- ^ the probability of the success - -> Parameter m Bool -{-# INLINE randomTrue #-} -randomTrue p = - do x <- randomUniform 0 1 - return (x <= p) - --- | Computation that returns 'False' in case of success. -randomFalse :: MonadComp m - => Double -- ^ the probability of the success - -> Parameter m Bool -{-# INLINE randomFalse #-} -randomFalse p = - do x <- randomUniform 0 1 - return (x > p) + +-- | +-- Module : Simulation.Aivika.Trans.Parameter.Random +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the random parameters of simulation experiments. +-- +-- To create a parameter that would return the same value within the simulation run, +-- you should memoize the computation with help of 'memoParameter', which is important +-- for the Monte-Carlo simulation. +-- +-- To create a random function that would return the same values in the integration +-- time points within the simulation run, you should either lift the computation to +-- the 'Dynamics' computation and then memoize it too but using the 'memo0Dynamics' +-- function for that computation, or just take the predefined function that does +-- namely this. + +module Simulation.Aivika.Trans.Parameter.Random + (randomUniform, + randomUniformInt, + randomNormal, + randomExponential, + randomErlang, + randomPoisson, + randomBinomial, + randomTrue, + randomFalse) where + +import System.Random + +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Generator +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Dynamics.Memo.Unboxed + +-- | Computation that generates a new random number distributed uniformly. +randomUniform :: MonadComp m + => Double -- ^ minimum + -> Double -- ^ maximum + -> Parameter m Double +{-# INLINE randomUniform #-} +randomUniform min max = + Parameter $ \r -> + let g = runGenerator r + in generateUniform g min max + +-- | Computation that generates a new random integer number distributed uniformly. +randomUniformInt :: MonadComp m + => Int -- ^ minimum + -> Int -- ^ maximum + -> Parameter m Int +{-# INLINE randomUniformInt #-} +randomUniformInt min max = + Parameter $ \r -> + let g = runGenerator r + in generateUniformInt g min max + +-- | Computation that generates a new random number distributed normally. +randomNormal :: MonadComp m + => Double -- ^ mean + -> Double -- ^ deviation + -> Parameter m Double +{-# INLINE randomNormal #-} +randomNormal mu nu = + Parameter $ \r -> + let g = runGenerator r + in generateNormal g mu nu + +-- | Computation that returns a new exponential random number with the specified mean +-- (the reciprocal of the rate). +randomExponential :: MonadComp m + => Double + -- ^ the mean (the reciprocal of the rate) + -> Parameter m Double +{-# INLINE randomExponential #-} +randomExponential mu = + Parameter $ \r -> + let g = runGenerator r + in generateExponential g mu + +-- | Computation that returns a new Erlang random number with the specified scale +-- (the reciprocal of the rate) and integer shape. +randomErlang :: MonadComp m + => Double + -- ^ the scale (the reciprocal of the rate) + -> Int + -- ^ the shape + -> Parameter m Double +{-# INLINE randomErlang #-} +randomErlang beta m = + Parameter $ \r -> + let g = runGenerator r + in generateErlang g beta m + +-- | Computation that returns a new Poisson random number with the specified mean. +randomPoisson :: MonadComp m + => Double + -- ^ the mean + -> Parameter m Int +{-# INLINE randomPoisson #-} +randomPoisson mu = + Parameter $ \r -> + let g = runGenerator r + in generatePoisson g mu + +-- | Computation that returns a new binomial random number with the specified +-- probability and trials. +randomBinomial :: MonadComp m + => Double -- ^ the probability + -> Int -- ^ the number of trials + -> Parameter m Int +{-# INLINE randomBinomial #-} +randomBinomial prob trials = + Parameter $ \r -> + let g = runGenerator r + in generateBinomial g prob trials + +-- | Computation that returns 'True' in case of success. +randomTrue :: MonadComp m + => Double -- ^ the probability of the success + -> Parameter m Bool +{-# INLINE randomTrue #-} +randomTrue p = + do x <- randomUniform 0 1 + return (x <= p) + +-- | Computation that returns 'False' in case of success. +randomFalse :: MonadComp m + => Double -- ^ the probability of the success + -> Parameter m Bool +{-# INLINE randomFalse #-} +randomFalse p = + do x <- randomUniform 0 1 + return (x > p) diff --git a/Simulation/Aivika/Trans/PriorityQueue.hs b/Simulation/Aivika/Trans/PriorityQueue.hs --- a/Simulation/Aivika/Trans/PriorityQueue.hs +++ b/Simulation/Aivika/Trans/PriorityQueue.hs @@ -1,186 +1,186 @@ - --- | --- Module : Simulation.Aivika.Trans.PriorityQueue --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- An imperative heap-based priority queue. --- -module Simulation.Aivika.Trans.PriorityQueue - (PriorityQueue, - queueNull, - queueCount, - newQueue, - enqueue, - dequeue, - queueFront) where - -import Control.Monad - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp - -import qualified Simulation.Aivika.Trans.ProtoArray as A -import qualified Simulation.Aivika.Trans.ProtoArray.Unboxed as UA - --- | The 'PriorityQueue' type represents an imperative heap-based --- priority queue. -data PriorityQueue m a = - PriorityQueue { pqSession :: Session m, - pqKeys :: ProtoRef m (UA.ProtoArray m Double), - pqVals :: ProtoRef m (A.ProtoArray m a), - pqSize :: ProtoRef m Int, - pqCapacity :: ProtoRef m Int } - -increase :: ProtoMonadComp m => PriorityQueue m a -> m () -increase pq = - do let s = pqSession pq - keyRef = pqKeys pq - valRef = pqVals pq - capacityRef = pqCapacity pq - keys <- readProtoRef keyRef - vals <- readProtoRef valRef - len <- readProtoRef capacityRef - let capacity' | len < 64 = 2 * len - | otherwise = (len `div` 2) * 3 - keys' <- UA.newProtoArray_ s capacity' - vals' <- A.newProtoArray_ s capacity' - mapM_ (\i -> do { k <- UA.readProtoArray keys i; UA.writeProtoArray keys' i k }) [0 .. len - 1] - mapM_ (\i -> do { v <- A.readProtoArray vals i; A.writeProtoArray vals' i v }) [0 .. len - 1] - writeProtoRef keyRef keys' - writeProtoRef valRef vals' - writeProtoRef capacityRef capacity' - -siftUp :: ProtoMonadComp m - => UA.ProtoArray m Double - -- ^ keys - -> A.ProtoArray m a - -- ^ values - -> Int - -- ^ index - -> Double - -- ^ key - -> a - -- ^ value - -> m () -siftUp keys vals i k v = - if i == 0 - then do UA.writeProtoArray keys i k - A.writeProtoArray vals i v - else do let n = (i - 1) `div` 2 - kn <- UA.readProtoArray keys n - if k >= kn - then do UA.writeProtoArray keys i k - A.writeProtoArray vals i v - else do vn <- A.readProtoArray vals n - UA.writeProtoArray keys i kn - A.writeProtoArray vals i vn - siftUp keys vals n k v - -siftDown :: ProtoMonadComp m - => UA.ProtoArray m Double - -- ^ keys - -> A.ProtoArray m a - -- ^ values - -> Int - -- ^ size - -> Int - -- ^ index - -> Double - -- ^ key - -> a - -- ^ value - -> m () -siftDown keys vals size i k v = - if i >= (size `div` 2) - then do UA.writeProtoArray keys i k - A.writeProtoArray vals i v - else do let n = 2 * i + 1 - n' = n + 1 - kn <- UA.readProtoArray keys n - if n' >= size - then if k <= kn - then do UA.writeProtoArray keys i k - A.writeProtoArray vals i v - else do vn <- A.readProtoArray vals n - UA.writeProtoArray keys i kn - A.writeProtoArray vals i vn - siftDown keys vals size n k v - else do kn' <- UA.readProtoArray keys n' - let n'' = if kn > kn' then n' else n - kn'' = min kn' kn - if k <= kn'' - then do UA.writeProtoArray keys i k - A.writeProtoArray vals i v - else do vn'' <- A.readProtoArray vals n'' - UA.writeProtoArray keys i kn'' - A.writeProtoArray vals i vn'' - siftDown keys vals size n'' k v - --- | Test whether the priority queue is empty. -queueNull :: ProtoMonadComp m => PriorityQueue m a -> m Bool -queueNull pq = - do size <- readProtoRef (pqSize pq) - return $ size == 0 - --- | Return the number of elements in the priority queue. -queueCount :: ProtoMonadComp m => PriorityQueue m a -> m Int -queueCount pq = readProtoRef (pqSize pq) - --- | Create a new priority queue. -newQueue :: ProtoMonadComp m => Session m -> m (PriorityQueue m a) -newQueue session = - do keys <- UA.newProtoArray_ session 11 - vals <- A.newProtoArray_ session 11 - keyRef <- newProtoRef session keys - valRef <- newProtoRef session vals - sizeRef <- newProtoRef session 0 - capacityRef <- newProtoRef session 11 - return PriorityQueue { pqSession = session, - pqKeys = keyRef, - pqVals = valRef, - pqSize = sizeRef, - pqCapacity = capacityRef } - --- | Enqueue a new element with the specified priority. -enqueue :: ProtoMonadComp m => PriorityQueue m a -> Double -> a -> m () -enqueue pq k v = - do i <- readProtoRef (pqSize pq) - n <- readProtoRef (pqCapacity pq) - when (i >= n - 1) $ increase pq - writeProtoRef (pqSize pq) (i + 1) - keys <- readProtoRef (pqKeys pq) - vals <- readProtoRef (pqVals pq) - siftUp keys vals i k v - --- | Dequeue the element with the minimal priority. -dequeue :: ProtoMonadComp m => PriorityQueue m a -> m () -dequeue pq = - do size <- readProtoRef (pqSize pq) - when (size == 0) $ error "Empty priority queue: dequeue" - let i = size - 1 - writeProtoRef (pqSize pq) i - keys <- readProtoRef (pqKeys pq) - vals <- readProtoRef (pqVals pq) - k <- UA.readProtoArray keys i - v <- A.readProtoArray vals i - let k0 = 0.0 - v0 = undefined - UA.writeProtoArray keys i k0 - A.writeProtoArray vals i v0 - siftDown keys vals i 0 k v - --- | Return the element with the minimal priority. -queueFront :: ProtoMonadComp m => PriorityQueue m a -> m (Double, a) -queueFront pq = - do size <- readProtoRef (pqSize pq) - when (size == 0) $ error "Empty priority queue: queueFront" - keys <- readProtoRef (pqKeys pq) - vals <- readProtoRef (pqVals pq) - k <- UA.readProtoArray keys 0 - v <- A.readProtoArray vals 0 - return (k, v) + +-- | +-- Module : Simulation.Aivika.Trans.PriorityQueue +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- An imperative heap-based priority queue. +-- +module Simulation.Aivika.Trans.PriorityQueue + (PriorityQueue, + queueNull, + queueCount, + newQueue, + enqueue, + dequeue, + queueFront) where + +import Control.Monad + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp + +import qualified Simulation.Aivika.Trans.ProtoArray as A +import qualified Simulation.Aivika.Trans.ProtoArray.Unboxed as UA + +-- | The 'PriorityQueue' type represents an imperative heap-based +-- priority queue. +data PriorityQueue m a = + PriorityQueue { pqSession :: Session m, + pqKeys :: ProtoRef m (UA.ProtoArray m Double), + pqVals :: ProtoRef m (A.ProtoArray m a), + pqSize :: ProtoRef m Int, + pqCapacity :: ProtoRef m Int } + +increase :: ProtoMonadComp m => PriorityQueue m a -> m () +increase pq = + do let s = pqSession pq + keyRef = pqKeys pq + valRef = pqVals pq + capacityRef = pqCapacity pq + keys <- readProtoRef keyRef + vals <- readProtoRef valRef + len <- readProtoRef capacityRef + let capacity' | len < 64 = 2 * len + | otherwise = (len `div` 2) * 3 + keys' <- UA.newProtoArray_ s capacity' + vals' <- A.newProtoArray_ s capacity' + mapM_ (\i -> do { k <- UA.readProtoArray keys i; UA.writeProtoArray keys' i k }) [0 .. len - 1] + mapM_ (\i -> do { v <- A.readProtoArray vals i; A.writeProtoArray vals' i v }) [0 .. len - 1] + writeProtoRef keyRef keys' + writeProtoRef valRef vals' + writeProtoRef capacityRef capacity' + +siftUp :: ProtoMonadComp m + => UA.ProtoArray m Double + -- ^ keys + -> A.ProtoArray m a + -- ^ values + -> Int + -- ^ index + -> Double + -- ^ key + -> a + -- ^ value + -> m () +siftUp keys vals i k v = + if i == 0 + then do UA.writeProtoArray keys i k + A.writeProtoArray vals i v + else do let n = (i - 1) `div` 2 + kn <- UA.readProtoArray keys n + if k >= kn + then do UA.writeProtoArray keys i k + A.writeProtoArray vals i v + else do vn <- A.readProtoArray vals n + UA.writeProtoArray keys i kn + A.writeProtoArray vals i vn + siftUp keys vals n k v + +siftDown :: ProtoMonadComp m + => UA.ProtoArray m Double + -- ^ keys + -> A.ProtoArray m a + -- ^ values + -> Int + -- ^ size + -> Int + -- ^ index + -> Double + -- ^ key + -> a + -- ^ value + -> m () +siftDown keys vals size i k v = + if i >= (size `div` 2) + then do UA.writeProtoArray keys i k + A.writeProtoArray vals i v + else do let n = 2 * i + 1 + n' = n + 1 + kn <- UA.readProtoArray keys n + if n' >= size + then if k <= kn + then do UA.writeProtoArray keys i k + A.writeProtoArray vals i v + else do vn <- A.readProtoArray vals n + UA.writeProtoArray keys i kn + A.writeProtoArray vals i vn + siftDown keys vals size n k v + else do kn' <- UA.readProtoArray keys n' + let n'' = if kn > kn' then n' else n + kn'' = min kn' kn + if k <= kn'' + then do UA.writeProtoArray keys i k + A.writeProtoArray vals i v + else do vn'' <- A.readProtoArray vals n'' + UA.writeProtoArray keys i kn'' + A.writeProtoArray vals i vn'' + siftDown keys vals size n'' k v + +-- | Test whether the priority queue is empty. +queueNull :: ProtoMonadComp m => PriorityQueue m a -> m Bool +queueNull pq = + do size <- readProtoRef (pqSize pq) + return $ size == 0 + +-- | Return the number of elements in the priority queue. +queueCount :: ProtoMonadComp m => PriorityQueue m a -> m Int +queueCount pq = readProtoRef (pqSize pq) + +-- | Create a new priority queue. +newQueue :: ProtoMonadComp m => Session m -> m (PriorityQueue m a) +newQueue session = + do keys <- UA.newProtoArray_ session 11 + vals <- A.newProtoArray_ session 11 + keyRef <- newProtoRef session keys + valRef <- newProtoRef session vals + sizeRef <- newProtoRef session 0 + capacityRef <- newProtoRef session 11 + return PriorityQueue { pqSession = session, + pqKeys = keyRef, + pqVals = valRef, + pqSize = sizeRef, + pqCapacity = capacityRef } + +-- | Enqueue a new element with the specified priority. +enqueue :: ProtoMonadComp m => PriorityQueue m a -> Double -> a -> m () +enqueue pq k v = + do i <- readProtoRef (pqSize pq) + n <- readProtoRef (pqCapacity pq) + when (i >= n - 1) $ increase pq + writeProtoRef (pqSize pq) (i + 1) + keys <- readProtoRef (pqKeys pq) + vals <- readProtoRef (pqVals pq) + siftUp keys vals i k v + +-- | Dequeue the element with the minimal priority. +dequeue :: ProtoMonadComp m => PriorityQueue m a -> m () +dequeue pq = + do size <- readProtoRef (pqSize pq) + when (size == 0) $ error "Empty priority queue: dequeue" + let i = size - 1 + writeProtoRef (pqSize pq) i + keys <- readProtoRef (pqKeys pq) + vals <- readProtoRef (pqVals pq) + k <- UA.readProtoArray keys i + v <- A.readProtoArray vals i + let k0 = 0.0 + v0 = undefined + UA.writeProtoArray keys i k0 + A.writeProtoArray vals i v0 + siftDown keys vals i 0 k v + +-- | Return the element with the minimal priority. +queueFront :: ProtoMonadComp m => PriorityQueue m a -> m (Double, a) +queueFront pq = + do size <- readProtoRef (pqSize pq) + when (size == 0) $ error "Empty priority queue: queueFront" + keys <- readProtoRef (pqKeys pq) + vals <- readProtoRef (pqVals pq) + k <- UA.readProtoArray keys 0 + v <- A.readProtoArray vals 0 + return (k, v) diff --git a/Simulation/Aivika/Trans/Process.hs b/Simulation/Aivika/Trans/Process.hs --- a/Simulation/Aivika/Trans/Process.hs +++ b/Simulation/Aivika/Trans/Process.hs @@ -1,82 +1,84 @@ - --- | --- Module : Simulation.Aivika.Trans.Process --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- A value in the 'Process' monad represents a discontinuous process that --- can suspend in any simulation time point and then resume later in the same --- or another time point. --- --- The process of this type can involve the 'Event', 'Dynamics' and 'Simulation' --- computations. Moreover, a value in the @Process@ monad can be run within --- the @Event@ computation. --- --- A value of the 'ProcessId' type is just an identifier of such a process. --- --- The characteristic property of the @Process@ type is function 'holdProcess' --- that suspends the current process for the specified time interval. --- -module Simulation.Aivika.Trans.Process - (-- * Process Monad - ProcessId, - Process, - ProcessLift(..), - -- * Running Process - runProcess, - runProcessUsingId, - runProcessInStartTime, - runProcessInStartTimeUsingId, - runProcessInStopTime, - runProcessInStopTimeUsingId, - -- * Spawning Processes - spawnProcess, - spawnProcessUsingId, - -- * Enqueueing Process - enqueueProcess, - enqueueProcessUsingId, - -- * Creating Process Identifier - newProcessId, - processId, - processUsingId, - -- * Holding, Interrupting, Passivating and Canceling Process - holdProcess, - interruptProcess, - processInterrupted, - passivateProcess, - processPassive, - reactivateProcess, - cancelProcessWithId, - cancelProcess, - processCancelled, - processCancelling, - whenCancellingProcess, - -- * Awaiting Signal - processAwait, - -- * Yield of Process - processYield, - -- * Process Timeout - timeoutProcess, - timeoutProcessUsingId, - -- * Parallelizing Processes - processParallel, - processParallelUsingIds, - processParallel_, - processParallelUsingIds_, - -- * Exception Handling - catchProcess, - finallyProcess, - throwProcess, - -- * Utilities - zipProcessParallel, - zip3ProcessParallel, - unzipProcess, - -- * Memoizing Process - memoProcess, - -- * Never Ending Process - neverProcess) where - -import Simulation.Aivika.Trans.Internal.Process + +-- | +-- Module : Simulation.Aivika.Trans.Process +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- A value in the 'Process' monad represents a discontinuous process that +-- can suspend in any simulation time point and then resume later in the same +-- or another time point. +-- +-- The process of this type can involve the 'Event', 'Dynamics' and 'Simulation' +-- computations. Moreover, a value in the @Process@ monad can be run within +-- the @Event@ computation. +-- +-- A value of the 'ProcessId' type is just an identifier of such a process. +-- +-- The characteristic property of the @Process@ type is function 'holdProcess' +-- that suspends the current process for the specified time interval. +-- +module Simulation.Aivika.Trans.Process + (-- * Process Monad + ProcessId, + Process, + ProcessLift(..), + -- * Running Process + runProcess, + runProcessUsingId, + runProcessInStartTime, + runProcessInStartTimeUsingId, + runProcessInStopTime, + runProcessInStopTimeUsingId, + -- * Spawning Processes + spawnProcess, + spawnProcessUsingId, + spawnProcessWith, + spawnProcessUsingIdWith, + -- * Enqueueing Process + enqueueProcess, + enqueueProcessUsingId, + -- * Creating Process Identifier + newProcessId, + processId, + processUsingId, + -- * Holding, Interrupting, Passivating and Canceling Process + holdProcess, + interruptProcess, + processInterrupted, + passivateProcess, + processPassive, + reactivateProcess, + cancelProcessWithId, + cancelProcess, + processCancelled, + processCancelling, + whenCancellingProcess, + -- * Awaiting Signal + processAwait, + -- * Yield of Process + processYield, + -- * Process Timeout + timeoutProcess, + timeoutProcessUsingId, + -- * Parallelizing Processes + processParallel, + processParallelUsingIds, + processParallel_, + processParallelUsingIds_, + -- * Exception Handling + catchProcess, + finallyProcess, + throwProcess, + -- * Utilities + zipProcessParallel, + zip3ProcessParallel, + unzipProcess, + -- * Memoizing Process + memoProcess, + -- * Never Ending Process + neverProcess) where + +import Simulation.Aivika.Trans.Internal.Process 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 @@ -1,474 +1,474 @@ - -{-# LANGUAGE FlexibleContexts #-} - --- | --- Module : Simulation.Aivika.Trans.Processor --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The processor of simulation data. --- -module Simulation.Aivika.Trans.Processor - (-- * Processor Type - Processor(..), - -- * Processor Primitives - emptyProcessor, - arrProcessor, - accumProcessor, - -- * Specifying Identifier - processorUsingId, - -- * Prefetch and Delay Processors - prefetchProcessor, - delayProcessor, - -- * Buffer Processor - bufferProcessor, - bufferProcessorLoop, - -- * Processing Queues - queueProcessor, - queueProcessorLoopMerging, - queueProcessorLoopSeq, - queueProcessorLoopParallel, - -- * Sequencing Processors - processorSeq, - -- * Parallelizing Processors - processorParallel, - processorQueuedParallel, - processorPrioritisingOutputParallel, - processorPrioritisingInputParallel, - processorPrioritisingInputOutputParallel, - -- * Arrival Processor - arrivalProcessor, - -- * Integrating with Signals - signalProcessor, - processorSignaling) where - -import qualified Control.Category as C -import Control.Arrow - -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Simulation -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Event -import Simulation.Aivika.Trans.Cont -import Simulation.Aivika.Trans.Process -import Simulation.Aivika.Trans.Stream -import Simulation.Aivika.Trans.QueueStrategy -import Simulation.Aivika.Trans.Signal -import Simulation.Aivika.Arrival (Arrival(..)) - --- | Represents a processor of simulation data. -newtype Processor m a b = - Processor { runProcessor :: Stream m a -> Stream m b - -- ^ Run the processor. - } - -instance C.Category (Processor m) where - - id = Processor id - - Processor x . Processor y = Processor (x . y) - --- The implementation is based on article --- A New Notation for Arrows by Ross Paterson, --- although my streams are different and they --- already depend on the Process monad, --- while the pure streams were considered in the --- mentioned article. - -instance MonadComp m => Arrow (Processor m) where - - arr = Processor . mapStream - - first (Processor f) = - Processor $ \xys -> - Cons $ - do (xs, ys) <- liftSimulation $ unzipStream xys - runStream $ zipStreamSeq (f xs) ys - - second (Processor f) = - Processor $ \xys -> - Cons $ - do (xs, ys) <- liftSimulation $ unzipStream xys - runStream $ zipStreamSeq xs (f ys) - - Processor f *** Processor g = - Processor $ \xys -> - Cons $ - do (xs, ys) <- liftSimulation $ unzipStream xys - runStream $ zipStreamSeq (f xs) (g ys) - - Processor f &&& Processor g = - Processor $ \xs -> zipStreamSeq (f xs) (g xs) - -instance MonadComp m => ArrowChoice (Processor m) where - - left (Processor f) = - Processor $ \xs -> - Cons $ - do ys <- liftSimulation $ memoStream xs - runStream $ replaceLeftStream ys (f $ leftStream ys) - - right (Processor f) = - Processor $ \xs -> - Cons $ - do ys <- liftSimulation $ memoStream xs - runStream $ replaceRightStream ys (f $ rightStream ys) - -instance MonadComp m => ArrowZero (Processor m) where - - zeroArrow = emptyProcessor - -instance MonadComp m => ArrowPlus (Processor m) where - - (Processor f) <+> (Processor g) = - Processor $ \xs -> - Cons $ - do [xs1, xs2] <- liftSimulation $ splitStream 2 xs - runStream $ mergeStreams (f xs1) (g xs2) - --- | A processor that never finishes its work producing an 'emptyStream'. -emptyProcessor :: MonadComp m => Processor m a b -emptyProcessor = Processor $ const emptyStream - --- | Create a simple processor by the specified handling function --- that runs the discontinuous process for each input value to get the output. -arrProcessor :: MonadComp m => (a -> Process m b) -> Processor m a b -arrProcessor = Processor . mapStreamM - --- | Accumulator that outputs a value determined by the supplied function. -accumProcessor :: MonadComp m => (acc -> a -> Process m (acc, b)) -> acc -> Processor m a b -accumProcessor f acc = - Processor $ \xs -> Cons $ loop xs acc where - loop xs acc = - do (a, xs') <- runStream xs - (acc', b) <- f acc a - return (b, Cons $ loop xs' acc') - --- | Create a processor that will use the specified process identifier. --- It can be useful to refer to the underlying 'Process' computation which --- can be passivated, interrupted, canceled and so on. See also the --- 'processUsingId' function for more details. -processorUsingId :: MonadComp m => ProcessId m -> Processor m a b -> Processor m a b -processorUsingId pid (Processor f) = - Processor $ Cons . processUsingId pid . runStream . f - --- | Launches the specified processors in parallel consuming the same input --- stream and producing a combined output stream. --- --- If you don't know what the enqueue strategies to apply, then --- you will probably need 'FCFS' for the both parameters, or --- function 'processorParallel' that does namely this. -processorQueuedParallel :: (MonadComp m, - EnqueueStrategy m si, - EnqueueStrategy m so) - => si - -- ^ the strategy applied for enqueuing the input data - -> so - -- ^ the strategy applied for enqueuing the output data - -> [Processor m a b] - -- ^ the processors to parallelize - -> Processor m a b - -- ^ the parallelized processor -processorQueuedParallel si so ps = - Processor $ \xs -> - Cons $ - do let n = length ps - input <- liftSimulation $ splitStreamQueueing si n xs - let results = flip map (zip input ps) $ \(input, p) -> - runProcessor p input - output = concatQueuedStreams so results - runStream output - --- | Launches the specified processors in parallel using priorities for combining the output. -processorPrioritisingOutputParallel :: (MonadComp m, - EnqueueStrategy m si, - PriorityQueueStrategy m so po) - => si - -- ^ the strategy applied for enqueuing the input data - -> so - -- ^ the strategy applied for enqueuing the output data - -> [Processor m a (po, b)] - -- ^ the processors to parallelize - -> Processor m a b - -- ^ the parallelized processor -processorPrioritisingOutputParallel si so ps = - Processor $ \xs -> - Cons $ - do let n = length ps - input <- liftSimulation $ splitStreamQueueing si n xs - let results = flip map (zip input ps) $ \(input, p) -> - runProcessor p input - output = concatPriorityStreams so results - runStream output - --- | Launches the specified processors in parallel using priorities for consuming the intput. -processorPrioritisingInputParallel :: (MonadComp m, - PriorityQueueStrategy m si pi, - EnqueueStrategy m so) - => si - -- ^ the strategy applied for enqueuing the input data - -> so - -- ^ the strategy applied for enqueuing the output data - -> [(Stream m pi, Processor m a b)] - -- ^ the streams of input priorities and the processors - -- to parallelize - -> Processor m a b - -- ^ the parallelized processor -processorPrioritisingInputParallel si so ps = - Processor $ \xs -> - Cons $ - do input <- liftSimulation $ splitStreamPrioritising si (map fst ps) xs - let results = flip map (zip input ps) $ \(input, (_, p)) -> - runProcessor p input - output = concatQueuedStreams so results - runStream output - --- | Launches the specified processors in parallel using priorities for consuming --- the input and combining the output. -processorPrioritisingInputOutputParallel :: (MonadComp m, - PriorityQueueStrategy m si pi, - PriorityQueueStrategy m so po) - => si - -- ^ the strategy applied for enqueuing the input data - -> so - -- ^ the strategy applied for enqueuing the output data - -> [(Stream m pi, Processor m a (po, b))] - -- ^ the streams of input priorities and the processors - -- to parallelize - -> Processor m a b - -- ^ the parallelized processor -processorPrioritisingInputOutputParallel si so ps = - Processor $ \xs -> - Cons $ - do input <- liftSimulation $ splitStreamPrioritising si (map fst ps) xs - let results = flip map (zip input ps) $ \(input, (_, p)) -> - runProcessor p input - output = concatPriorityStreams so results - runStream output - --- | Launches the processors in parallel consuming the same input stream and producing --- a combined output stream. This version applies the 'FCFS' strategy both for input --- and output, which suits the most part of uses cases. -processorParallel :: MonadComp m => [Processor m a b] -> Processor m a b -processorParallel = processorQueuedParallel FCFS FCFS - --- | Launches the processors sequentially using the 'prefetchProcessor' between them --- to model an autonomous work of each of the processors specified. -processorSeq :: MonadComp m => [Processor m a a] -> Processor m a a -processorSeq [] = emptyProcessor -processorSeq [p] = p -processorSeq (p : ps) = p >>> prefetchProcessor >>> processorSeq ps - --- | Create a buffer processor, where the process from the first argument --- consumes the input stream but the stream passed in as the second argument --- and produced usually by some other process is returned as an output. --- This kind of processor is very useful for modeling the queues. -bufferProcessor :: MonadComp m - => (Stream m a -> Process m ()) - -- ^ a separate process to consume the input - -> Stream m b - -- ^ the resulting stream of data - -> Processor m a b -bufferProcessor consume output = - Processor $ \xs -> - Cons $ - do spawnProcess CancelTogether (consume xs) - runStream output - --- | Like 'bufferProcessor' but allows creating a loop when some items --- can be processed repeatedly. It is very useful for modeling the processors --- with queues and loop-backs. -bufferProcessorLoop :: MonadComp m - => (Stream m a -> Stream m c -> Process m ()) - -- ^ consume two streams: the input values of type @a@ - -- and the values of type @c@ returned by the loop - -> Stream m d - -- ^ the stream of data that may become results - -> Processor m d (Either e b) - -- ^ process and then decide what values of type @e@ - -- should be processed in the loop (this is a condition) - -> Processor m e c - -- ^ process in the loop and then return a value - -- of type @c@ to the input again (this is a loop body) - -> Processor m a b -bufferProcessorLoop consume preoutput cond body = - Processor $ \xs -> - Cons $ - do (reverted, output) <- - liftSimulation $ - partitionEitherStream $ - runProcessor cond preoutput - spawnProcess CancelTogether - (consume xs $ runProcessor body reverted) - runStream output - --- | Return a processor with help of which we can model the queue. --- --- Although the function doesn't refer to the queue directly, its main use case --- is namely a processing of the queue. The first argument should be the enqueueing --- operation, while the second argument should be the opposite dequeueing operation. --- --- The reason is as follows. There are many possible combinations how the queues --- can be modeled. There is no sense to enumerate all them creating a separate function --- for each case. We can just use combinators to define exactly what we need. --- --- So, the queue can lose the input items if the queue is full, or the input process --- can suspend while the queue is full, or we can use priorities for enqueueing, --- storing and dequeueing the items in different combinations. There are so many use --- cases! --- --- There is a hope that this function along with other similar functions from this --- module is sufficient to cover the most important cases. Even if it is not sufficient --- then you can use a more generic function 'bufferProcessor' which this function is --- based on. In case of need, you can even write your own function from scratch. It is --- quite easy actually. -queueProcessor :: MonadComp m => - (a -> Process m ()) - -- ^ enqueue the input item and wait - -- while the queue is full if required - -- so that there were no hanging items - -> Process m b - -- ^ dequeue an output item - -> Processor m a b - -- ^ the buffering processor -queueProcessor enqueue dequeue = - bufferProcessor - (consumeStream enqueue) - (repeatProcess dequeue) - --- | Like 'queueProcessor' creates a queue processor but with a loop when some items --- can be processed and then added to the queue again. Also it allows specifying --- how two input streams of data can be merged. -queueProcessorLoopMerging :: MonadComp m - => (Stream m a -> Stream m d -> Stream m e) - -- ^ merge two streams: the input values of type @a@ - -- and the values of type @d@ returned by the loop - -> (e -> Process m ()) - -- ^ enqueue the input item and wait - -- while the queue is full if required - -- so that there were no hanging items - -> Process m c - -- ^ dequeue an item for the further processing - -> Processor m c (Either f b) - -- ^ process and then decide what values of type @f@ - -- should be processed in the loop (this is a condition) - -> Processor m f d - -- ^ process in the loop and then return a value - -- of type @d@ to the queue again (this is a loop body) - -> Processor m a b - -- ^ the buffering processor -queueProcessorLoopMerging merge enqueue dequeue = - bufferProcessorLoop - (\bs cs -> - consumeStream enqueue $ - merge bs cs) - (repeatProcess dequeue) - --- | Like 'queueProcessorLoopMerging' creates a queue processor with a loop when --- some items can be processed and then added to the queue again. Only it sequentially --- merges two input streams of data: one stream that come from the external source and --- another stream of data returned by the loop. The first stream has a priority over --- the second one. -queueProcessorLoopSeq :: MonadComp m - => (a -> Process m ()) - -- ^ enqueue the input item and wait - -- while the queue is full if required - -- so that there were no hanging items - -> Process m c - -- ^ dequeue an item for the further processing - -> Processor m c (Either e b) - -- ^ process and then decide what values of type @e@ - -- should be processed in the loop (this is a condition) - -> Processor m e a - -- ^ process in the loop and then return a value - -- of type @a@ to the queue again (this is a loop body) - -> Processor m a b - -- ^ the buffering processor -queueProcessorLoopSeq = - queueProcessorLoopMerging mergeStreams - --- | Like 'queueProcessorLoopMerging' creates a queue processor with a loop when --- some items can be processed and then added to the queue again. Only it runs two --- simultaneous processes to enqueue the input streams of data: one stream that come --- from the external source and another stream of data returned by the loop. -queueProcessorLoopParallel :: MonadComp m - => (a -> Process m ()) - -- ^ enqueue the input item and wait - -- while the queue is full if required - -- so that there were no hanging items - -> Process m c - -- ^ dequeue an item for the further processing - -> Processor m c (Either e b) - -- ^ process and then decide what values of type @e@ - -- should be processed in the loop (this is a condition) - -> Processor m e a - -- ^ process in the loop and then return a value - -- of type @a@ to the queue again (this is a loop body) - -> Processor m a b - -- ^ the buffering processor -queueProcessorLoopParallel enqueue dequeue = - bufferProcessorLoop - (\bs cs -> - do spawnProcess CancelTogether $ - consumeStream enqueue bs - spawnProcess CancelTogether $ - consumeStream enqueue cs) - (repeatProcess dequeue) - --- | This is a prefetch processor that requests for one more data item from --- the input in advance while the latest item is not yet fully processed in --- the chain of streams, usually by other processors. --- --- You can think of this as the prefetched processor could place its latest --- data item in some temporary space for later use, which is very useful --- for modeling a sequence of separate and independent work places. -prefetchProcessor :: MonadComp m => Processor m a a -prefetchProcessor = Processor prefetchStream - --- | Convert the specified signal transform to a processor. --- --- The processor may return data with delay as the values are requested by demand. --- Consider using the 'arrivalSignal' function to provide with the information --- about the time points at which the signal was actually triggered. --- --- The point is that the 'Stream' used in the 'Processor' is requested outside, --- while the 'Signal' is triggered inside. They are different by nature. --- The former is passive, while the latter is active. --- --- Cancel the processor's process to unsubscribe from the signals provided. -signalProcessor :: MonadComp m => (Signal m a -> Signal m b) -> Processor m a b -signalProcessor f = - Processor $ \xs -> - Cons $ - do sa <- streamSignal xs - sb <- signalStream (f sa) - runStream sb - --- | Convert the specified processor to a signal transform. --- --- The processor may return data with delay as the values are requested by demand. --- Consider using the 'arrivalSignal' function to provide with the information --- about the time points at which the signal was actually triggered. --- --- The point is that the 'Stream' used in the 'Processor' is requested outside, --- while the 'Signal' is triggered inside. They are different by nature. --- The former is passive, while the latter is active. --- --- Cancel the returned process to unsubscribe from the signal specified. -processorSignaling :: MonadComp m => Processor m a b -> Signal m a -> Process m (Signal m b) -processorSignaling (Processor f) sa = - do xs <- signalStream sa - let ys = f xs - streamSignal ys - --- | A processor that adds the information about the time points at which --- the original stream items were received by demand. -arrivalProcessor :: MonadComp m => Processor m a (Arrival a) -arrivalProcessor = Processor arrivalStream - --- | A processor that delays the input stream by one step using the specified initial value. -delayProcessor :: MonadComp m => a -> Processor m a a -delayProcessor a0 = Processor $ delayStream a0 + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.Processor +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The processor of simulation data. +-- +module Simulation.Aivika.Trans.Processor + (-- * Processor Type + Processor(..), + -- * Processor Primitives + emptyProcessor, + arrProcessor, + accumProcessor, + -- * Specifying Identifier + processorUsingId, + -- * Prefetch and Delay Processors + prefetchProcessor, + delayProcessor, + -- * Buffer Processor + bufferProcessor, + bufferProcessorLoop, + -- * Processing Queues + queueProcessor, + queueProcessorLoopMerging, + queueProcessorLoopSeq, + queueProcessorLoopParallel, + -- * Sequencing Processors + processorSeq, + -- * Parallelizing Processors + processorParallel, + processorQueuedParallel, + processorPrioritisingOutputParallel, + processorPrioritisingInputParallel, + processorPrioritisingInputOutputParallel, + -- * Arrival Processor + arrivalProcessor, + -- * Integrating with Signals + signalProcessor, + processorSignaling) where + +import qualified Control.Category as C +import Control.Arrow + +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Event +import Simulation.Aivika.Trans.Cont +import Simulation.Aivika.Trans.Process +import Simulation.Aivika.Trans.Stream +import Simulation.Aivika.Trans.QueueStrategy +import Simulation.Aivika.Trans.Signal +import Simulation.Aivika.Arrival (Arrival(..)) + +-- | Represents a processor of simulation data. +newtype Processor m a b = + Processor { runProcessor :: Stream m a -> Stream m b + -- ^ Run the processor. + } + +instance C.Category (Processor m) where + + id = Processor id + + Processor x . Processor y = Processor (x . y) + +-- The implementation is based on article +-- A New Notation for Arrows by Ross Paterson, +-- although my streams are different and they +-- already depend on the Process monad, +-- while the pure streams were considered in the +-- mentioned article. + +instance MonadComp m => Arrow (Processor m) where + + arr = Processor . mapStream + + first (Processor f) = + Processor $ \xys -> + Cons $ + do (xs, ys) <- liftSimulation $ unzipStream xys + runStream $ zipStreamSeq (f xs) ys + + second (Processor f) = + Processor $ \xys -> + Cons $ + do (xs, ys) <- liftSimulation $ unzipStream xys + runStream $ zipStreamSeq xs (f ys) + + Processor f *** Processor g = + Processor $ \xys -> + Cons $ + do (xs, ys) <- liftSimulation $ unzipStream xys + runStream $ zipStreamSeq (f xs) (g ys) + + Processor f &&& Processor g = + Processor $ \xs -> zipStreamSeq (f xs) (g xs) + +instance MonadComp m => ArrowChoice (Processor m) where + + left (Processor f) = + Processor $ \xs -> + Cons $ + do ys <- liftSimulation $ memoStream xs + runStream $ replaceLeftStream ys (f $ leftStream ys) + + right (Processor f) = + Processor $ \xs -> + Cons $ + do ys <- liftSimulation $ memoStream xs + runStream $ replaceRightStream ys (f $ rightStream ys) + +instance MonadComp m => ArrowZero (Processor m) where + + zeroArrow = emptyProcessor + +instance MonadComp m => ArrowPlus (Processor m) where + + (Processor f) <+> (Processor g) = + Processor $ \xs -> + Cons $ + do [xs1, xs2] <- liftSimulation $ splitStream 2 xs + runStream $ mergeStreams (f xs1) (g xs2) + +-- | A processor that never finishes its work producing an 'emptyStream'. +emptyProcessor :: MonadComp m => Processor m a b +emptyProcessor = Processor $ const emptyStream + +-- | Create a simple processor by the specified handling function +-- that runs the discontinuous process for each input value to get the output. +arrProcessor :: MonadComp m => (a -> Process m b) -> Processor m a b +arrProcessor = Processor . mapStreamM + +-- | Accumulator that outputs a value determined by the supplied function. +accumProcessor :: MonadComp m => (acc -> a -> Process m (acc, b)) -> acc -> Processor m a b +accumProcessor f acc = + Processor $ \xs -> Cons $ loop xs acc where + loop xs acc = + do (a, xs') <- runStream xs + (acc', b) <- f acc a + return (b, Cons $ loop xs' acc') + +-- | Create a processor that will use the specified process identifier. +-- It can be useful to refer to the underlying 'Process' computation which +-- can be passivated, interrupted, canceled and so on. See also the +-- 'processUsingId' function for more details. +processorUsingId :: MonadComp m => ProcessId m -> Processor m a b -> Processor m a b +processorUsingId pid (Processor f) = + Processor $ Cons . processUsingId pid . runStream . f + +-- | Launches the specified processors in parallel consuming the same input +-- stream and producing a combined output stream. +-- +-- If you don't know what the enqueue strategies to apply, then +-- you will probably need 'FCFS' for the both parameters, or +-- function 'processorParallel' that does namely this. +processorQueuedParallel :: (MonadComp m, + EnqueueStrategy m si, + EnqueueStrategy m so) + => si + -- ^ the strategy applied for enqueuing the input data + -> so + -- ^ the strategy applied for enqueuing the output data + -> [Processor m a b] + -- ^ the processors to parallelize + -> Processor m a b + -- ^ the parallelized processor +processorQueuedParallel si so ps = + Processor $ \xs -> + Cons $ + do let n = length ps + input <- liftSimulation $ splitStreamQueueing si n xs + let results = flip map (zip input ps) $ \(input, p) -> + runProcessor p input + output = concatQueuedStreams so results + runStream output + +-- | Launches the specified processors in parallel using priorities for combining the output. +processorPrioritisingOutputParallel :: (MonadComp m, + EnqueueStrategy m si, + PriorityQueueStrategy m so po) + => si + -- ^ the strategy applied for enqueuing the input data + -> so + -- ^ the strategy applied for enqueuing the output data + -> [Processor m a (po, b)] + -- ^ the processors to parallelize + -> Processor m a b + -- ^ the parallelized processor +processorPrioritisingOutputParallel si so ps = + Processor $ \xs -> + Cons $ + do let n = length ps + input <- liftSimulation $ splitStreamQueueing si n xs + let results = flip map (zip input ps) $ \(input, p) -> + runProcessor p input + output = concatPriorityStreams so results + runStream output + +-- | Launches the specified processors in parallel using priorities for consuming the intput. +processorPrioritisingInputParallel :: (MonadComp m, + PriorityQueueStrategy m si pi, + EnqueueStrategy m so) + => si + -- ^ the strategy applied for enqueuing the input data + -> so + -- ^ the strategy applied for enqueuing the output data + -> [(Stream m pi, Processor m a b)] + -- ^ the streams of input priorities and the processors + -- to parallelize + -> Processor m a b + -- ^ the parallelized processor +processorPrioritisingInputParallel si so ps = + Processor $ \xs -> + Cons $ + do input <- liftSimulation $ splitStreamPrioritising si (map fst ps) xs + let results = flip map (zip input ps) $ \(input, (_, p)) -> + runProcessor p input + output = concatQueuedStreams so results + runStream output + +-- | Launches the specified processors in parallel using priorities for consuming +-- the input and combining the output. +processorPrioritisingInputOutputParallel :: (MonadComp m, + PriorityQueueStrategy m si pi, + PriorityQueueStrategy m so po) + => si + -- ^ the strategy applied for enqueuing the input data + -> so + -- ^ the strategy applied for enqueuing the output data + -> [(Stream m pi, Processor m a (po, b))] + -- ^ the streams of input priorities and the processors + -- to parallelize + -> Processor m a b + -- ^ the parallelized processor +processorPrioritisingInputOutputParallel si so ps = + Processor $ \xs -> + Cons $ + do input <- liftSimulation $ splitStreamPrioritising si (map fst ps) xs + let results = flip map (zip input ps) $ \(input, (_, p)) -> + runProcessor p input + output = concatPriorityStreams so results + runStream output + +-- | Launches the processors in parallel consuming the same input stream and producing +-- a combined output stream. This version applies the 'FCFS' strategy both for input +-- and output, which suits the most part of uses cases. +processorParallel :: MonadComp m => [Processor m a b] -> Processor m a b +processorParallel = processorQueuedParallel FCFS FCFS + +-- | Launches the processors sequentially using the 'prefetchProcessor' between them +-- to model an autonomous work of each of the processors specified. +processorSeq :: MonadComp m => [Processor m a a] -> Processor m a a +processorSeq [] = emptyProcessor +processorSeq [p] = p +processorSeq (p : ps) = p >>> prefetchProcessor >>> processorSeq ps + +-- | Create a buffer processor, where the process from the first argument +-- consumes the input stream but the stream passed in as the second argument +-- and produced usually by some other process is returned as an output. +-- This kind of processor is very useful for modeling the queues. +bufferProcessor :: MonadComp m + => (Stream m a -> Process m ()) + -- ^ a separate process to consume the input + -> Stream m b + -- ^ the resulting stream of data + -> Processor m a b +bufferProcessor consume output = + Processor $ \xs -> + Cons $ + do spawnProcess (consume xs) + runStream output + +-- | Like 'bufferProcessor' but allows creating a loop when some items +-- can be processed repeatedly. It is very useful for modeling the processors +-- with queues and loop-backs. +bufferProcessorLoop :: MonadComp m + => (Stream m a -> Stream m c -> Process m ()) + -- ^ consume two streams: the input values of type @a@ + -- and the values of type @c@ returned by the loop + -> Stream m d + -- ^ the stream of data that may become results + -> Processor m d (Either e b) + -- ^ process and then decide what values of type @e@ + -- should be processed in the loop (this is a condition) + -> Processor m e c + -- ^ process in the loop and then return a value + -- of type @c@ to the input again (this is a loop body) + -> Processor m a b +bufferProcessorLoop consume preoutput cond body = + Processor $ \xs -> + Cons $ + do (reverted, output) <- + liftSimulation $ + partitionEitherStream $ + runProcessor cond preoutput + spawnProcess + (consume xs $ runProcessor body reverted) + runStream output + +-- | Return a processor with help of which we can model the queue. +-- +-- Although the function doesn't refer to the queue directly, its main use case +-- is namely a processing of the queue. The first argument should be the enqueueing +-- operation, while the second argument should be the opposite dequeueing operation. +-- +-- The reason is as follows. There are many possible combinations how the queues +-- can be modeled. There is no sense to enumerate all them creating a separate function +-- for each case. We can just use combinators to define exactly what we need. +-- +-- So, the queue can lose the input items if the queue is full, or the input process +-- can suspend while the queue is full, or we can use priorities for enqueueing, +-- storing and dequeueing the items in different combinations. There are so many use +-- cases! +-- +-- There is a hope that this function along with other similar functions from this +-- module is sufficient to cover the most important cases. Even if it is not sufficient +-- then you can use a more generic function 'bufferProcessor' which this function is +-- based on. In case of need, you can even write your own function from scratch. It is +-- quite easy actually. +queueProcessor :: MonadComp m => + (a -> Process m ()) + -- ^ enqueue the input item and wait + -- while the queue is full if required + -- so that there were no hanging items + -> Process m b + -- ^ dequeue an output item + -> Processor m a b + -- ^ the buffering processor +queueProcessor enqueue dequeue = + bufferProcessor + (consumeStream enqueue) + (repeatProcess dequeue) + +-- | Like 'queueProcessor' creates a queue processor but with a loop when some items +-- can be processed and then added to the queue again. Also it allows specifying +-- how two input streams of data can be merged. +queueProcessorLoopMerging :: MonadComp m + => (Stream m a -> Stream m d -> Stream m e) + -- ^ merge two streams: the input values of type @a@ + -- and the values of type @d@ returned by the loop + -> (e -> Process m ()) + -- ^ enqueue the input item and wait + -- while the queue is full if required + -- so that there were no hanging items + -> Process m c + -- ^ dequeue an item for the further processing + -> Processor m c (Either f b) + -- ^ process and then decide what values of type @f@ + -- should be processed in the loop (this is a condition) + -> Processor m f d + -- ^ process in the loop and then return a value + -- of type @d@ to the queue again (this is a loop body) + -> Processor m a b + -- ^ the buffering processor +queueProcessorLoopMerging merge enqueue dequeue = + bufferProcessorLoop + (\bs cs -> + consumeStream enqueue $ + merge bs cs) + (repeatProcess dequeue) + +-- | Like 'queueProcessorLoopMerging' creates a queue processor with a loop when +-- some items can be processed and then added to the queue again. Only it sequentially +-- merges two input streams of data: one stream that come from the external source and +-- another stream of data returned by the loop. The first stream has a priority over +-- the second one. +queueProcessorLoopSeq :: MonadComp m + => (a -> Process m ()) + -- ^ enqueue the input item and wait + -- while the queue is full if required + -- so that there were no hanging items + -> Process m c + -- ^ dequeue an item for the further processing + -> Processor m c (Either e b) + -- ^ process and then decide what values of type @e@ + -- should be processed in the loop (this is a condition) + -> Processor m e a + -- ^ process in the loop and then return a value + -- of type @a@ to the queue again (this is a loop body) + -> Processor m a b + -- ^ the buffering processor +queueProcessorLoopSeq = + queueProcessorLoopMerging mergeStreams + +-- | Like 'queueProcessorLoopMerging' creates a queue processor with a loop when +-- some items can be processed and then added to the queue again. Only it runs two +-- simultaneous processes to enqueue the input streams of data: one stream that come +-- from the external source and another stream of data returned by the loop. +queueProcessorLoopParallel :: MonadComp m + => (a -> Process m ()) + -- ^ enqueue the input item and wait + -- while the queue is full if required + -- so that there were no hanging items + -> Process m c + -- ^ dequeue an item for the further processing + -> Processor m c (Either e b) + -- ^ process and then decide what values of type @e@ + -- should be processed in the loop (this is a condition) + -> Processor m e a + -- ^ process in the loop and then return a value + -- of type @a@ to the queue again (this is a loop body) + -> Processor m a b + -- ^ the buffering processor +queueProcessorLoopParallel enqueue dequeue = + bufferProcessorLoop + (\bs cs -> + do spawnProcess $ + consumeStream enqueue bs + spawnProcess $ + consumeStream enqueue cs) + (repeatProcess dequeue) + +-- | This is a prefetch processor that requests for one more data item from +-- the input in advance while the latest item is not yet fully processed in +-- the chain of streams, usually by other processors. +-- +-- You can think of this as the prefetched processor could place its latest +-- data item in some temporary space for later use, which is very useful +-- for modeling a sequence of separate and independent work places. +prefetchProcessor :: MonadComp m => Processor m a a +prefetchProcessor = Processor prefetchStream + +-- | Convert the specified signal transform to a processor. +-- +-- The processor may return data with delay as the values are requested by demand. +-- Consider using the 'arrivalSignal' function to provide with the information +-- about the time points at which the signal was actually triggered. +-- +-- The point is that the 'Stream' used in the 'Processor' is requested outside, +-- while the 'Signal' is triggered inside. They are different by nature. +-- The former is passive, while the latter is active. +-- +-- Cancel the processor's process to unsubscribe from the signals provided. +signalProcessor :: MonadComp m => (Signal m a -> Signal m b) -> Processor m a b +signalProcessor f = + Processor $ \xs -> + Cons $ + do sa <- streamSignal xs + sb <- signalStream (f sa) + runStream sb + +-- | Convert the specified processor to a signal transform. +-- +-- The processor may return data with delay as the values are requested by demand. +-- Consider using the 'arrivalSignal' function to provide with the information +-- about the time points at which the signal was actually triggered. +-- +-- The point is that the 'Stream' used in the 'Processor' is requested outside, +-- while the 'Signal' is triggered inside. They are different by nature. +-- The former is passive, while the latter is active. +-- +-- Cancel the returned process to unsubscribe from the signal specified. +processorSignaling :: MonadComp m => Processor m a b -> Signal m a -> Process m (Signal m b) +processorSignaling (Processor f) sa = + do xs <- signalStream sa + let ys = f xs + streamSignal ys + +-- | A processor that adds the information about the time points at which +-- the original stream items were received by demand. +arrivalProcessor :: MonadComp m => Processor m a (Arrival a) +arrivalProcessor = Processor arrivalStream + +-- | A processor that delays the input stream by one step using the specified initial value. +delayProcessor :: MonadComp m => a -> Processor m a a +delayProcessor a0 = Processor $ delayStream a0 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,59 +1,59 @@ - --- | --- Module : Simulation.Aivika.Trans.Processor.RoundRobbin --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines the Round-Robbin processor. --- -module Simulation.Aivika.Trans.Processor.RoundRobbin - (roundRobbinProcessor, - roundRobbinProcessorUsingIds) where - -import Control.Monad - -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Simulation -import Simulation.Aivika.Trans.Event -import Simulation.Aivika.Trans.Process -import Simulation.Aivika.Trans.Processor -import Simulation.Aivika.Trans.Stream -import Simulation.Aivika.Trans.Queue.Infinite - --- | Represents the Round-Robbin processor that tries to perform the task within --- the specified timeout. If the task times out, then it is canceled and returned --- to the processor again; otherwise, the successful result is redirected to output. -roundRobbinProcessor :: MonadComp m => Processor m (Process m Double, Process m a) a -roundRobbinProcessor = - Processor $ - runProcessor roundRobbinProcessorUsingIds . mapStreamM f where - f (timeout, p) = - let x = do timeout' <- timeout - pid <- liftSimulation newProcessId - return (timeout', pid) - in return (x, p) - --- | Like 'roundRobbinProcessor' but allows specifying the process identifiers which --- must be unique for every new attemp to perform the task even if the task is the same. -roundRobbinProcessorUsingIds :: MonadComp m => Processor m (Process m (Double, ProcessId m), Process m a) a -roundRobbinProcessorUsingIds = - Processor $ \xs -> - Cons $ - do q <- liftEvent newFCFSQueue - let process = - do t@(x, p) <- dequeue q - (timeout, pid) <- x - result <- timeoutProcessUsingId timeout pid p - case result of - Just a -> return a - Nothing -> - do liftEvent $ enqueue q t - process - processor = - bufferProcessor - (consumeStream $ liftEvent . enqueue q) - (repeatProcess process) - runStream $ runProcessor processor xs + +-- | +-- Module : Simulation.Aivika.Trans.Processor.RoundRobbin +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the Round-Robbin processor. +-- +module Simulation.Aivika.Trans.Processor.RoundRobbin + (roundRobbinProcessor, + roundRobbinProcessorUsingIds) where + +import Control.Monad + +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Event +import Simulation.Aivika.Trans.Process +import Simulation.Aivika.Trans.Processor +import Simulation.Aivika.Trans.Stream +import Simulation.Aivika.Trans.Queue.Infinite + +-- | Represents the Round-Robbin processor that tries to perform the task within +-- the specified timeout. If the task times out, then it is canceled and returned +-- to the processor again; otherwise, the successful result is redirected to output. +roundRobbinProcessor :: MonadComp m => Processor m (Process m Double, Process m a) a +roundRobbinProcessor = + Processor $ + runProcessor roundRobbinProcessorUsingIds . mapStreamM f where + f (timeout, p) = + let x = do timeout' <- timeout + pid <- liftSimulation newProcessId + return (timeout', pid) + in return (x, p) + +-- | Like 'roundRobbinProcessor' but allows specifying the process identifiers which +-- must be unique for every new attemp to perform the task even if the task is the same. +roundRobbinProcessorUsingIds :: MonadComp m => Processor m (Process m (Double, ProcessId m), Process m a) a +roundRobbinProcessorUsingIds = + Processor $ \xs -> + Cons $ + do q <- liftEvent newFCFSQueue + let process = + do t@(x, p) <- dequeue q + (timeout, pid) <- x + result <- timeoutProcessUsingId timeout pid p + case result of + Just a -> return a + Nothing -> + do liftEvent $ enqueue q t + process + processor = + bufferProcessor + (consumeStream $ liftEvent . enqueue q) + (repeatProcess process) + runStream $ runProcessor processor xs diff --git a/Simulation/Aivika/Trans/ProtoArray.hs b/Simulation/Aivika/Trans/ProtoArray.hs --- a/Simulation/Aivika/Trans/ProtoArray.hs +++ b/Simulation/Aivika/Trans/ProtoArray.hs @@ -1,82 +1,82 @@ - -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Simulation.Aivika.Trans.ProtoArray --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It defines a prototype of all mutable arrays. --- -module Simulation.Aivika.Trans.ProtoArray - (ProtoArrayMonad(..)) where - -import Data.Array -import Data.Array.IO.Safe - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef - --- | A monad within which computation we can create and work with --- the prototype of mutable arrays. -class ProtoRefMonad m => ProtoArrayMonad m where - - -- | A prototype of mutable array. - data ProtoArray m :: * -> * - - -- | Return the array size. - protoArrayCount :: ProtoArray m a -> m Int - - -- | Create a new ptototype of mutable array by the specified session, - -- size and initial value. - newProtoArray :: Session m -> Int -> a -> m (ProtoArray m a) - - -- | Create a new ptototype of mutable array by the specified session - -- and size with every element initialised to an undefined value. - newProtoArray_ :: Session m -> Int -> m (ProtoArray m a) - - -- | Read an element from the mutable array. - readProtoArray :: ProtoArray m a -> Int -> m a - - -- | Write the element in the mutable array. - writeProtoArray :: ProtoArray m a -> Int -> a -> m () - - -- | Return a list of the elements. - protoArrayToList :: ProtoArray m a -> m [a] - - -- | Create an array by the specified list of elements. - protoArrayFromList :: [a] -> m (ProtoArray m a) - - -- | Return the elements of the mutable array in an immutable array. - freezeProtoArray :: ProtoArray m a -> m (Array Int a) - -instance ProtoArrayMonad IO where - - newtype ProtoArray IO a = ProtoArray (IOArray Int a) - - {-# SPECIALISE INLINE protoArrayCount :: ProtoArray IO a -> IO Int #-} - protoArrayCount (ProtoArray a) = do { (0, n') <- getBounds a; return $ n' + 1 } - - {-# SPECIALISE INLINE newProtoArray :: Session IO -> Int -> a -> IO (ProtoArray IO a) #-} - newProtoArray s n a = fmap ProtoArray $ newArray (0, n - 1) a - - {-# SPECIALISE INLINE newProtoArray_ :: Session IO -> Int -> IO (ProtoArray IO a) #-} - newProtoArray_ s n = fmap ProtoArray $ newArray_ (0, n - 1) - - {-# SPECIALISE INLINE readProtoArray :: ProtoArray IO a -> Int -> IO a #-} - readProtoArray (ProtoArray a) = readArray a - - {-# SPECIALISE INLINE writeProtoArray :: ProtoArray IO a -> Int -> a -> IO () #-} - writeProtoArray (ProtoArray a) = writeArray a - - {-# SPECIALISE INLINE protoArrayToList :: ProtoArray IO a -> IO [a] #-} - protoArrayToList (ProtoArray a) = getElems a - - {-# SPECIALISE INLINE protoArrayFromList :: [a] -> IO (ProtoArray IO a) #-} - protoArrayFromList xs = fmap ProtoArray $ newListArray (0, length xs - 1) xs - - {-# SPECIALISE INLINE freezeProtoArray :: ProtoArray IO a -> IO (Array Int a) #-} - freezeProtoArray (ProtoArray a) = freeze a + +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Simulation.Aivika.Trans.ProtoArray +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It defines a prototype of all mutable arrays. +-- +module Simulation.Aivika.Trans.ProtoArray + (ProtoArrayMonad(..)) where + +import Data.Array +import Data.Array.IO.Safe + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef + +-- | A monad within which computation we can create and work with +-- the prototype of mutable arrays. +class ProtoRefMonad m => ProtoArrayMonad m where + + -- | A prototype of mutable array. + data ProtoArray m :: * -> * + + -- | Return the array size. + protoArrayCount :: ProtoArray m a -> m Int + + -- | Create a new ptototype of mutable array by the specified session, + -- size and initial value. + newProtoArray :: Session m -> Int -> a -> m (ProtoArray m a) + + -- | Create a new ptototype of mutable array by the specified session + -- and size with every element initialised to an undefined value. + newProtoArray_ :: Session m -> Int -> m (ProtoArray m a) + + -- | Read an element from the mutable array. + readProtoArray :: ProtoArray m a -> Int -> m a + + -- | Write the element in the mutable array. + writeProtoArray :: ProtoArray m a -> Int -> a -> m () + + -- | Return a list of the elements. + protoArrayToList :: ProtoArray m a -> m [a] + + -- | Create an array by the specified list of elements. + protoArrayFromList :: [a] -> m (ProtoArray m a) + + -- | Return the elements of the mutable array in an immutable array. + freezeProtoArray :: ProtoArray m a -> m (Array Int a) + +instance ProtoArrayMonad IO where + + newtype ProtoArray IO a = ProtoArray (IOArray Int a) + + {-# SPECIALISE INLINE protoArrayCount :: ProtoArray IO a -> IO Int #-} + protoArrayCount (ProtoArray a) = do { (0, n') <- getBounds a; return $ n' + 1 } + + {-# SPECIALISE INLINE newProtoArray :: Session IO -> Int -> a -> IO (ProtoArray IO a) #-} + newProtoArray s n a = fmap ProtoArray $ newArray (0, n - 1) a + + {-# SPECIALISE INLINE newProtoArray_ :: Session IO -> Int -> IO (ProtoArray IO a) #-} + newProtoArray_ s n = fmap ProtoArray $ newArray_ (0, n - 1) + + {-# SPECIALISE INLINE readProtoArray :: ProtoArray IO a -> Int -> IO a #-} + readProtoArray (ProtoArray a) = readArray a + + {-# SPECIALISE INLINE writeProtoArray :: ProtoArray IO a -> Int -> a -> IO () #-} + writeProtoArray (ProtoArray a) = writeArray a + + {-# SPECIALISE INLINE protoArrayToList :: ProtoArray IO a -> IO [a] #-} + protoArrayToList (ProtoArray a) = getElems a + + {-# SPECIALISE INLINE protoArrayFromList :: [a] -> IO (ProtoArray IO a) #-} + protoArrayFromList xs = fmap ProtoArray $ newListArray (0, length xs - 1) xs + + {-# SPECIALISE INLINE freezeProtoArray :: ProtoArray IO a -> IO (Array Int a) #-} + freezeProtoArray (ProtoArray a) = freeze a diff --git a/Simulation/Aivika/Trans/ProtoArray/Unboxed.hs b/Simulation/Aivika/Trans/ProtoArray/Unboxed.hs --- a/Simulation/Aivika/Trans/ProtoArray/Unboxed.hs +++ b/Simulation/Aivika/Trans/ProtoArray/Unboxed.hs @@ -1,98 +1,98 @@ - -{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} - --- | --- Module : Simulation.Aivika.Trans.ProtoArray.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It defines a prototype of all mutable unboxed arrays. --- -module Simulation.Aivika.Trans.ProtoArray.Unboxed - (ProtoArrayMonad(..)) where - -import Data.Array -import Data.Array.IO.Safe - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef - --- | A monad within which computation we can create and work with --- the prototype of mutable unboxed arrays. -class ProtoRefMonad m => ProtoArrayMonad m a where - - -- | A prototype of mutable unboxed array. - data ProtoArray m :: * -> * - - -- | Return the array size. - protoArrayCount :: ProtoArray m a -> m Int - - -- | Create a new ptototype of mutable array by the specified session, - -- size and initial value. - newProtoArray :: Session m -> Int -> a -> m (ProtoArray m a) - - -- | Create a new ptototype of mutable array by the specified session - -- and size with every element initialised to an undefined value. - newProtoArray_ :: Session m -> Int -> m (ProtoArray m a) - - -- | Read an element from the mutable array. - readProtoArray :: ProtoArray m a -> Int -> m a - - -- | Write the element in the mutable array. - writeProtoArray :: ProtoArray m a -> Int -> a -> m () - - -- | Return a list of the elements. - protoArrayToList :: ProtoArray m a -> m [a] - - -- | Create an array by the specified list of elements. - protoArrayFromList :: [a] -> m (ProtoArray m a) - - -- | Return the elements of the mutable array in an immutable array. - freezeProtoArray :: ProtoArray m a -> m (Array Int a) - -instance MArray IOUArray a IO => ProtoArrayMonad IO a where - - newtype ProtoArray IO a = ProtoArray (IOUArray Int a) - - {-# SPECIALISE INLINE protoArrayCount :: MArray IOUArray Double IO => ProtoArray IO Double -> IO Int #-} - {-# SPECIALISE INLINE protoArrayCount :: MArray IOUArray Float IO => ProtoArray IO Float -> IO Int #-} - {-# SPECIALISE INLINE protoArrayCount :: MArray IOUArray Int IO => ProtoArray IO Int -> IO Int #-} - protoArrayCount (ProtoArray a) = do { (0, n') <- getBounds a; return $ n' + 1 } - - {-# SPECIALISE INLINE newProtoArray :: MArray IOUArray Double IO => Session IO -> Int -> Double -> IO (ProtoArray IO Double) #-} - {-# SPECIALISE INLINE newProtoArray :: MArray IOUArray Float IO => Session IO -> Int -> Float -> IO (ProtoArray IO Float) #-} - {-# SPECIALISE INLINE newProtoArray :: MArray IOUArray Int IO => Session IO -> Int -> Int -> IO (ProtoArray IO Int) #-} - newProtoArray s n a = fmap ProtoArray $ newArray (0, n - 1) a - - {-# SPECIALISE INLINE newProtoArray_ :: MArray IOUArray Double IO => Session IO -> Int -> IO (ProtoArray IO Double) #-} - {-# SPECIALISE INLINE newProtoArray_ :: MArray IOUArray Float IO => Session IO -> Int -> IO (ProtoArray IO Float) #-} - {-# SPECIALISE INLINE newProtoArray_ :: MArray IOUArray Int IO => Session IO -> Int -> IO (ProtoArray IO Int) #-} - newProtoArray_ s n = fmap ProtoArray $ newArray_ (0, n - 1) - - {-# SPECIALISE INLINE readProtoArray :: MArray IOUArray Double IO => ProtoArray IO Double -> Int -> IO Double #-} - {-# SPECIALISE INLINE readProtoArray :: MArray IOUArray Float IO => ProtoArray IO Float -> Int -> IO Float #-} - {-# SPECIALISE INLINE readProtoArray :: MArray IOUArray Int IO => ProtoArray IO Int -> Int -> IO Int #-} - readProtoArray (ProtoArray a) = readArray a - - {-# SPECIALISE INLINE writeProtoArray :: MArray IOUArray Double IO => ProtoArray IO Double -> Int -> Double -> IO () #-} - {-# SPECIALISE INLINE writeProtoArray :: MArray IOUArray Float IO => ProtoArray IO Float -> Int -> Float -> IO () #-} - {-# SPECIALISE INLINE writeProtoArray :: MArray IOUArray Int IO => ProtoArray IO Int -> Int -> Int -> IO () #-} - writeProtoArray (ProtoArray a) = writeArray a - - {-# SPECIALISE INLINE protoArrayToList :: MArray IOUArray Double IO => ProtoArray IO Double -> IO [Double] #-} - {-# SPECIALISE INLINE protoArrayToList :: MArray IOUArray Float IO => ProtoArray IO Float -> IO [Float] #-} - {-# SPECIALISE INLINE protoArrayToList :: MArray IOUArray Int IO => ProtoArray IO Int -> IO [Int] #-} - protoArrayToList (ProtoArray a) = getElems a - - {-# SPECIALISE INLINE protoArrayFromList :: MArray IOUArray Double IO => [Double] -> IO (ProtoArray IO Double) #-} - {-# SPECIALISE INLINE protoArrayFromList :: MArray IOUArray Float IO => [Float] -> IO (ProtoArray IO Float) #-} - {-# SPECIALISE INLINE protoArrayFromList :: MArray IOUArray Int IO => [Int] -> IO (ProtoArray IO Int) #-} - protoArrayFromList xs = fmap ProtoArray $ newListArray (0, length xs - 1) xs - - {-# SPECIALISE INLINE freezeProtoArray :: MArray IOUArray Double IO => ProtoArray IO Double -> IO (Array Int Double) #-} - {-# SPECIALISE INLINE freezeProtoArray :: MArray IOUArray Float IO => ProtoArray IO Float -> IO (Array Int Float) #-} - {-# SPECIALISE INLINE freezeProtoArray :: MArray IOUArray Int IO => ProtoArray IO Int -> IO (Array Int Int) #-} - freezeProtoArray (ProtoArray a) = freeze a + +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.Trans.ProtoArray.Unboxed +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It defines a prototype of all mutable unboxed arrays. +-- +module Simulation.Aivika.Trans.ProtoArray.Unboxed + (ProtoArrayMonad(..)) where + +import Data.Array +import Data.Array.IO.Safe + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef + +-- | A monad within which computation we can create and work with +-- the prototype of mutable unboxed arrays. +class ProtoRefMonad m => ProtoArrayMonad m a where + + -- | A prototype of mutable unboxed array. + data ProtoArray m :: * -> * + + -- | Return the array size. + protoArrayCount :: ProtoArray m a -> m Int + + -- | Create a new ptototype of mutable array by the specified session, + -- size and initial value. + newProtoArray :: Session m -> Int -> a -> m (ProtoArray m a) + + -- | Create a new ptototype of mutable array by the specified session + -- and size with every element initialised to an undefined value. + newProtoArray_ :: Session m -> Int -> m (ProtoArray m a) + + -- | Read an element from the mutable array. + readProtoArray :: ProtoArray m a -> Int -> m a + + -- | Write the element in the mutable array. + writeProtoArray :: ProtoArray m a -> Int -> a -> m () + + -- | Return a list of the elements. + protoArrayToList :: ProtoArray m a -> m [a] + + -- | Create an array by the specified list of elements. + protoArrayFromList :: [a] -> m (ProtoArray m a) + + -- | Return the elements of the mutable array in an immutable array. + freezeProtoArray :: ProtoArray m a -> m (Array Int a) + +instance MArray IOUArray a IO => ProtoArrayMonad IO a where + + newtype ProtoArray IO a = ProtoArray (IOUArray Int a) + + {-# SPECIALISE INLINE protoArrayCount :: MArray IOUArray Double IO => ProtoArray IO Double -> IO Int #-} + {-# SPECIALISE INLINE protoArrayCount :: MArray IOUArray Float IO => ProtoArray IO Float -> IO Int #-} + {-# SPECIALISE INLINE protoArrayCount :: MArray IOUArray Int IO => ProtoArray IO Int -> IO Int #-} + protoArrayCount (ProtoArray a) = do { (0, n') <- getBounds a; return $ n' + 1 } + + {-# SPECIALISE INLINE newProtoArray :: MArray IOUArray Double IO => Session IO -> Int -> Double -> IO (ProtoArray IO Double) #-} + {-# SPECIALISE INLINE newProtoArray :: MArray IOUArray Float IO => Session IO -> Int -> Float -> IO (ProtoArray IO Float) #-} + {-# SPECIALISE INLINE newProtoArray :: MArray IOUArray Int IO => Session IO -> Int -> Int -> IO (ProtoArray IO Int) #-} + newProtoArray s n a = fmap ProtoArray $ newArray (0, n - 1) a + + {-# SPECIALISE INLINE newProtoArray_ :: MArray IOUArray Double IO => Session IO -> Int -> IO (ProtoArray IO Double) #-} + {-# SPECIALISE INLINE newProtoArray_ :: MArray IOUArray Float IO => Session IO -> Int -> IO (ProtoArray IO Float) #-} + {-# SPECIALISE INLINE newProtoArray_ :: MArray IOUArray Int IO => Session IO -> Int -> IO (ProtoArray IO Int) #-} + newProtoArray_ s n = fmap ProtoArray $ newArray_ (0, n - 1) + + {-# SPECIALISE INLINE readProtoArray :: MArray IOUArray Double IO => ProtoArray IO Double -> Int -> IO Double #-} + {-# SPECIALISE INLINE readProtoArray :: MArray IOUArray Float IO => ProtoArray IO Float -> Int -> IO Float #-} + {-# SPECIALISE INLINE readProtoArray :: MArray IOUArray Int IO => ProtoArray IO Int -> Int -> IO Int #-} + readProtoArray (ProtoArray a) = readArray a + + {-# SPECIALISE INLINE writeProtoArray :: MArray IOUArray Double IO => ProtoArray IO Double -> Int -> Double -> IO () #-} + {-# SPECIALISE INLINE writeProtoArray :: MArray IOUArray Float IO => ProtoArray IO Float -> Int -> Float -> IO () #-} + {-# SPECIALISE INLINE writeProtoArray :: MArray IOUArray Int IO => ProtoArray IO Int -> Int -> Int -> IO () #-} + writeProtoArray (ProtoArray a) = writeArray a + + {-# SPECIALISE INLINE protoArrayToList :: MArray IOUArray Double IO => ProtoArray IO Double -> IO [Double] #-} + {-# SPECIALISE INLINE protoArrayToList :: MArray IOUArray Float IO => ProtoArray IO Float -> IO [Float] #-} + {-# SPECIALISE INLINE protoArrayToList :: MArray IOUArray Int IO => ProtoArray IO Int -> IO [Int] #-} + protoArrayToList (ProtoArray a) = getElems a + + {-# SPECIALISE INLINE protoArrayFromList :: MArray IOUArray Double IO => [Double] -> IO (ProtoArray IO Double) #-} + {-# SPECIALISE INLINE protoArrayFromList :: MArray IOUArray Float IO => [Float] -> IO (ProtoArray IO Float) #-} + {-# SPECIALISE INLINE protoArrayFromList :: MArray IOUArray Int IO => [Int] -> IO (ProtoArray IO Int) #-} + protoArrayFromList xs = fmap ProtoArray $ newListArray (0, length xs - 1) xs + + {-# SPECIALISE INLINE freezeProtoArray :: MArray IOUArray Double IO => ProtoArray IO Double -> IO (Array Int Double) #-} + {-# SPECIALISE INLINE freezeProtoArray :: MArray IOUArray Float IO => ProtoArray IO Float -> IO (Array Int Float) #-} + {-# SPECIALISE INLINE freezeProtoArray :: MArray IOUArray Int IO => ProtoArray IO Int -> IO (Array Int Int) #-} + freezeProtoArray (ProtoArray a) = freeze a diff --git a/Simulation/Aivika/Trans/ProtoRef.hs b/Simulation/Aivika/Trans/ProtoRef.hs --- a/Simulation/Aivika/Trans/ProtoRef.hs +++ b/Simulation/Aivika/Trans/ProtoRef.hs @@ -1,61 +1,61 @@ - -{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleInstances #-} - --- | --- Module : Simulation.Aivika.Trans.ProtoRef --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It defines a prototype of mutable references. --- -module Simulation.Aivika.Trans.ProtoRef - (ProtoRefMonad(..), - ProtoRef(..)) where - -import Data.IORef - -import Simulation.Aivika.Trans.Session - --- | A monad within which computation we can create and work with --- the prototype of mutable reference. -class (Functor m, Monad m) => ProtoRefMonad m where - - -- | A prototype of mutable reference. - data ProtoRef m :: * -> * - - -- | Create a new ptototype of mutable reference by the specified session and initial value. - newProtoRef :: Session m -> a -> m (ProtoRef m a) - - -- | Read the contents of the prototype of mutable reference. - readProtoRef :: ProtoRef m a -> m a - - -- | Write a new value in the prototype of mutable reference. - writeProtoRef :: ProtoRef m a -> a -> m () - - -- | Modify a value stored in the prototype of mutable reference. - modifyProtoRef :: ProtoRef m a -> (a -> a) -> m () - - -- | A strict version of 'modifyProtoRef'. - modifyProtoRef' :: ProtoRef m a -> (a -> a) -> m () - -instance ProtoRefMonad IO where - - newtype ProtoRef IO a = ProtoRef (IORef a) - - {-# SPECIALIZE INLINE newProtoRef :: Session IO -> a -> IO (ProtoRef IO a) #-} - newProtoRef session = fmap ProtoRef . newIORef - - {-# SPECIALIZE INLINE readProtoRef :: ProtoRef IO a -> IO a #-} - readProtoRef (ProtoRef x) = readIORef x - - {-# SPECIALIZE INLINE writeProtoRef :: ProtoRef IO a -> a -> IO () #-} - writeProtoRef (ProtoRef x) = writeIORef x - - {-# SPECIALIZE INLINE modifyProtoRef :: ProtoRef IO a -> (a -> a) -> IO () #-} - modifyProtoRef (ProtoRef x) = modifyIORef x - - {-# SPECIALIZE INLINE modifyProtoRef' :: ProtoRef IO a -> (a -> a) -> IO () #-} - modifyProtoRef' (ProtoRef x) = modifyIORef' x + +{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleInstances #-} + +-- | +-- Module : Simulation.Aivika.Trans.ProtoRef +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It defines a prototype of mutable references. +-- +module Simulation.Aivika.Trans.ProtoRef + (ProtoRefMonad(..), + ProtoRef(..)) where + +import Data.IORef + +import Simulation.Aivika.Trans.Session + +-- | A monad within which computation we can create and work with +-- the prototype of mutable reference. +class (Functor m, Monad m) => ProtoRefMonad m where + + -- | A prototype of mutable reference. + data ProtoRef m :: * -> * + + -- | Create a new ptototype of mutable reference by the specified session and initial value. + newProtoRef :: Session m -> a -> m (ProtoRef m a) + + -- | Read the contents of the prototype of mutable reference. + readProtoRef :: ProtoRef m a -> m a + + -- | Write a new value in the prototype of mutable reference. + writeProtoRef :: ProtoRef m a -> a -> m () + + -- | Modify a value stored in the prototype of mutable reference. + modifyProtoRef :: ProtoRef m a -> (a -> a) -> m () + + -- | A strict version of 'modifyProtoRef'. + modifyProtoRef' :: ProtoRef m a -> (a -> a) -> m () + +instance ProtoRefMonad IO where + + newtype ProtoRef IO a = ProtoRef (IORef a) + + {-# SPECIALIZE INLINE newProtoRef :: Session IO -> a -> IO (ProtoRef IO a) #-} + newProtoRef session = fmap ProtoRef . newIORef + + {-# SPECIALIZE INLINE readProtoRef :: ProtoRef IO a -> IO a #-} + readProtoRef (ProtoRef x) = readIORef x + + {-# SPECIALIZE INLINE writeProtoRef :: ProtoRef IO a -> a -> IO () #-} + writeProtoRef (ProtoRef x) = writeIORef x + + {-# SPECIALIZE INLINE modifyProtoRef :: ProtoRef IO a -> (a -> a) -> IO () #-} + modifyProtoRef (ProtoRef x) = modifyIORef x + + {-# SPECIALIZE INLINE modifyProtoRef' :: ProtoRef IO a -> (a -> a) -> IO () #-} + modifyProtoRef' (ProtoRef x) = modifyIORef' x diff --git a/Simulation/Aivika/Trans/Queue.hs b/Simulation/Aivika/Trans/Queue.hs --- a/Simulation/Aivika/Trans/Queue.hs +++ b/Simulation/Aivika/Trans/Queue.hs @@ -1,1122 +1,1122 @@ - -{-# LANGUAGE FlexibleContexts #-} - --- | --- Module : Simulation.Aivika.Trans.Queue --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines a queue that can use the specified strategies. So, having only --- the 'FCFS', 'LCFS', 'SIRO' and 'StaticPriorities' strategies, you can build --- 4 x 4 x 4 = 64 different types of the queue, each of them will have its own --- behaviour. --- -module Simulation.Aivika.Trans.Queue - (-- * Queue Types - FCFSQueue, - LCFSQueue, - SIROQueue, - PriorityQueue, - Queue, - -- * Creating Queue - newFCFSQueue, - newLCFSQueue, - newSIROQueue, - newPriorityQueue, - newQueue, - -- * Queue Properties and Activities - enqueueStrategy, - enqueueStoringStrategy, - dequeueStrategy, - queueNull, - queueFull, - queueMaxCount, - queueCount, - queueCountStats, - enqueueCount, - enqueueLostCount, - enqueueStoreCount, - dequeueCount, - dequeueExtractCount, - queueLoadFactor, - enqueueRate, - enqueueStoreRate, - dequeueRate, - dequeueExtractRate, - queueWaitTime, - queueTotalWaitTime, - enqueueWaitTime, - dequeueWaitTime, - queueRate, - -- * Dequeuing and Enqueuing - dequeue, - dequeueWithOutputPriority, - tryDequeue, - enqueue, - enqueueWithInputPriority, - enqueueWithStoringPriority, - enqueueWithInputStoringPriorities, - tryEnqueue, - tryEnqueueWithStoringPriority, - enqueueOrLost, - enqueueOrLost_, - enqueueWithStoringPriorityOrLost, - enqueueWithStoringPriorityOrLost_, - -- * Awaiting - waitWhileFullQueue, - -- * Summary - queueSummary, - -- * Derived Signals for Properties - queueNullChanged, - queueNullChanged_, - queueFullChanged, - queueFullChanged_, - queueCountChanged, - queueCountChanged_, - enqueueCountChanged, - enqueueCountChanged_, - enqueueLostCountChanged, - enqueueLostCountChanged_, - enqueueStoreCountChanged, - enqueueStoreCountChanged_, - dequeueCountChanged, - dequeueCountChanged_, - dequeueExtractCountChanged, - dequeueExtractCountChanged_, - queueLoadFactorChanged, - queueLoadFactorChanged_, - queueWaitTimeChanged, - queueWaitTimeChanged_, - queueTotalWaitTimeChanged, - queueTotalWaitTimeChanged_, - enqueueWaitTimeChanged, - enqueueWaitTimeChanged_, - dequeueWaitTimeChanged, - dequeueWaitTimeChanged_, - queueRateChanged, - queueRateChanged_, - -- * Basic Signals - enqueueInitiated, - enqueueStored, - enqueueLost, - dequeueRequested, - dequeueExtracted, - -- * Overall Signal - queueChanged_) where - -import Data.Monoid - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Parameter -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Dynamics -import Simulation.Aivika.Trans.Internal.Event -import Simulation.Aivika.Trans.Internal.Process -import Simulation.Aivika.Trans.Internal.Signal -import Simulation.Aivika.Trans.Signal -import Simulation.Aivika.Trans.Resource -import Simulation.Aivika.Trans.QueueStrategy -import Simulation.Aivika.Trans.Statistics - --- | A type synonym for the ordinary FIFO queue also known as the FCFS --- (First Come - First Serviced) queue. -type FCFSQueue m a = Queue m FCFS FCFS FCFS a - --- | A type synonym for the ordinary LIFO queue also known as the LCFS --- (Last Come - First Serviced) queue. -type LCFSQueue m a = Queue m FCFS LCFS FCFS a - --- | A type synonym for the SIRO (Serviced in Random Order) queue. -type SIROQueue m a = Queue m FCFS SIRO FCFS a - --- | A type synonym for the queue with static priorities applied when --- storing the elements in the queue. -type PriorityQueue m a = Queue m FCFS StaticPriorities FCFS a - --- | Represents a queue using the specified strategies for enqueueing (input), @si@, --- internal storing (in memory), @sm@, and dequeueing (output), @so@, where @a@ denotes --- the type of items stored in the queue. Type @m@ denotes the underlying monad within --- which the simulation executes. -data Queue m si sm so a = - Queue { queueMaxCount :: Int, - -- ^ The queue capacity. - enqueueStrategy :: si, - -- ^ The strategy applied to the enqueueing (input) processes when the queue is full. - enqueueStoringStrategy :: sm, - -- ^ The strategy applied when storing (in memory) items in the queue. - dequeueStrategy :: so, - -- ^ The strategy applied to the dequeueing (output) processes when the queue is empty. - enqueueRes :: Resource m si, - queueStore :: StrategyQueue m sm (QueueItem a), - dequeueRes :: Resource m so, - queueCountRef :: ProtoRef m Int, - queueCountStatsRef :: ProtoRef m (TimingStats Int), - enqueueCountRef :: ProtoRef m Int, - enqueueLostCountRef :: ProtoRef m Int, - enqueueStoreCountRef :: ProtoRef m Int, - dequeueCountRef :: ProtoRef m Int, - dequeueExtractCountRef :: ProtoRef m Int, - queueWaitTimeRef :: ProtoRef m (SamplingStats Double), - queueTotalWaitTimeRef :: ProtoRef m (SamplingStats Double), - enqueueWaitTimeRef :: ProtoRef m (SamplingStats Double), - dequeueWaitTimeRef :: ProtoRef m (SamplingStats Double), - enqueueInitiatedSource :: SignalSource m a, - enqueueLostSource :: SignalSource m a, - enqueueStoredSource :: SignalSource m a, - dequeueRequestedSource :: SignalSource m (), - dequeueExtractedSource :: SignalSource m a } - --- | Stores the item and a time of its enqueuing. -data QueueItem a = - QueueItem { itemValue :: a, - -- ^ Return the item value. - itemInputTime :: Double, - -- ^ Return the time of enqueuing the item. - itemStoringTime :: Double - -- ^ Return the time of storing in the queue, or - -- @itemInputTime@ before the actual storing when - -- the item was just enqueued. - } - --- | Create a new FCFS queue with the specified capacity. -newFCFSQueue :: MonadComp m => Int -> Event m (FCFSQueue m a) -newFCFSQueue = newQueue FCFS FCFS FCFS - --- | Create a new LCFS queue with the specified capacity. -newLCFSQueue :: MonadComp m => Int -> Event m (LCFSQueue m a) -newLCFSQueue = newQueue FCFS LCFS FCFS - --- | Create a new SIRO queue with the specified capacity. -newSIROQueue :: MonadComp m => Int -> Event m (SIROQueue m a) -newSIROQueue = newQueue FCFS SIRO FCFS - --- | Create a new priority queue with the specified capacity. -newPriorityQueue :: MonadComp m => Int -> Event m (PriorityQueue m a) -newPriorityQueue = newQueue FCFS StaticPriorities FCFS - --- | Create a new queue with the specified strategies and capacity. -newQueue :: (MonadComp m, - QueueStrategy m si, - QueueStrategy m sm, - QueueStrategy m so) => - si - -- ^ the strategy applied to the enqueueing (input) processes when the queue is full - -> sm - -- ^ the strategy applied when storing items in the queue - -> so - -- ^ the strategy applied to the dequeueing (output) processes when the queue is empty - -> Int - -- ^ the queue capacity - -> Event m (Queue m si sm so a) -newQueue si sm so count = - do t <- liftDynamics time - sn <- liftParameter simulationSession - i <- liftComp $ newProtoRef sn 0 - is <- liftComp $ newProtoRef sn $ returnTimingStats t 0 - ci <- liftComp $ newProtoRef sn 0 - cl <- liftComp $ newProtoRef sn 0 - cm <- liftComp $ newProtoRef sn 0 - cr <- liftComp $ newProtoRef sn 0 - co <- liftComp $ newProtoRef sn 0 - ri <- liftSimulation $ newResourceWithMaxCount si count (Just count) - qm <- liftSimulation $ newStrategyQueue sm - ro <- liftSimulation $ newResourceWithMaxCount so 0 (Just count) - w <- liftComp $ newProtoRef sn mempty - wt <- liftComp $ newProtoRef sn mempty - wi <- liftComp $ newProtoRef sn mempty - wo <- liftComp $ newProtoRef sn mempty - s1 <- liftSimulation $ newSignalSource - s2 <- liftSimulation $ newSignalSource - s3 <- liftSimulation $ newSignalSource - s4 <- liftSimulation $ newSignalSource - s5 <- liftSimulation $ newSignalSource - return Queue { queueMaxCount = count, - enqueueStrategy = si, - enqueueStoringStrategy = sm, - dequeueStrategy = so, - enqueueRes = ri, - queueStore = qm, - dequeueRes = ro, - queueCountRef = i, - queueCountStatsRef = is, - enqueueCountRef = ci, - enqueueLostCountRef = cl, - enqueueStoreCountRef = cm, - dequeueCountRef = cr, - dequeueExtractCountRef = co, - queueWaitTimeRef = w, - queueTotalWaitTimeRef = wt, - enqueueWaitTimeRef = wi, - dequeueWaitTimeRef = wo, - enqueueInitiatedSource = s1, - enqueueLostSource = s2, - enqueueStoredSource = s3, - dequeueRequestedSource = s4, - dequeueExtractedSource = s5 } - --- | Test whether the queue is empty. --- --- See also 'queueNullChanged' and 'queueNullChanged_'. -queueNull :: MonadComp m => Queue m si sm so a -> Event m Bool -queueNull q = - Event $ \p -> - do n <- readProtoRef (queueCountRef q) - return (n == 0) - --- | Signal when the 'queueNull' property value has changed. -queueNullChanged :: MonadComp m => Queue m si sm so a -> Signal m Bool -queueNullChanged q = - mapSignalM (const $ queueNull q) (queueNullChanged_ q) - --- | Signal when the 'queueNull' property value has changed. -queueNullChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () -queueNullChanged_ = queueCountChanged_ - --- | Test whether the queue is full. --- --- See also 'queueFullChanged' and 'queueFullChanged_'. -queueFull :: MonadComp m => Queue m si sm so a -> Event m Bool -queueFull q = - Event $ \p -> - do n <- readProtoRef (queueCountRef q) - return (n == queueMaxCount q) - --- | Signal when the 'queueFull' property value has changed. -queueFullChanged :: MonadComp m => Queue m si sm so a -> Signal m Bool -queueFullChanged q = - mapSignalM (const $ queueFull q) (queueFullChanged_ q) - --- | Signal when the 'queueFull' property value has changed. -queueFullChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () -queueFullChanged_ = queueCountChanged_ - --- | Return the current queue size. --- --- See also 'queueCountStats', 'queueCountChanged' and 'queueCountChanged_'. -queueCount :: MonadComp m => Queue m si sm so a -> Event m Int -queueCount q = - Event $ \p -> readProtoRef (queueCountRef q) - --- | Return the queue size statistics. -queueCountStats :: MonadComp m => Queue m si sm so a -> Event m (TimingStats Int) -queueCountStats q = - Event $ \p -> readProtoRef (queueCountStatsRef q) - --- | Signal when the 'queueCount' property value has changed. -queueCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int -queueCountChanged q = - mapSignalM (const $ queueCount q) (queueCountChanged_ q) - --- | Signal when the 'queueCount' property value has changed. -queueCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () -queueCountChanged_ q = - mapSignal (const ()) (enqueueStored q) <> - mapSignal (const ()) (dequeueExtracted q) - --- | Return the total number of input items that were enqueued. --- --- See also 'enqueueCountChanged' and 'enqueueCountChanged_'. -enqueueCount :: MonadComp m => Queue m si sm so a -> Event m Int -enqueueCount q = - Event $ \p -> readProtoRef (enqueueCountRef q) - --- | Signal when the 'enqueueCount' property value has changed. -enqueueCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int -enqueueCountChanged q = - mapSignalM (const $ enqueueCount q) (enqueueCountChanged_ q) - --- | Signal when the 'enqueueCount' property value has changed. -enqueueCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () -enqueueCountChanged_ q = - mapSignal (const ()) (enqueueInitiated q) - --- | Return the number of lost items. --- --- See also 'enqueueLostCountChanged' and 'enqueueLostCountChanged_'. -enqueueLostCount :: MonadComp m => Queue m si sm so a -> Event m Int -enqueueLostCount q = - Event $ \p -> readProtoRef (enqueueLostCountRef q) - --- | Signal when the 'enqueueLostCount' property value has changed. -enqueueLostCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int -enqueueLostCountChanged q = - mapSignalM (const $ enqueueLostCount q) (enqueueLostCountChanged_ q) - --- | Signal when the 'enqueueLostCount' property value has changed. -enqueueLostCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () -enqueueLostCountChanged_ q = - mapSignal (const ()) (enqueueLost q) - --- | Return the total number of input items that were stored. --- --- See also 'enqueueStoreCountChanged' and 'enqueueStoreCountChanged_'. -enqueueStoreCount :: MonadComp m => Queue m si sm so a -> Event m Int -enqueueStoreCount q = - Event $ \p -> readProtoRef (enqueueStoreCountRef q) - --- | Signal when the 'enqueueStoreCount' property value has changed. -enqueueStoreCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int -enqueueStoreCountChanged q = - mapSignalM (const $ enqueueStoreCount q) (enqueueStoreCountChanged_ q) - --- | Signal when the 'enqueueStoreCount' property value has changed. -enqueueStoreCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () -enqueueStoreCountChanged_ q = - mapSignal (const ()) (enqueueStored q) - --- | Return the total number of requests for dequeueing the items, --- not taking into account the failed attempts to dequeue immediately --- without suspension. --- --- See also 'dequeueCountChanged' and 'dequeueCountChanged_'. -dequeueCount :: MonadComp m => Queue m si sm so a -> Event m Int -dequeueCount q = - Event $ \p -> readProtoRef (dequeueCountRef q) - --- | Signal when the 'dequeueCount' property value has changed. -dequeueCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int -dequeueCountChanged q = - mapSignalM (const $ dequeueCount q) (dequeueCountChanged_ q) - --- | Signal when the 'dequeueCount' property value has changed. -dequeueCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () -dequeueCountChanged_ q = - mapSignal (const ()) (dequeueRequested q) - --- | Return the total number of output items that were actually dequeued. --- --- See also 'dequeueExtractCountChanged' and 'dequeueExtractCountChanged_'. -dequeueExtractCount :: MonadComp m => Queue m si sm so a -> Event m Int -dequeueExtractCount q = - Event $ \p -> readProtoRef (dequeueExtractCountRef q) - --- | Signal when the 'dequeueExtractCount' property value has changed. -dequeueExtractCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int -dequeueExtractCountChanged q = - mapSignalM (const $ dequeueExtractCount q) (dequeueExtractCountChanged_ q) - --- | Signal when the 'dequeueExtractCount' property value has changed. -dequeueExtractCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () -dequeueExtractCountChanged_ q = - mapSignal (const ()) (dequeueExtracted q) - --- | Return the load factor: the queue size divided by its maximum size. --- --- See also 'queueLoadFactorChanged' and 'queueLoadFactorChanged_'. -queueLoadFactor :: MonadComp m => Queue m si sm so a -> Event m Double -queueLoadFactor q = - Event $ \p -> - do x <- readProtoRef (queueCountRef q) - let y = queueMaxCount q - return (fromIntegral x / fromIntegral y) - --- | Signal when the 'queueLoadFactor' property value has changed. -queueLoadFactorChanged :: MonadComp m => Queue m si sm so a -> Signal m Double -queueLoadFactorChanged q = - mapSignalM (const $ queueLoadFactor q) (queueLoadFactorChanged_ q) - --- | Signal when the 'queueLoadFactor' property value has changed. -queueLoadFactorChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () -queueLoadFactorChanged_ q = - mapSignal (const ()) (enqueueStored q) <> - mapSignal (const ()) (dequeueExtracted q) - --- | Return the rate of the input items that were enqueued: how many items --- per time. -enqueueRate :: MonadComp m => Queue m si sm so a -> Event m Double -enqueueRate q = - Event $ \p -> - do x <- readProtoRef (enqueueCountRef q) - let t0 = spcStartTime $ pointSpecs p - t = pointTime p - return (fromIntegral x / (t - t0)) - --- | Return the rate of the items that were stored: how many items --- per time. -enqueueStoreRate :: MonadComp m => Queue m si sm so a -> Event m Double -enqueueStoreRate q = - Event $ \p -> - do x <- readProtoRef (enqueueStoreCountRef q) - let t0 = spcStartTime $ pointSpecs p - t = pointTime p - return (fromIntegral x / (t - t0)) - --- | Return the rate of the requests for dequeueing the items: how many requests --- per time. It does not include the failed attempts to dequeue immediately --- without suspension. -dequeueRate :: MonadComp m => Queue m si sm so a -> Event m Double -dequeueRate q = - Event $ \p -> - do x <- readProtoRef (dequeueCountRef q) - let t0 = spcStartTime $ pointSpecs p - t = pointTime p - return (fromIntegral x / (t - t0)) - --- | Return the rate of the output items that were actually dequeued: how many items --- per time. -dequeueExtractRate :: MonadComp m => Queue m si sm so a -> Event m Double -dequeueExtractRate q = - Event $ \p -> - do x <- readProtoRef (dequeueExtractCountRef q) - let t0 = spcStartTime $ pointSpecs p - t = pointTime p - return (fromIntegral x / (t - t0)) - --- | Return the wait time from the time at which the item was stored in the queue to --- the time at which it was dequeued. --- --- See also 'queueWaitTimeChanged' and 'queueWaitTimeChanged_'. -queueWaitTime :: MonadComp m => Queue m si sm so a -> Event m (SamplingStats Double) -queueWaitTime q = - Event $ \p -> readProtoRef (queueWaitTimeRef q) - --- | Signal when the 'queueWaitTime' property value has changed. -queueWaitTimeChanged :: MonadComp m => Queue m si sm so a -> Signal m (SamplingStats Double) -queueWaitTimeChanged q = - mapSignalM (const $ queueWaitTime q) (queueWaitTimeChanged_ q) - --- | Signal when the 'queueWaitTime' property value has changed. -queueWaitTimeChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () -queueWaitTimeChanged_ q = - mapSignal (const ()) (dequeueExtracted q) - --- | Return the total wait time from the time at which the enqueueing operation --- was initiated to the time at which the item was dequeued. --- --- In some sense, @queueTotalWaitTime == queueInputWaitTime + queueWaitTime@. --- --- See also 'queueTotalWaitTimeChanged' and 'queueTotalWaitTimeChanged_'. -queueTotalWaitTime :: MonadComp m => Queue m si sm so a -> Event m (SamplingStats Double) -queueTotalWaitTime q = - Event $ \p -> readProtoRef (queueTotalWaitTimeRef q) - --- | Signal when the 'queueTotalWaitTime' property value has changed. -queueTotalWaitTimeChanged :: MonadComp m => Queue m si sm so a -> Signal m (SamplingStats Double) -queueTotalWaitTimeChanged q = - mapSignalM (const $ queueTotalWaitTime q) (queueTotalWaitTimeChanged_ q) - --- | Signal when the 'queueTotalWaitTime' property value has changed. -queueTotalWaitTimeChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () -queueTotalWaitTimeChanged_ q = - mapSignal (const ()) (dequeueExtracted q) - --- | Return the enqueue wait time from the time at which the enqueueing operation --- was initiated to the time at which the item was stored in the queue. --- --- See also 'enqueueWaitTimeChanged' and 'enqueueWaitTimeChanged_'. -enqueueWaitTime :: MonadComp m => Queue m si sm so a -> Event m (SamplingStats Double) -enqueueWaitTime q = - Event $ \p -> readProtoRef (enqueueWaitTimeRef q) - --- | Signal when the 'enqueueWaitTime' property value has changed. -enqueueWaitTimeChanged :: MonadComp m => Queue m si sm so a -> Signal m (SamplingStats Double) -enqueueWaitTimeChanged q = - mapSignalM (const $ enqueueWaitTime q) (enqueueWaitTimeChanged_ q) - --- | Signal when the 'enqueueWaitTime' property value has changed. -enqueueWaitTimeChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () -enqueueWaitTimeChanged_ q = - mapSignal (const ()) (enqueueStored q) - --- | 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. --- --- See also 'dequeueWaitTimeChanged' and 'dequeueWaitTimeChanged_'. -dequeueWaitTime :: MonadComp m => Queue m si sm so a -> Event m (SamplingStats Double) -dequeueWaitTime q = - Event $ \p -> readProtoRef (dequeueWaitTimeRef q) - --- | Signal when the 'dequeueWaitTime' property value has changed. -dequeueWaitTimeChanged :: MonadComp m => Queue m si sm so a -> Signal m (SamplingStats Double) -dequeueWaitTimeChanged q = - mapSignalM (const $ dequeueWaitTime q) (dequeueWaitTimeChanged_ q) - --- | Signal when the 'dequeueWaitTime' property value has changed. -dequeueWaitTimeChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () -dequeueWaitTimeChanged_ q = - mapSignal (const ()) (dequeueExtracted q) - --- | Return a long-term average queue rate calculated as --- the average queue size divided by the average wait time. --- --- This value may be less than the actual arrival rate as the queue is --- finite and new arrivals may be locked while the queue remains full. --- --- See also 'queueRateChanged' and 'queueRateChanged_'. -queueRate :: MonadComp m => Queue m si sm so a -> Event m Double -queueRate q = - Event $ \p -> - do x <- readProtoRef (queueCountStatsRef q) - y <- readProtoRef (queueWaitTimeRef q) - return (timingStatsMean x / samplingStatsMean y) - --- | Signal when the 'queueRate' property value has changed. -queueRateChanged :: MonadComp m => Queue m si sm so a -> Signal m Double -queueRateChanged q = - mapSignalM (const $ queueRate q) (queueRateChanged_ q) - --- | Signal when the 'queueRate' property value has changed. -queueRateChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () -queueRateChanged_ q = - mapSignal (const ()) (enqueueStored q) <> - mapSignal (const ()) (dequeueExtracted q) - --- | Dequeue suspending the process if the queue is empty. -dequeue :: (MonadComp m, - DequeueStrategy m si, - DequeueStrategy m sm, - EnqueueStrategy m so) - => Queue m si sm so a - -- ^ the queue - -> Process m a - -- ^ the dequeued value -dequeue q = - do t <- liftEvent $ dequeueRequest q - requestResource (dequeueRes q) - liftEvent $ dequeueExtract q t - --- | Dequeue with the output priority suspending the process if the queue is empty. -dequeueWithOutputPriority :: (MonadComp m, - DequeueStrategy m si, - DequeueStrategy m sm, - PriorityQueueStrategy m so po) - => Queue m si sm so a - -- ^ the queue - -> po - -- ^ the priority for output - -> Process m a - -- ^ the dequeued value -dequeueWithOutputPriority q po = - do t <- liftEvent $ dequeueRequest q - requestResourceWithPriority (dequeueRes q) po - liftEvent $ dequeueExtract q t - --- | Try to dequeue immediately. -tryDequeue :: (MonadComp m, - DequeueStrategy m si, - DequeueStrategy m sm) - => Queue m si sm so a - -- ^ the queue - -> Event m (Maybe a) - -- ^ the dequeued value of 'Nothing' -tryDequeue q = - do x <- tryRequestResourceWithinEvent (dequeueRes q) - if x - then do t <- dequeueRequest q - fmap Just $ dequeueExtract q t - else return Nothing - --- | Enqueue the item suspending the process if the queue is full. -enqueue :: (MonadComp m, - EnqueueStrategy m si, - EnqueueStrategy m sm, - DequeueStrategy m so) - => Queue m si sm so a - -- ^ the queue - -> a - -- ^ the item to enqueue - -> Process m () -enqueue q a = - do i <- liftEvent $ enqueueInitiate q a - requestResource (enqueueRes q) - liftEvent $ enqueueStore q i - --- | Enqueue with the input priority the item suspending the process if the queue is full. -enqueueWithInputPriority :: (MonadComp m, - PriorityQueueStrategy m si pi, - EnqueueStrategy m sm, - DequeueStrategy m so) - => Queue m si sm so a - -- ^ the queue - -> pi - -- ^ the priority for input - -> a - -- ^ the item to enqueue - -> Process m () -enqueueWithInputPriority q pi a = - do i <- liftEvent $ enqueueInitiate q a - requestResourceWithPriority (enqueueRes q) pi - liftEvent $ enqueueStore q i - --- | Enqueue with the storing priority the item suspending the process if the queue is full. -enqueueWithStoringPriority :: (MonadComp m, - EnqueueStrategy m si, - PriorityQueueStrategy m sm pm, - DequeueStrategy m so) - => Queue m si sm so a - -- ^ the queue - -> pm - -- ^ the priority for storing - -> a - -- ^ the item to enqueue - -> Process m () -enqueueWithStoringPriority q pm a = - do i <- liftEvent $ enqueueInitiate q a - requestResource (enqueueRes q) - liftEvent $ enqueueStoreWithPriority q pm i - --- | Enqueue with the input and storing priorities the item suspending the process if the queue is full. -enqueueWithInputStoringPriorities :: (MonadComp m, - PriorityQueueStrategy m si pi, - PriorityQueueStrategy m sm pm, - DequeueStrategy m so) - => Queue m si sm so a - -- ^ the queue - -> pi - -- ^ the priority for input - -> pm - -- ^ the priority for storing - -> a - -- ^ the item to enqueue - -> Process m () -enqueueWithInputStoringPriorities q pi pm a = - do i <- liftEvent $ enqueueInitiate q a - requestResourceWithPriority (enqueueRes q) pi - liftEvent $ enqueueStoreWithPriority q pm i - --- | Try to enqueue the item. Return 'False' in the monad if the queue is full. -tryEnqueue :: (MonadComp m, - EnqueueStrategy m sm, - DequeueStrategy m so) - => Queue m si sm so a - -- ^ the queue - -> a - -- ^ the item which we try to enqueue - -> Event m Bool -tryEnqueue q a = - do x <- tryRequestResourceWithinEvent (enqueueRes q) - if x - then do enqueueInitiate q a >>= enqueueStore q - return True - else return False - --- | Try to enqueue with the storing priority the item. Return 'False' in --- the monad if the queue is full. -tryEnqueueWithStoringPriority :: (MonadComp m, - PriorityQueueStrategy m sm pm, - DequeueStrategy m so) - => Queue m si sm so a - -- ^ the queue - -> pm - -- ^ the priority for storing - -> a - -- ^ the item which we try to enqueue - -> Event m Bool -tryEnqueueWithStoringPriority q pm a = - do x <- tryRequestResourceWithinEvent (enqueueRes q) - if x - then do enqueueInitiate q a >>= enqueueStoreWithPriority q pm - return True - else return False - --- | Try to enqueue the item. If the queue is full then the item will be lost --- and 'False' will be returned. -enqueueOrLost :: (MonadComp m, - EnqueueStrategy m sm, - DequeueStrategy m so) - => Queue m si sm so a - -- ^ the queue - -> a - -- ^ the item which we try to enqueue - -> Event m Bool -enqueueOrLost q a = - do x <- tryRequestResourceWithinEvent (enqueueRes q) - if x - then do enqueueInitiate q a >>= enqueueStore q - return True - else do enqueueDeny q a - return False - --- | Try to enqueue with the storing priority the item. If the queue is full --- then the item will be lost and 'False' will be returned. -enqueueWithStoringPriorityOrLost :: (MonadComp m, - PriorityQueueStrategy m sm pm, - DequeueStrategy m so) - => Queue m si sm so a - -- ^ the queue - -> pm - -- ^ the priority for storing - -> a - -- ^ the item which we try to enqueue - -> Event m Bool -enqueueWithStoringPriorityOrLost q pm a = - do x <- tryRequestResourceWithinEvent (enqueueRes q) - if x - then do enqueueInitiate q a >>= enqueueStoreWithPriority q pm - return True - else do enqueueDeny q a - return False - --- | Try to enqueue the item. If the queue is full then the item will be lost. -enqueueOrLost_ :: (MonadComp m, - EnqueueStrategy m sm, - DequeueStrategy m so) - => Queue m si sm so a - -- ^ the queue - -> a - -- ^ the item which we try to enqueue - -> Event m () -enqueueOrLost_ q a = - do x <- enqueueOrLost q a - return () - --- | Try to enqueue with the storing priority the item. If the queue is full --- then the item will be lost. -enqueueWithStoringPriorityOrLost_ :: (MonadComp m, - PriorityQueueStrategy m sm pm, - DequeueStrategy m so) - => Queue m si sm so a - -- ^ the queue - -> pm - -- ^ the priority for storing - -> a - -- ^ the item which we try to enqueue - -> Event m () -enqueueWithStoringPriorityOrLost_ q pm a = - do x <- enqueueWithStoringPriorityOrLost q pm a - return () - --- | Return a signal that notifies when the enqueuing operation is initiated. -enqueueInitiated :: MonadComp m => Queue m si sm so a -> Signal m a -enqueueInitiated q = publishSignal (enqueueInitiatedSource q) - --- | Return a signal that notifies when the enqueuing operation is completed --- and the item is stored in the internal memory of the queue. -enqueueStored :: MonadComp m => Queue m si sm so a -> Signal m a -enqueueStored q = publishSignal (enqueueStoredSource q) - --- | Return a signal which notifies that the item was lost when --- attempting to add it to the full queue with help of --- 'enqueueOrLost', 'enqueueOrLost_' or similar functions that imply --- that the element can be lost. All their names are ending with @OrLost@ --- or @OrLost_@. --- --- In other cases the enqueued items are not lost but the corresponded process --- can suspend until the internal queue storage is freed. Although there is one --- exception from this rule. If the process trying to enqueue a new element was --- suspended but then canceled through 'cancelProcess' from the outside then --- the item will not be added. -enqueueLost :: MonadComp m => Queue m si sm so a -> Signal m a -enqueueLost q = publishSignal (enqueueLostSource q) - --- | Return a signal that notifies when the dequeuing operation was requested. -dequeueRequested :: MonadComp m => Queue m si sm so a -> Signal m () -dequeueRequested q = publishSignal (dequeueRequestedSource q) - --- | Return a signal that notifies when the item was extracted from the internal --- storage of the queue and prepared for immediate receiving by the dequeuing process. -dequeueExtracted :: MonadComp m => Queue m si sm so a -> Signal m a -dequeueExtracted q = publishSignal (dequeueExtractedSource q) - --- | Initiate the process of enqueuing the item. -enqueueInitiate :: MonadComp m - => Queue m si sm so a - -- ^ the queue - -> a - -- ^ the item to be enqueued - -> Event m (QueueItem a) -enqueueInitiate q a = - Event $ \p -> - do let t = pointTime p - modifyProtoRef' (enqueueCountRef q) (+ 1) - invokeEvent p $ - triggerSignal (enqueueInitiatedSource q) a - return QueueItem { itemValue = a, - itemInputTime = t, - itemStoringTime = t -- it will be updated soon - } - --- | Store the item. -enqueueStore :: (MonadComp m, - EnqueueStrategy m sm, - DequeueStrategy m so) - => Queue m si sm so a - -- ^ the queue - -> QueueItem a - -- ^ the item to be stored - -> Event m () -enqueueStore q i = - Event $ \p -> - do let i' = i { itemStoringTime = pointTime p } -- now we have the actual time of storing - invokeEvent p $ - strategyEnqueue (queueStore q) i' - c <- readProtoRef (queueCountRef q) - let c' = c + 1 - t = pointTime p - c' `seq` writeProtoRef (queueCountRef q) c' - modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c') - modifyProtoRef' (enqueueStoreCountRef q) (+ 1) - invokeEvent p $ - enqueueStat q i' - invokeEvent p $ - releaseResourceWithinEvent (dequeueRes q) - invokeEvent p $ - triggerSignal (enqueueStoredSource q) (itemValue i') - --- | Store with the priority the item. -enqueueStoreWithPriority :: (MonadComp m, - PriorityQueueStrategy m sm pm, - DequeueStrategy m so) - => Queue m si sm so a - -- ^ the queue - -> pm - -- ^ the priority for storing - -> QueueItem a - -- ^ the item to be enqueued - -> Event m () -enqueueStoreWithPriority q pm i = - Event $ \p -> - do let i' = i { itemStoringTime = pointTime p } -- now we have the actual time of storing - invokeEvent p $ - strategyEnqueueWithPriority (queueStore q) pm i' - c <- readProtoRef (queueCountRef q) - let c' = c + 1 - t = pointTime p - c' `seq` writeProtoRef (queueCountRef q) c' - modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c') - modifyProtoRef' (enqueueStoreCountRef q) (+ 1) - invokeEvent p $ - enqueueStat q i' - invokeEvent p $ - releaseResourceWithinEvent (dequeueRes q) - invokeEvent p $ - triggerSignal (enqueueStoredSource q) (itemValue i') - --- | Deny the enqueuing. -enqueueDeny :: MonadComp m - => Queue m si sm so a - -- ^ the queue - -> a - -- ^ the item to be denied - -> Event m () -enqueueDeny q a = - Event $ \p -> - do modifyProtoRef' (enqueueLostCountRef q) $ (+) 1 - invokeEvent p $ - triggerSignal (enqueueLostSource q) a - --- | Update the statistics for the input wait time of the enqueuing operation. -enqueueStat :: MonadComp m - => Queue m si sm so a - -- ^ the queue - -> QueueItem a - -- ^ the item and its input time - -> Event m () - -- ^ the action of updating the statistics -enqueueStat q i = - Event $ \p -> - do let t0 = itemInputTime i - t1 = itemStoringTime i - modifyProtoRef' (enqueueWaitTimeRef q) $ - addSamplingStats (t1 - t0) - --- | Accept the dequeuing request and return the current simulation time. -dequeueRequest :: MonadComp m - => Queue m si sm so a - -- ^ the queue - -> Event m Double - -- ^ the current time -dequeueRequest q = - Event $ \p -> - do modifyProtoRef' (dequeueCountRef q) (+ 1) - invokeEvent p $ - triggerSignal (dequeueRequestedSource q) () - return $ pointTime p - --- | Extract an item for the dequeuing request. -dequeueExtract :: (MonadComp m, - DequeueStrategy m si, - DequeueStrategy m sm) - => Queue m si sm so a - -- ^ the queue - -> Double - -- ^ the time of the dequeuing request - -> Event m a - -- ^ the dequeued value -dequeueExtract q t' = - Event $ \p -> - do i <- invokeEvent p $ - strategyDequeue (queueStore q) - c <- readProtoRef (queueCountRef q) - let c' = c - 1 - t = pointTime p - c' `seq` writeProtoRef (queueCountRef q) c' - modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c') - modifyProtoRef' (dequeueExtractCountRef q) (+ 1) - invokeEvent p $ - dequeueStat q t' i - invokeEvent p $ - releaseResourceWithinEvent (enqueueRes q) - invokeEvent p $ - triggerSignal (dequeueExtractedSource q) (itemValue i) - return $ itemValue i - --- | Update the statistics for the output wait time of the dequeuing operation --- and the wait time of storing in the queue. -dequeueStat :: MonadComp m - => Queue m si sm so a - -- ^ the queue - -> Double - -- ^ the time of the dequeuing request - -> QueueItem a - -- ^ the item and its input time - -> Event m () - -- ^ the action of updating the statistics -dequeueStat q t' i = - Event $ \p -> - do let t0 = itemInputTime i - t1 = itemStoringTime i - t = pointTime p - modifyProtoRef' (dequeueWaitTimeRef q) $ - addSamplingStats (t - t') - modifyProtoRef' (queueTotalWaitTimeRef q) $ - addSamplingStats (t - t0) - modifyProtoRef' (queueWaitTimeRef q) $ - addSamplingStats (t - t1) - --- | Wait while the queue is full. -waitWhileFullQueue :: MonadComp m => Queue m si sm so a -> Process m () -waitWhileFullQueue q = - do x <- liftEvent (queueFull q) - when x $ - do processAwait (dequeueExtracted q) - waitWhileFullQueue q - --- | Signal whenever any property of the queue changes. --- --- The property must have the corresponded signal. There are also characteristics --- similar to the properties but that have no signals. As a rule, such characteristics --- already depend on the simulation time and therefore they may change at any --- time point. -queueChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () -queueChanged_ q = - mapSignal (const ()) (enqueueInitiated q) <> - mapSignal (const ()) (enqueueStored q) <> - mapSignal (const ()) (enqueueLost q) <> - dequeueRequested q <> - mapSignal (const ()) (dequeueExtracted q) - --- | Return the summary for the queue with desciption of its --- properties and activities using the specified indent. -queueSummary :: (MonadComp m, Show si, Show sm, Show so) => Queue m si sm so a -> Int -> Event m ShowS -queueSummary q indent = - do let si = enqueueStrategy q - sm = enqueueStoringStrategy q - so = dequeueStrategy q - null <- queueNull q - full <- queueFull q - let maxCount = queueMaxCount q - count <- queueCount q - countStats <- queueCountStats q - enqueueCount <- enqueueCount q - enqueueLostCount <- enqueueLostCount q - enqueueStoreCount <- enqueueStoreCount q - dequeueCount <- dequeueCount q - dequeueExtractCount <- dequeueExtractCount q - loadFactor <- queueLoadFactor q - enqueueRate <- enqueueRate q - enqueueStoreRate <- enqueueStoreRate q - dequeueRate <- dequeueRate q - dequeueExtractRate <- dequeueExtractRate q - waitTime <- queueWaitTime q - totalWaitTime <- queueTotalWaitTime q - enqueueWaitTime <- enqueueWaitTime q - dequeueWaitTime <- dequeueWaitTime q - let tab = replicate indent ' ' - return $ - showString tab . - showString "the enqueueing (input) strategy = " . - shows si . - showString "\n" . - showString tab . - showString "the storing (memory) strategy = " . - shows sm . - showString "\n" . - showString tab . - showString "the dequeueing (output) strategy = " . - shows so . - showString "\n" . - showString tab . - showString "empty? = " . - shows null . - showString "\n" . - showString tab . - showString "full? = " . - shows full . - showString "\n" . - showString tab . - showString "max. capacity = " . - shows maxCount . - showString "\n" . - showString tab . - showString "size = " . - shows count . - showString "\n" . - showString tab . - showString "the size statistics = \n\n" . - timingStatsSummary countStats (2 + indent) . - showString "\n\n" . - showString tab . - showString "the enqueue count (number of the input items that were enqueued) = " . - shows enqueueCount . - showString "\n" . - showString tab . - showString "the enqueue lost count (number of the lost items) = " . - shows enqueueLostCount . - showString "\n" . - showString tab . - showString "the enqueue store count (number of the input items that were stored) = " . - shows enqueueStoreCount . - showString "\n" . - showString tab . - showString "the dequeue count (number of requests for dequeueing an item) = " . - shows dequeueCount . - showString "\n" . - showString tab . - showString "the dequeue extract count (number of the output items that were dequeued) = " . - shows dequeueExtractCount . - showString "\n" . - showString tab . - showString "the load factor (size / max. capacity) = " . - shows loadFactor . - showString "\n" . - showString tab . - showString "the enqueue rate (how many input items were enqueued per time) = " . - shows enqueueRate . - showString "\n" . - showString tab . - showString "the enqueue store rate (how many input items were stored per time) = " . - shows enqueueStoreRate . - showString "\n" . - showString tab . - showString "the dequeue rate (how many requests for dequeueing per time) = " . - shows dequeueRate . - showString "\n" . - showString tab . - showString "the dequeue extract rate (how many output items were dequeued per time) = " . - shows dequeueExtractRate . - showString "\n" . - showString tab . - showString "the wait time (when was stored -> when was dequeued) = \n\n" . - samplingStatsSummary waitTime (2 + indent) . - showString "\n\n" . - showString tab . - showString "the total wait time (when the enqueueing was initiated -> when was dequeued) = \n\n" . - samplingStatsSummary totalWaitTime (2 + indent) . - showString "\n\n" . - showString tab . - showString "the enqueue wait time (when the enqueueing was initiated -> when was stored) = \n\n" . - samplingStatsSummary enqueueWaitTime (2 + indent) . - showString "\n\n" . - showString tab . - showString "the dequeue wait time (when was requested for dequeueing -> when was dequeued) = \n\n" . - samplingStatsSummary dequeueWaitTime (2 + indent) + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.Queue +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines a queue that can use the specified strategies. So, having only +-- the 'FCFS', 'LCFS', 'SIRO' and 'StaticPriorities' strategies, you can build +-- 4 x 4 x 4 = 64 different types of the queue, each of them will have its own +-- behaviour. +-- +module Simulation.Aivika.Trans.Queue + (-- * Queue Types + FCFSQueue, + LCFSQueue, + SIROQueue, + PriorityQueue, + Queue, + -- * Creating Queue + newFCFSQueue, + newLCFSQueue, + newSIROQueue, + newPriorityQueue, + newQueue, + -- * Queue Properties and Activities + enqueueStrategy, + enqueueStoringStrategy, + dequeueStrategy, + queueNull, + queueFull, + queueMaxCount, + queueCount, + queueCountStats, + enqueueCount, + enqueueLostCount, + enqueueStoreCount, + dequeueCount, + dequeueExtractCount, + queueLoadFactor, + enqueueRate, + enqueueStoreRate, + dequeueRate, + dequeueExtractRate, + queueWaitTime, + queueTotalWaitTime, + enqueueWaitTime, + dequeueWaitTime, + queueRate, + -- * Dequeuing and Enqueuing + dequeue, + dequeueWithOutputPriority, + tryDequeue, + enqueue, + enqueueWithInputPriority, + enqueueWithStoringPriority, + enqueueWithInputStoringPriorities, + tryEnqueue, + tryEnqueueWithStoringPriority, + enqueueOrLost, + enqueueOrLost_, + enqueueWithStoringPriorityOrLost, + enqueueWithStoringPriorityOrLost_, + -- * Awaiting + waitWhileFullQueue, + -- * Summary + queueSummary, + -- * Derived Signals for Properties + queueNullChanged, + queueNullChanged_, + queueFullChanged, + queueFullChanged_, + queueCountChanged, + queueCountChanged_, + enqueueCountChanged, + enqueueCountChanged_, + enqueueLostCountChanged, + enqueueLostCountChanged_, + enqueueStoreCountChanged, + enqueueStoreCountChanged_, + dequeueCountChanged, + dequeueCountChanged_, + dequeueExtractCountChanged, + dequeueExtractCountChanged_, + queueLoadFactorChanged, + queueLoadFactorChanged_, + queueWaitTimeChanged, + queueWaitTimeChanged_, + queueTotalWaitTimeChanged, + queueTotalWaitTimeChanged_, + enqueueWaitTimeChanged, + enqueueWaitTimeChanged_, + dequeueWaitTimeChanged, + dequeueWaitTimeChanged_, + queueRateChanged, + queueRateChanged_, + -- * Basic Signals + enqueueInitiated, + enqueueStored, + enqueueLost, + dequeueRequested, + dequeueExtracted, + -- * Overall Signal + queueChanged_) where + +import Data.Monoid + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Process +import Simulation.Aivika.Trans.Internal.Signal +import Simulation.Aivika.Trans.Signal +import Simulation.Aivika.Trans.Resource +import Simulation.Aivika.Trans.QueueStrategy +import Simulation.Aivika.Trans.Statistics + +-- | A type synonym for the ordinary FIFO queue also known as the FCFS +-- (First Come - First Serviced) queue. +type FCFSQueue m a = Queue m FCFS FCFS FCFS a + +-- | A type synonym for the ordinary LIFO queue also known as the LCFS +-- (Last Come - First Serviced) queue. +type LCFSQueue m a = Queue m FCFS LCFS FCFS a + +-- | A type synonym for the SIRO (Serviced in Random Order) queue. +type SIROQueue m a = Queue m FCFS SIRO FCFS a + +-- | A type synonym for the queue with static priorities applied when +-- storing the elements in the queue. +type PriorityQueue m a = Queue m FCFS StaticPriorities FCFS a + +-- | Represents a queue using the specified strategies for enqueueing (input), @si@, +-- internal storing (in memory), @sm@, and dequeueing (output), @so@, where @a@ denotes +-- the type of items stored in the queue. Type @m@ denotes the underlying monad within +-- which the simulation executes. +data Queue m si sm so a = + Queue { queueMaxCount :: Int, + -- ^ The queue capacity. + enqueueStrategy :: si, + -- ^ The strategy applied to the enqueueing (input) processes when the queue is full. + enqueueStoringStrategy :: sm, + -- ^ The strategy applied when storing (in memory) items in the queue. + dequeueStrategy :: so, + -- ^ The strategy applied to the dequeueing (output) processes when the queue is empty. + enqueueRes :: Resource m si, + queueStore :: StrategyQueue m sm (QueueItem a), + dequeueRes :: Resource m so, + queueCountRef :: ProtoRef m Int, + queueCountStatsRef :: ProtoRef m (TimingStats Int), + enqueueCountRef :: ProtoRef m Int, + enqueueLostCountRef :: ProtoRef m Int, + enqueueStoreCountRef :: ProtoRef m Int, + dequeueCountRef :: ProtoRef m Int, + dequeueExtractCountRef :: ProtoRef m Int, + queueWaitTimeRef :: ProtoRef m (SamplingStats Double), + queueTotalWaitTimeRef :: ProtoRef m (SamplingStats Double), + enqueueWaitTimeRef :: ProtoRef m (SamplingStats Double), + dequeueWaitTimeRef :: ProtoRef m (SamplingStats Double), + enqueueInitiatedSource :: SignalSource m a, + enqueueLostSource :: SignalSource m a, + enqueueStoredSource :: SignalSource m a, + dequeueRequestedSource :: SignalSource m (), + dequeueExtractedSource :: SignalSource m a } + +-- | Stores the item and a time of its enqueuing. +data QueueItem a = + QueueItem { itemValue :: a, + -- ^ Return the item value. + itemInputTime :: Double, + -- ^ Return the time of enqueuing the item. + itemStoringTime :: Double + -- ^ Return the time of storing in the queue, or + -- @itemInputTime@ before the actual storing when + -- the item was just enqueued. + } + +-- | Create a new FCFS queue with the specified capacity. +newFCFSQueue :: MonadComp m => Int -> Event m (FCFSQueue m a) +newFCFSQueue = newQueue FCFS FCFS FCFS + +-- | Create a new LCFS queue with the specified capacity. +newLCFSQueue :: MonadComp m => Int -> Event m (LCFSQueue m a) +newLCFSQueue = newQueue FCFS LCFS FCFS + +-- | Create a new SIRO queue with the specified capacity. +newSIROQueue :: MonadComp m => Int -> Event m (SIROQueue m a) +newSIROQueue = newQueue FCFS SIRO FCFS + +-- | Create a new priority queue with the specified capacity. +newPriorityQueue :: MonadComp m => Int -> Event m (PriorityQueue m a) +newPriorityQueue = newQueue FCFS StaticPriorities FCFS + +-- | Create a new queue with the specified strategies and capacity. +newQueue :: (MonadComp m, + QueueStrategy m si, + QueueStrategy m sm, + QueueStrategy m so) => + si + -- ^ the strategy applied to the enqueueing (input) processes when the queue is full + -> sm + -- ^ the strategy applied when storing items in the queue + -> so + -- ^ the strategy applied to the dequeueing (output) processes when the queue is empty + -> Int + -- ^ the queue capacity + -> Event m (Queue m si sm so a) +newQueue si sm so count = + do t <- liftDynamics time + sn <- liftParameter simulationSession + i <- liftComp $ newProtoRef sn 0 + is <- liftComp $ newProtoRef sn $ returnTimingStats t 0 + ci <- liftComp $ newProtoRef sn 0 + cl <- liftComp $ newProtoRef sn 0 + cm <- liftComp $ newProtoRef sn 0 + cr <- liftComp $ newProtoRef sn 0 + co <- liftComp $ newProtoRef sn 0 + ri <- liftSimulation $ newResourceWithMaxCount si count (Just count) + qm <- liftSimulation $ newStrategyQueue sm + ro <- liftSimulation $ newResourceWithMaxCount so 0 (Just count) + w <- liftComp $ newProtoRef sn mempty + wt <- liftComp $ newProtoRef sn mempty + wi <- liftComp $ newProtoRef sn mempty + wo <- liftComp $ newProtoRef sn mempty + s1 <- liftSimulation $ newSignalSource + s2 <- liftSimulation $ newSignalSource + s3 <- liftSimulation $ newSignalSource + s4 <- liftSimulation $ newSignalSource + s5 <- liftSimulation $ newSignalSource + return Queue { queueMaxCount = count, + enqueueStrategy = si, + enqueueStoringStrategy = sm, + dequeueStrategy = so, + enqueueRes = ri, + queueStore = qm, + dequeueRes = ro, + queueCountRef = i, + queueCountStatsRef = is, + enqueueCountRef = ci, + enqueueLostCountRef = cl, + enqueueStoreCountRef = cm, + dequeueCountRef = cr, + dequeueExtractCountRef = co, + queueWaitTimeRef = w, + queueTotalWaitTimeRef = wt, + enqueueWaitTimeRef = wi, + dequeueWaitTimeRef = wo, + enqueueInitiatedSource = s1, + enqueueLostSource = s2, + enqueueStoredSource = s3, + dequeueRequestedSource = s4, + dequeueExtractedSource = s5 } + +-- | Test whether the queue is empty. +-- +-- See also 'queueNullChanged' and 'queueNullChanged_'. +queueNull :: MonadComp m => Queue m si sm so a -> Event m Bool +queueNull q = + Event $ \p -> + do n <- readProtoRef (queueCountRef q) + return (n == 0) + +-- | Signal when the 'queueNull' property value has changed. +queueNullChanged :: MonadComp m => Queue m si sm so a -> Signal m Bool +queueNullChanged q = + mapSignalM (const $ queueNull q) (queueNullChanged_ q) + +-- | Signal when the 'queueNull' property value has changed. +queueNullChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () +queueNullChanged_ = queueCountChanged_ + +-- | Test whether the queue is full. +-- +-- See also 'queueFullChanged' and 'queueFullChanged_'. +queueFull :: MonadComp m => Queue m si sm so a -> Event m Bool +queueFull q = + Event $ \p -> + do n <- readProtoRef (queueCountRef q) + return (n == queueMaxCount q) + +-- | Signal when the 'queueFull' property value has changed. +queueFullChanged :: MonadComp m => Queue m si sm so a -> Signal m Bool +queueFullChanged q = + mapSignalM (const $ queueFull q) (queueFullChanged_ q) + +-- | Signal when the 'queueFull' property value has changed. +queueFullChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () +queueFullChanged_ = queueCountChanged_ + +-- | Return the current queue size. +-- +-- See also 'queueCountStats', 'queueCountChanged' and 'queueCountChanged_'. +queueCount :: MonadComp m => Queue m si sm so a -> Event m Int +queueCount q = + Event $ \p -> readProtoRef (queueCountRef q) + +-- | Return the queue size statistics. +queueCountStats :: MonadComp m => Queue m si sm so a -> Event m (TimingStats Int) +queueCountStats q = + Event $ \p -> readProtoRef (queueCountStatsRef q) + +-- | Signal when the 'queueCount' property value has changed. +queueCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int +queueCountChanged q = + mapSignalM (const $ queueCount q) (queueCountChanged_ q) + +-- | Signal when the 'queueCount' property value has changed. +queueCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () +queueCountChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the total number of input items that were enqueued. +-- +-- See also 'enqueueCountChanged' and 'enqueueCountChanged_'. +enqueueCount :: MonadComp m => Queue m si sm so a -> Event m Int +enqueueCount q = + Event $ \p -> readProtoRef (enqueueCountRef q) + +-- | Signal when the 'enqueueCount' property value has changed. +enqueueCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int +enqueueCountChanged q = + mapSignalM (const $ enqueueCount q) (enqueueCountChanged_ q) + +-- | Signal when the 'enqueueCount' property value has changed. +enqueueCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () +enqueueCountChanged_ q = + mapSignal (const ()) (enqueueInitiated q) + +-- | Return the number of lost items. +-- +-- See also 'enqueueLostCountChanged' and 'enqueueLostCountChanged_'. +enqueueLostCount :: MonadComp m => Queue m si sm so a -> Event m Int +enqueueLostCount q = + Event $ \p -> readProtoRef (enqueueLostCountRef q) + +-- | Signal when the 'enqueueLostCount' property value has changed. +enqueueLostCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int +enqueueLostCountChanged q = + mapSignalM (const $ enqueueLostCount q) (enqueueLostCountChanged_ q) + +-- | Signal when the 'enqueueLostCount' property value has changed. +enqueueLostCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () +enqueueLostCountChanged_ q = + mapSignal (const ()) (enqueueLost q) + +-- | Return the total number of input items that were stored. +-- +-- See also 'enqueueStoreCountChanged' and 'enqueueStoreCountChanged_'. +enqueueStoreCount :: MonadComp m => Queue m si sm so a -> Event m Int +enqueueStoreCount q = + Event $ \p -> readProtoRef (enqueueStoreCountRef q) + +-- | Signal when the 'enqueueStoreCount' property value has changed. +enqueueStoreCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int +enqueueStoreCountChanged q = + mapSignalM (const $ enqueueStoreCount q) (enqueueStoreCountChanged_ q) + +-- | Signal when the 'enqueueStoreCount' property value has changed. +enqueueStoreCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () +enqueueStoreCountChanged_ q = + mapSignal (const ()) (enqueueStored q) + +-- | Return the total number of requests for dequeueing the items, +-- not taking into account the failed attempts to dequeue immediately +-- without suspension. +-- +-- See also 'dequeueCountChanged' and 'dequeueCountChanged_'. +dequeueCount :: MonadComp m => Queue m si sm so a -> Event m Int +dequeueCount q = + Event $ \p -> readProtoRef (dequeueCountRef q) + +-- | Signal when the 'dequeueCount' property value has changed. +dequeueCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int +dequeueCountChanged q = + mapSignalM (const $ dequeueCount q) (dequeueCountChanged_ q) + +-- | Signal when the 'dequeueCount' property value has changed. +dequeueCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () +dequeueCountChanged_ q = + mapSignal (const ()) (dequeueRequested q) + +-- | Return the total number of output items that were actually dequeued. +-- +-- See also 'dequeueExtractCountChanged' and 'dequeueExtractCountChanged_'. +dequeueExtractCount :: MonadComp m => Queue m si sm so a -> Event m Int +dequeueExtractCount q = + Event $ \p -> readProtoRef (dequeueExtractCountRef q) + +-- | Signal when the 'dequeueExtractCount' property value has changed. +dequeueExtractCountChanged :: MonadComp m => Queue m si sm so a -> Signal m Int +dequeueExtractCountChanged q = + mapSignalM (const $ dequeueExtractCount q) (dequeueExtractCountChanged_ q) + +-- | Signal when the 'dequeueExtractCount' property value has changed. +dequeueExtractCountChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () +dequeueExtractCountChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the load factor: the queue size divided by its maximum size. +-- +-- See also 'queueLoadFactorChanged' and 'queueLoadFactorChanged_'. +queueLoadFactor :: MonadComp m => Queue m si sm so a -> Event m Double +queueLoadFactor q = + Event $ \p -> + do x <- readProtoRef (queueCountRef q) + let y = queueMaxCount q + return (fromIntegral x / fromIntegral y) + +-- | Signal when the 'queueLoadFactor' property value has changed. +queueLoadFactorChanged :: MonadComp m => Queue m si sm so a -> Signal m Double +queueLoadFactorChanged q = + mapSignalM (const $ queueLoadFactor q) (queueLoadFactorChanged_ q) + +-- | Signal when the 'queueLoadFactor' property value has changed. +queueLoadFactorChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () +queueLoadFactorChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the rate of the input items that were enqueued: how many items +-- per time. +enqueueRate :: MonadComp m => Queue m si sm so a -> Event m Double +enqueueRate q = + Event $ \p -> + do x <- readProtoRef (enqueueCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the rate of the items that were stored: how many items +-- per time. +enqueueStoreRate :: MonadComp m => Queue m si sm so a -> Event m Double +enqueueStoreRate q = + Event $ \p -> + do x <- readProtoRef (enqueueStoreCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the rate of the requests for dequeueing the items: how many requests +-- per time. It does not include the failed attempts to dequeue immediately +-- without suspension. +dequeueRate :: MonadComp m => Queue m si sm so a -> Event m Double +dequeueRate q = + Event $ \p -> + do x <- readProtoRef (dequeueCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the rate of the output items that were actually dequeued: how many items +-- per time. +dequeueExtractRate :: MonadComp m => Queue m si sm so a -> Event m Double +dequeueExtractRate q = + Event $ \p -> + do x <- readProtoRef (dequeueExtractCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the wait time from the time at which the item was stored in the queue to +-- the time at which it was dequeued. +-- +-- See also 'queueWaitTimeChanged' and 'queueWaitTimeChanged_'. +queueWaitTime :: MonadComp m => Queue m si sm so a -> Event m (SamplingStats Double) +queueWaitTime q = + Event $ \p -> readProtoRef (queueWaitTimeRef q) + +-- | Signal when the 'queueWaitTime' property value has changed. +queueWaitTimeChanged :: MonadComp m => Queue m si sm so a -> Signal m (SamplingStats Double) +queueWaitTimeChanged q = + mapSignalM (const $ queueWaitTime q) (queueWaitTimeChanged_ q) + +-- | Signal when the 'queueWaitTime' property value has changed. +queueWaitTimeChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () +queueWaitTimeChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the total wait time from the time at which the enqueueing operation +-- was initiated to the time at which the item was dequeued. +-- +-- In some sense, @queueTotalWaitTime == queueInputWaitTime + queueWaitTime@. +-- +-- See also 'queueTotalWaitTimeChanged' and 'queueTotalWaitTimeChanged_'. +queueTotalWaitTime :: MonadComp m => Queue m si sm so a -> Event m (SamplingStats Double) +queueTotalWaitTime q = + Event $ \p -> readProtoRef (queueTotalWaitTimeRef q) + +-- | Signal when the 'queueTotalWaitTime' property value has changed. +queueTotalWaitTimeChanged :: MonadComp m => Queue m si sm so a -> Signal m (SamplingStats Double) +queueTotalWaitTimeChanged q = + mapSignalM (const $ queueTotalWaitTime q) (queueTotalWaitTimeChanged_ q) + +-- | Signal when the 'queueTotalWaitTime' property value has changed. +queueTotalWaitTimeChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () +queueTotalWaitTimeChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the enqueue wait time from the time at which the enqueueing operation +-- was initiated to the time at which the item was stored in the queue. +-- +-- See also 'enqueueWaitTimeChanged' and 'enqueueWaitTimeChanged_'. +enqueueWaitTime :: MonadComp m => Queue m si sm so a -> Event m (SamplingStats Double) +enqueueWaitTime q = + Event $ \p -> readProtoRef (enqueueWaitTimeRef q) + +-- | Signal when the 'enqueueWaitTime' property value has changed. +enqueueWaitTimeChanged :: MonadComp m => Queue m si sm so a -> Signal m (SamplingStats Double) +enqueueWaitTimeChanged q = + mapSignalM (const $ enqueueWaitTime q) (enqueueWaitTimeChanged_ q) + +-- | Signal when the 'enqueueWaitTime' property value has changed. +enqueueWaitTimeChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () +enqueueWaitTimeChanged_ q = + mapSignal (const ()) (enqueueStored q) + +-- | 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. +-- +-- See also 'dequeueWaitTimeChanged' and 'dequeueWaitTimeChanged_'. +dequeueWaitTime :: MonadComp m => Queue m si sm so a -> Event m (SamplingStats Double) +dequeueWaitTime q = + Event $ \p -> readProtoRef (dequeueWaitTimeRef q) + +-- | Signal when the 'dequeueWaitTime' property value has changed. +dequeueWaitTimeChanged :: MonadComp m => Queue m si sm so a -> Signal m (SamplingStats Double) +dequeueWaitTimeChanged q = + mapSignalM (const $ dequeueWaitTime q) (dequeueWaitTimeChanged_ q) + +-- | Signal when the 'dequeueWaitTime' property value has changed. +dequeueWaitTimeChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () +dequeueWaitTimeChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return a long-term average queue rate calculated as +-- the average queue size divided by the average wait time. +-- +-- This value may be less than the actual arrival rate as the queue is +-- finite and new arrivals may be locked while the queue remains full. +-- +-- See also 'queueRateChanged' and 'queueRateChanged_'. +queueRate :: MonadComp m => Queue m si sm so a -> Event m Double +queueRate q = + Event $ \p -> + do x <- readProtoRef (queueCountStatsRef q) + y <- readProtoRef (queueWaitTimeRef q) + return (timingStatsMean x / samplingStatsMean y) + +-- | Signal when the 'queueRate' property value has changed. +queueRateChanged :: MonadComp m => Queue m si sm so a -> Signal m Double +queueRateChanged q = + mapSignalM (const $ queueRate q) (queueRateChanged_ q) + +-- | Signal when the 'queueRate' property value has changed. +queueRateChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () +queueRateChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Dequeue suspending the process if the queue is empty. +dequeue :: (MonadComp m, + DequeueStrategy m si, + DequeueStrategy m sm, + EnqueueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> Process m a + -- ^ the dequeued value +dequeue q = + do t <- liftEvent $ dequeueRequest q + requestResource (dequeueRes q) + liftEvent $ dequeueExtract q t + +-- | Dequeue with the output priority suspending the process if the queue is empty. +dequeueWithOutputPriority :: (MonadComp m, + DequeueStrategy m si, + DequeueStrategy m sm, + PriorityQueueStrategy m so po) + => Queue m si sm so a + -- ^ the queue + -> po + -- ^ the priority for output + -> Process m a + -- ^ the dequeued value +dequeueWithOutputPriority q po = + do t <- liftEvent $ dequeueRequest q + requestResourceWithPriority (dequeueRes q) po + liftEvent $ dequeueExtract q t + +-- | Try to dequeue immediately. +tryDequeue :: (MonadComp m, + DequeueStrategy m si, + DequeueStrategy m sm) + => Queue m si sm so a + -- ^ the queue + -> Event m (Maybe a) + -- ^ the dequeued value of 'Nothing' +tryDequeue q = + do x <- tryRequestResourceWithinEvent (dequeueRes q) + if x + then do t <- dequeueRequest q + fmap Just $ dequeueExtract q t + else return Nothing + +-- | Enqueue the item suspending the process if the queue is full. +enqueue :: (MonadComp m, + EnqueueStrategy m si, + EnqueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item to enqueue + -> Process m () +enqueue q a = + do i <- liftEvent $ enqueueInitiate q a + requestResource (enqueueRes q) + liftEvent $ enqueueStore q i + +-- | Enqueue with the input priority the item suspending the process if the queue is full. +enqueueWithInputPriority :: (MonadComp m, + PriorityQueueStrategy m si pi, + EnqueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> pi + -- ^ the priority for input + -> a + -- ^ the item to enqueue + -> Process m () +enqueueWithInputPriority q pi a = + do i <- liftEvent $ enqueueInitiate q a + requestResourceWithPriority (enqueueRes q) pi + liftEvent $ enqueueStore q i + +-- | Enqueue with the storing priority the item suspending the process if the queue is full. +enqueueWithStoringPriority :: (MonadComp m, + EnqueueStrategy m si, + PriorityQueueStrategy m sm pm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to enqueue + -> Process m () +enqueueWithStoringPriority q pm a = + do i <- liftEvent $ enqueueInitiate q a + requestResource (enqueueRes q) + liftEvent $ enqueueStoreWithPriority q pm i + +-- | Enqueue with the input and storing priorities the item suspending the process if the queue is full. +enqueueWithInputStoringPriorities :: (MonadComp m, + PriorityQueueStrategy m si pi, + PriorityQueueStrategy m sm pm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> pi + -- ^ the priority for input + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to enqueue + -> Process m () +enqueueWithInputStoringPriorities q pi pm a = + do i <- liftEvent $ enqueueInitiate q a + requestResourceWithPriority (enqueueRes q) pi + liftEvent $ enqueueStoreWithPriority q pm i + +-- | Try to enqueue the item. Return 'False' in the monad if the queue is full. +tryEnqueue :: (MonadComp m, + EnqueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item which we try to enqueue + -> Event m Bool +tryEnqueue q a = + do x <- tryRequestResourceWithinEvent (enqueueRes q) + if x + then do enqueueInitiate q a >>= enqueueStore q + return True + else return False + +-- | Try to enqueue with the storing priority the item. Return 'False' in +-- the monad if the queue is full. +tryEnqueueWithStoringPriority :: (MonadComp m, + PriorityQueueStrategy m sm pm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item which we try to enqueue + -> Event m Bool +tryEnqueueWithStoringPriority q pm a = + do x <- tryRequestResourceWithinEvent (enqueueRes q) + if x + then do enqueueInitiate q a >>= enqueueStoreWithPriority q pm + return True + else return False + +-- | Try to enqueue the item. If the queue is full then the item will be lost +-- and 'False' will be returned. +enqueueOrLost :: (MonadComp m, + EnqueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item which we try to enqueue + -> Event m Bool +enqueueOrLost q a = + do x <- tryRequestResourceWithinEvent (enqueueRes q) + if x + then do enqueueInitiate q a >>= enqueueStore q + return True + else do enqueueDeny q a + return False + +-- | Try to enqueue with the storing priority the item. If the queue is full +-- then the item will be lost and 'False' will be returned. +enqueueWithStoringPriorityOrLost :: (MonadComp m, + PriorityQueueStrategy m sm pm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item which we try to enqueue + -> Event m Bool +enqueueWithStoringPriorityOrLost q pm a = + do x <- tryRequestResourceWithinEvent (enqueueRes q) + if x + then do enqueueInitiate q a >>= enqueueStoreWithPriority q pm + return True + else do enqueueDeny q a + return False + +-- | Try to enqueue the item. If the queue is full then the item will be lost. +enqueueOrLost_ :: (MonadComp m, + EnqueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item which we try to enqueue + -> Event m () +enqueueOrLost_ q a = + do x <- enqueueOrLost q a + return () + +-- | Try to enqueue with the storing priority the item. If the queue is full +-- then the item will be lost. +enqueueWithStoringPriorityOrLost_ :: (MonadComp m, + PriorityQueueStrategy m sm pm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item which we try to enqueue + -> Event m () +enqueueWithStoringPriorityOrLost_ q pm a = + do x <- enqueueWithStoringPriorityOrLost q pm a + return () + +-- | Return a signal that notifies when the enqueuing operation is initiated. +enqueueInitiated :: MonadComp m => Queue m si sm so a -> Signal m a +enqueueInitiated q = publishSignal (enqueueInitiatedSource q) + +-- | Return a signal that notifies when the enqueuing operation is completed +-- and the item is stored in the internal memory of the queue. +enqueueStored :: MonadComp m => Queue m si sm so a -> Signal m a +enqueueStored q = publishSignal (enqueueStoredSource q) + +-- | Return a signal which notifies that the item was lost when +-- attempting to add it to the full queue with help of +-- 'enqueueOrLost', 'enqueueOrLost_' or similar functions that imply +-- that the element can be lost. All their names are ending with @OrLost@ +-- or @OrLost_@. +-- +-- In other cases the enqueued items are not lost but the corresponded process +-- can suspend until the internal queue storage is freed. Although there is one +-- exception from this rule. If the process trying to enqueue a new element was +-- suspended but then canceled through 'cancelProcess' from the outside then +-- the item will not be added. +enqueueLost :: MonadComp m => Queue m si sm so a -> Signal m a +enqueueLost q = publishSignal (enqueueLostSource q) + +-- | Return a signal that notifies when the dequeuing operation was requested. +dequeueRequested :: MonadComp m => Queue m si sm so a -> Signal m () +dequeueRequested q = publishSignal (dequeueRequestedSource q) + +-- | Return a signal that notifies when the item was extracted from the internal +-- storage of the queue and prepared for immediate receiving by the dequeuing process. +dequeueExtracted :: MonadComp m => Queue m si sm so a -> Signal m a +dequeueExtracted q = publishSignal (dequeueExtractedSource q) + +-- | Initiate the process of enqueuing the item. +enqueueInitiate :: MonadComp m + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item to be enqueued + -> Event m (QueueItem a) +enqueueInitiate q a = + Event $ \p -> + do let t = pointTime p + modifyProtoRef' (enqueueCountRef q) (+ 1) + invokeEvent p $ + triggerSignal (enqueueInitiatedSource q) a + return QueueItem { itemValue = a, + itemInputTime = t, + itemStoringTime = t -- it will be updated soon + } + +-- | Store the item. +enqueueStore :: (MonadComp m, + EnqueueStrategy m sm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> QueueItem a + -- ^ the item to be stored + -> Event m () +enqueueStore q i = + Event $ \p -> + do let i' = i { itemStoringTime = pointTime p } -- now we have the actual time of storing + invokeEvent p $ + strategyEnqueue (queueStore q) i' + c <- readProtoRef (queueCountRef q) + let c' = c + 1 + t = pointTime p + c' `seq` writeProtoRef (queueCountRef q) c' + modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c') + modifyProtoRef' (enqueueStoreCountRef q) (+ 1) + invokeEvent p $ + enqueueStat q i' + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + invokeEvent p $ + triggerSignal (enqueueStoredSource q) (itemValue i') + +-- | Store with the priority the item. +enqueueStoreWithPriority :: (MonadComp m, + PriorityQueueStrategy m sm pm, + DequeueStrategy m so) + => Queue m si sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> QueueItem a + -- ^ the item to be enqueued + -> Event m () +enqueueStoreWithPriority q pm i = + Event $ \p -> + do let i' = i { itemStoringTime = pointTime p } -- now we have the actual time of storing + invokeEvent p $ + strategyEnqueueWithPriority (queueStore q) pm i' + c <- readProtoRef (queueCountRef q) + let c' = c + 1 + t = pointTime p + c' `seq` writeProtoRef (queueCountRef q) c' + modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c') + modifyProtoRef' (enqueueStoreCountRef q) (+ 1) + invokeEvent p $ + enqueueStat q i' + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + invokeEvent p $ + triggerSignal (enqueueStoredSource q) (itemValue i') + +-- | Deny the enqueuing. +enqueueDeny :: MonadComp m + => Queue m si sm so a + -- ^ the queue + -> a + -- ^ the item to be denied + -> Event m () +enqueueDeny q a = + Event $ \p -> + do modifyProtoRef' (enqueueLostCountRef q) $ (+) 1 + invokeEvent p $ + triggerSignal (enqueueLostSource q) a + +-- | Update the statistics for the input wait time of the enqueuing operation. +enqueueStat :: MonadComp m + => Queue m si sm so a + -- ^ the queue + -> QueueItem a + -- ^ the item and its input time + -> Event m () + -- ^ the action of updating the statistics +enqueueStat q i = + Event $ \p -> + do let t0 = itemInputTime i + t1 = itemStoringTime i + modifyProtoRef' (enqueueWaitTimeRef q) $ + addSamplingStats (t1 - t0) + +-- | Accept the dequeuing request and return the current simulation time. +dequeueRequest :: MonadComp m + => Queue m si sm so a + -- ^ the queue + -> Event m Double + -- ^ the current time +dequeueRequest q = + Event $ \p -> + do modifyProtoRef' (dequeueCountRef q) (+ 1) + invokeEvent p $ + triggerSignal (dequeueRequestedSource q) () + return $ pointTime p + +-- | Extract an item for the dequeuing request. +dequeueExtract :: (MonadComp m, + DequeueStrategy m si, + DequeueStrategy m sm) + => Queue m si sm so a + -- ^ the queue + -> Double + -- ^ the time of the dequeuing request + -> Event m a + -- ^ the dequeued value +dequeueExtract q t' = + Event $ \p -> + do i <- invokeEvent p $ + strategyDequeue (queueStore q) + c <- readProtoRef (queueCountRef q) + let c' = c - 1 + t = pointTime p + c' `seq` writeProtoRef (queueCountRef q) c' + modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c') + modifyProtoRef' (dequeueExtractCountRef q) (+ 1) + invokeEvent p $ + dequeueStat q t' i + invokeEvent p $ + releaseResourceWithinEvent (enqueueRes q) + invokeEvent p $ + triggerSignal (dequeueExtractedSource q) (itemValue i) + return $ itemValue i + +-- | Update the statistics for the output wait time of the dequeuing operation +-- and the wait time of storing in the queue. +dequeueStat :: MonadComp m + => Queue m si sm so a + -- ^ the queue + -> Double + -- ^ the time of the dequeuing request + -> QueueItem a + -- ^ the item and its input time + -> Event m () + -- ^ the action of updating the statistics +dequeueStat q t' i = + Event $ \p -> + do let t0 = itemInputTime i + t1 = itemStoringTime i + t = pointTime p + modifyProtoRef' (dequeueWaitTimeRef q) $ + addSamplingStats (t - t') + modifyProtoRef' (queueTotalWaitTimeRef q) $ + addSamplingStats (t - t0) + modifyProtoRef' (queueWaitTimeRef q) $ + addSamplingStats (t - t1) + +-- | Wait while the queue is full. +waitWhileFullQueue :: MonadComp m => Queue m si sm so a -> Process m () +waitWhileFullQueue q = + do x <- liftEvent (queueFull q) + when x $ + do processAwait (dequeueExtracted q) + waitWhileFullQueue q + +-- | Signal whenever any property of the queue changes. +-- +-- The property must have the corresponded signal. There are also characteristics +-- similar to the properties but that have no signals. As a rule, such characteristics +-- already depend on the simulation time and therefore they may change at any +-- time point. +queueChanged_ :: MonadComp m => Queue m si sm so a -> Signal m () +queueChanged_ q = + mapSignal (const ()) (enqueueInitiated q) <> + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (enqueueLost q) <> + dequeueRequested q <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the summary for the queue with desciption of its +-- properties and activities using the specified indent. +queueSummary :: (MonadComp m, Show si, Show sm, Show so) => Queue m si sm so a -> Int -> Event m ShowS +queueSummary q indent = + do let si = enqueueStrategy q + sm = enqueueStoringStrategy q + so = dequeueStrategy q + null <- queueNull q + full <- queueFull q + let maxCount = queueMaxCount q + count <- queueCount q + countStats <- queueCountStats q + enqueueCount <- enqueueCount q + enqueueLostCount <- enqueueLostCount q + enqueueStoreCount <- enqueueStoreCount q + dequeueCount <- dequeueCount q + dequeueExtractCount <- dequeueExtractCount q + loadFactor <- queueLoadFactor q + enqueueRate <- enqueueRate q + enqueueStoreRate <- enqueueStoreRate q + dequeueRate <- dequeueRate q + dequeueExtractRate <- dequeueExtractRate q + waitTime <- queueWaitTime q + totalWaitTime <- queueTotalWaitTime q + enqueueWaitTime <- enqueueWaitTime q + dequeueWaitTime <- dequeueWaitTime q + let tab = replicate indent ' ' + return $ + showString tab . + showString "the enqueueing (input) strategy = " . + shows si . + showString "\n" . + showString tab . + showString "the storing (memory) strategy = " . + shows sm . + showString "\n" . + showString tab . + showString "the dequeueing (output) strategy = " . + shows so . + showString "\n" . + showString tab . + showString "empty? = " . + shows null . + showString "\n" . + showString tab . + showString "full? = " . + shows full . + showString "\n" . + showString tab . + showString "max. capacity = " . + shows maxCount . + showString "\n" . + showString tab . + showString "size = " . + shows count . + showString "\n" . + showString tab . + showString "the size statistics = \n\n" . + timingStatsSummary countStats (2 + indent) . + showString "\n\n" . + showString tab . + showString "the enqueue count (number of the input items that were enqueued) = " . + shows enqueueCount . + showString "\n" . + showString tab . + showString "the enqueue lost count (number of the lost items) = " . + shows enqueueLostCount . + showString "\n" . + showString tab . + showString "the enqueue store count (number of the input items that were stored) = " . + shows enqueueStoreCount . + showString "\n" . + showString tab . + showString "the dequeue count (number of requests for dequeueing an item) = " . + shows dequeueCount . + showString "\n" . + showString tab . + showString "the dequeue extract count (number of the output items that were dequeued) = " . + shows dequeueExtractCount . + showString "\n" . + showString tab . + showString "the load factor (size / max. capacity) = " . + shows loadFactor . + showString "\n" . + showString tab . + showString "the enqueue rate (how many input items were enqueued per time) = " . + shows enqueueRate . + showString "\n" . + showString tab . + showString "the enqueue store rate (how many input items were stored per time) = " . + shows enqueueStoreRate . + showString "\n" . + showString tab . + showString "the dequeue rate (how many requests for dequeueing per time) = " . + shows dequeueRate . + showString "\n" . + showString tab . + showString "the dequeue extract rate (how many output items were dequeued per time) = " . + shows dequeueExtractRate . + showString "\n" . + showString tab . + showString "the wait time (when was stored -> when was dequeued) = \n\n" . + samplingStatsSummary waitTime (2 + indent) . + showString "\n\n" . + showString tab . + showString "the total wait time (when the enqueueing was initiated -> when was dequeued) = \n\n" . + samplingStatsSummary totalWaitTime (2 + indent) . + showString "\n\n" . + showString tab . + showString "the enqueue wait time (when the enqueueing was initiated -> when was stored) = \n\n" . + samplingStatsSummary enqueueWaitTime (2 + indent) . + showString "\n\n" . + showString tab . + showString "the dequeue wait time (when was requested for dequeueing -> when was dequeued) = \n\n" . + samplingStatsSummary dequeueWaitTime (2 + indent) 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 @@ -1,649 +1,648 @@ - -{-# LANGUAGE FlexibleContexts #-} - --- | --- Module : Simulation.Aivika.Trans.Queue.Infinite --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines an infinite queue that can use the specified strategies. --- -module Simulation.Aivika.Trans.Queue.Infinite - (-- * Queue Types - FCFSQueue, - LCFSQueue, - SIROQueue, - PriorityQueue, - Queue, - -- * Creating Queue - newFCFSQueue, - newLCFSQueue, - newSIROQueue, - newPriorityQueue, - newQueue, - -- * Queue Properties and Activities - enqueueStoringStrategy, - dequeueStrategy, - queueNull, - queueCount, - queueCountStats, - enqueueStoreCount, - dequeueCount, - dequeueExtractCount, - enqueueStoreRate, - dequeueRate, - dequeueExtractRate, - queueWaitTime, - dequeueWaitTime, - queueRate, - -- * Dequeuing and Enqueuing - dequeue, - dequeueWithOutputPriority, - tryDequeue, - enqueue, - enqueueWithStoringPriority, - -- * Summary - queueSummary, - -- * Derived Signals for Properties - queueNullChanged, - queueNullChanged_, - queueCountChanged, - queueCountChanged_, - enqueueStoreCountChanged, - enqueueStoreCountChanged_, - dequeueCountChanged, - dequeueCountChanged_, - dequeueExtractCountChanged, - dequeueExtractCountChanged_, - queueWaitTimeChanged, - queueWaitTimeChanged_, - dequeueWaitTimeChanged, - dequeueWaitTimeChanged_, - queueRateChanged, - queueRateChanged_, - -- * Basic Signals - enqueueStored, - dequeueRequested, - dequeueExtracted, - -- * Overall Signal - queueChanged_) where - -import Data.IORef -import Data.Monoid - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Parameter -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Dynamics -import Simulation.Aivika.Trans.Internal.Event -import Simulation.Aivika.Trans.Internal.Process -import Simulation.Aivika.Trans.Internal.Signal -import Simulation.Aivika.Trans.Signal -import Simulation.Aivika.Trans.Resource -import Simulation.Aivika.Trans.QueueStrategy -import Simulation.Aivika.Trans.Statistics - --- | A type synonym for the ordinary FIFO queue also known as the FCFS --- (First Come - First Serviced) queue. -type FCFSQueue m a = Queue m FCFS FCFS a - --- | A type synonym for the ordinary LIFO queue also known as the LCFS --- (Last Come - First Serviced) queue. -type LCFSQueue m a = Queue m LCFS FCFS a - --- | A type synonym for the SIRO (Serviced in Random Order) queue. -type SIROQueue m a = Queue m SIRO FCFS a - --- | A type synonym for the queue with static priorities applied when --- storing the elements in the queue. -type PriorityQueue m a = Queue m StaticPriorities FCFS a - --- | Represents an infinite queue using the specified strategies for --- internal storing (in memory), @sm@, and dequeueing (output), @so@, where @a@ denotes --- the type of items stored in the queue. As usual, type @m@ denotes --- the underlying computation within which the simulation executes. -data Queue m sm so a = - Queue { enqueueStoringStrategy :: sm, - -- ^ The strategy applied when storing (in memory) items in the queue. - dequeueStrategy :: so, - -- ^ The strategy applied to the dequeueing (output) processes. - queueStore :: StrategyQueue m sm (QueueItem a), - dequeueRes :: Resource m so, - queueCountRef :: ProtoRef m Int, - queueCountStatsRef :: ProtoRef m (TimingStats Int), - enqueueStoreCountRef :: ProtoRef m Int, - dequeueCountRef :: ProtoRef m Int, - dequeueExtractCountRef :: ProtoRef m Int, - queueWaitTimeRef :: ProtoRef m (SamplingStats Double), - dequeueWaitTimeRef :: ProtoRef m (SamplingStats Double), - enqueueStoredSource :: SignalSource m a, - dequeueRequestedSource :: SignalSource m (), - dequeueExtractedSource :: SignalSource m a } - --- | Stores the item and a time of its enqueuing. -data QueueItem a = - QueueItem { itemValue :: a, - -- ^ Return the item value. - itemStoringTime :: Double - -- ^ Return the time of storing in the queue. - } - --- | Create a new infinite FCFS queue. -newFCFSQueue :: MonadComp m => Event m (FCFSQueue m a) -newFCFSQueue = newQueue FCFS FCFS - --- | Create a new infinite LCFS queue. -newLCFSQueue :: MonadComp m => Event m (LCFSQueue m a) -newLCFSQueue = newQueue LCFS FCFS - --- | Create a new infinite SIRO queue. -newSIROQueue :: MonadComp m => Event m (SIROQueue m a) -newSIROQueue = newQueue SIRO FCFS - --- | Create a new infinite priority queue. -newPriorityQueue :: MonadComp m => Event m (PriorityQueue m a) -newPriorityQueue = newQueue StaticPriorities FCFS - --- | Create a new infinite queue with the specified strategies. -newQueue :: (MonadComp m, - QueueStrategy m sm, - QueueStrategy m so) => - sm - -- ^ the strategy applied when storing items in the queue - -> so - -- ^ the strategy applied to the dequeueing (output) processes when the queue is empty - -> Event m (Queue m sm so a) -newQueue sm so = - do t <- liftDynamics time - sn <- liftParameter simulationSession - i <- liftComp $ newProtoRef sn 0 - is <- liftComp $ newProtoRef sn $ returnTimingStats t 0 - cm <- liftComp $ newProtoRef sn 0 - cr <- liftComp $ newProtoRef sn 0 - co <- liftComp $ newProtoRef sn 0 - qm <- liftSimulation $ newStrategyQueue sm - ro <- liftSimulation $ newResourceWithMaxCount so 0 Nothing - w <- liftComp $ newProtoRef sn mempty - wo <- liftComp $ newProtoRef sn mempty - s3 <- liftSimulation newSignalSource - s4 <- liftSimulation newSignalSource - s5 <- liftSimulation newSignalSource - return Queue { enqueueStoringStrategy = sm, - dequeueStrategy = so, - queueStore = qm, - dequeueRes = ro, - queueCountRef = i, - queueCountStatsRef = is, - enqueueStoreCountRef = cm, - dequeueCountRef = cr, - dequeueExtractCountRef = co, - queueWaitTimeRef = w, - dequeueWaitTimeRef = wo, - enqueueStoredSource = s3, - dequeueRequestedSource = s4, - dequeueExtractedSource = s5 } - --- | Test whether the queue is empty. --- --- See also 'queueNullChanged' and 'queueNullChanged_'. -queueNull :: MonadComp m => Queue m sm so a -> Event m Bool -queueNull q = - Event $ \p -> - do n <- readProtoRef (queueCountRef q) - return (n == 0) - --- | Signal when the 'queueNull' property value has changed. -queueNullChanged :: MonadComp m => Queue m sm so a -> Signal m Bool -queueNullChanged q = - mapSignalM (const $ queueNull q) (queueNullChanged_ q) - --- | Signal when the 'queueNull' property value has changed. -queueNullChanged_ :: MonadComp m => Queue m sm so a -> Signal m () -queueNullChanged_ = queueCountChanged_ - --- | Return the current queue size. --- --- See also 'queueCountStats', 'queueCountChanged' and 'queueCountChanged_'. -queueCount :: MonadComp m => Queue m sm so a -> Event m Int -queueCount q = - Event $ \p -> readProtoRef (queueCountRef q) - --- | Return the queue size statistics. -queueCountStats :: MonadComp m => Queue m sm so a -> Event m (TimingStats Int) -queueCountStats q = - Event $ \p -> readProtoRef (queueCountStatsRef q) - --- | Signal when the 'queueCount' property value has changed. -queueCountChanged :: MonadComp m => Queue m sm so a -> Signal m Int -queueCountChanged q = - mapSignalM (const $ queueCount q) (queueCountChanged_ q) - --- | Signal when the 'queueCount' property value has changed. -queueCountChanged_ :: MonadComp m => Queue m sm so a -> Signal m () -queueCountChanged_ q = - mapSignal (const ()) (enqueueStored q) <> - mapSignal (const ()) (dequeueExtracted q) - --- | Return the total number of input items that were stored. --- --- See also 'enqueueStoreCountChanged' and 'enqueueStoreCountChanged_'. -enqueueStoreCount :: MonadComp m => Queue m sm so a -> Event m Int -enqueueStoreCount q = - Event $ \p -> readProtoRef (enqueueStoreCountRef q) - --- | Signal when the 'enqueueStoreCount' property value has changed. -enqueueStoreCountChanged :: MonadComp m => Queue m sm so a -> Signal m Int -enqueueStoreCountChanged q = - mapSignalM (const $ enqueueStoreCount q) (enqueueStoreCountChanged_ q) - --- | Signal when the 'enqueueStoreCount' property value has changed. -enqueueStoreCountChanged_ :: MonadComp m => Queue m sm so a -> Signal m () -enqueueStoreCountChanged_ q = - mapSignal (const ()) (enqueueStored q) - --- | Return the total number of requests for dequeueing the items, --- not taking into account the failed attempts to dequeue immediately --- without suspension. --- --- See also 'dequeueCountChanged' and 'dequeueCountChanged_'. -dequeueCount :: MonadComp m => Queue m sm so a -> Event m Int -dequeueCount q = - Event $ \p -> readProtoRef (dequeueCountRef q) - --- | Signal when the 'dequeueCount' property value has changed. -dequeueCountChanged :: MonadComp m => Queue m sm so a -> Signal m Int -dequeueCountChanged q = - mapSignalM (const $ dequeueCount q) (dequeueCountChanged_ q) - --- | Signal when the 'dequeueCount' property value has changed. -dequeueCountChanged_ :: MonadComp m => Queue m sm so a -> Signal m () -dequeueCountChanged_ q = - mapSignal (const ()) (dequeueRequested q) - --- | Return the total number of output items that were actually dequeued. --- --- See also 'dequeueExtractCountChanged' and 'dequeueExtractCountChanged_'. -dequeueExtractCount :: MonadComp m => Queue m sm so a -> Event m Int -dequeueExtractCount q = - Event $ \p -> readProtoRef (dequeueExtractCountRef q) - --- | Signal when the 'dequeueExtractCount' property value has changed. -dequeueExtractCountChanged :: MonadComp m => Queue m sm so a -> Signal m Int -dequeueExtractCountChanged q = - mapSignalM (const $ dequeueExtractCount q) (dequeueExtractCountChanged_ q) - --- | Signal when the 'dequeueExtractCount' property value has changed. -dequeueExtractCountChanged_ :: MonadComp m => Queue m sm so a -> Signal m () -dequeueExtractCountChanged_ q = - mapSignal (const ()) (dequeueExtracted q) - --- | Return the rate of the items that were stored: how many items --- per time. -enqueueStoreRate :: MonadComp m => Queue m sm so a -> Event m Double -enqueueStoreRate q = - Event $ \p -> - do x <- readProtoRef (enqueueStoreCountRef q) - let t0 = spcStartTime $ pointSpecs p - t = pointTime p - return (fromIntegral x / (t - t0)) - --- | Return the rate of the requests for dequeueing the items: how many requests --- per time. It does not include the failed attempts to dequeue immediately --- without suspension. -dequeueRate :: MonadComp m => Queue m sm so a -> Event m Double -dequeueRate q = - Event $ \p -> - do x <- readProtoRef (dequeueCountRef q) - let t0 = spcStartTime $ pointSpecs p - t = pointTime p - return (fromIntegral x / (t - t0)) - --- | Return the rate of the output items that were dequeued: how many items --- per time. -dequeueExtractRate :: MonadComp m => Queue m sm so a -> Event m Double -dequeueExtractRate q = - Event $ \p -> - do x <- readProtoRef (dequeueExtractCountRef q) - let t0 = spcStartTime $ pointSpecs p - t = pointTime p - return (fromIntegral x / (t - t0)) - --- | Return the wait time from the time at which the item was stored in the queue to --- the time at which it was dequeued. --- --- See also 'queueWaitTimeChanged' and 'queueWaitTimeChanged_'. -queueWaitTime :: MonadComp m => Queue m sm so a -> Event m (SamplingStats Double) -queueWaitTime q = - Event $ \p -> readProtoRef (queueWaitTimeRef q) - --- | Signal when the 'queueWaitTime' property value has changed. -queueWaitTimeChanged :: MonadComp m => Queue m sm so a -> Signal m (SamplingStats Double) -queueWaitTimeChanged q = - mapSignalM (const $ queueWaitTime q) (queueWaitTimeChanged_ q) - --- | Signal when the 'queueWaitTime' property value has changed. -queueWaitTimeChanged_ :: MonadComp m => Queue m sm so a -> Signal m () -queueWaitTimeChanged_ q = - mapSignal (const ()) (dequeueExtracted q) - --- | 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. --- --- See also 'dequeueWaitTimeChanged' and 'dequeueWaitTimeChanged_'. -dequeueWaitTime :: MonadComp m => Queue m sm so a -> Event m (SamplingStats Double) -dequeueWaitTime q = - Event $ \p -> readProtoRef (dequeueWaitTimeRef q) - --- | Signal when the 'dequeueWaitTime' property value has changed. -dequeueWaitTimeChanged :: MonadComp m => Queue m sm so a -> Signal m (SamplingStats Double) -dequeueWaitTimeChanged q = - mapSignalM (const $ dequeueWaitTime q) (dequeueWaitTimeChanged_ q) - --- | Signal when the 'dequeueWaitTime' property value has changed. -dequeueWaitTimeChanged_ :: MonadComp m => Queue m sm so a -> Signal m () -dequeueWaitTimeChanged_ q = - mapSignal (const ()) (dequeueExtracted q) - --- | Return a long-term average queue rate calculated as --- the average queue size divided by the average wait time. --- --- See also 'queueRateChanged' and 'queueRateChanged_'. -queueRate :: MonadComp m => Queue m sm so a -> Event m Double -queueRate q = - Event $ \p -> - do x <- readProtoRef (queueCountStatsRef q) - y <- readProtoRef (queueWaitTimeRef q) - return (timingStatsMean x / samplingStatsMean y) - --- | Signal when the 'queueRate' property value has changed. -queueRateChanged :: MonadComp m => Queue m sm so a -> Signal m Double -queueRateChanged q = - mapSignalM (const $ queueRate q) (queueRateChanged_ q) - --- | Signal when the 'queueRate' property value has changed. -queueRateChanged_ :: MonadComp m => Queue m sm so a -> Signal m () -queueRateChanged_ q = - mapSignal (const ()) (enqueueStored q) <> - mapSignal (const ()) (dequeueExtracted q) - --- | Dequeue suspending the process if the queue is empty. -dequeue :: (MonadComp m, - DequeueStrategy m sm, - EnqueueStrategy m so) - => Queue m sm so a - -- ^ the queue - -> Process m a - -- ^ the dequeued value -dequeue q = - do t <- liftEvent $ dequeueRequest q - requestResource (dequeueRes q) - liftEvent $ dequeueExtract q t - --- | Dequeue with the output priority suspending the process if the queue is empty. -dequeueWithOutputPriority :: (MonadComp m, - DequeueStrategy m sm, - PriorityQueueStrategy m so po) - => Queue m sm so a - -- ^ the queue - -> po - -- ^ the priority for output - -> Process m a - -- ^ the dequeued value -dequeueWithOutputPriority q po = - do t <- liftEvent $ dequeueRequest q - requestResourceWithPriority (dequeueRes q) po - liftEvent $ dequeueExtract q t - --- | Try to dequeue immediately. -tryDequeue :: (MonadComp m, DequeueStrategy m sm) - => Queue m sm so a - -- ^ the queue - -> Event m (Maybe a) - -- ^ the dequeued value of 'Nothing' -tryDequeue q = - do x <- tryRequestResourceWithinEvent (dequeueRes q) - if x - then do t <- dequeueRequest q - fmap Just $ dequeueExtract q t - else return Nothing - --- | Enqueue the item. -enqueue :: (MonadComp m, - EnqueueStrategy m sm, - DequeueStrategy m so) - => Queue m sm so a - -- ^ the queue - -> a - -- ^ the item to enqueue - -> Event m () -enqueue = enqueueStore - --- | Enqueue with the storing priority the item. -enqueueWithStoringPriority :: (MonadComp m, - PriorityQueueStrategy m sm pm, - DequeueStrategy m so) - => Queue m sm so a - -- ^ the queue - -> pm - -- ^ the priority for storing - -> a - -- ^ the item to enqueue - -> Event m () -enqueueWithStoringPriority = enqueueStoreWithPriority - --- | Return a signal that notifies when the enqueued item --- is stored in the internal memory of the queue. -enqueueStored :: MonadComp m => Queue m sm so a -> Signal m a -enqueueStored q = publishSignal (enqueueStoredSource q) - --- | Return a signal that notifies when the dequeuing operation was requested. -dequeueRequested :: MonadComp m => Queue m sm so a -> Signal m () -dequeueRequested q = publishSignal (dequeueRequestedSource q) - --- | Return a signal that notifies when the item was extracted from the internal --- storage of the queue and prepared for immediate receiving by the dequeuing process. -dequeueExtracted :: MonadComp m => Queue m sm so a -> Signal m a -dequeueExtracted q = publishSignal (dequeueExtractedSource q) - --- | Store the item. -enqueueStore :: (MonadComp m, - EnqueueStrategy m sm, - DequeueStrategy m so) - => Queue m sm so a - -- ^ the queue - -> a - -- ^ the item to be stored - -> Event m () -enqueueStore q a = - Event $ \p -> - do let i = QueueItem { itemValue = a, - itemStoringTime = pointTime p } - invokeEvent p $ - strategyEnqueue (queueStore q) i - c <- readProtoRef (queueCountRef q) - let c' = c + 1 - t = pointTime p - c' `seq` writeProtoRef (queueCountRef q) c' - modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c') - modifyProtoRef' (enqueueStoreCountRef q) (+ 1) - invokeEvent p $ - releaseResourceWithinEvent (dequeueRes q) - invokeEvent p $ - triggerSignal (enqueueStoredSource q) (itemValue i) - --- | Store with the priority the item. -enqueueStoreWithPriority :: (MonadComp m, - PriorityQueueStrategy m sm pm, - DequeueStrategy m so) - => Queue m sm so a - -- ^ the queue - -> pm - -- ^ the priority for storing - -> a - -- ^ the item to be enqueued - -> Event m () -enqueueStoreWithPriority q pm a = - Event $ \p -> - do let i = QueueItem { itemValue = a, - itemStoringTime = pointTime p } - invokeEvent p $ - strategyEnqueueWithPriority (queueStore q) pm i - c <- readProtoRef (queueCountRef q) - let c' = c + 1 - t = pointTime p - c' `seq` writeProtoRef (queueCountRef q) c' - modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c') - modifyProtoRef' (enqueueStoreCountRef q) (+ 1) - invokeEvent p $ - releaseResourceWithinEvent (dequeueRes q) - invokeEvent p $ - triggerSignal (enqueueStoredSource q) (itemValue i) - --- | Accept the dequeuing request and return the current simulation time. -dequeueRequest :: MonadComp m - => Queue m sm so a - -- ^ the queue - -> Event m Double - -- ^ the current time -dequeueRequest q = - Event $ \p -> - do modifyProtoRef' (dequeueCountRef q) (+ 1) - invokeEvent p $ - triggerSignal (dequeueRequestedSource q) () - return $ pointTime p - --- | Extract an item for the dequeuing request. -dequeueExtract :: (MonadComp m, DequeueStrategy m sm) - => Queue m sm so a - -- ^ the queue - -> Double - -- ^ the time of the dequeuing request - -> Event m a - -- ^ the dequeued value -dequeueExtract q t' = - Event $ \p -> - do i <- invokeEvent p $ - strategyDequeue (queueStore q) - c <- readProtoRef (queueCountRef q) - let c' = c - 1 - t = pointTime p - c' `seq` writeProtoRef (queueCountRef q) c' - modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c') - modifyProtoRef' (dequeueExtractCountRef q) (+ 1) - invokeEvent p $ - dequeueStat q t' i - invokeEvent p $ - triggerSignal (dequeueExtractedSource q) (itemValue i) - return $ itemValue i - --- | Update the statistics for the output wait time of the dequeuing operation --- and the wait time of storing in the queue. -dequeueStat :: MonadComp m - => Queue m sm so a - -- ^ the queue - -> Double - -- ^ the time of the dequeuing request - -> QueueItem a - -- ^ the item and its input time - -> Event m () - -- ^ the action of updating the statistics -dequeueStat q t' i = - Event $ \p -> - do let t1 = itemStoringTime i - t = pointTime p - modifyProtoRef' (dequeueWaitTimeRef q) $ - addSamplingStats (t - t') - modifyProtoRef' (queueWaitTimeRef q) $ - addSamplingStats (t - t1) - --- | Signal whenever any property of the queue changes. --- --- The property must have the corresponded signal. There are also characteristics --- similar to the properties but that have no signals. As a rule, such characteristics --- already depend on the simulation time and therefore they may change at any --- time point. -queueChanged_ :: MonadComp m => Queue m sm so a -> Signal m () -queueChanged_ q = - mapSignal (const ()) (enqueueStored q) <> - dequeueRequested q <> - mapSignal (const ()) (dequeueExtracted q) - --- | Return the summary for the queue with desciption of its --- properties and activities using the specified indent. -queueSummary :: (MonadComp m, Show sm, Show so) => Queue m sm so a -> Int -> Event m ShowS -queueSummary q indent = - do let sm = enqueueStoringStrategy q - so = dequeueStrategy q - null <- queueNull q - count <- queueCount q - countStats <- queueCountStats q - enqueueStoreCount <- enqueueStoreCount q - dequeueCount <- dequeueCount q - dequeueExtractCount <- dequeueExtractCount q - enqueueStoreRate <- enqueueStoreRate q - dequeueRate <- dequeueRate q - dequeueExtractRate <- dequeueExtractRate q - waitTime <- queueWaitTime q - dequeueWaitTime <- dequeueWaitTime q - let tab = replicate indent ' ' - return $ - showString tab . - showString "the storing (memory) strategy = " . - shows sm . - showString "\n" . - showString tab . - showString "the dequeueing (output) strategy = " . - shows so . - showString "\n" . - showString tab . - showString "empty? = " . - shows null . - showString "\n" . - showString tab . - showString "the current size = " . - shows count . - showString "\n" . - showString tab . - showString "the size statistics = \n\n" . - timingStatsSummary countStats (2 + indent) . - showString "\n\n" . - showString tab . - showString "the enqueue store count (number of the input items that were stored) = " . - shows enqueueStoreCount . - showString "\n" . - showString tab . - showString "the dequeue count (number of requests for dequeueing an item) = " . - shows dequeueCount . - showString "\n" . - showString tab . - showString "the dequeue extract count (number of the output items that were dequeued) = " . - shows dequeueExtractCount . - showString "\n" . - showString tab . - showString "the enqueue store rate (how many input items were stored per time) = " . - shows enqueueStoreRate . - showString "\n" . - showString tab . - showString "the dequeue rate (how many requests for dequeueing per time) = " . - shows dequeueRate . - showString "\n" . - showString tab . - showString "the dequeue extract rate (how many output items were dequeued per time) = " . - shows dequeueExtractRate . - showString "\n" . - showString tab . - showString "the wait time (when was stored -> when was dequeued) = \n\n" . - samplingStatsSummary waitTime (2 + indent) . - showString "\n\n" . - showString tab . - showString "the dequeue wait time (when was requested for dequeueing -> when was dequeued) = \n\n" . - samplingStatsSummary dequeueWaitTime (2 + indent) + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.Queue.Infinite +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines an infinite queue that can use the specified strategies. +-- +module Simulation.Aivika.Trans.Queue.Infinite + (-- * Queue Types + FCFSQueue, + LCFSQueue, + SIROQueue, + PriorityQueue, + Queue, + -- * Creating Queue + newFCFSQueue, + newLCFSQueue, + newSIROQueue, + newPriorityQueue, + newQueue, + -- * Queue Properties and Activities + enqueueStoringStrategy, + dequeueStrategy, + queueNull, + queueCount, + queueCountStats, + enqueueStoreCount, + dequeueCount, + dequeueExtractCount, + enqueueStoreRate, + dequeueRate, + dequeueExtractRate, + queueWaitTime, + dequeueWaitTime, + queueRate, + -- * Dequeuing and Enqueuing + dequeue, + dequeueWithOutputPriority, + tryDequeue, + enqueue, + enqueueWithStoringPriority, + -- * Summary + queueSummary, + -- * Derived Signals for Properties + queueNullChanged, + queueNullChanged_, + queueCountChanged, + queueCountChanged_, + enqueueStoreCountChanged, + enqueueStoreCountChanged_, + dequeueCountChanged, + dequeueCountChanged_, + dequeueExtractCountChanged, + dequeueExtractCountChanged_, + queueWaitTimeChanged, + queueWaitTimeChanged_, + dequeueWaitTimeChanged, + dequeueWaitTimeChanged_, + queueRateChanged, + queueRateChanged_, + -- * Basic Signals + enqueueStored, + dequeueRequested, + dequeueExtracted, + -- * Overall Signal + queueChanged_) where + +import Data.Monoid + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Process +import Simulation.Aivika.Trans.Internal.Signal +import Simulation.Aivika.Trans.Signal +import Simulation.Aivika.Trans.Resource +import Simulation.Aivika.Trans.QueueStrategy +import Simulation.Aivika.Trans.Statistics + +-- | A type synonym for the ordinary FIFO queue also known as the FCFS +-- (First Come - First Serviced) queue. +type FCFSQueue m a = Queue m FCFS FCFS a + +-- | A type synonym for the ordinary LIFO queue also known as the LCFS +-- (Last Come - First Serviced) queue. +type LCFSQueue m a = Queue m LCFS FCFS a + +-- | A type synonym for the SIRO (Serviced in Random Order) queue. +type SIROQueue m a = Queue m SIRO FCFS a + +-- | A type synonym for the queue with static priorities applied when +-- storing the elements in the queue. +type PriorityQueue m a = Queue m StaticPriorities FCFS a + +-- | Represents an infinite queue using the specified strategies for +-- internal storing (in memory), @sm@, and dequeueing (output), @so@, where @a@ denotes +-- the type of items stored in the queue. As usual, type @m@ denotes +-- the underlying computation within which the simulation executes. +data Queue m sm so a = + Queue { enqueueStoringStrategy :: sm, + -- ^ The strategy applied when storing (in memory) items in the queue. + dequeueStrategy :: so, + -- ^ The strategy applied to the dequeueing (output) processes. + queueStore :: StrategyQueue m sm (QueueItem a), + dequeueRes :: Resource m so, + queueCountRef :: ProtoRef m Int, + queueCountStatsRef :: ProtoRef m (TimingStats Int), + enqueueStoreCountRef :: ProtoRef m Int, + dequeueCountRef :: ProtoRef m Int, + dequeueExtractCountRef :: ProtoRef m Int, + queueWaitTimeRef :: ProtoRef m (SamplingStats Double), + dequeueWaitTimeRef :: ProtoRef m (SamplingStats Double), + enqueueStoredSource :: SignalSource m a, + dequeueRequestedSource :: SignalSource m (), + dequeueExtractedSource :: SignalSource m a } + +-- | Stores the item and a time of its enqueuing. +data QueueItem a = + QueueItem { itemValue :: a, + -- ^ Return the item value. + itemStoringTime :: Double + -- ^ Return the time of storing in the queue. + } + +-- | Create a new infinite FCFS queue. +newFCFSQueue :: MonadComp m => Event m (FCFSQueue m a) +newFCFSQueue = newQueue FCFS FCFS + +-- | Create a new infinite LCFS queue. +newLCFSQueue :: MonadComp m => Event m (LCFSQueue m a) +newLCFSQueue = newQueue LCFS FCFS + +-- | Create a new infinite SIRO queue. +newSIROQueue :: MonadComp m => Event m (SIROQueue m a) +newSIROQueue = newQueue SIRO FCFS + +-- | Create a new infinite priority queue. +newPriorityQueue :: MonadComp m => Event m (PriorityQueue m a) +newPriorityQueue = newQueue StaticPriorities FCFS + +-- | Create a new infinite queue with the specified strategies. +newQueue :: (MonadComp m, + QueueStrategy m sm, + QueueStrategy m so) => + sm + -- ^ the strategy applied when storing items in the queue + -> so + -- ^ the strategy applied to the dequeueing (output) processes when the queue is empty + -> Event m (Queue m sm so a) +newQueue sm so = + do t <- liftDynamics time + sn <- liftParameter simulationSession + i <- liftComp $ newProtoRef sn 0 + is <- liftComp $ newProtoRef sn $ returnTimingStats t 0 + cm <- liftComp $ newProtoRef sn 0 + cr <- liftComp $ newProtoRef sn 0 + co <- liftComp $ newProtoRef sn 0 + qm <- liftSimulation $ newStrategyQueue sm + ro <- liftSimulation $ newResourceWithMaxCount so 0 Nothing + w <- liftComp $ newProtoRef sn mempty + wo <- liftComp $ newProtoRef sn mempty + s3 <- liftSimulation newSignalSource + s4 <- liftSimulation newSignalSource + s5 <- liftSimulation newSignalSource + return Queue { enqueueStoringStrategy = sm, + dequeueStrategy = so, + queueStore = qm, + dequeueRes = ro, + queueCountRef = i, + queueCountStatsRef = is, + enqueueStoreCountRef = cm, + dequeueCountRef = cr, + dequeueExtractCountRef = co, + queueWaitTimeRef = w, + dequeueWaitTimeRef = wo, + enqueueStoredSource = s3, + dequeueRequestedSource = s4, + dequeueExtractedSource = s5 } + +-- | Test whether the queue is empty. +-- +-- See also 'queueNullChanged' and 'queueNullChanged_'. +queueNull :: MonadComp m => Queue m sm so a -> Event m Bool +queueNull q = + Event $ \p -> + do n <- readProtoRef (queueCountRef q) + return (n == 0) + +-- | Signal when the 'queueNull' property value has changed. +queueNullChanged :: MonadComp m => Queue m sm so a -> Signal m Bool +queueNullChanged q = + mapSignalM (const $ queueNull q) (queueNullChanged_ q) + +-- | Signal when the 'queueNull' property value has changed. +queueNullChanged_ :: MonadComp m => Queue m sm so a -> Signal m () +queueNullChanged_ = queueCountChanged_ + +-- | Return the current queue size. +-- +-- See also 'queueCountStats', 'queueCountChanged' and 'queueCountChanged_'. +queueCount :: MonadComp m => Queue m sm so a -> Event m Int +queueCount q = + Event $ \p -> readProtoRef (queueCountRef q) + +-- | Return the queue size statistics. +queueCountStats :: MonadComp m => Queue m sm so a -> Event m (TimingStats Int) +queueCountStats q = + Event $ \p -> readProtoRef (queueCountStatsRef q) + +-- | Signal when the 'queueCount' property value has changed. +queueCountChanged :: MonadComp m => Queue m sm so a -> Signal m Int +queueCountChanged q = + mapSignalM (const $ queueCount q) (queueCountChanged_ q) + +-- | Signal when the 'queueCount' property value has changed. +queueCountChanged_ :: MonadComp m => Queue m sm so a -> Signal m () +queueCountChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the total number of input items that were stored. +-- +-- See also 'enqueueStoreCountChanged' and 'enqueueStoreCountChanged_'. +enqueueStoreCount :: MonadComp m => Queue m sm so a -> Event m Int +enqueueStoreCount q = + Event $ \p -> readProtoRef (enqueueStoreCountRef q) + +-- | Signal when the 'enqueueStoreCount' property value has changed. +enqueueStoreCountChanged :: MonadComp m => Queue m sm so a -> Signal m Int +enqueueStoreCountChanged q = + mapSignalM (const $ enqueueStoreCount q) (enqueueStoreCountChanged_ q) + +-- | Signal when the 'enqueueStoreCount' property value has changed. +enqueueStoreCountChanged_ :: MonadComp m => Queue m sm so a -> Signal m () +enqueueStoreCountChanged_ q = + mapSignal (const ()) (enqueueStored q) + +-- | Return the total number of requests for dequeueing the items, +-- not taking into account the failed attempts to dequeue immediately +-- without suspension. +-- +-- See also 'dequeueCountChanged' and 'dequeueCountChanged_'. +dequeueCount :: MonadComp m => Queue m sm so a -> Event m Int +dequeueCount q = + Event $ \p -> readProtoRef (dequeueCountRef q) + +-- | Signal when the 'dequeueCount' property value has changed. +dequeueCountChanged :: MonadComp m => Queue m sm so a -> Signal m Int +dequeueCountChanged q = + mapSignalM (const $ dequeueCount q) (dequeueCountChanged_ q) + +-- | Signal when the 'dequeueCount' property value has changed. +dequeueCountChanged_ :: MonadComp m => Queue m sm so a -> Signal m () +dequeueCountChanged_ q = + mapSignal (const ()) (dequeueRequested q) + +-- | Return the total number of output items that were actually dequeued. +-- +-- See also 'dequeueExtractCountChanged' and 'dequeueExtractCountChanged_'. +dequeueExtractCount :: MonadComp m => Queue m sm so a -> Event m Int +dequeueExtractCount q = + Event $ \p -> readProtoRef (dequeueExtractCountRef q) + +-- | Signal when the 'dequeueExtractCount' property value has changed. +dequeueExtractCountChanged :: MonadComp m => Queue m sm so a -> Signal m Int +dequeueExtractCountChanged q = + mapSignalM (const $ dequeueExtractCount q) (dequeueExtractCountChanged_ q) + +-- | Signal when the 'dequeueExtractCount' property value has changed. +dequeueExtractCountChanged_ :: MonadComp m => Queue m sm so a -> Signal m () +dequeueExtractCountChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the rate of the items that were stored: how many items +-- per time. +enqueueStoreRate :: MonadComp m => Queue m sm so a -> Event m Double +enqueueStoreRate q = + Event $ \p -> + do x <- readProtoRef (enqueueStoreCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the rate of the requests for dequeueing the items: how many requests +-- per time. It does not include the failed attempts to dequeue immediately +-- without suspension. +dequeueRate :: MonadComp m => Queue m sm so a -> Event m Double +dequeueRate q = + Event $ \p -> + do x <- readProtoRef (dequeueCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the rate of the output items that were dequeued: how many items +-- per time. +dequeueExtractRate :: MonadComp m => Queue m sm so a -> Event m Double +dequeueExtractRate q = + Event $ \p -> + do x <- readProtoRef (dequeueExtractCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the wait time from the time at which the item was stored in the queue to +-- the time at which it was dequeued. +-- +-- See also 'queueWaitTimeChanged' and 'queueWaitTimeChanged_'. +queueWaitTime :: MonadComp m => Queue m sm so a -> Event m (SamplingStats Double) +queueWaitTime q = + Event $ \p -> readProtoRef (queueWaitTimeRef q) + +-- | Signal when the 'queueWaitTime' property value has changed. +queueWaitTimeChanged :: MonadComp m => Queue m sm so a -> Signal m (SamplingStats Double) +queueWaitTimeChanged q = + mapSignalM (const $ queueWaitTime q) (queueWaitTimeChanged_ q) + +-- | Signal when the 'queueWaitTime' property value has changed. +queueWaitTimeChanged_ :: MonadComp m => Queue m sm so a -> Signal m () +queueWaitTimeChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | 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. +-- +-- See also 'dequeueWaitTimeChanged' and 'dequeueWaitTimeChanged_'. +dequeueWaitTime :: MonadComp m => Queue m sm so a -> Event m (SamplingStats Double) +dequeueWaitTime q = + Event $ \p -> readProtoRef (dequeueWaitTimeRef q) + +-- | Signal when the 'dequeueWaitTime' property value has changed. +dequeueWaitTimeChanged :: MonadComp m => Queue m sm so a -> Signal m (SamplingStats Double) +dequeueWaitTimeChanged q = + mapSignalM (const $ dequeueWaitTime q) (dequeueWaitTimeChanged_ q) + +-- | Signal when the 'dequeueWaitTime' property value has changed. +dequeueWaitTimeChanged_ :: MonadComp m => Queue m sm so a -> Signal m () +dequeueWaitTimeChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return a long-term average queue rate calculated as +-- the average queue size divided by the average wait time. +-- +-- See also 'queueRateChanged' and 'queueRateChanged_'. +queueRate :: MonadComp m => Queue m sm so a -> Event m Double +queueRate q = + Event $ \p -> + do x <- readProtoRef (queueCountStatsRef q) + y <- readProtoRef (queueWaitTimeRef q) + return (timingStatsMean x / samplingStatsMean y) + +-- | Signal when the 'queueRate' property value has changed. +queueRateChanged :: MonadComp m => Queue m sm so a -> Signal m Double +queueRateChanged q = + mapSignalM (const $ queueRate q) (queueRateChanged_ q) + +-- | Signal when the 'queueRate' property value has changed. +queueRateChanged_ :: MonadComp m => Queue m sm so a -> Signal m () +queueRateChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Dequeue suspending the process if the queue is empty. +dequeue :: (MonadComp m, + DequeueStrategy m sm, + EnqueueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> Process m a + -- ^ the dequeued value +dequeue q = + do t <- liftEvent $ dequeueRequest q + requestResource (dequeueRes q) + liftEvent $ dequeueExtract q t + +-- | Dequeue with the output priority suspending the process if the queue is empty. +dequeueWithOutputPriority :: (MonadComp m, + DequeueStrategy m sm, + PriorityQueueStrategy m so po) + => Queue m sm so a + -- ^ the queue + -> po + -- ^ the priority for output + -> Process m a + -- ^ the dequeued value +dequeueWithOutputPriority q po = + do t <- liftEvent $ dequeueRequest q + requestResourceWithPriority (dequeueRes q) po + liftEvent $ dequeueExtract q t + +-- | Try to dequeue immediately. +tryDequeue :: (MonadComp m, DequeueStrategy m sm) + => Queue m sm so a + -- ^ the queue + -> Event m (Maybe a) + -- ^ the dequeued value of 'Nothing' +tryDequeue q = + do x <- tryRequestResourceWithinEvent (dequeueRes q) + if x + then do t <- dequeueRequest q + fmap Just $ dequeueExtract q t + else return Nothing + +-- | Enqueue the item. +enqueue :: (MonadComp m, + EnqueueStrategy m sm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> a + -- ^ the item to enqueue + -> Event m () +enqueue = enqueueStore + +-- | Enqueue with the storing priority the item. +enqueueWithStoringPriority :: (MonadComp m, + PriorityQueueStrategy m sm pm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to enqueue + -> Event m () +enqueueWithStoringPriority = enqueueStoreWithPriority + +-- | Return a signal that notifies when the enqueued item +-- is stored in the internal memory of the queue. +enqueueStored :: MonadComp m => Queue m sm so a -> Signal m a +enqueueStored q = publishSignal (enqueueStoredSource q) + +-- | Return a signal that notifies when the dequeuing operation was requested. +dequeueRequested :: MonadComp m => Queue m sm so a -> Signal m () +dequeueRequested q = publishSignal (dequeueRequestedSource q) + +-- | Return a signal that notifies when the item was extracted from the internal +-- storage of the queue and prepared for immediate receiving by the dequeuing process. +dequeueExtracted :: MonadComp m => Queue m sm so a -> Signal m a +dequeueExtracted q = publishSignal (dequeueExtractedSource q) + +-- | Store the item. +enqueueStore :: (MonadComp m, + EnqueueStrategy m sm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> a + -- ^ the item to be stored + -> Event m () +enqueueStore q a = + Event $ \p -> + do let i = QueueItem { itemValue = a, + itemStoringTime = pointTime p } + invokeEvent p $ + strategyEnqueue (queueStore q) i + c <- readProtoRef (queueCountRef q) + let c' = c + 1 + t = pointTime p + c' `seq` writeProtoRef (queueCountRef q) c' + modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c') + modifyProtoRef' (enqueueStoreCountRef q) (+ 1) + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + invokeEvent p $ + triggerSignal (enqueueStoredSource q) (itemValue i) + +-- | Store with the priority the item. +enqueueStoreWithPriority :: (MonadComp m, + PriorityQueueStrategy m sm pm, + DequeueStrategy m so) + => Queue m sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to be enqueued + -> Event m () +enqueueStoreWithPriority q pm a = + Event $ \p -> + do let i = QueueItem { itemValue = a, + itemStoringTime = pointTime p } + invokeEvent p $ + strategyEnqueueWithPriority (queueStore q) pm i + c <- readProtoRef (queueCountRef q) + let c' = c + 1 + t = pointTime p + c' `seq` writeProtoRef (queueCountRef q) c' + modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c') + modifyProtoRef' (enqueueStoreCountRef q) (+ 1) + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + invokeEvent p $ + triggerSignal (enqueueStoredSource q) (itemValue i) + +-- | Accept the dequeuing request and return the current simulation time. +dequeueRequest :: MonadComp m + => Queue m sm so a + -- ^ the queue + -> Event m Double + -- ^ the current time +dequeueRequest q = + Event $ \p -> + do modifyProtoRef' (dequeueCountRef q) (+ 1) + invokeEvent p $ + triggerSignal (dequeueRequestedSource q) () + return $ pointTime p + +-- | Extract an item for the dequeuing request. +dequeueExtract :: (MonadComp m, DequeueStrategy m sm) + => Queue m sm so a + -- ^ the queue + -> Double + -- ^ the time of the dequeuing request + -> Event m a + -- ^ the dequeued value +dequeueExtract q t' = + Event $ \p -> + do i <- invokeEvent p $ + strategyDequeue (queueStore q) + c <- readProtoRef (queueCountRef q) + let c' = c - 1 + t = pointTime p + c' `seq` writeProtoRef (queueCountRef q) c' + modifyProtoRef' (queueCountStatsRef q) (addTimingStats t c') + modifyProtoRef' (dequeueExtractCountRef q) (+ 1) + invokeEvent p $ + dequeueStat q t' i + invokeEvent p $ + triggerSignal (dequeueExtractedSource q) (itemValue i) + return $ itemValue i + +-- | Update the statistics for the output wait time of the dequeuing operation +-- and the wait time of storing in the queue. +dequeueStat :: MonadComp m + => Queue m sm so a + -- ^ the queue + -> Double + -- ^ the time of the dequeuing request + -> QueueItem a + -- ^ the item and its input time + -> Event m () + -- ^ the action of updating the statistics +dequeueStat q t' i = + Event $ \p -> + do let t1 = itemStoringTime i + t = pointTime p + modifyProtoRef' (dequeueWaitTimeRef q) $ + addSamplingStats (t - t') + modifyProtoRef' (queueWaitTimeRef q) $ + addSamplingStats (t - t1) + +-- | Signal whenever any property of the queue changes. +-- +-- The property must have the corresponded signal. There are also characteristics +-- similar to the properties but that have no signals. As a rule, such characteristics +-- already depend on the simulation time and therefore they may change at any +-- time point. +queueChanged_ :: MonadComp m => Queue m sm so a -> Signal m () +queueChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + dequeueRequested q <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the summary for the queue with desciption of its +-- properties and activities using the specified indent. +queueSummary :: (MonadComp m, Show sm, Show so) => Queue m sm so a -> Int -> Event m ShowS +queueSummary q indent = + do let sm = enqueueStoringStrategy q + so = dequeueStrategy q + null <- queueNull q + count <- queueCount q + countStats <- queueCountStats q + enqueueStoreCount <- enqueueStoreCount q + dequeueCount <- dequeueCount q + dequeueExtractCount <- dequeueExtractCount q + enqueueStoreRate <- enqueueStoreRate q + dequeueRate <- dequeueRate q + dequeueExtractRate <- dequeueExtractRate q + waitTime <- queueWaitTime q + dequeueWaitTime <- dequeueWaitTime q + let tab = replicate indent ' ' + return $ + showString tab . + showString "the storing (memory) strategy = " . + shows sm . + showString "\n" . + showString tab . + showString "the dequeueing (output) strategy = " . + shows so . + showString "\n" . + showString tab . + showString "empty? = " . + shows null . + showString "\n" . + showString tab . + showString "the current size = " . + shows count . + showString "\n" . + showString tab . + showString "the size statistics = \n\n" . + timingStatsSummary countStats (2 + indent) . + showString "\n\n" . + showString tab . + showString "the enqueue store count (number of the input items that were stored) = " . + shows enqueueStoreCount . + showString "\n" . + showString tab . + showString "the dequeue count (number of requests for dequeueing an item) = " . + shows dequeueCount . + showString "\n" . + showString tab . + showString "the dequeue extract count (number of the output items that were dequeued) = " . + shows dequeueExtractCount . + showString "\n" . + showString tab . + showString "the enqueue store rate (how many input items were stored per time) = " . + shows enqueueStoreRate . + showString "\n" . + showString tab . + showString "the dequeue rate (how many requests for dequeueing per time) = " . + shows dequeueRate . + showString "\n" . + showString tab . + showString "the dequeue extract rate (how many output items were dequeued per time) = " . + shows dequeueExtractRate . + showString "\n" . + showString tab . + showString "the wait time (when was stored -> when was dequeued) = \n\n" . + samplingStatsSummary waitTime (2 + indent) . + showString "\n\n" . + showString tab . + showString "the dequeue wait time (when was requested for dequeueing -> when was dequeued) = \n\n" . + samplingStatsSummary dequeueWaitTime (2 + indent) 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 @@ -1,202 +1,202 @@ - -{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, FunctionalDependencies, UndecidableInstances #-} - --- | --- Module : Simulation.Aivika.Trans.QueueStrategy --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines the queue strategies. --- -module Simulation.Aivika.Trans.QueueStrategy where - -import Control.Monad.Trans - -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Comp.Template -import Simulation.Aivika.Trans.Parameter -import Simulation.Aivika.Trans.Parameter.Random -import Simulation.Aivika.Trans.Simulation -import Simulation.Aivika.Trans.Event - -import qualified Simulation.Aivika.Trans.DoubleLinkedList as LL -import qualified Simulation.Aivika.Trans.PriorityQueue as PQ -import qualified Simulation.Aivika.Trans.Vector as V - --- | Defines the basic queue strategy. -class MonadComp m => QueueStrategy m s where - - -- | The strategy queue. - data StrategyQueue m s :: * -> * - - -- | Create a new queue by the specified strategy. - newStrategyQueue :: s - -- ^ the strategy - -> Simulation m (StrategyQueue m s a) - -- ^ a new queue - - -- | Test whether the queue is empty. - strategyQueueNull :: StrategyQueue m s a - -- ^ the queue - -> Event m Bool - -- ^ the result of the test - --- | Defines a strategy with support of the dequeuing operation. -class QueueStrategy m s => DequeueStrategy m s where - - -- | Dequeue the front element and return it. - strategyDequeue :: StrategyQueue m s a - -- ^ the queue - -> Event m a - -- ^ the dequeued element - --- | It defines a strategy when we can enqueue a single element. -class DequeueStrategy m s => EnqueueStrategy m s where - - -- | Enqueue an element. - strategyEnqueue :: StrategyQueue m s a - -- ^ the queue - -> a - -- ^ the element to be enqueued - -> Event m () - -- ^ the action of enqueuing - --- | It defines a strategy when we can enqueue an element with the specified priority. -class DequeueStrategy m s => PriorityQueueStrategy m s p | s -> p where - - -- | Enqueue an element with the specified priority. - strategyEnqueueWithPriority :: StrategyQueue m s a - -- ^ the queue - -> p - -- ^ the priority - -> a - -- ^ the element to be enqueued - -> Event m () - -- ^ the action of enqueuing - --- | Strategy: First Come - First Served (FCFS). -data FCFS = FCFS deriving (Eq, Ord, Show) - --- | Strategy: Last Come - First Served (LCFS) -data LCFS = LCFS deriving (Eq, Ord, Show) - --- | Strategy: Service in Random Order (SIRO). -data SIRO = SIRO deriving (Eq, Ord, Show) - --- | Strategy: Static Priorities. It uses the priority queue. -data StaticPriorities = StaticPriorities deriving (Eq, Ord, Show) - --- | An implementation of the 'FCFS' queue strategy. -instance MonadComp m => QueueStrategy m FCFS where - - -- | A queue used by the 'FCFS' strategy. - newtype StrategyQueue m FCFS a = FCFSQueue (LL.DoubleLinkedList m a) - - newStrategyQueue s = - fmap FCFSQueue $ - do session <- liftParameter simulationSession - liftComp $ LL.newList session - - strategyQueueNull (FCFSQueue q) = liftComp $ LL.listNull q - --- | An implementation of the 'FCFS' queue strategy. -instance QueueStrategy m FCFS => DequeueStrategy m FCFS where - - strategyDequeue (FCFSQueue q) = - liftComp $ - do i <- LL.listFirst q - LL.listRemoveFirst q - return i - --- | An implementation of the 'FCFS' queue strategy. -instance DequeueStrategy m FCFS => EnqueueStrategy m FCFS where - - strategyEnqueue (FCFSQueue q) i = liftComp $ LL.listAddLast q i - --- | An implementation of the 'LCFS' queue strategy. -instance MonadComp m => QueueStrategy m LCFS where - - -- | A queue used by the 'LCFS' strategy. - newtype StrategyQueue m LCFS a = LCFSQueue (LL.DoubleLinkedList m a) - - newStrategyQueue s = - fmap LCFSQueue $ - do session <- liftParameter simulationSession - liftComp $ LL.newList session - - strategyQueueNull (LCFSQueue q) = liftComp $ LL.listNull q - --- | An implementation of the 'LCFS' queue strategy. -instance QueueStrategy m LCFS => DequeueStrategy m LCFS where - - strategyDequeue (LCFSQueue q) = - liftComp $ - do i <- LL.listFirst q - LL.listRemoveFirst q - return i - --- | An implementation of the 'LCFS' queue strategy. -instance DequeueStrategy m LCFS => EnqueueStrategy m LCFS where - - strategyEnqueue (LCFSQueue q) i = liftComp $ LL.listInsertFirst q i - --- | An implementation of the 'StaticPriorities' queue strategy. -instance MonadComp m => QueueStrategy m StaticPriorities where - - -- | A queue used by the 'StaticPriorities' strategy. - newtype StrategyQueue m StaticPriorities a = StaticPriorityQueue (PQ.PriorityQueue m a) - - newStrategyQueue s = - fmap StaticPriorityQueue $ - do session <- liftParameter simulationSession - liftComp $ PQ.newQueue session - - strategyQueueNull (StaticPriorityQueue q) = liftComp $ PQ.queueNull q - --- | An implementation of the 'StaticPriorities' queue strategy. -instance QueueStrategy m StaticPriorities => DequeueStrategy m StaticPriorities where - - strategyDequeue (StaticPriorityQueue q) = - liftComp $ - do (_, i) <- PQ.queueFront q - PQ.dequeue q - return i - --- | An implementation of the 'StaticPriorities' queue strategy. -instance DequeueStrategy m StaticPriorities => PriorityQueueStrategy m StaticPriorities Double where - - strategyEnqueueWithPriority (StaticPriorityQueue q) p i = liftComp $ PQ.enqueue q p i - --- | An implementation of the 'SIRO' queue strategy. -instance MonadComp m => QueueStrategy m SIRO where - - -- | A queue used by the 'SIRO' strategy. - newtype StrategyQueue m SIRO a = SIROQueue (V.Vector m a) - - newStrategyQueue s = - fmap SIROQueue $ - do session <- liftParameter simulationSession - liftComp $ V.newVector session - - strategyQueueNull (SIROQueue q) = - liftComp $ - do n <- V.vectorCount q - return (n == 0) - --- | An implementation of the 'SIRO' queue strategy. -instance QueueStrategy m SIRO => DequeueStrategy m SIRO where - - strategyDequeue (SIROQueue q) = - do n <- liftComp $ V.vectorCount q - i <- liftParameter $ randomUniformInt 0 (n - 1) - x <- liftComp $ V.readVector q i - liftComp $ V.vectorDeleteAt q i - return x - --- | An implementation of the 'SIRO' queue strategy. -instance DequeueStrategy m SIRO => EnqueueStrategy m SIRO where - - strategyEnqueue (SIROQueue q) i = liftComp $ V.appendVector q i + +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, FunctionalDependencies, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.Trans.QueueStrategy +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the queue strategies. +-- +module Simulation.Aivika.Trans.QueueStrategy where + +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Comp.Template +import Simulation.Aivika.Trans.Parameter +import Simulation.Aivika.Trans.Parameter.Random +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Event + +import qualified Simulation.Aivika.Trans.DoubleLinkedList as LL +import qualified Simulation.Aivika.Trans.PriorityQueue as PQ +import qualified Simulation.Aivika.Trans.Vector as V + +-- | Defines the basic queue strategy. +class MonadComp m => QueueStrategy m s where + + -- | The strategy queue. + data StrategyQueue m s :: * -> * + + -- | Create a new queue by the specified strategy. + newStrategyQueue :: s + -- ^ the strategy + -> Simulation m (StrategyQueue m s a) + -- ^ a new queue + + -- | Test whether the queue is empty. + strategyQueueNull :: StrategyQueue m s a + -- ^ the queue + -> Event m Bool + -- ^ the result of the test + +-- | Defines a strategy with support of the dequeuing operation. +class QueueStrategy m s => DequeueStrategy m s where + + -- | Dequeue the front element and return it. + strategyDequeue :: StrategyQueue m s a + -- ^ the queue + -> Event m a + -- ^ the dequeued element + +-- | It defines a strategy when we can enqueue a single element. +class DequeueStrategy m s => EnqueueStrategy m s where + + -- | Enqueue an element. + strategyEnqueue :: StrategyQueue m s a + -- ^ the queue + -> a + -- ^ the element to be enqueued + -> Event m () + -- ^ the action of enqueuing + +-- | It defines a strategy when we can enqueue an element with the specified priority. +class DequeueStrategy m s => PriorityQueueStrategy m s p | s -> p where + + -- | Enqueue an element with the specified priority. + strategyEnqueueWithPriority :: StrategyQueue m s a + -- ^ the queue + -> p + -- ^ the priority + -> a + -- ^ the element to be enqueued + -> Event m () + -- ^ the action of enqueuing + +-- | Strategy: First Come - First Served (FCFS). +data FCFS = FCFS deriving (Eq, Ord, Show) + +-- | Strategy: Last Come - First Served (LCFS) +data LCFS = LCFS deriving (Eq, Ord, Show) + +-- | Strategy: Service in Random Order (SIRO). +data SIRO = SIRO deriving (Eq, Ord, Show) + +-- | Strategy: Static Priorities. It uses the priority queue. +data StaticPriorities = StaticPriorities deriving (Eq, Ord, Show) + +-- | An implementation of the 'FCFS' queue strategy. +instance MonadComp m => QueueStrategy m FCFS where + + -- | A queue used by the 'FCFS' strategy. + newtype StrategyQueue m FCFS a = FCFSQueue (LL.DoubleLinkedList m a) + + newStrategyQueue s = + fmap FCFSQueue $ + do session <- liftParameter simulationSession + liftComp $ LL.newList session + + strategyQueueNull (FCFSQueue q) = liftComp $ LL.listNull q + +-- | An implementation of the 'FCFS' queue strategy. +instance QueueStrategy m FCFS => DequeueStrategy m FCFS where + + strategyDequeue (FCFSQueue q) = + liftComp $ + do i <- LL.listFirst q + LL.listRemoveFirst q + return i + +-- | An implementation of the 'FCFS' queue strategy. +instance DequeueStrategy m FCFS => EnqueueStrategy m FCFS where + + strategyEnqueue (FCFSQueue q) i = liftComp $ LL.listAddLast q i + +-- | An implementation of the 'LCFS' queue strategy. +instance MonadComp m => QueueStrategy m LCFS where + + -- | A queue used by the 'LCFS' strategy. + newtype StrategyQueue m LCFS a = LCFSQueue (LL.DoubleLinkedList m a) + + newStrategyQueue s = + fmap LCFSQueue $ + do session <- liftParameter simulationSession + liftComp $ LL.newList session + + strategyQueueNull (LCFSQueue q) = liftComp $ LL.listNull q + +-- | An implementation of the 'LCFS' queue strategy. +instance QueueStrategy m LCFS => DequeueStrategy m LCFS where + + strategyDequeue (LCFSQueue q) = + liftComp $ + do i <- LL.listFirst q + LL.listRemoveFirst q + return i + +-- | An implementation of the 'LCFS' queue strategy. +instance DequeueStrategy m LCFS => EnqueueStrategy m LCFS where + + strategyEnqueue (LCFSQueue q) i = liftComp $ LL.listInsertFirst q i + +-- | An implementation of the 'StaticPriorities' queue strategy. +instance MonadComp m => QueueStrategy m StaticPriorities where + + -- | A queue used by the 'StaticPriorities' strategy. + newtype StrategyQueue m StaticPriorities a = StaticPriorityQueue (PQ.PriorityQueue m a) + + newStrategyQueue s = + fmap StaticPriorityQueue $ + do session <- liftParameter simulationSession + liftComp $ PQ.newQueue session + + strategyQueueNull (StaticPriorityQueue q) = liftComp $ PQ.queueNull q + +-- | An implementation of the 'StaticPriorities' queue strategy. +instance QueueStrategy m StaticPriorities => DequeueStrategy m StaticPriorities where + + strategyDequeue (StaticPriorityQueue q) = + liftComp $ + do (_, i) <- PQ.queueFront q + PQ.dequeue q + return i + +-- | An implementation of the 'StaticPriorities' queue strategy. +instance DequeueStrategy m StaticPriorities => PriorityQueueStrategy m StaticPriorities Double where + + strategyEnqueueWithPriority (StaticPriorityQueue q) p i = liftComp $ PQ.enqueue q p i + +-- | An implementation of the 'SIRO' queue strategy. +instance MonadComp m => QueueStrategy m SIRO where + + -- | A queue used by the 'SIRO' strategy. + newtype StrategyQueue m SIRO a = SIROQueue (V.Vector m a) + + newStrategyQueue s = + fmap SIROQueue $ + do session <- liftParameter simulationSession + liftComp $ V.newVector session + + strategyQueueNull (SIROQueue q) = + liftComp $ + do n <- V.vectorCount q + return (n == 0) + +-- | An implementation of the 'SIRO' queue strategy. +instance QueueStrategy m SIRO => DequeueStrategy m SIRO where + + strategyDequeue (SIROQueue q) = + do n <- liftComp $ V.vectorCount q + i <- liftParameter $ randomUniformInt 0 (n - 1) + x <- liftComp $ V.readVector q i + liftComp $ V.vectorDeleteAt q i + return x + +-- | An implementation of the 'SIRO' queue strategy. +instance DequeueStrategy m SIRO => EnqueueStrategy m SIRO where + + strategyEnqueue (SIROQueue q) i = liftComp $ V.appendVector q i diff --git a/Simulation/Aivika/Trans/Ref.hs b/Simulation/Aivika/Trans/Ref.hs --- a/Simulation/Aivika/Trans/Ref.hs +++ b/Simulation/Aivika/Trans/Ref.hs @@ -1,76 +1,76 @@ - --- | --- Module : Simulation.Aivika.Trans.Ref --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines an updatable reference that depends on the event queue. --- -module Simulation.Aivika.Trans.Ref - (Ref, - refChanged, - refChanged_, - newRef, - readRef, - writeRef, - modifyRef) where - -import Data.IORef - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Event -import Simulation.Aivika.Trans.Internal.Signal -import Simulation.Aivika.Trans.Signal - --- | The 'Ref' type represents a mutable variable similar to the 'IORef' variable --- but only dependent on the event queue, which allows synchronizing the reference --- with the model explicitly through the 'Event' monad. -data Ref m a = - Ref { refValue :: ProtoRef m a, - refChangedSource :: SignalSource m a } - --- | Create a new reference. -newRef :: MonadComp m => a -> Simulation m (Ref m a) -newRef a = - Simulation $ \r -> - do let s = runSession r - x <- newProtoRef s a - s <- invokeSimulation r newSignalSource - return Ref { refValue = x, - refChangedSource = s } - --- | Read the value of a reference. -readRef :: MonadComp m => Ref m a -> Event m a -readRef r = Event $ \p -> readProtoRef (refValue r) - --- | Write a new value into the reference. -writeRef :: MonadComp m => Ref m a -> a -> Event m () -writeRef r a = Event $ \p -> - do a `seq` writeProtoRef (refValue r) a - invokeEvent p $ triggerSignal (refChangedSource r) a - --- | Mutate the contents of the reference. -modifyRef :: MonadComp m => Ref m a -> (a -> a) -> Event m () -modifyRef r f = Event $ \p -> - do a <- readProtoRef (refValue r) - let b = f a - b `seq` writeProtoRef (refValue r) b - invokeEvent p $ triggerSignal (refChangedSource r) b - --- | Return a signal that notifies about every change of the reference state. -refChanged :: MonadComp m => Ref m a -> Signal m a -refChanged v = publishSignal (refChangedSource v) - --- | Return a signal that notifies about every change of the reference state. -refChanged_ :: MonadComp m => Ref m a -> Signal m () -refChanged_ r = mapSignal (const ()) $ refChanged r + +-- | +-- Module : Simulation.Aivika.Trans.Ref +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines an updatable reference that depends on the event queue. +-- +module Simulation.Aivika.Trans.Ref + (Ref, + refChanged, + refChanged_, + newRef, + readRef, + writeRef, + modifyRef) where + +import Data.IORef + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Signal +import Simulation.Aivika.Trans.Signal + +-- | The 'Ref' type represents a mutable variable similar to the 'IORef' variable +-- but only dependent on the event queue, which allows synchronizing the reference +-- with the model explicitly through the 'Event' monad. +data Ref m a = + Ref { refValue :: ProtoRef m a, + refChangedSource :: SignalSource m a } + +-- | Create a new reference. +newRef :: MonadComp m => a -> Simulation m (Ref m a) +newRef a = + Simulation $ \r -> + do let s = runSession r + x <- newProtoRef s a + s <- invokeSimulation r newSignalSource + return Ref { refValue = x, + refChangedSource = s } + +-- | Read the value of a reference. +readRef :: MonadComp m => Ref m a -> Event m a +readRef r = Event $ \p -> readProtoRef (refValue r) + +-- | Write a new value into the reference. +writeRef :: MonadComp m => Ref m a -> a -> Event m () +writeRef r a = Event $ \p -> + do a `seq` writeProtoRef (refValue r) a + invokeEvent p $ triggerSignal (refChangedSource r) a + +-- | Mutate the contents of the reference. +modifyRef :: MonadComp m => Ref m a -> (a -> a) -> Event m () +modifyRef r f = Event $ \p -> + do a <- readProtoRef (refValue r) + let b = f a + b `seq` writeProtoRef (refValue r) b + invokeEvent p $ triggerSignal (refChangedSource r) b + +-- | Return a signal that notifies about every change of the reference state. +refChanged :: MonadComp m => Ref m a -> Signal m a +refChanged v = publishSignal (refChangedSource v) + +-- | Return a signal that notifies about every change of the reference state. +refChanged_ :: MonadComp m => Ref m a -> Signal m () +refChanged_ r = mapSignal (const ()) $ refChanged r diff --git a/Simulation/Aivika/Trans/Ref/Plain.hs b/Simulation/Aivika/Trans/Ref/Plain.hs --- a/Simulation/Aivika/Trans/Ref/Plain.hs +++ b/Simulation/Aivika/Trans/Ref/Plain.hs @@ -1,60 +1,60 @@ - --- | --- Module : Simulation.Aivika.Trans.Ref.Plain --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines a plain and more fast version of an updatable reference --- that depends on the event queue but that doesn't supply with the signal notification. --- -module Simulation.Aivika.Trans.Ref.Plain - (Ref, - newRef, - readRef, - writeRef, - modifyRef) where - -import Data.IORef - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Event - --- | The 'Ref' type represents a mutable variable similar to the 'IORef' variable --- but only dependent on the event queue, which allows synchronizing the reference --- with the model explicitly through the 'Event' monad. -newtype Ref m a = - Ref { refValue :: ProtoRef m a } - --- | Create a new reference. -newRef :: MonadComp m => a -> Simulation m (Ref m a) -newRef a = - Simulation $ \r -> - do let s = runSession r - x <- newProtoRef s a - return Ref { refValue = x } - --- | Read the value of a reference. -readRef :: MonadComp m => Ref m a -> Event m a -readRef r = Event $ \p -> readProtoRef (refValue r) - --- | Write a new value into the reference. -writeRef :: MonadComp m => Ref m a -> a -> Event m () -writeRef r a = Event $ \p -> - a `seq` writeProtoRef (refValue r) a - --- | Mutate the contents of the reference. -modifyRef :: MonadComp m => Ref m a -> (a -> a) -> Event m () -modifyRef r f = Event $ \p -> - do a <- readProtoRef (refValue r) - let b = f a - b `seq` writeProtoRef (refValue r) b + +-- | +-- Module : Simulation.Aivika.Trans.Ref.Plain +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines a plain and more fast version of an updatable reference +-- that depends on the event queue but that doesn't supply with the signal notification. +-- +module Simulation.Aivika.Trans.Ref.Plain + (Ref, + newRef, + readRef, + writeRef, + modifyRef) where + +import Data.IORef + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Event + +-- | The 'Ref' type represents a mutable variable similar to the 'IORef' variable +-- but only dependent on the event queue, which allows synchronizing the reference +-- with the model explicitly through the 'Event' monad. +newtype Ref m a = + Ref { refValue :: ProtoRef m a } + +-- | Create a new reference. +newRef :: MonadComp m => a -> Simulation m (Ref m a) +newRef a = + Simulation $ \r -> + do let s = runSession r + x <- newProtoRef s a + return Ref { refValue = x } + +-- | Read the value of a reference. +readRef :: MonadComp m => Ref m a -> Event m a +readRef r = Event $ \p -> readProtoRef (refValue r) + +-- | Write a new value into the reference. +writeRef :: MonadComp m => Ref m a -> a -> Event m () +writeRef r a = Event $ \p -> + a `seq` writeProtoRef (refValue r) a + +-- | Mutate the contents of the reference. +modifyRef :: MonadComp m => Ref m a -> (a -> a) -> Event m () +modifyRef r f = Event $ \p -> + do a <- readProtoRef (refValue r) + let b = f a + b `seq` writeProtoRef (refValue r) b diff --git a/Simulation/Aivika/Trans/Resource.hs b/Simulation/Aivika/Trans/Resource.hs --- a/Simulation/Aivika/Trans/Resource.hs +++ b/Simulation/Aivika/Trans/Resource.hs @@ -1,347 +1,347 @@ - -{-# LANGUAGE FlexibleContexts #-} - --- | --- Module : Simulation.Aivika.Trans.Resource --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines the resource which can be acquired and --- then released by the discontinuous process 'Process'. --- The resource can be either limited by the upper bound --- (run-time check), or it can have no upper bound. The latter --- is useful for modeling the infinite queue, for example. --- -module Simulation.Aivika.Trans.Resource - (-- * Resource Types - FCFSResource, - LCFSResource, - SIROResource, - PriorityResource, - Resource, - -- * Creating Resource - newFCFSResource, - newFCFSResourceWithMaxCount, - newLCFSResource, - newLCFSResourceWithMaxCount, - newSIROResource, - newSIROResourceWithMaxCount, - newPriorityResource, - newPriorityResourceWithMaxCount, - newResource, - newResourceWithMaxCount, - -- * Resource Properties - resourceStrategy, - resourceMaxCount, - resourceCount, - -- * Requesting for and Releasing Resource - requestResource, - requestResourceWithPriority, - tryRequestResourceWithinEvent, - releaseResource, - releaseResourceWithinEvent, - usingResource, - usingResourceWithPriority) where - -import Control.Monad -import Control.Monad.Trans -import Control.Exception - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Event -import Simulation.Aivika.Trans.Internal.Cont -import Simulation.Aivika.Trans.Internal.Process -import Simulation.Aivika.Trans.QueueStrategy - -import qualified Simulation.Aivika.Trans.DoubleLinkedList as DLL -import qualified Simulation.Aivika.Trans.Vector as V -import qualified Simulation.Aivika.Trans.PriorityQueue as PQ - --- | The ordinary FCFS (First Come - First Serviced) resource. -type FCFSResource m = Resource m FCFS - --- | The ordinary LCFS (Last Come - First Serviced) resource. -type LCFSResource m = Resource m LCFS - --- | The SIRO (Serviced in Random Order) resource. -type SIROResource m = Resource m SIRO - --- | The resource with static priorities. -type PriorityResource m = Resource m StaticPriorities - --- | Represents the resource with strategy @s@ applied for queuing the requests. -data Resource m s = - Resource { resourceStrategy :: s, - -- ^ Return the strategy applied for queuing the requests. - resourceMaxCount :: Maybe Int, - -- ^ Return the maximum count of the resource, where 'Nothing' - -- means that the resource has no upper bound. - resourceCountRef :: ProtoRef m Int, - resourceWaitList :: StrategyQueue m s (Event m (Maybe (ContParams m ()))) } - --- | Create a new FCFS resource with the specified initial count which value becomes --- the upper bound as well. -newFCFSResource :: MonadComp m - => Int - -- ^ the initial count (and maximal count too) of the resource - -> Simulation m (FCFSResource m) -newFCFSResource = newResource FCFS - --- | Create a new FCFS resource with the specified initial and maximum counts, --- where 'Nothing' means that the resource has no upper bound. -newFCFSResourceWithMaxCount :: MonadComp m - => Int - -- ^ the initial count of the resource - -> Maybe Int - -- ^ the maximum count of the resource, which can be indefinite - -> Simulation m (FCFSResource m) -newFCFSResourceWithMaxCount = newResourceWithMaxCount FCFS - --- | Create a new LCFS resource with the specified initial count which value becomes --- the upper bound as well. -newLCFSResource :: MonadComp m - => Int - -- ^ the initial count (and maximal count too) of the resource - -> Simulation m (LCFSResource m) -newLCFSResource = newResource LCFS - --- | Create a new LCFS resource with the specified initial and maximum counts, --- where 'Nothing' means that the resource has no upper bound. -newLCFSResourceWithMaxCount :: MonadComp m - => Int - -- ^ the initial count of the resource - -> Maybe Int - -- ^ the maximum count of the resource, which can be indefinite - -> Simulation m (LCFSResource m) -newLCFSResourceWithMaxCount = newResourceWithMaxCount LCFS - --- | Create a new SIRO resource with the specified initial count which value becomes --- the upper bound as well. -newSIROResource :: MonadComp m - => Int - -- ^ the initial count (and maximal count too) of the resource - -> Simulation m (SIROResource m) -newSIROResource = newResource SIRO - --- | Create a new SIRO resource with the specified initial and maximum counts, --- where 'Nothing' means that the resource has no upper bound. -newSIROResourceWithMaxCount :: MonadComp m - => Int - -- ^ the initial count of the resource - -> Maybe Int - -- ^ the maximum count of the resource, which can be indefinite - -> Simulation m (SIROResource m) -newSIROResourceWithMaxCount = newResourceWithMaxCount SIRO - --- | Create a new priority resource with the specified initial count which value becomes --- the upper bound as well. -newPriorityResource :: MonadComp m - => Int - -- ^ the initial count (and maximal count too) of the resource - -> Simulation m (PriorityResource m) -newPriorityResource = newResource StaticPriorities - --- | Create a new priority resource with the specified initial and maximum counts, --- where 'Nothing' means that the resource has no upper bound. -newPriorityResourceWithMaxCount :: MonadComp m - => Int - -- ^ the initial count of the resource - -> Maybe Int - -- ^ the maximum count of the resource, which can be indefinite - -> Simulation m (PriorityResource m) -newPriorityResourceWithMaxCount = newResourceWithMaxCount StaticPriorities - --- | Create a new resource with the specified queue strategy and initial count. --- The last value becomes the upper bound as well. -newResource :: (MonadComp m, QueueStrategy m s) - => s - -- ^ the strategy for managing the queuing requests - -> Int - -- ^ the initial count (and maximal count too) of the resource - -> Simulation m (Resource m s) -newResource s count = - Simulation $ \r -> - do when (count < 0) $ - error $ - "The resource count cannot be negative: " ++ - "newResource." - let session = runSession r - countRef <- newProtoRef session count - waitList <- invokeSimulation r $ newStrategyQueue s - return Resource { resourceStrategy = s, - resourceMaxCount = Just count, - resourceCountRef = countRef, - resourceWaitList = waitList } - --- | Create a new resource with the specified queue strategy, initial and maximum counts, --- where 'Nothing' means that the resource has no upper bound. -newResourceWithMaxCount :: (MonadComp m, QueueStrategy m s) - => s - -- ^ the strategy for managing the queuing requests - -> Int - -- ^ the initial count of the resource - -> Maybe Int - -- ^ the maximum count of the resource, which can be indefinite - -> Simulation m (Resource m s) -newResourceWithMaxCount s count maxCount = - Simulation $ \r -> - do when (count < 0) $ - error $ - "The resource count cannot be negative: " ++ - "newResourceWithMaxCount." - case maxCount of - Just maxCount | count > maxCount -> - error $ - "The resource count cannot be greater than " ++ - "its maximum value: newResourceWithMaxCount." - _ -> - return () - let session = runSession r - countRef <- newProtoRef session count - waitList <- invokeSimulation r $ newStrategyQueue s - return Resource { resourceStrategy = s, - resourceMaxCount = maxCount, - resourceCountRef = countRef, - resourceWaitList = waitList } - --- | Return the current count of the resource. -resourceCount :: MonadComp m => Resource m s -> Event m Int -resourceCount r = - Event $ \p -> readProtoRef (resourceCountRef r) - --- | Request for the resource decreasing its count in case of success, --- otherwise suspending the discontinuous process until some other --- process releases the resource. -requestResource :: (MonadComp m, EnqueueStrategy m s) - => Resource m s - -- ^ the requested resource - -> Process m () -requestResource r = - Process $ \pid -> - Cont $ \c -> - Event $ \p -> - do a <- readProtoRef (resourceCountRef r) - if a == 0 - then do c <- invokeEvent p $ contFreeze c - invokeEvent p $ - strategyEnqueue (resourceWaitList r) c - else do let a' = a - 1 - a' `seq` writeProtoRef (resourceCountRef r) a' - invokeEvent p $ resumeCont c () - --- | Request with the priority for the resource decreasing its count --- in case of success, otherwise suspending the discontinuous process --- until some other process releases the resource. -requestResourceWithPriority :: (MonadComp m, PriorityQueueStrategy m s p) - => Resource m s - -- ^ the requested resource - -> p - -- ^ the priority - -> Process m () -requestResourceWithPriority r priority = - Process $ \pid -> - Cont $ \c -> - Event $ \p -> - do a <- readProtoRef (resourceCountRef r) - if a == 0 - then do c <- invokeEvent p $ contFreeze c - invokeEvent p $ - strategyEnqueueWithPriority (resourceWaitList r) priority c - else do let a' = a - 1 - a' `seq` writeProtoRef (resourceCountRef r) a' - invokeEvent p $ resumeCont c () - --- | Release the resource increasing its count and resuming one of the --- previously suspended processes as possible. -releaseResource :: (MonadComp m, DequeueStrategy m s) - => Resource m s - -- ^ the resource to release - -> Process m () -releaseResource r = - Process $ \_ -> - Cont $ \c -> - Event $ \p -> - do invokeEvent p $ releaseResourceWithinEvent r - invokeEvent p $ resumeCont c () - --- | Release the resource increasing its count and resuming one of the --- previously suspended processes as possible. -releaseResourceWithinEvent :: (MonadComp m, DequeueStrategy m s) - => Resource m s - -- ^ the resource to release - -> Event m () -releaseResourceWithinEvent r = - Event $ \p -> - do a <- readProtoRef (resourceCountRef r) - let a' = a + 1 - case resourceMaxCount r of - Just maxCount | a' > maxCount -> - error $ - "The resource count cannot be greater than " ++ - "its maximum value: releaseResourceWithinEvent." - _ -> - return () - f <- invokeEvent p $ - strategyQueueNull (resourceWaitList r) - if f - then a' `seq` writeProtoRef (resourceCountRef r) a' - else do c <- invokeEvent p $ - strategyDequeue (resourceWaitList r) - c <- invokeEvent p c - case c of - Nothing -> - invokeEvent p $ releaseResourceWithinEvent r - Just c -> - invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c () - --- | Try to request for the resource decreasing its count in case of success --- and returning 'True' in the 'Event' monad; otherwise, returning 'False'. -tryRequestResourceWithinEvent :: MonadComp m - => Resource m s - -- ^ the resource which we try to request for - -> Event m Bool -tryRequestResourceWithinEvent r = - Event $ \p -> - do a <- readProtoRef (resourceCountRef r) - if a == 0 - then return False - else do let a' = a - 1 - a' `seq` writeProtoRef (resourceCountRef r) a' - return True - --- | Acquire the resource, perform some action and safely release the resource --- in the end, even if the 'IOException' was raised within the action. -usingResource :: (MonadComp m, EnqueueStrategy m s) - => Resource m s - -- ^ the resource we are going to request for and then release in the end - -> Process m a - -- ^ the action we are going to apply having the resource - -> Process m a - -- ^ the result of the action -usingResource r m = - do requestResource r - finallyProcess m $ releaseResource r - --- | Acquire the resource with the specified priority, perform some action and --- safely release the resource in the end, even if the 'IOException' was raised --- within the action. -usingResourceWithPriority :: (MonadComp m, PriorityQueueStrategy m s p) - => Resource m s - -- ^ the resource we are going to request for and then - -- release in the end - -> p - -- ^ the priority - -> Process m a - -- ^ the action we are going to apply having the resource - -> Process m a - -- ^ the result of the action -usingResourceWithPriority r priority m = - do requestResourceWithPriority r priority - finallyProcess m $ releaseResource r + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.Resource +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the resource which can be acquired and +-- then released by the discontinuous process 'Process'. +-- The resource can be either limited by the upper bound +-- (run-time check), or it can have no upper bound. The latter +-- is useful for modeling the infinite queue, for example. +-- +module Simulation.Aivika.Trans.Resource + (-- * Resource Types + FCFSResource, + LCFSResource, + SIROResource, + PriorityResource, + Resource, + -- * Creating Resource + newFCFSResource, + newFCFSResourceWithMaxCount, + newLCFSResource, + newLCFSResourceWithMaxCount, + newSIROResource, + newSIROResourceWithMaxCount, + newPriorityResource, + newPriorityResourceWithMaxCount, + newResource, + newResourceWithMaxCount, + -- * Resource Properties + resourceStrategy, + resourceMaxCount, + resourceCount, + -- * Requesting for and Releasing Resource + requestResource, + requestResourceWithPriority, + tryRequestResourceWithinEvent, + releaseResource, + releaseResourceWithinEvent, + usingResource, + usingResourceWithPriority) where + +import Control.Monad +import Control.Monad.Trans +import Control.Exception + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Cont +import Simulation.Aivika.Trans.Internal.Process +import Simulation.Aivika.Trans.QueueStrategy + +import qualified Simulation.Aivika.Trans.DoubleLinkedList as DLL +import qualified Simulation.Aivika.Trans.Vector as V +import qualified Simulation.Aivika.Trans.PriorityQueue as PQ + +-- | The ordinary FCFS (First Come - First Serviced) resource. +type FCFSResource m = Resource m FCFS + +-- | The ordinary LCFS (Last Come - First Serviced) resource. +type LCFSResource m = Resource m LCFS + +-- | The SIRO (Serviced in Random Order) resource. +type SIROResource m = Resource m SIRO + +-- | The resource with static priorities. +type PriorityResource m = Resource m StaticPriorities + +-- | Represents the resource with strategy @s@ applied for queuing the requests. +data Resource m s = + Resource { resourceStrategy :: s, + -- ^ Return the strategy applied for queuing the requests. + resourceMaxCount :: Maybe Int, + -- ^ Return the maximum count of the resource, where 'Nothing' + -- means that the resource has no upper bound. + resourceCountRef :: ProtoRef m Int, + resourceWaitList :: StrategyQueue m s (Event m (Maybe (ContParams m ()))) } + +-- | Create a new FCFS resource with the specified initial count which value becomes +-- the upper bound as well. +newFCFSResource :: MonadComp m + => Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation m (FCFSResource m) +newFCFSResource = newResource FCFS + +-- | Create a new FCFS resource with the specified initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newFCFSResourceWithMaxCount :: MonadComp m + => Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation m (FCFSResource m) +newFCFSResourceWithMaxCount = newResourceWithMaxCount FCFS + +-- | Create a new LCFS resource with the specified initial count which value becomes +-- the upper bound as well. +newLCFSResource :: MonadComp m + => Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation m (LCFSResource m) +newLCFSResource = newResource LCFS + +-- | Create a new LCFS resource with the specified initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newLCFSResourceWithMaxCount :: MonadComp m + => Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation m (LCFSResource m) +newLCFSResourceWithMaxCount = newResourceWithMaxCount LCFS + +-- | Create a new SIRO resource with the specified initial count which value becomes +-- the upper bound as well. +newSIROResource :: MonadComp m + => Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation m (SIROResource m) +newSIROResource = newResource SIRO + +-- | Create a new SIRO resource with the specified initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newSIROResourceWithMaxCount :: MonadComp m + => Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation m (SIROResource m) +newSIROResourceWithMaxCount = newResourceWithMaxCount SIRO + +-- | Create a new priority resource with the specified initial count which value becomes +-- the upper bound as well. +newPriorityResource :: MonadComp m + => Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation m (PriorityResource m) +newPriorityResource = newResource StaticPriorities + +-- | Create a new priority resource with the specified initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newPriorityResourceWithMaxCount :: MonadComp m + => Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation m (PriorityResource m) +newPriorityResourceWithMaxCount = newResourceWithMaxCount StaticPriorities + +-- | Create a new resource with the specified queue strategy and initial count. +-- The last value becomes the upper bound as well. +newResource :: (MonadComp m, QueueStrategy m s) + => s + -- ^ the strategy for managing the queuing requests + -> Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation m (Resource m s) +newResource s count = + Simulation $ \r -> + do when (count < 0) $ + error $ + "The resource count cannot be negative: " ++ + "newResource." + let session = runSession r + countRef <- newProtoRef session count + waitList <- invokeSimulation r $ newStrategyQueue s + return Resource { resourceStrategy = s, + resourceMaxCount = Just count, + resourceCountRef = countRef, + resourceWaitList = waitList } + +-- | Create a new resource with the specified queue strategy, initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newResourceWithMaxCount :: (MonadComp m, QueueStrategy m s) + => s + -- ^ the strategy for managing the queuing requests + -> Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation m (Resource m s) +newResourceWithMaxCount s count maxCount = + Simulation $ \r -> + do when (count < 0) $ + error $ + "The resource count cannot be negative: " ++ + "newResourceWithMaxCount." + case maxCount of + Just maxCount | count > maxCount -> + error $ + "The resource count cannot be greater than " ++ + "its maximum value: newResourceWithMaxCount." + _ -> + return () + let session = runSession r + countRef <- newProtoRef session count + waitList <- invokeSimulation r $ newStrategyQueue s + return Resource { resourceStrategy = s, + resourceMaxCount = maxCount, + resourceCountRef = countRef, + resourceWaitList = waitList } + +-- | Return the current count of the resource. +resourceCount :: MonadComp m => Resource m s -> Event m Int +resourceCount r = + Event $ \p -> readProtoRef (resourceCountRef r) + +-- | Request for the resource decreasing its count in case of success, +-- otherwise suspending the discontinuous process until some other +-- process releases the resource. +requestResource :: (MonadComp m, EnqueueStrategy m s) + => Resource m s + -- ^ the requested resource + -> Process m () +requestResource r = + Process $ \pid -> + Cont $ \c -> + Event $ \p -> + do a <- readProtoRef (resourceCountRef r) + if a == 0 + then do c <- invokeEvent p $ contFreeze c + invokeEvent p $ + strategyEnqueue (resourceWaitList r) c + else do let a' = a - 1 + a' `seq` writeProtoRef (resourceCountRef r) a' + invokeEvent p $ resumeCont c () + +-- | Request with the priority for the resource decreasing its count +-- in case of success, otherwise suspending the discontinuous process +-- until some other process releases the resource. +requestResourceWithPriority :: (MonadComp m, PriorityQueueStrategy m s p) + => Resource m s + -- ^ the requested resource + -> p + -- ^ the priority + -> Process m () +requestResourceWithPriority r priority = + Process $ \pid -> + Cont $ \c -> + Event $ \p -> + do a <- readProtoRef (resourceCountRef r) + if a == 0 + then do c <- invokeEvent p $ contFreeze c + invokeEvent p $ + strategyEnqueueWithPriority (resourceWaitList r) priority c + else do let a' = a - 1 + a' `seq` writeProtoRef (resourceCountRef r) a' + invokeEvent p $ resumeCont c () + +-- | Release the resource increasing its count and resuming one of the +-- previously suspended processes as possible. +releaseResource :: (MonadComp m, DequeueStrategy m s) + => Resource m s + -- ^ the resource to release + -> Process m () +releaseResource r = + Process $ \_ -> + Cont $ \c -> + Event $ \p -> + do invokeEvent p $ releaseResourceWithinEvent r + invokeEvent p $ resumeCont c () + +-- | Release the resource increasing its count and resuming one of the +-- previously suspended processes as possible. +releaseResourceWithinEvent :: (MonadComp m, DequeueStrategy m s) + => Resource m s + -- ^ the resource to release + -> Event m () +releaseResourceWithinEvent r = + Event $ \p -> + do a <- readProtoRef (resourceCountRef r) + let a' = a + 1 + case resourceMaxCount r of + Just maxCount | a' > maxCount -> + error $ + "The resource count cannot be greater than " ++ + "its maximum value: releaseResourceWithinEvent." + _ -> + return () + f <- invokeEvent p $ + strategyQueueNull (resourceWaitList r) + if f + then a' `seq` writeProtoRef (resourceCountRef r) a' + else do c <- invokeEvent p $ + strategyDequeue (resourceWaitList r) + c <- invokeEvent p c + case c of + Nothing -> + invokeEvent p $ releaseResourceWithinEvent r + Just c -> + invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c () + +-- | Try to request for the resource decreasing its count in case of success +-- and returning 'True' in the 'Event' monad; otherwise, returning 'False'. +tryRequestResourceWithinEvent :: MonadComp m + => Resource m s + -- ^ the resource which we try to request for + -> Event m Bool +tryRequestResourceWithinEvent r = + Event $ \p -> + do a <- readProtoRef (resourceCountRef r) + if a == 0 + then return False + else do let a' = a - 1 + a' `seq` writeProtoRef (resourceCountRef r) a' + return True + +-- | Acquire the resource, perform some action and safely release the resource +-- in the end, even if the 'IOException' was raised within the action. +usingResource :: (MonadComp m, EnqueueStrategy m s) + => Resource m s + -- ^ the resource we are going to request for and then release in the end + -> Process m a + -- ^ the action we are going to apply having the resource + -> Process m a + -- ^ the result of the action +usingResource r m = + do requestResource r + finallyProcess m $ releaseResource r + +-- | Acquire the resource with the specified priority, perform some action and +-- safely release the resource in the end, even if the 'IOException' was raised +-- within the action. +usingResourceWithPriority :: (MonadComp m, PriorityQueueStrategy m s p) + => Resource m s + -- ^ the resource we are going to request for and then + -- release in the end + -> p + -- ^ the priority + -> Process m a + -- ^ the action we are going to apply having the resource + -> Process m a + -- ^ the result of the action +usingResourceWithPriority r priority m = + do requestResourceWithPriority r priority + finallyProcess m $ releaseResource r 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,1890 +1,1939 @@ - -{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, UndecidableInstances, ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies #-} - --- | --- Module : Simulation.Aivika.Trans.Results --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module allows exporting the simulation results from the model. --- -module Simulation.Aivika.Trans.Results - (-- * Definitions Focused on Modeling - Results, - ResultTransform, - ResultName, - ResultProvider(..), - results, - expandResults, - resultSummary, - resultByName, - resultByProperty, - resultById, - resultByIndex, - resultBySubscript, - ResultComputing(..), - ResultListWithSubscript(..), - ResultArrayWithSubscript(..), -#ifndef __HASTE__ - ResultVectorWithSubscript(..), -#endif - -- * Definitions Focused on Using the Library - ResultExtract(..), - extractIntResults, - extractIntListResults, - extractIntStatsResults, - extractIntStatsEitherResults, - extractIntTimingStatsResults, - extractDoubleResults, - extractDoubleListResults, - extractDoubleStatsResults, - extractDoubleStatsEitherResults, - extractDoubleTimingStatsResults, - extractStringResults, - ResultPredefinedSignals(..), - newResultPredefinedSignals, - resultSignal, - pureResultSignal, - -- * Definitions Focused on Extending the Library - ResultSourceMap, - ResultSource(..), - ResultItem(..), - ResultItemable(..), - resultItemToIntStatsEitherValue, - resultItemToDoubleStatsEitherValue, - ResultObject(..), - ResultProperty(..), - ResultVector(..), - memoResultVectorSignal, - memoResultVectorSummary, - ResultSeparator(..), - ResultValue(..), - voidResultValue, - ResultContainer(..), - resultContainerPropertySource, - resultContainerConstProperty, - resultContainerIntegProperty, - resultContainerProperty, - resultContainerMapProperty, - resultValueToContainer, - resultContainerToValue, - ResultData, - ResultSignal(..), - maybeResultSignal, - textResultSource, - timeResultSource, - resultSourceToIntValues, - resultSourceToIntListValues, - resultSourceToIntStatsValues, - resultSourceToIntStatsEitherValues, - resultSourceToIntTimingStatsValues, - resultSourceToDoubleValues, - resultSourceToDoubleListValues, - resultSourceToDoubleStatsValues, - resultSourceToDoubleStatsEitherValues, - resultSourceToDoubleTimingStatsValues, - resultSourceToStringValues, - resultSourceMap, - resultSourceList, - resultsToIntValues, - resultsToIntListValues, - resultsToIntStatsValues, - resultsToIntStatsEitherValues, - resultsToIntTimingStatsValues, - resultsToDoubleValues, - resultsToDoubleListValues, - resultsToDoubleStatsValues, - resultsToDoubleStatsEitherValues, - resultsToDoubleTimingStatsValues, - resultsToStringValues, - composeResults, - computeResultValue) where - -import Control.Monad -import Control.Monad.Trans - -import qualified Data.Map as M -import qualified Data.Array as A - -#ifndef __HASTE__ -import qualified Data.Vector as V -#endif - -import Data.Ix -import Data.Maybe -import Data.Monoid - -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Parameter -import Simulation.Aivika.Trans.Simulation -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Event -import Simulation.Aivika.Trans.Signal -import Simulation.Aivika.Trans.Statistics -import Simulation.Aivika.Trans.Statistics.Accumulator -import Simulation.Aivika.Trans.Ref -import qualified Simulation.Aivika.Trans.Ref.Plain as LR -import Simulation.Aivika.Trans.Var -import Simulation.Aivika.Trans.QueueStrategy -import qualified Simulation.Aivika.Trans.Queue as Q -import qualified Simulation.Aivika.Trans.Queue.Infinite as IQ -import Simulation.Aivika.Trans.Arrival -import Simulation.Aivika.Trans.Server -import Simulation.Aivika.Trans.Results.Locale - --- | A name used for indentifying the results when generating output. -type ResultName = String - --- | Represents a provider of the simulation results. It is usually something, or --- an array of something, or a list of such values which can be simulated to get data. -class MonadComp m => ResultProvider p m | p -> m where - - -- | Return the source of simulation results by the specified name, description and provider. - resultSource :: ResultName -> ResultDescription -> p -> ResultSource m - resultSource name descr = resultSource' name (UserDefinedResultId descr) - - -- | Return the source of simulation results by the specified name, identifier and provider. - resultSource' :: ResultName -> ResultId -> p -> ResultSource m - --- | It associates the result sources with their names. -type ResultSourceMap m = M.Map ResultName (ResultSource m) - --- | Encapsulates the result source. -data ResultSource m = ResultItemSource (ResultItem m) - -- ^ The source consisting of a single item. - | ResultObjectSource (ResultObject m) - -- ^ An object-like source. - | ResultVectorSource (ResultVector m) - -- ^ A vector-like structure. - | ResultSeparatorSource ResultSeparator - -- ^ This is a separator text. - --- | The simulation results represented by a single item. -data ResultItem m = forall a. ResultItemable a => ResultItem (a m) - --- | Represents a type class for actual representing the items. -class ResultItemable a where - - -- | The item name. - resultItemName :: a m -> ResultName - - -- | The item identifier. - resultItemId :: a m -> ResultId - - -- | Whether the item emits a signal. - resultItemSignal :: MonadComp m => a m -> ResultSignal m - - -- | Return an expanded version of the item, for example, - -- when the statistics item is exanded to an object - -- having the corresponded properties for count, average, - -- deviation, minimum, maximum and so on. - resultItemExpansion :: MonadComp m => a m -> ResultSource m - - -- | Return usually a short version of the item, i.e. its summary, - -- but values of some data types such as statistics can be - -- implicitly expanded to an object with the corresponded - -- properties. - resultItemSummary :: MonadComp m => a m -> ResultSource m - - -- | Return integer numbers in time points. - resultItemToIntValue :: MonadComp m => a m -> ResultValue Int m - - -- | Return lists of integer numbers in time points. - resultItemToIntListValue :: MonadComp m => a m -> ResultValue [Int] m - - -- | Return statistics based on integer numbers. - resultItemToIntStatsValue :: MonadComp m => a m -> ResultValue (SamplingStats Int) m - - -- | Return timing statistics based on integer numbers. - resultItemToIntTimingStatsValue :: MonadComp m => a m -> ResultValue (TimingStats Int) m - - -- | Return double numbers in time points. - resultItemToDoubleValue :: MonadComp m => a m -> ResultValue Double m - - -- | Return lists of double numbers in time points. - resultItemToDoubleListValue :: MonadComp m => a m -> ResultValue [Double] m - - -- | Return statistics based on double numbers. - resultItemToDoubleStatsValue :: MonadComp m => a m -> ResultValue (SamplingStats Double) m - - -- | Return timing statistics based on integer numbers. - resultItemToDoubleTimingStatsValue :: MonadComp m => a m -> ResultValue (TimingStats Double) m - - -- | Return string representations in time points. - resultItemToStringValue :: MonadComp m => a m -> ResultValue String m - --- | Return a version optimised for fast aggregation of the statistics based on integer numbers. -resultItemToIntStatsEitherValue :: (MonadComp m, ResultItemable a) => a m -> ResultValue (Either Int (SamplingStats Int)) m -resultItemToIntStatsEitherValue x = - case resultValueData x1 of - Just a1 -> mapResultValue Left x1 - Nothing -> - case resultValueData x2 of - Just a2 -> mapResultValue Right x2 - Nothing -> voidResultValue x2 - where - x1 = resultItemToIntValue x - x2 = resultItemToIntStatsValue x - --- | Return a version optimised for fast aggregation of the statistics based on double floating point numbers. -resultItemToDoubleStatsEitherValue :: (MonadComp m, ResultItemable a) => a m -> ResultValue (Either Double (SamplingStats Double)) m -resultItemToDoubleStatsEitherValue x = - case resultValueData x1 of - Just a1 -> mapResultValue Left x1 - Nothing -> - case resultValueData x2 of - Just a2 -> mapResultValue Right x2 - Nothing -> voidResultValue x2 - where - x1 = resultItemToDoubleValue x - x2 = resultItemToDoubleStatsValue x - --- | The simulation results represented by an object having properties. -data ResultObject m = - ResultObject { resultObjectName :: ResultName, - -- ^ The object name. - resultObjectId :: ResultId, - -- ^ The object identifier. - resultObjectTypeId :: ResultId, - -- ^ The object type identifier. - resultObjectProperties :: [ResultProperty m], - -- ^ The object properties. - resultObjectSignal :: ResultSignal m, - -- ^ A combined signal if present. - resultObjectSummary :: ResultSource m - -- ^ A short version of the object, i.e. its summary. - } - --- | The object property containing the simulation results. -data ResultProperty m = - ResultProperty { resultPropertyLabel :: ResultName, - -- ^ The property short label. - resultPropertyId :: ResultId, - -- ^ The property identifier. - resultPropertySource :: ResultSource m - -- ^ The simulation results supplied by the property. - } - --- | The simulation results represented by a vector. -data ResultVector m = - ResultVector { resultVectorName :: ResultName, - -- ^ The vector name. - resultVectorId :: ResultId, - -- ^ The vector identifier. - resultVectorItems :: A.Array Int (ResultSource m), - -- ^ The results supplied by the vector items. - resultVectorSubscript :: A.Array Int ResultName, - -- ^ The subscript used as a suffix to create item names. - resultVectorSignal :: ResultSignal m, - -- ^ A combined signal if present. - resultVectorSummary :: ResultSource m - -- ^ A short version of the vector, i.e. summary. - } - --- | Calculate the result vector signal and memoize it in a new vector. -memoResultVectorSignal :: MonadComp m => ResultVector m -> ResultVector m -memoResultVectorSignal x = - x { resultVectorSignal = - foldr (<>) mempty $ map resultSourceSignal $ A.elems $ resultVectorItems x } - --- | Calculate the result vector summary and memoize it in a new vector. -memoResultVectorSummary :: MonadComp m => ResultVector m -> ResultVector m -memoResultVectorSummary x = - x { resultVectorSummary = - ResultVectorSource $ - x { resultVectorItems = - A.array bnds [(i, resultSourceSummary e) | (i, e) <- ies] } } - where - arr = resultVectorItems x - bnds = A.bounds arr - ies = A.assocs arr - --- | It separates the simulation results when printing. -data ResultSeparator = - ResultSeparator { resultSeparatorText :: String - -- ^ The separator text. - } - --- | A parameterised value that actually represents a generalised result item that have no parametric type. -data ResultValue e m = - ResultValue { resultValueName :: ResultName, - -- ^ The value name. - resultValueId :: ResultId, - -- ^ The value identifier. - resultValueData :: ResultData e m, - -- ^ Simulation data supplied by the value. - resultValueSignal :: ResultSignal m - -- ^ Whether the value emits a signal when changing simulation data. - } - -mapResultValue :: MonadComp m => (a -> b) -> ResultValue a m -> ResultValue b m -mapResultValue f x = x { resultValueData = fmap (fmap f) (resultValueData x) } - --- | Return a new value with the discarded simulation results. -voidResultValue :: ResultValue a m -> ResultValue b m -voidResultValue x = x { resultValueData = Nothing } - --- | A container of the simulation results such as queue, server or array. -data ResultContainer e m = - ResultContainer { resultContainerName :: ResultName, - -- ^ The container name. - resultContainerId :: ResultId, - -- ^ The container identifier. - resultContainerData :: e, - -- ^ The container data. - resultContainerSignal :: ResultSignal m - -- ^ Whether the container emits a signal when changing simulation data. - } - -mapResultContainer :: (a -> b) -> ResultContainer a m -> ResultContainer b m -mapResultContainer f x = x { resultContainerData = f (resultContainerData x) } - --- | Create a new property source by the specified container. -resultContainerPropertySource :: ResultItemable (ResultValue b) - => ResultContainer a m - -- ^ the container - -> ResultName - -- ^ the property label - -> ResultId - -- ^ the property identifier - -> (a -> ResultData b m) - -- ^ get the specified data from the container - -> (a -> ResultSignal m) - -- ^ get the data signal from the container - -> ResultSource m -resultContainerPropertySource cont name i f g = - ResultItemSource $ - ResultItem $ - ResultValue { - resultValueName = (resultContainerName cont) ++ "." ++ name, - resultValueId = i, - resultValueData = f (resultContainerData cont), - resultValueSignal = g (resultContainerData cont) } - --- | Create a constant property by the specified container. -resultContainerConstProperty :: (MonadComp m, - ResultItemable (ResultValue b)) - => ResultContainer a m - -- ^ the container - -> ResultName - -- ^ the property label - -> ResultId - -- ^ the property identifier - -> (a -> b) - -- ^ get the specified data from the container - -> ResultProperty m -resultContainerConstProperty cont name i f = - ResultProperty { - resultPropertyLabel = name, - resultPropertyId = i, - resultPropertySource = - resultContainerPropertySource cont name i (Just . return . f) (const EmptyResultSignal) } - --- | Create by the specified container a property that changes in the integration time points, or it is supposed to be such one. -resultContainerIntegProperty :: (MonadComp m, - ResultItemable (ResultValue b)) - => ResultContainer a m - -- ^ the container - -> ResultName - -- ^ the property label - -> ResultId - -- ^ the property identifier - -> (a -> Event m b) - -- ^ get the specified data from the container - -> ResultProperty m -resultContainerIntegProperty cont name i f = - ResultProperty { - resultPropertyLabel = name, - resultPropertyId = i, - resultPropertySource = - resultContainerPropertySource cont name i (Just . f) (const UnknownResultSignal) } - --- | Create a property by the specified container. -resultContainerProperty :: (MonadComp m, - ResultItemable (ResultValue b)) - => ResultContainer a m - -- ^ the container - -> ResultName - -- ^ the property label - -> ResultId - -- ^ the property identifier - -> (a -> Event m b) - -- ^ get the specified data from the container - -> (a -> Signal m ()) - -- ^ get a signal triggered when changing data. - -> ResultProperty m -resultContainerProperty cont name i f g = - ResultProperty { - resultPropertyLabel = name, - resultPropertyId = i, - resultPropertySource = - resultContainerPropertySource cont name i (Just . f) (ResultSignal . g) } - --- | Create by the specified container a mapped property which is recomputed each time again and again. -resultContainerMapProperty :: (MonadComp m, - ResultItemable (ResultValue b)) - => ResultContainer (ResultData a m) m - -- ^ the container - -> ResultName - -- ^ the property label - -> ResultId - -- ^ the property identifier - -> (a -> b) - -- ^ recompute the specified data - -> ResultProperty m -resultContainerMapProperty cont name i f = - ResultProperty { - resultPropertyLabel = name, - resultPropertyId = i, - resultPropertySource = - resultContainerPropertySource cont name i (fmap $ fmap f) (const $ resultContainerSignal cont) } - --- | Convert the result value to a container with the specified object identifier. -resultValueToContainer :: ResultValue a m -> ResultContainer (ResultData a m) m -resultValueToContainer x = - ResultContainer { - resultContainerName = resultValueName x, - resultContainerId = resultValueId x, - resultContainerData = resultValueData x, - resultContainerSignal = resultValueSignal x } - --- | Convert the result container to a value. -resultContainerToValue :: ResultContainer (ResultData a m) m -> ResultValue a m -resultContainerToValue x = - ResultValue { - resultValueName = resultContainerName x, - resultValueId = resultContainerId x, - resultValueData = resultContainerData x, - resultValueSignal = resultContainerSignal x } - --- | Represents the very simulation results. -type ResultData e m = Maybe (Event m e) - --- | Whether an object containing the results emits a signal notifying about change of data. -data ResultSignal m = EmptyResultSignal - -- ^ There is no signal at all. - | UnknownResultSignal - -- ^ The signal is unknown, but the entity probably changes. - | ResultSignal (Signal m ()) - -- ^ When the signal is precisely specified. - | ResultSignalMix (Signal m ()) - -- ^ When the specified signal was combined with unknown signal. - -instance MonadComp m => Monoid (ResultSignal m) where - - mempty = EmptyResultSignal - - mappend EmptyResultSignal z = z - - mappend UnknownResultSignal EmptyResultSignal = UnknownResultSignal - mappend UnknownResultSignal UnknownResultSignal = UnknownResultSignal - mappend UnknownResultSignal (ResultSignal x) = ResultSignalMix x - mappend UnknownResultSignal z@(ResultSignalMix x) = z - - mappend z@(ResultSignal x) EmptyResultSignal = z - mappend (ResultSignal x) UnknownResultSignal = ResultSignalMix x - mappend (ResultSignal x) (ResultSignal y) = ResultSignal (x <> y) - mappend (ResultSignal x) (ResultSignalMix y) = ResultSignalMix (x <> y) - - mappend z@(ResultSignalMix x) EmptyResultSignal = z - mappend z@(ResultSignalMix x) UnknownResultSignal = z - mappend (ResultSignalMix x) (ResultSignal y) = ResultSignalMix (x <> y) - mappend (ResultSignalMix x) (ResultSignalMix y) = ResultSignalMix (x <> y) - --- | Construct a new result signal by the specified optional pure signal. -maybeResultSignal :: Maybe (Signal m ()) -> ResultSignal m -maybeResultSignal (Just x) = ResultSignal x -maybeResultSignal Nothing = EmptyResultSignal - -instance ResultItemable (ResultValue Int) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = id - resultItemToIntListValue = mapResultValue return - resultItemToIntStatsValue = mapResultValue returnSamplingStats - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = mapResultValue fromIntegral - resultItemToDoubleListValue = mapResultValue (return . fromIntegral) - resultItemToDoubleStatsValue = mapResultValue (returnSamplingStats . fromIntegral) - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = mapResultValue show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue Double) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = id - resultItemToDoubleListValue = mapResultValue return - resultItemToDoubleStatsValue = mapResultValue returnSamplingStats - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = mapResultValue show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue [Int]) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = id - resultItemToIntStatsValue = mapResultValue listSamplingStats - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = mapResultValue (map fromIntegral) - resultItemToDoubleStatsValue = mapResultValue (fromIntSamplingStats . listSamplingStats) - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = mapResultValue show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue [Double]) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = id - resultItemToDoubleStatsValue = mapResultValue listSamplingStats - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = mapResultValue show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue (SamplingStats Int)) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = id - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = mapResultValue fromIntSamplingStats - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = mapResultValue show - - resultItemExpansion = samplingStatsResultSource - resultItemSummary = samplingStatsResultSummary - -instance ResultItemable (ResultValue (SamplingStats Double)) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = id - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = mapResultValue show - - resultItemExpansion = samplingStatsResultSource - resultItemSummary = samplingStatsResultSummary - -instance ResultItemable (ResultValue (TimingStats Int)) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = id - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = mapResultValue fromIntTimingStats - - resultItemToStringValue = mapResultValue show - - resultItemExpansion = timingStatsResultSource - resultItemSummary = timingStatsResultSummary - -instance ResultItemable (ResultValue (TimingStats Double)) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = id - - resultItemToStringValue = mapResultValue show - - resultItemExpansion = timingStatsResultSource - resultItemSummary = timingStatsResultSummary - -instance ResultItemable (ResultValue Bool) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = mapResultValue show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue String) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = mapResultValue show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue ()) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = mapResultValue show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue FCFS) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = mapResultValue show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue LCFS) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = mapResultValue show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue SIRO) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = mapResultValue show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue StaticPriorities) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = mapResultValue show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - --- | Flatten the result source. -flattenResultSource :: ResultSource m -> [ResultItem m] -flattenResultSource (ResultItemSource x) = [x] -flattenResultSource (ResultObjectSource x) = - concat $ map (flattenResultSource . resultPropertySource) $ resultObjectProperties x -flattenResultSource (ResultVectorSource x) = - concat $ map flattenResultSource $ A.elems $ resultVectorItems x -flattenResultSource (ResultSeparatorSource x) = [] - --- | Return the result source name. -resultSourceName :: ResultSource m -> ResultName -resultSourceName (ResultItemSource (ResultItem x)) = resultItemName x -resultSourceName (ResultObjectSource x) = resultObjectName x -resultSourceName (ResultVectorSource x) = resultVectorName x -resultSourceName (ResultSeparatorSource x) = [] - --- | Expand the result source returning a more detailed version expanding the properties as possible. -expandResultSource :: MonadComp m => ResultSource m -> ResultSource m -expandResultSource (ResultItemSource (ResultItem x)) = resultItemExpansion x -expandResultSource (ResultObjectSource x) = - ResultObjectSource $ - x { resultObjectProperties = - flip fmap (resultObjectProperties x) $ \p -> - p { resultPropertySource = expandResultSource (resultPropertySource p) } } -expandResultSource (ResultVectorSource x) = - ResultVectorSource $ - x { resultVectorItems = - A.array bnds [(i, expandResultSource e) | (i, e) <- ies] } - where arr = resultVectorItems x - bnds = A.bounds arr - ies = A.assocs arr -expandResultSource z@(ResultSeparatorSource x) = z - --- | Return a summarised and usually more short version of the result source expanding the main properties or excluding auxiliary properties if required. -resultSourceSummary :: MonadComp m => ResultSource m -> ResultSource m -resultSourceSummary (ResultItemSource (ResultItem x)) = resultItemSummary x -resultSourceSummary (ResultObjectSource x) = resultObjectSummary x -resultSourceSummary (ResultVectorSource x) = resultVectorSummary x -resultSourceSummary z@(ResultSeparatorSource x) = z - --- | Return a signal emitted by the source. -resultSourceSignal :: MonadComp m => ResultSource m -> ResultSignal m -resultSourceSignal (ResultItemSource (ResultItem x)) = resultItemSignal x -resultSourceSignal (ResultObjectSource x) = resultObjectSignal x -resultSourceSignal (ResultVectorSource x) = resultVectorSignal x -resultSourceSignal (ResultSeparatorSource x) = EmptyResultSignal - --- | Represent the result source as integer numbers. -resultSourceToIntValues :: MonadComp m => ResultSource m -> [ResultValue Int m] -resultSourceToIntValues = map (\(ResultItem x) -> resultItemToIntValue x) . flattenResultSource - --- | Represent the result source as lists of integer numbers. -resultSourceToIntListValues :: MonadComp m => ResultSource m -> [ResultValue [Int] m] -resultSourceToIntListValues = map (\(ResultItem x) -> resultItemToIntListValue x) . flattenResultSource - --- | Represent the result source as statistics based on integer numbers. -resultSourceToIntStatsValues :: MonadComp m => ResultSource m -> [ResultValue (SamplingStats Int) m] -resultSourceToIntStatsValues = map (\(ResultItem x) -> resultItemToIntStatsValue x) . flattenResultSource - --- | Represent the result source as statistics based on integer numbers and optimised for fast aggregation. -resultSourceToIntStatsEitherValues :: MonadComp m => ResultSource m -> [ResultValue (Either Int (SamplingStats Int)) m] -resultSourceToIntStatsEitherValues = map (\(ResultItem x) -> resultItemToIntStatsEitherValue x) . flattenResultSource - --- | Represent the result source as timing statistics based on integer numbers. -resultSourceToIntTimingStatsValues :: MonadComp m => ResultSource m -> [ResultValue (TimingStats Int) m] -resultSourceToIntTimingStatsValues = map (\(ResultItem x) -> resultItemToIntTimingStatsValue x) . flattenResultSource - --- | Represent the result source as double floating point numbers. -resultSourceToDoubleValues :: MonadComp m => ResultSource m -> [ResultValue Double m] -resultSourceToDoubleValues = map (\(ResultItem x) -> resultItemToDoubleValue x) . flattenResultSource - --- | Represent the result source as lists of double floating point numbers. -resultSourceToDoubleListValues :: MonadComp m => ResultSource m -> [ResultValue [Double] m] -resultSourceToDoubleListValues = map (\(ResultItem x) -> resultItemToDoubleListValue x) . flattenResultSource - --- | Represent the result source as statistics based on double floating point numbers. -resultSourceToDoubleStatsValues :: MonadComp m => ResultSource m -> [ResultValue (SamplingStats Double) m] -resultSourceToDoubleStatsValues = map (\(ResultItem x) -> resultItemToDoubleStatsValue x) . flattenResultSource - --- | Represent the result source as statistics based on double floating point numbers and optimised for fast aggregation. -resultSourceToDoubleStatsEitherValues :: MonadComp m => ResultSource m -> [ResultValue (Either Double (SamplingStats Double)) m] -resultSourceToDoubleStatsEitherValues = map (\(ResultItem x) -> resultItemToDoubleStatsEitherValue x) . flattenResultSource - --- | Represent the result source as timing statistics based on double floating point numbers. -resultSourceToDoubleTimingStatsValues :: MonadComp m => ResultSource m -> [ResultValue (TimingStats Double) m] -resultSourceToDoubleTimingStatsValues = map (\(ResultItem x) -> resultItemToDoubleTimingStatsValue x) . flattenResultSource - --- | Represent the result source as string values. -resultSourceToStringValues :: MonadComp m => ResultSource m -> [ResultValue String m] -resultSourceToStringValues = map (\(ResultItem x) -> resultItemToStringValue x) . flattenResultSource - --- | It contains the results of simulation. -data Results m = - Results { resultSourceMap :: ResultSourceMap m, - -- ^ The sources of simulation results as a map of associated names. - resultSourceList :: [ResultSource m] - -- ^ The sources of simulation results as an ordered list. - } - --- | It transforms the results of simulation. -type ResultTransform m = Results m -> Results m - --- | It representes the predefined signals provided by every simulation model. -data ResultPredefinedSignals m = - ResultPredefinedSignals { resultSignalInIntegTimes :: Signal m Double, - -- ^ The signal triggered in the integration time points. - resultSignalInStartTime :: Signal m Double, - -- ^ The signal triggered in the start time. - resultSignalInStopTime :: Signal m Double - -- ^ The signal triggered in the stop time. - } - --- | Create the predefined signals provided by every simulation model. -newResultPredefinedSignals :: MonadComp m => Simulation m (ResultPredefinedSignals m) -newResultPredefinedSignals = runDynamicsInStartTime $ runEventWith EarlierEvents d where - d = do signalInIntegTimes <- newSignalInIntegTimes - signalInStartTime <- newSignalInStartTime - signalInStopTime <- newSignalInStopTime - return ResultPredefinedSignals { resultSignalInIntegTimes = signalInIntegTimes, - resultSignalInStartTime = signalInStartTime, - resultSignalInStopTime = signalInStopTime } - -instance Monoid (Results m) where - - mempty = results mempty - mappend x y = results $ resultSourceList x <> resultSourceList y - --- | Prepare the simulation results. -results :: [ResultSource m] -> Results m -results ms = - Results { resultSourceMap = M.fromList $ map (\x -> (resultSourceName x, x)) ms, - resultSourceList = ms } - --- | Represent the results as integer numbers. -resultsToIntValues :: MonadComp m => Results m -> [ResultValue Int m] -resultsToIntValues = concat . map resultSourceToIntValues . resultSourceList - --- | Represent the results as lists of integer numbers. -resultsToIntListValues :: MonadComp m => Results m -> [ResultValue [Int] m] -resultsToIntListValues = concat . map resultSourceToIntListValues . resultSourceList - --- | Represent the results as statistics based on integer numbers. -resultsToIntStatsValues :: MonadComp m => Results m -> [ResultValue (SamplingStats Int) m] -resultsToIntStatsValues = concat . map resultSourceToIntStatsValues . resultSourceList - --- | Represent the results as statistics based on integer numbers and optimised for fast aggregation. -resultsToIntStatsEitherValues :: MonadComp m => Results m -> [ResultValue (Either Int (SamplingStats Int)) m] -resultsToIntStatsEitherValues = concat . map resultSourceToIntStatsEitherValues . resultSourceList - --- | Represent the results as timing statistics based on integer numbers. -resultsToIntTimingStatsValues :: MonadComp m => Results m -> [ResultValue (TimingStats Int) m] -resultsToIntTimingStatsValues = concat . map resultSourceToIntTimingStatsValues . resultSourceList - --- | Represent the results as double floating point numbers. -resultsToDoubleValues :: MonadComp m => Results m -> [ResultValue Double m] -resultsToDoubleValues = concat . map resultSourceToDoubleValues . resultSourceList - --- | Represent the results as lists of double floating point numbers. -resultsToDoubleListValues :: MonadComp m => Results m -> [ResultValue [Double] m] -resultsToDoubleListValues = concat . map resultSourceToDoubleListValues . resultSourceList - --- | Represent the results as statistics based on double floating point numbers. -resultsToDoubleStatsValues :: MonadComp m => Results m -> [ResultValue (SamplingStats Double) m] -resultsToDoubleStatsValues = concat . map resultSourceToDoubleStatsValues . resultSourceList - --- | Represent the results as statistics based on double floating point numbers and optimised for fast aggregation. -resultsToDoubleStatsEitherValues :: MonadComp m => Results m -> [ResultValue (Either Double (SamplingStats Double)) m] -resultsToDoubleStatsEitherValues = concat . map resultSourceToDoubleStatsEitherValues . resultSourceList - --- | Represent the results as timing statistics based on double floating point numbers. -resultsToDoubleTimingStatsValues :: MonadComp m => Results m -> [ResultValue (TimingStats Double) m] -resultsToDoubleTimingStatsValues = concat . map resultSourceToDoubleTimingStatsValues . resultSourceList - --- | Represent the results as string values. -resultsToStringValues :: MonadComp m => Results m -> [ResultValue String m] -resultsToStringValues = concat . map resultSourceToStringValues . resultSourceList - --- | Return a signal emitted by the specified results. -resultSignal :: MonadComp m => Results m -> ResultSignal m -resultSignal = mconcat . map resultSourceSignal . resultSourceList - --- | Return an expanded version of the simulation results expanding the properties as possible, which --- takes place for expanding statistics to show the count, average, deviation, minimum, maximum etc. --- as separate values. -expandResults :: MonadComp m => ResultTransform m -expandResults = results . map expandResultSource . resultSourceList - --- | Return a short version of the simulation results, i.e. their summary, expanding the main properties --- or excluding auxiliary properties if required. -resultSummary :: MonadComp m => ResultTransform m -resultSummary = results . map resultSourceSummary . resultSourceList - --- | Take a result by its name. -resultByName :: ResultName -> ResultTransform m -resultByName name rs = - case M.lookup name (resultSourceMap rs) of - Just x -> results [x] - Nothing -> - error $ - "Not found result source with name " ++ name ++ - ": resultByName" - --- | Take a result from the object with the specified property label, --- but it is more preferrable to refer to the property by its 'ResultId' --- identifier with help of the 'resultById' function. -resultByProperty :: ResultName -> ResultTransform m -resultByProperty label rs = flip composeResults rs loop - where - loop x = - case x of - ResultObjectSource s -> - let ps = - flip filter (resultObjectProperties s) $ \p -> - resultPropertyLabel p == label - in case ps of - [] -> - error $ - "Not found property " ++ label ++ - " for object " ++ resultObjectName s ++ - ": resultByProperty" - ps -> - map resultPropertySource ps - ResultVectorSource s -> - concat $ map loop $ A.elems $ resultVectorItems s - x -> - error $ - "Result source " ++ resultSourceName x ++ - " is neither object, nor vector " ++ - ": resultByProperty" - --- | Take a result from the object with the specified identifier. It can identify --- an item, object property, the object iself, vector or its elements. -resultById :: ResultId -> ResultTransform m -resultById i rs = flip composeResults rs loop - where - loop x = - case x of - ResultItemSource (ResultItem s) -> - if resultItemId s == i - then [x] - else error $ - "Expected to find item with Id = " ++ show i ++ - ", while the item " ++ resultItemName s ++ - " has actual Id = " ++ show (resultItemId s) ++ - ": resultById" - ResultObjectSource s -> - if resultObjectId s == i - then [x] - else let ps = - flip filter (resultObjectProperties s) $ \p -> - resultPropertyId p == i - in case ps of - [] -> - error $ - "Not found property with Id = " ++ show i ++ - " for object " ++ resultObjectName s ++ - " that has actual Id = " ++ show (resultObjectId s) ++ - ": resultById" - ps -> - map resultPropertySource ps - ResultVectorSource s -> - if resultVectorId s == i - then [x] - else concat $ map loop $ A.elems $ resultVectorItems s - x -> - error $ - "Result source " ++ resultSourceName x ++ - " is neither item, nor object, nor vector " ++ - ": resultById" - --- | Take a result from the vector by the specified integer index. -resultByIndex :: Int -> ResultTransform m -resultByIndex index rs = flip composeResults rs loop - where - loop x = - case x of - ResultVectorSource s -> - [resultVectorItems s A.! index] - x -> - error $ - "Result source " ++ resultSourceName x ++ - " is not vector " ++ - ": resultByIndex" - --- | Take a result from the vector by the specified string subscript. -resultBySubscript :: ResultName -> ResultTransform m -resultBySubscript subscript rs = flip composeResults rs loop - where - loop x = - case x of - ResultVectorSource s -> - let ys = A.elems $ resultVectorItems s - zs = A.elems $ resultVectorSubscript s - ps = - flip filter (zip ys zs) $ \(y, z) -> - z == subscript - in case ps of - [] -> - error $ - "Not found subscript " ++ subscript ++ - " for vector " ++ resultVectorName s ++ - ": resultBySubscript" - ps -> - map fst ps - x -> - error $ - "Result source " ++ resultSourceName x ++ - " is not vector " ++ - ": resultBySubscript" - --- | Compose the results using the specified transformation function. -composeResults :: (ResultSource m -> [ResultSource m]) -> ResultTransform m -composeResults f = - results . concat . map f . resultSourceList - --- | Concatenate the results using the specified list of transformation functions. -concatResults :: [ResultTransform m] -> ResultTransform m -concatResults trs rs = - results $ concat $ map (\tr -> resultSourceList $ tr rs) trs - --- | Append the results using the specified transformation functions. -appendResults :: ResultTransform m -> ResultTransform m -> ResultTransform m -appendResults x y = - concatResults [x, y] - --- | Return a pure signal as a result of combination of the predefined signals --- with the specified result signal usually provided by the sources. --- --- The signal returned is triggered when the source signal is triggered. --- The pure signal is also triggered in the integration time points --- if the source signal is unknown or it was combined with any unknown signal. -pureResultSignal :: MonadComp m => ResultPredefinedSignals m -> ResultSignal m -> Signal m () -pureResultSignal rs EmptyResultSignal = - void (resultSignalInStartTime rs) -pureResultSignal rs UnknownResultSignal = - void (resultSignalInIntegTimes rs) -pureResultSignal rs (ResultSignal s) = - void (resultSignalInStartTime rs) <> void (resultSignalInStopTime rs) <> s -pureResultSignal rs (ResultSignalMix s) = - void (resultSignalInIntegTimes rs) <> s - --- | Defines a final result extract: its name, values and other data. -data ResultExtract e m = - ResultExtract { resultExtractName :: ResultName, - -- ^ The result name. - resultExtractId :: ResultId, - -- ^ The result identifier. - resultExtractData :: Event m e, - -- ^ The result values. - resultExtractSignal :: ResultSignal m - -- ^ Whether the result emits a signal. - } - --- | Extract the results as integer values, or raise a conversion error. -extractIntResults :: MonadComp m => Results m -> [ResultExtract Int m] -extractIntResults rs = flip map (resultsToIntValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of integer values: extractIntResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as lists of integer values, or raise a conversion error. -extractIntListResults :: MonadComp m => Results m -> [ResultExtract [Int] m] -extractIntListResults rs = flip map (resultsToIntListValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of lists of integer values: extractIntListResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as statistics based on integer values, --- or raise a conversion error. -extractIntStatsResults :: MonadComp m => Results m -> [ResultExtract (SamplingStats Int) m] -extractIntStatsResults rs = flip map (resultsToIntStatsValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of statistics based on integer values: extractIntStatsResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as statistics based on integer values and optimised --- for fast aggregation, or raise a conversion error. -extractIntStatsEitherResults :: MonadComp m => Results m -> [ResultExtract (Either Int (SamplingStats Int)) m] -extractIntStatsEitherResults rs = flip map (resultsToIntStatsEitherValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of statistics based on integer values: extractIntStatsEitherResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as timing statistics based on integer values, --- or raise a conversion error. -extractIntTimingStatsResults :: MonadComp m => Results m -> [ResultExtract (TimingStats Int) m] -extractIntTimingStatsResults rs = flip map (resultsToIntTimingStatsValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of timing statistics based on integer values: extractIntTimingStatsResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as double floating point values, or raise a conversion error. -extractDoubleResults :: MonadComp m => Results m -> [ResultExtract Double m] -extractDoubleResults rs = flip map (resultsToDoubleValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of double floating point values: extractDoubleResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as lists of double floating point values, --- or raise a conversion error. -extractDoubleListResults :: MonadComp m => Results m -> [ResultExtract [Double] m] -extractDoubleListResults rs = flip map (resultsToDoubleListValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of lists of double floating point values: extractDoubleListResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as statistics based on double floating point values, --- or raise a conversion error. -extractDoubleStatsResults :: MonadComp m => Results m -> [ResultExtract (SamplingStats Double) m] -extractDoubleStatsResults rs = flip map (resultsToDoubleStatsValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of statistics based on double floating point values: extractDoubleStatsResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as statistics based on double floating point values --- and optimised for fast aggregation, or raise a conversion error. -extractDoubleStatsEitherResults :: MonadComp m => Results m -> [ResultExtract (Either Double (SamplingStats Double)) m] -extractDoubleStatsEitherResults rs = flip map (resultsToDoubleStatsEitherValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of statistics based on double floating point values: extractDoubleStatsEitherResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as timing statistics based on double floating point values, --- or raise a conversion error. -extractDoubleTimingStatsResults :: MonadComp m => Results m -> [ResultExtract (TimingStats Double) m] -extractDoubleTimingStatsResults rs = flip map (resultsToDoubleTimingStatsValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of timing statistics based on double floating point values: extractDoubleTimingStatsResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as string values, or raise a conversion error. -extractStringResults :: MonadComp m => Results m -> [ResultExtract String m] -extractStringResults rs = flip map (resultsToStringValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of string values: extractStringResults" - Just a -> - ResultExtract n i a s - --- | Represents a computation that can return the simulation data. -class MonadComp m => ResultComputing t m where - - -- | Compute data with the results of simulation. - computeResultData :: t m a -> ResultData a m - - -- | Return the signal triggered when data change if such a signal exists. - computeResultSignal :: t m a -> ResultSignal m - --- | Return a new result value by the specified name, identifier and computation. -computeResultValue :: ResultComputing t m - => ResultName - -- ^ the result name - -> ResultId - -- ^ the result identifier - -> t m a - -- ^ the result computation - -> ResultValue a m -computeResultValue name i m = - ResultValue { - resultValueName = name, - resultValueId = i, - resultValueData = computeResultData m, - resultValueSignal = computeResultSignal m } - -instance MonadComp m => ResultComputing Parameter m where - - computeResultData = Just . liftParameter - computeResultSignal = const UnknownResultSignal - -instance MonadComp m => ResultComputing Simulation m where - - computeResultData = Just . liftSimulation - computeResultSignal = const UnknownResultSignal - -instance MonadComp m => ResultComputing Dynamics m where - - computeResultData = Just . liftDynamics - computeResultSignal = const UnknownResultSignal - -instance MonadComp m => ResultComputing Event m where - - computeResultData = Just . id - computeResultSignal = const UnknownResultSignal - -instance MonadComp m => ResultComputing Ref m where - - computeResultData = Just . readRef - computeResultSignal = ResultSignal . refChanged_ - -instance MonadComp m => ResultComputing LR.Ref m where - - computeResultData = Just . LR.readRef - computeResultSignal = const UnknownResultSignal - -instance MonadComp m => ResultComputing Var m where - - computeResultData = Just . readVar - computeResultSignal = ResultSignal . varChanged_ - -instance MonadComp m => ResultComputing Signalable m where - - computeResultData = Just . readSignalable - computeResultSignal = ResultSignal . signalableChanged_ - --- | Return a source by the specified statistics. -samplingStatsResultSource :: (MonadComp m, - ResultItemable (ResultValue a), - ResultItemable (ResultValue (SamplingStats a))) - => ResultValue (SamplingStats a) m - -- ^ the statistics - -> ResultSource m -samplingStatsResultSource x = - ResultObjectSource $ - ResultObject { - resultObjectName = resultValueName x, - resultObjectId = resultValueId x, - resultObjectTypeId = SamplingStatsId, - resultObjectSignal = resultValueSignal x, - resultObjectSummary = samplingStatsResultSummary x, - resultObjectProperties = [ - resultContainerMapProperty c "count" SamplingStatsCountId samplingStatsCount, - resultContainerMapProperty c "mean" SamplingStatsMeanId samplingStatsMean, - resultContainerMapProperty c "mean2" SamplingStatsMean2Id samplingStatsMean2, - resultContainerMapProperty c "std" SamplingStatsDeviationId samplingStatsDeviation, - resultContainerMapProperty c "var" SamplingStatsVarianceId samplingStatsVariance, - resultContainerMapProperty c "min" SamplingStatsMinId samplingStatsMin, - resultContainerMapProperty c "max" SamplingStatsMaxId samplingStatsMax ] } - where - c = resultValueToContainer x - --- | Return the summary by the specified statistics. -samplingStatsResultSummary :: (MonadComp m, - ResultItemable (ResultValue (SamplingStats a))) - => ResultValue (SamplingStats a) m - -- ^ the statistics - -> ResultSource m -samplingStatsResultSummary = ResultItemSource . ResultItem . resultItemToStringValue - --- | Return a source by the specified timing statistics. -timingStatsResultSource :: (MonadComp m, - TimingData a, - ResultItemable (ResultValue a), - ResultItemable (ResultValue (TimingStats a))) - => ResultValue (TimingStats a) m - -- ^ the statistics - -> ResultSource m -timingStatsResultSource x = - ResultObjectSource $ - ResultObject { - resultObjectName = resultValueName x, - resultObjectId = resultValueId x, - resultObjectTypeId = TimingStatsId, - resultObjectSignal = resultValueSignal x, - resultObjectSummary = timingStatsResultSummary x, - resultObjectProperties = [ - resultContainerMapProperty c "count" TimingStatsCountId timingStatsCount, - resultContainerMapProperty c "mean" TimingStatsMeanId timingStatsMean, - resultContainerMapProperty c "std" TimingStatsDeviationId timingStatsDeviation, - resultContainerMapProperty c "var" TimingStatsVarianceId timingStatsVariance, - resultContainerMapProperty c "min" TimingStatsMinId timingStatsMin, - resultContainerMapProperty c "max" TimingStatsMaxId timingStatsMax, - resultContainerMapProperty c "minTime" TimingStatsMinTimeId timingStatsMinTime, - resultContainerMapProperty c "maxTime" TimingStatsMaxTimeId timingStatsMaxTime, - resultContainerMapProperty c "startTime" TimingStatsStartTimeId timingStatsStartTime, - resultContainerMapProperty c "lastTime" TimingStatsLastTimeId timingStatsLastTime, - resultContainerMapProperty c "sum" TimingStatsSumId timingStatsSum, - resultContainerMapProperty c "sum2" TimingStatsSum2Id timingStatsSum2 ] } - where - c = resultValueToContainer x - --- | Return the summary by the specified timing statistics. -timingStatsResultSummary :: (MonadComp m, - TimingData a, - ResultItemable (ResultValue (TimingStats a))) - => ResultValue (TimingStats a) m - -- ^ the statistics - -> ResultSource m -timingStatsResultSummary = ResultItemSource . ResultItem . resultItemToStringValue - --- | Return a source by the specified finite queue. -queueResultSource :: (MonadComp m, - Show si, Show sm, Show so, - ResultItemable (ResultValue si), - ResultItemable (ResultValue sm), - ResultItemable (ResultValue so)) - => ResultContainer (Q.Queue m si sm so a) m - -- ^ the queue container - -> ResultSource m -queueResultSource c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = FiniteQueueId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = queueResultSummary c, - resultObjectProperties = [ - resultContainerConstProperty c "enqueueStrategy" EnqueueStrategyId Q.enqueueStrategy, - resultContainerConstProperty c "enqueueStoringStrategy" EnqueueStoringStrategyId Q.enqueueStoringStrategy, - resultContainerConstProperty c "dequeueStrategy" DequeueStrategyId Q.dequeueStrategy, - resultContainerProperty c "queueNull" QueueNullId Q.queueNull Q.queueNullChanged_, - resultContainerProperty c "queueFull" QueueFullId Q.queueFull Q.queueFullChanged_, - resultContainerConstProperty c "queueMaxCount" QueueMaxCountId Q.queueMaxCount, - resultContainerProperty c "queueCount" QueueCountId Q.queueCount Q.queueCountChanged_, - resultContainerProperty c "queueCountStats" QueueCountStatsId Q.queueCountStats Q.queueCountChanged_, - resultContainerProperty c "enqueueCount" EnqueueCountId Q.enqueueCount Q.enqueueCountChanged_, - resultContainerProperty c "enqueueLostCount" EnqueueLostCountId Q.enqueueLostCount Q.enqueueLostCountChanged_, - resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId Q.enqueueStoreCount Q.enqueueStoreCountChanged_, - resultContainerProperty c "dequeueCount" DequeueCountId Q.dequeueCount Q.dequeueCountChanged_, - resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId Q.dequeueExtractCount Q.dequeueExtractCountChanged_, - resultContainerProperty c "queueLoadFactor" QueueLoadFactorId Q.queueLoadFactor Q.queueLoadFactorChanged_, - resultContainerIntegProperty c "enqueueRate" EnqueueRateId Q.enqueueRate, - resultContainerIntegProperty c "enqueueStoreRate" EnqueueStoreRateId Q.enqueueStoreRate, - resultContainerIntegProperty c "dequeueRate" DequeueRateId Q.dequeueRate, - resultContainerIntegProperty c "dequeueExtractRate" DequeueExtractRateId Q.dequeueExtractRate, - resultContainerProperty c "queueWaitTime" QueueWaitTimeId Q.queueWaitTime Q.queueWaitTimeChanged_, - resultContainerProperty c "queueTotalWaitTime" QueueTotalWaitTimeId Q.queueTotalWaitTime Q.queueTotalWaitTimeChanged_, - resultContainerProperty c "enqueueWaitTime" EnqueueWaitTimeId Q.enqueueWaitTime Q.enqueueWaitTimeChanged_, - resultContainerProperty c "dequeueWaitTime" DequeueWaitTimeId Q.dequeueWaitTime Q.dequeueWaitTimeChanged_, - resultContainerProperty c "queueRate" QueueRateId Q.queueRate Q.queueRateChanged_ ] } - --- | Return the summary by the specified finite queue. -queueResultSummary :: (MonadComp m, - Show si, Show sm, Show so) - => ResultContainer (Q.Queue m si sm so a) m - -- ^ the queue container - -> ResultSource m -queueResultSummary c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = FiniteQueueId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = queueResultSummary c, - resultObjectProperties = [ - resultContainerConstProperty c "queueMaxCount" QueueMaxCountId Q.queueMaxCount, - resultContainerProperty c "queueCountStats" QueueCountStatsId Q.queueCountStats Q.queueCountChanged_, - resultContainerProperty c "enqueueCount" EnqueueCountId Q.enqueueCount Q.enqueueCountChanged_, - resultContainerProperty c "enqueueLostCount" EnqueueLostCountId Q.enqueueLostCount Q.enqueueLostCountChanged_, - resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId Q.enqueueStoreCount Q.enqueueStoreCountChanged_, - resultContainerProperty c "dequeueCount" DequeueCountId Q.dequeueCount Q.dequeueCountChanged_, - resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId Q.dequeueExtractCount Q.dequeueExtractCountChanged_, - resultContainerProperty c "queueLoadFactor" QueueLoadFactorId Q.queueLoadFactor Q.queueLoadFactorChanged_, - resultContainerProperty c "queueWaitTime" QueueWaitTimeId Q.queueWaitTime Q.queueWaitTimeChanged_, - resultContainerProperty c "queueRate" QueueRateId Q.queueRate Q.queueRateChanged_ ] } - --- | Return a source by the specified infinite queue. -infiniteQueueResultSource :: (MonadComp m, - Show sm, Show so, - ResultItemable (ResultValue sm), - ResultItemable (ResultValue so)) - => ResultContainer (IQ.Queue m sm so a) m - -- ^ the queue container - -> ResultSource m -infiniteQueueResultSource c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = FiniteQueueId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = infiniteQueueResultSummary c, - resultObjectProperties = [ - resultContainerConstProperty c "enqueueStoringStrategy" EnqueueStoringStrategyId IQ.enqueueStoringStrategy, - resultContainerConstProperty c "dequeueStrategy" DequeueStrategyId IQ.dequeueStrategy, - resultContainerProperty c "queueNull" QueueNullId IQ.queueNull IQ.queueNullChanged_, - resultContainerProperty c "queueCount" QueueCountId IQ.queueCount IQ.queueCountChanged_, - resultContainerProperty c "queueCountStats" QueueCountStatsId IQ.queueCountStats IQ.queueCountChanged_, - resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId IQ.enqueueStoreCount IQ.enqueueStoreCountChanged_, - resultContainerProperty c "dequeueCount" DequeueCountId IQ.dequeueCount IQ.dequeueCountChanged_, - resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId IQ.dequeueExtractCount IQ.dequeueExtractCountChanged_, - resultContainerIntegProperty c "enqueueStoreRate" EnqueueStoreRateId IQ.enqueueStoreRate, - resultContainerIntegProperty c "dequeueRate" DequeueRateId IQ.dequeueRate, - resultContainerIntegProperty c "dequeueExtractRate" DequeueExtractRateId IQ.dequeueExtractRate, - resultContainerProperty c "queueWaitTime" QueueWaitTimeId IQ.queueWaitTime IQ.queueWaitTimeChanged_, - resultContainerProperty c "dequeueWaitTime" DequeueWaitTimeId IQ.dequeueWaitTime IQ.dequeueWaitTimeChanged_, - resultContainerProperty c "queueRate" QueueRateId IQ.queueRate IQ.queueRateChanged_ ] } - --- | Return the summary by the specified infinite queue. -infiniteQueueResultSummary :: (MonadComp m, - Show sm, Show so) - => ResultContainer (IQ.Queue m sm so a) m - -- ^ the queue container - -> ResultSource m -infiniteQueueResultSummary c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = FiniteQueueId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = infiniteQueueResultSummary c, - resultObjectProperties = [ - resultContainerProperty c "queueCountStats" QueueCountStatsId IQ.queueCountStats IQ.queueCountChanged_, - resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId IQ.enqueueStoreCount IQ.enqueueStoreCountChanged_, - resultContainerProperty c "dequeueCount" DequeueCountId IQ.dequeueCount IQ.dequeueCountChanged_, - resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId IQ.dequeueExtractCount IQ.dequeueExtractCountChanged_, - resultContainerProperty c "queueWaitTime" QueueWaitTimeId IQ.queueWaitTime IQ.queueWaitTimeChanged_, - resultContainerProperty c "queueRate" QueueRateId IQ.queueRate IQ.queueRateChanged_ ] } - --- | Return a source by the specified arrival timer. -arrivalTimerResultSource :: MonadComp m - => ResultContainer (ArrivalTimer m) m - -- ^ the arrival timer container - -> ResultSource m -arrivalTimerResultSource c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = ArrivalTimerId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = arrivalTimerResultSummary c, - resultObjectProperties = [ - resultContainerProperty c "processingTime" ArrivalProcessingTimeId arrivalProcessingTime arrivalProcessingTimeChanged_ ] } - --- | Return the summary by the specified arrival timer. -arrivalTimerResultSummary :: MonadComp m - => ResultContainer (ArrivalTimer m) m - -- ^ the arrival timer container - -> ResultSource m -arrivalTimerResultSummary c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = ArrivalTimerId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = arrivalTimerResultSummary c, - resultObjectProperties = [ - resultContainerProperty c "processingTime" ArrivalProcessingTimeId arrivalProcessingTime arrivalProcessingTimeChanged_ ] } - --- | Return a source by the specified server. -serverResultSource :: (MonadComp m, - Show s, ResultItemable (ResultValue s)) - => ResultContainer (Server m s a b) m - -- ^ the server container - -> ResultSource m -serverResultSource c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = ServerId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = serverResultSummary c, - resultObjectProperties = [ - resultContainerConstProperty c "initState" ServerInitStateId serverInitState, - resultContainerProperty c "state" ServerStateId serverState serverStateChanged_, - resultContainerProperty c "totalInputWaitTime" ServerTotalInputWaitTimeId serverTotalInputWaitTime serverTotalInputWaitTimeChanged_, - resultContainerProperty c "totalProcessingTime" ServerTotalProcessingTimeId serverTotalProcessingTime serverTotalProcessingTimeChanged_, - resultContainerProperty c "totalOutputWaitTime" ServerTotalOutputWaitTimeId serverTotalOutputWaitTime serverTotalOutputWaitTimeChanged_, - resultContainerProperty c "inputWaitTime" ServerInputWaitTimeId serverInputWaitTime serverInputWaitTimeChanged_, - resultContainerProperty c "processingTime" ServerProcessingTimeId serverProcessingTime serverProcessingTimeChanged_, - resultContainerProperty c "outputWaitTime" ServerOutputWaitTimeId serverOutputWaitTime serverOutputWaitTimeChanged_, - resultContainerProperty c "inputWaitFactor" ServerInputWaitFactorId serverInputWaitFactor serverInputWaitFactorChanged_, - resultContainerProperty c "processingFactor" ServerProcessingFactorId serverProcessingFactor serverProcessingFactorChanged_, - resultContainerProperty c "outputWaitFactor" ServerOutputWaitFactorId serverOutputWaitFactor serverOutputWaitFactorChanged_ ] } - --- | Return the summary by the specified server. -serverResultSummary :: MonadComp m - => ResultContainer (Server m s a b) m - -- ^ the server container - -> ResultSource m -serverResultSummary c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = ServerId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = serverResultSummary c, - resultObjectProperties = [ - resultContainerProperty c "inputWaitTime" ServerInputWaitTimeId serverInputWaitTime serverInputWaitTimeChanged_, - resultContainerProperty c "processingTime" ServerProcessingTimeId serverProcessingTime serverProcessingTimeChanged_, - resultContainerProperty c "outputWaitTime" ServerOutputWaitTimeId serverOutputWaitTime serverOutputWaitTimeChanged_, - resultContainerProperty c "inputWaitFactor" ServerInputWaitFactorId serverInputWaitFactor serverInputWaitFactorChanged_, - resultContainerProperty c "processingFactor" ServerProcessingFactorId serverProcessingFactor serverProcessingFactorChanged_, - resultContainerProperty c "outputWaitFactor" ServerOutputWaitFactorId serverOutputWaitFactor serverOutputWaitFactorChanged_ ] } - --- | Return an arbitrary text as a separator source. -textResultSource :: String -> ResultSource m -textResultSource text = - ResultSeparatorSource $ - ResultSeparator { resultSeparatorText = text } - --- | Return the source of the modeling time. -timeResultSource :: MonadComp m => ResultSource m -timeResultSource = resultSource' "t" TimeId time - --- | Make an integer subscript -intSubscript :: Int -> ResultName -intSubscript i = "[" ++ show i ++ "]" - -instance ResultComputing t m => ResultProvider (t m Double) m where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing t m => ResultProvider (t m [Double]) m where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing t m => ResultProvider (t m (SamplingStats Double)) m where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing t m => ResultProvider (t m (TimingStats Double)) m where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing t m => ResultProvider (t m Int) m where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing t m => ResultProvider (t m [Int]) m where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing t m => ResultProvider (t m (SamplingStats Int)) m where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing t m => ResultProvider (t m (TimingStats Int)) m where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing t m => ResultProvider (t m String) m where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultProvider p m => ResultProvider [p] m where - - resultSource' name i m = - resultSource' name i $ ResultListWithSubscript m subscript where - subscript = map snd $ zip m $ map intSubscript [0..] - -instance (Show i, Ix i, ResultProvider p m) => ResultProvider (A.Array i p) m where - - resultSource' name i m = - resultSource' name i $ ResultListWithSubscript items subscript where - items = A.elems m - subscript = map (\i -> "[" ++ show i ++ "]") (A.indices m) - -#ifndef __HASTE__ - -instance ResultProvider p m => ResultProvider (V.Vector p) m where - - resultSource' name i m = - resultSource' name i $ ResultVectorWithSubscript m subscript where - subscript = V.imap (\i x -> intSubscript i) m - -#endif - --- | Represents a list with the specified subscript. -data ResultListWithSubscript p = - ResultListWithSubscript [p] [String] - --- | Represents an array with the specified subscript. -data ResultArrayWithSubscript i p = - ResultArrayWithSubscript (A.Array i p) (A.Array i String) - -#ifndef __HASTE__ - --- | Represents a vector with the specified subscript. -data ResultVectorWithSubscript p = - ResultVectorWithSubscript (V.Vector p) (V.Vector String) - -#endif - -instance ResultProvider p m => ResultProvider (ResultListWithSubscript p) m where - - resultSource' name i (ResultListWithSubscript xs ys) = - ResultVectorSource $ - memoResultVectorSignal $ - memoResultVectorSummary $ - ResultVector { resultVectorName = name, - resultVectorId = i, - resultVectorItems = axs, - resultVectorSubscript = ays, - resultVectorSignal = undefined, - resultVectorSummary = undefined } - where - bnds = (0, length xs - 1) - axs = A.listArray bnds items - ays = A.listArray bnds ys - items = - flip map (zip ys xs) $ \(y, x) -> - let name' = name ++ y - in resultSource' name' (VectorItemId y) x - items' = map resultSourceSummary items - -instance (Show i, Ix i, ResultProvider p m) => ResultProvider (ResultArrayWithSubscript i p) m where - - resultSource' name i (ResultArrayWithSubscript xs ys) = - resultSource' name i $ ResultListWithSubscript items subscript where - items = A.elems xs - subscript = A.elems ys - -#ifndef __HASTE__ - -instance ResultProvider p m => ResultProvider (ResultVectorWithSubscript p) m where - - resultSource' name i (ResultVectorWithSubscript xs ys) = - ResultVectorSource $ - memoResultVectorSignal $ - memoResultVectorSummary $ - ResultVector { resultVectorName = name, - resultVectorId = i, - resultVectorItems = axs, - resultVectorSubscript = ays, - resultVectorSignal = undefined, - resultVectorSummary = undefined } - where - bnds = (0, V.length xs - 1) - axs = A.listArray bnds (V.toList items) - ays = A.listArray bnds (V.toList ys) - items = - V.generate (V.length xs) $ \i -> - let x = xs V.! i - y = ys V.! i - name' = name ++ y - in resultSource' name' (VectorItemId y) x - items' = V.map resultSourceSummary items - -#endif - -instance (Ix i, Show i, ResultComputing t m) => ResultProvider (t m (A.Array i Double)) 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 - - resultSource' name i m = - ResultItemSource $ ResultItem $ mapResultValue A.elems $ computeResultValue name i m - -#ifndef __HASTE__ - -instance ResultComputing t m => ResultProvider (t m (V.Vector Double)) 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 - - resultSource' name i m = - ResultItemSource $ ResultItem $ mapResultValue V.toList $ computeResultValue name i m - -#endif - -instance (MonadComp m, - Show si, Show sm, Show so, - ResultItemable (ResultValue si), - ResultItemable (ResultValue sm), - ResultItemable (ResultValue so)) - => ResultProvider (Q.Queue m si sm so a) m where - - resultSource' name i m = - queueResultSource $ ResultContainer name i m (ResultSignal $ Q.queueChanged_ m) - -instance (MonadComp m, - Show sm, Show so, - ResultItemable (ResultValue sm), - ResultItemable (ResultValue so)) - => ResultProvider (IQ.Queue m sm so a) m where - - resultSource' name i m = - infiniteQueueResultSource $ ResultContainer name i m (ResultSignal $ IQ.queueChanged_ m) - -instance MonadComp m => ResultProvider (ArrivalTimer m) m where - - resultSource' name i m = - arrivalTimerResultSource $ ResultContainer name i m (ResultSignal $ arrivalProcessingTimeChanged_ m) - -instance (MonadComp m, Show s, ResultItemable (ResultValue s)) => ResultProvider (Server m s a b) m where - - resultSource' name i m = - serverResultSource $ ResultContainer name i m (ResultSignal $ serverChanged_ m) + +{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, UndecidableInstances, ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies #-} + +-- | +-- Module : Simulation.Aivika.Trans.Results +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module allows exporting the simulation results from the model. +-- +module Simulation.Aivika.Trans.Results + (-- * Definitions Focused on Modeling + Results, + ResultTransform, + ResultName, + ResultProvider(..), + results, + expandResults, + resultSummary, + resultByName, + resultByProperty, + resultById, + resultByIndex, + resultBySubscript, + ResultComputing(..), + ResultListWithSubscript(..), + ResultArrayWithSubscript(..), +#ifndef __HASTE__ + ResultVectorWithSubscript(..), +#endif + -- * Definitions Focused on Using the Library + ResultExtract(..), + extractIntResults, + extractIntListResults, + extractIntStatsResults, + extractIntStatsEitherResults, + extractIntTimingStatsResults, + extractDoubleResults, + extractDoubleListResults, + extractDoubleStatsResults, + extractDoubleStatsEitherResults, + extractDoubleTimingStatsResults, + extractStringResults, + ResultPredefinedSignals(..), + newResultPredefinedSignals, + resultSignal, + pureResultSignal, + -- * Definitions Focused on Extending the Library + ResultSourceMap, + ResultSource(..), + ResultItem(..), + ResultItemable(..), + resultItemToIntStatsEitherValue, + resultItemToDoubleStatsEitherValue, + ResultObject(..), + ResultProperty(..), + ResultVector(..), + memoResultVectorSignal, + memoResultVectorSummary, + ResultSeparator(..), + ResultValue(..), + voidResultValue, + ResultContainer(..), + resultContainerPropertySource, + resultContainerConstProperty, + resultContainerIntegProperty, + resultContainerProperty, + resultContainerMapProperty, + resultValueToContainer, + resultContainerToValue, + ResultData, + ResultSignal(..), + maybeResultSignal, + textResultSource, + timeResultSource, + resultSourceToIntValues, + resultSourceToIntListValues, + resultSourceToIntStatsValues, + resultSourceToIntStatsEitherValues, + resultSourceToIntTimingStatsValues, + resultSourceToDoubleValues, + resultSourceToDoubleListValues, + resultSourceToDoubleStatsValues, + resultSourceToDoubleStatsEitherValues, + resultSourceToDoubleTimingStatsValues, + resultSourceToStringValues, + resultSourceMap, + resultSourceList, + resultsToIntValues, + resultsToIntListValues, + resultsToIntStatsValues, + resultsToIntStatsEitherValues, + resultsToIntTimingStatsValues, + resultsToDoubleValues, + resultsToDoubleListValues, + resultsToDoubleStatsValues, + resultsToDoubleStatsEitherValues, + resultsToDoubleTimingStatsValues, + resultsToStringValues, + composeResults, + computeResultValue) where + +import Control.Monad +import Control.Monad.Trans + +import qualified Data.Map as M +import qualified Data.Array as A + +#ifndef __HASTE__ +import qualified Data.Vector as V +#endif + +import Data.Ix +import Data.Maybe +import Data.Monoid + +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Parameter +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Event +import Simulation.Aivika.Trans.Signal +import Simulation.Aivika.Trans.Statistics +import Simulation.Aivika.Trans.Statistics.Accumulator +import Simulation.Aivika.Trans.Ref +import qualified Simulation.Aivika.Trans.Ref.Plain as LR +import Simulation.Aivika.Trans.Var +import Simulation.Aivika.Trans.QueueStrategy +import qualified Simulation.Aivika.Trans.Queue as Q +import qualified Simulation.Aivika.Trans.Queue.Infinite as IQ +import Simulation.Aivika.Trans.Arrival +import Simulation.Aivika.Trans.Server +import Simulation.Aivika.Trans.Activity +import Simulation.Aivika.Trans.Results.Locale + +-- | A name used for indentifying the results when generating output. +type ResultName = String + +-- | Represents a provider of the simulation results. It is usually something, or +-- an array of something, or a list of such values which can be simulated to get data. +class MonadComp m => ResultProvider p m | p -> m where + + -- | Return the source of simulation results by the specified name, description and provider. + resultSource :: ResultName -> ResultDescription -> p -> ResultSource m + resultSource name descr = resultSource' name (UserDefinedResultId descr) + + -- | Return the source of simulation results by the specified name, identifier and provider. + resultSource' :: ResultName -> ResultId -> p -> ResultSource m + +-- | It associates the result sources with their names. +type ResultSourceMap m = M.Map ResultName (ResultSource m) + +-- | Encapsulates the result source. +data ResultSource m = ResultItemSource (ResultItem m) + -- ^ The source consisting of a single item. + | ResultObjectSource (ResultObject m) + -- ^ An object-like source. + | ResultVectorSource (ResultVector m) + -- ^ A vector-like structure. + | ResultSeparatorSource ResultSeparator + -- ^ This is a separator text. + +-- | The simulation results represented by a single item. +data ResultItem m = forall a. ResultItemable a => ResultItem (a m) + +-- | Represents a type class for actual representing the items. +class ResultItemable a where + + -- | The item name. + resultItemName :: a m -> ResultName + + -- | The item identifier. + resultItemId :: a m -> ResultId + + -- | Whether the item emits a signal. + resultItemSignal :: MonadComp m => a m -> ResultSignal m + + -- | Return an expanded version of the item, for example, + -- when the statistics item is exanded to an object + -- having the corresponded properties for count, average, + -- deviation, minimum, maximum and so on. + resultItemExpansion :: MonadComp m => a m -> ResultSource m + + -- | Return usually a short version of the item, i.e. its summary, + -- but values of some data types such as statistics can be + -- implicitly expanded to an object with the corresponded + -- properties. + resultItemSummary :: MonadComp m => a m -> ResultSource m + + -- | Return integer numbers in time points. + resultItemToIntValue :: MonadComp m => a m -> ResultValue Int m + + -- | Return lists of integer numbers in time points. + resultItemToIntListValue :: MonadComp m => a m -> ResultValue [Int] m + + -- | Return statistics based on integer numbers. + resultItemToIntStatsValue :: MonadComp m => a m -> ResultValue (SamplingStats Int) m + + -- | Return timing statistics based on integer numbers. + resultItemToIntTimingStatsValue :: MonadComp m => a m -> ResultValue (TimingStats Int) m + + -- | Return double numbers in time points. + resultItemToDoubleValue :: MonadComp m => a m -> ResultValue Double m + + -- | Return lists of double numbers in time points. + resultItemToDoubleListValue :: MonadComp m => a m -> ResultValue [Double] m + + -- | Return statistics based on double numbers. + resultItemToDoubleStatsValue :: MonadComp m => a m -> ResultValue (SamplingStats Double) m + + -- | Return timing statistics based on integer numbers. + resultItemToDoubleTimingStatsValue :: MonadComp m => a m -> ResultValue (TimingStats Double) m + + -- | Return string representations in time points. + resultItemToStringValue :: MonadComp m => a m -> ResultValue String m + +-- | Return a version optimised for fast aggregation of the statistics based on integer numbers. +resultItemToIntStatsEitherValue :: (MonadComp m, ResultItemable a) => a m -> ResultValue (Either Int (SamplingStats Int)) m +resultItemToIntStatsEitherValue x = + case resultValueData x1 of + Just a1 -> mapResultValue Left x1 + Nothing -> + case resultValueData x2 of + Just a2 -> mapResultValue Right x2 + Nothing -> voidResultValue x2 + where + x1 = resultItemToIntValue x + x2 = resultItemToIntStatsValue x + +-- | Return a version optimised for fast aggregation of the statistics based on double floating point numbers. +resultItemToDoubleStatsEitherValue :: (MonadComp m, ResultItemable a) => a m -> ResultValue (Either Double (SamplingStats Double)) m +resultItemToDoubleStatsEitherValue x = + case resultValueData x1 of + Just a1 -> mapResultValue Left x1 + Nothing -> + case resultValueData x2 of + Just a2 -> mapResultValue Right x2 + Nothing -> voidResultValue x2 + where + x1 = resultItemToDoubleValue x + x2 = resultItemToDoubleStatsValue x + +-- | The simulation results represented by an object having properties. +data ResultObject m = + ResultObject { resultObjectName :: ResultName, + -- ^ The object name. + resultObjectId :: ResultId, + -- ^ The object identifier. + resultObjectTypeId :: ResultId, + -- ^ The object type identifier. + resultObjectProperties :: [ResultProperty m], + -- ^ The object properties. + resultObjectSignal :: ResultSignal m, + -- ^ A combined signal if present. + resultObjectSummary :: ResultSource m + -- ^ A short version of the object, i.e. its summary. + } + +-- | The object property containing the simulation results. +data ResultProperty m = + ResultProperty { resultPropertyLabel :: ResultName, + -- ^ The property short label. + resultPropertyId :: ResultId, + -- ^ The property identifier. + resultPropertySource :: ResultSource m + -- ^ The simulation results supplied by the property. + } + +-- | The simulation results represented by a vector. +data ResultVector m = + ResultVector { resultVectorName :: ResultName, + -- ^ The vector name. + resultVectorId :: ResultId, + -- ^ The vector identifier. + resultVectorItems :: A.Array Int (ResultSource m), + -- ^ The results supplied by the vector items. + resultVectorSubscript :: A.Array Int ResultName, + -- ^ The subscript used as a suffix to create item names. + resultVectorSignal :: ResultSignal m, + -- ^ A combined signal if present. + resultVectorSummary :: ResultSource m + -- ^ A short version of the vector, i.e. summary. + } + +-- | Calculate the result vector signal and memoize it in a new vector. +memoResultVectorSignal :: MonadComp m => ResultVector m -> ResultVector m +memoResultVectorSignal x = + x { resultVectorSignal = + foldr (<>) mempty $ map resultSourceSignal $ A.elems $ resultVectorItems x } + +-- | Calculate the result vector summary and memoize it in a new vector. +memoResultVectorSummary :: MonadComp m => ResultVector m -> ResultVector m +memoResultVectorSummary x = + x { resultVectorSummary = + ResultVectorSource $ + x { resultVectorItems = + A.array bnds [(i, resultSourceSummary e) | (i, e) <- ies] } } + where + arr = resultVectorItems x + bnds = A.bounds arr + ies = A.assocs arr + +-- | It separates the simulation results when printing. +data ResultSeparator = + ResultSeparator { resultSeparatorText :: String + -- ^ The separator text. + } + +-- | A parameterised value that actually represents a generalised result item that have no parametric type. +data ResultValue e m = + ResultValue { resultValueName :: ResultName, + -- ^ The value name. + resultValueId :: ResultId, + -- ^ The value identifier. + resultValueData :: ResultData e m, + -- ^ Simulation data supplied by the value. + resultValueSignal :: ResultSignal m + -- ^ Whether the value emits a signal when changing simulation data. + } + +mapResultValue :: MonadComp m => (a -> b) -> ResultValue a m -> ResultValue b m +mapResultValue f x = x { resultValueData = fmap (fmap f) (resultValueData x) } + +-- | Return a new value with the discarded simulation results. +voidResultValue :: ResultValue a m -> ResultValue b m +voidResultValue x = x { resultValueData = Nothing } + +-- | A container of the simulation results such as queue, server or array. +data ResultContainer e m = + ResultContainer { resultContainerName :: ResultName, + -- ^ The container name. + resultContainerId :: ResultId, + -- ^ The container identifier. + resultContainerData :: e, + -- ^ The container data. + resultContainerSignal :: ResultSignal m + -- ^ Whether the container emits a signal when changing simulation data. + } + +mapResultContainer :: (a -> b) -> ResultContainer a m -> ResultContainer b m +mapResultContainer f x = x { resultContainerData = f (resultContainerData x) } + +-- | Create a new property source by the specified container. +resultContainerPropertySource :: ResultItemable (ResultValue b) + => ResultContainer a m + -- ^ the container + -> ResultName + -- ^ the property label + -> ResultId + -- ^ the property identifier + -> (a -> ResultData b m) + -- ^ get the specified data from the container + -> (a -> ResultSignal m) + -- ^ get the data signal from the container + -> ResultSource m +resultContainerPropertySource cont name i f g = + ResultItemSource $ + ResultItem $ + ResultValue { + resultValueName = (resultContainerName cont) ++ "." ++ name, + resultValueId = i, + resultValueData = f (resultContainerData cont), + resultValueSignal = g (resultContainerData cont) } + +-- | Create a constant property by the specified container. +resultContainerConstProperty :: (MonadComp m, + ResultItemable (ResultValue b)) + => ResultContainer a m + -- ^ the container + -> ResultName + -- ^ the property label + -> ResultId + -- ^ the property identifier + -> (a -> b) + -- ^ get the specified data from the container + -> ResultProperty m +resultContainerConstProperty cont name i f = + ResultProperty { + resultPropertyLabel = name, + resultPropertyId = i, + resultPropertySource = + resultContainerPropertySource cont name i (Just . return . f) (const EmptyResultSignal) } + +-- | Create by the specified container a property that changes in the integration time points, or it is supposed to be such one. +resultContainerIntegProperty :: (MonadComp m, + ResultItemable (ResultValue b)) + => ResultContainer a m + -- ^ the container + -> ResultName + -- ^ the property label + -> ResultId + -- ^ the property identifier + -> (a -> Event m b) + -- ^ get the specified data from the container + -> ResultProperty m +resultContainerIntegProperty cont name i f = + ResultProperty { + resultPropertyLabel = name, + resultPropertyId = i, + resultPropertySource = + resultContainerPropertySource cont name i (Just . f) (const UnknownResultSignal) } + +-- | Create a property by the specified container. +resultContainerProperty :: (MonadComp m, + ResultItemable (ResultValue b)) + => ResultContainer a m + -- ^ the container + -> ResultName + -- ^ the property label + -> ResultId + -- ^ the property identifier + -> (a -> Event m b) + -- ^ get the specified data from the container + -> (a -> Signal m ()) + -- ^ get a signal triggered when changing data. + -> ResultProperty m +resultContainerProperty cont name i f g = + ResultProperty { + resultPropertyLabel = name, + resultPropertyId = i, + resultPropertySource = + resultContainerPropertySource cont name i (Just . f) (ResultSignal . g) } + +-- | Create by the specified container a mapped property which is recomputed each time again and again. +resultContainerMapProperty :: (MonadComp m, + ResultItemable (ResultValue b)) + => ResultContainer (ResultData a m) m + -- ^ the container + -> ResultName + -- ^ the property label + -> ResultId + -- ^ the property identifier + -> (a -> b) + -- ^ recompute the specified data + -> ResultProperty m +resultContainerMapProperty cont name i f = + ResultProperty { + resultPropertyLabel = name, + resultPropertyId = i, + resultPropertySource = + resultContainerPropertySource cont name i (fmap $ fmap f) (const $ resultContainerSignal cont) } + +-- | Convert the result value to a container with the specified object identifier. +resultValueToContainer :: ResultValue a m -> ResultContainer (ResultData a m) m +resultValueToContainer x = + ResultContainer { + resultContainerName = resultValueName x, + resultContainerId = resultValueId x, + resultContainerData = resultValueData x, + resultContainerSignal = resultValueSignal x } + +-- | Convert the result container to a value. +resultContainerToValue :: ResultContainer (ResultData a m) m -> ResultValue a m +resultContainerToValue x = + ResultValue { + resultValueName = resultContainerName x, + resultValueId = resultContainerId x, + resultValueData = resultContainerData x, + resultValueSignal = resultContainerSignal x } + +-- | Represents the very simulation results. +type ResultData e m = Maybe (Event m e) + +-- | Whether an object containing the results emits a signal notifying about change of data. +data ResultSignal m = EmptyResultSignal + -- ^ There is no signal at all. + | UnknownResultSignal + -- ^ The signal is unknown, but the entity probably changes. + | ResultSignal (Signal m ()) + -- ^ When the signal is precisely specified. + | ResultSignalMix (Signal m ()) + -- ^ When the specified signal was combined with unknown signal. + +instance MonadComp m => Monoid (ResultSignal m) where + + mempty = EmptyResultSignal + + mappend EmptyResultSignal z = z + + mappend UnknownResultSignal EmptyResultSignal = UnknownResultSignal + mappend UnknownResultSignal UnknownResultSignal = UnknownResultSignal + mappend UnknownResultSignal (ResultSignal x) = ResultSignalMix x + mappend UnknownResultSignal z@(ResultSignalMix x) = z + + mappend z@(ResultSignal x) EmptyResultSignal = z + mappend (ResultSignal x) UnknownResultSignal = ResultSignalMix x + mappend (ResultSignal x) (ResultSignal y) = ResultSignal (x <> y) + mappend (ResultSignal x) (ResultSignalMix y) = ResultSignalMix (x <> y) + + mappend z@(ResultSignalMix x) EmptyResultSignal = z + mappend z@(ResultSignalMix x) UnknownResultSignal = z + mappend (ResultSignalMix x) (ResultSignal y) = ResultSignalMix (x <> y) + mappend (ResultSignalMix x) (ResultSignalMix y) = ResultSignalMix (x <> y) + +-- | Construct a new result signal by the specified optional pure signal. +maybeResultSignal :: Maybe (Signal m ()) -> ResultSignal m +maybeResultSignal (Just x) = ResultSignal x +maybeResultSignal Nothing = EmptyResultSignal + +instance ResultItemable (ResultValue Int) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = id + resultItemToIntListValue = mapResultValue return + resultItemToIntStatsValue = mapResultValue returnSamplingStats + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = mapResultValue fromIntegral + resultItemToDoubleListValue = mapResultValue (return . fromIntegral) + resultItemToDoubleStatsValue = mapResultValue (returnSamplingStats . fromIntegral) + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = mapResultValue show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue Double) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = id + resultItemToDoubleListValue = mapResultValue return + resultItemToDoubleStatsValue = mapResultValue returnSamplingStats + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = mapResultValue show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue [Int]) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = id + resultItemToIntStatsValue = mapResultValue listSamplingStats + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = mapResultValue (map fromIntegral) + resultItemToDoubleStatsValue = mapResultValue (fromIntSamplingStats . listSamplingStats) + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = mapResultValue show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue [Double]) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = id + resultItemToDoubleStatsValue = mapResultValue listSamplingStats + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = mapResultValue show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue (SamplingStats Int)) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = id + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = mapResultValue fromIntSamplingStats + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = mapResultValue show + + resultItemExpansion = samplingStatsResultSource + resultItemSummary = samplingStatsResultSummary + +instance ResultItemable (ResultValue (SamplingStats Double)) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = id + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = mapResultValue show + + resultItemExpansion = samplingStatsResultSource + resultItemSummary = samplingStatsResultSummary + +instance ResultItemable (ResultValue (TimingStats Int)) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = id + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = mapResultValue fromIntTimingStats + + resultItemToStringValue = mapResultValue show + + resultItemExpansion = timingStatsResultSource + resultItemSummary = timingStatsResultSummary + +instance ResultItemable (ResultValue (TimingStats Double)) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = id + + resultItemToStringValue = mapResultValue show + + resultItemExpansion = timingStatsResultSource + resultItemSummary = timingStatsResultSummary + +instance ResultItemable (ResultValue Bool) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = mapResultValue show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue String) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = id + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue ()) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = mapResultValue show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue FCFS) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = mapResultValue show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue LCFS) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = mapResultValue show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue SIRO) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = mapResultValue show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue StaticPriorities) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = mapResultValue show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +-- | Flatten the result source. +flattenResultSource :: ResultSource m -> [ResultItem m] +flattenResultSource (ResultItemSource x) = [x] +flattenResultSource (ResultObjectSource x) = + concat $ map (flattenResultSource . resultPropertySource) $ resultObjectProperties x +flattenResultSource (ResultVectorSource x) = + concat $ map flattenResultSource $ A.elems $ resultVectorItems x +flattenResultSource (ResultSeparatorSource x) = [] + +-- | Return the result source name. +resultSourceName :: ResultSource m -> ResultName +resultSourceName (ResultItemSource (ResultItem x)) = resultItemName x +resultSourceName (ResultObjectSource x) = resultObjectName x +resultSourceName (ResultVectorSource x) = resultVectorName x +resultSourceName (ResultSeparatorSource x) = [] + +-- | Expand the result source returning a more detailed version expanding the properties as possible. +expandResultSource :: MonadComp m => ResultSource m -> ResultSource m +expandResultSource (ResultItemSource (ResultItem x)) = resultItemExpansion x +expandResultSource (ResultObjectSource x) = + ResultObjectSource $ + x { resultObjectProperties = + flip fmap (resultObjectProperties x) $ \p -> + p { resultPropertySource = expandResultSource (resultPropertySource p) } } +expandResultSource (ResultVectorSource x) = + ResultVectorSource $ + x { resultVectorItems = + A.array bnds [(i, expandResultSource e) | (i, e) <- ies] } + where arr = resultVectorItems x + bnds = A.bounds arr + ies = A.assocs arr +expandResultSource z@(ResultSeparatorSource x) = z + +-- | Return a summarised and usually more short version of the result source expanding the main properties or excluding auxiliary properties if required. +resultSourceSummary :: MonadComp m => ResultSource m -> ResultSource m +resultSourceSummary (ResultItemSource (ResultItem x)) = resultItemSummary x +resultSourceSummary (ResultObjectSource x) = resultObjectSummary x +resultSourceSummary (ResultVectorSource x) = resultVectorSummary x +resultSourceSummary z@(ResultSeparatorSource x) = z + +-- | Return a signal emitted by the source. +resultSourceSignal :: MonadComp m => ResultSource m -> ResultSignal m +resultSourceSignal (ResultItemSource (ResultItem x)) = resultItemSignal x +resultSourceSignal (ResultObjectSource x) = resultObjectSignal x +resultSourceSignal (ResultVectorSource x) = resultVectorSignal x +resultSourceSignal (ResultSeparatorSource x) = EmptyResultSignal + +-- | Represent the result source as integer numbers. +resultSourceToIntValues :: MonadComp m => ResultSource m -> [ResultValue Int m] +resultSourceToIntValues = map (\(ResultItem x) -> resultItemToIntValue x) . flattenResultSource + +-- | Represent the result source as lists of integer numbers. +resultSourceToIntListValues :: MonadComp m => ResultSource m -> [ResultValue [Int] m] +resultSourceToIntListValues = map (\(ResultItem x) -> resultItemToIntListValue x) . flattenResultSource + +-- | Represent the result source as statistics based on integer numbers. +resultSourceToIntStatsValues :: MonadComp m => ResultSource m -> [ResultValue (SamplingStats Int) m] +resultSourceToIntStatsValues = map (\(ResultItem x) -> resultItemToIntStatsValue x) . flattenResultSource + +-- | Represent the result source as statistics based on integer numbers and optimised for fast aggregation. +resultSourceToIntStatsEitherValues :: MonadComp m => ResultSource m -> [ResultValue (Either Int (SamplingStats Int)) m] +resultSourceToIntStatsEitherValues = map (\(ResultItem x) -> resultItemToIntStatsEitherValue x) . flattenResultSource + +-- | Represent the result source as timing statistics based on integer numbers. +resultSourceToIntTimingStatsValues :: MonadComp m => ResultSource m -> [ResultValue (TimingStats Int) m] +resultSourceToIntTimingStatsValues = map (\(ResultItem x) -> resultItemToIntTimingStatsValue x) . flattenResultSource + +-- | Represent the result source as double floating point numbers. +resultSourceToDoubleValues :: MonadComp m => ResultSource m -> [ResultValue Double m] +resultSourceToDoubleValues = map (\(ResultItem x) -> resultItemToDoubleValue x) . flattenResultSource + +-- | Represent the result source as lists of double floating point numbers. +resultSourceToDoubleListValues :: MonadComp m => ResultSource m -> [ResultValue [Double] m] +resultSourceToDoubleListValues = map (\(ResultItem x) -> resultItemToDoubleListValue x) . flattenResultSource + +-- | Represent the result source as statistics based on double floating point numbers. +resultSourceToDoubleStatsValues :: MonadComp m => ResultSource m -> [ResultValue (SamplingStats Double) m] +resultSourceToDoubleStatsValues = map (\(ResultItem x) -> resultItemToDoubleStatsValue x) . flattenResultSource + +-- | Represent the result source as statistics based on double floating point numbers and optimised for fast aggregation. +resultSourceToDoubleStatsEitherValues :: MonadComp m => ResultSource m -> [ResultValue (Either Double (SamplingStats Double)) m] +resultSourceToDoubleStatsEitherValues = map (\(ResultItem x) -> resultItemToDoubleStatsEitherValue x) . flattenResultSource + +-- | Represent the result source as timing statistics based on double floating point numbers. +resultSourceToDoubleTimingStatsValues :: MonadComp m => ResultSource m -> [ResultValue (TimingStats Double) m] +resultSourceToDoubleTimingStatsValues = map (\(ResultItem x) -> resultItemToDoubleTimingStatsValue x) . flattenResultSource + +-- | Represent the result source as string values. +resultSourceToStringValues :: MonadComp m => ResultSource m -> [ResultValue String m] +resultSourceToStringValues = map (\(ResultItem x) -> resultItemToStringValue x) . flattenResultSource + +-- | It contains the results of simulation. +data Results m = + Results { resultSourceMap :: ResultSourceMap m, + -- ^ The sources of simulation results as a map of associated names. + resultSourceList :: [ResultSource m] + -- ^ The sources of simulation results as an ordered list. + } + +-- | It transforms the results of simulation. +type ResultTransform m = Results m -> Results m + +-- | It representes the predefined signals provided by every simulation model. +data ResultPredefinedSignals m = + ResultPredefinedSignals { resultSignalInIntegTimes :: Signal m Double, + -- ^ The signal triggered in the integration time points. + resultSignalInStartTime :: Signal m Double, + -- ^ The signal triggered in the start time. + resultSignalInStopTime :: Signal m Double + -- ^ The signal triggered in the stop time. + } + +-- | Create the predefined signals provided by every simulation model. +newResultPredefinedSignals :: MonadComp m => Simulation m (ResultPredefinedSignals m) +newResultPredefinedSignals = runDynamicsInStartTime $ runEventWith EarlierEvents d where + d = do signalInIntegTimes <- newSignalInIntegTimes + signalInStartTime <- newSignalInStartTime + signalInStopTime <- newSignalInStopTime + return ResultPredefinedSignals { resultSignalInIntegTimes = signalInIntegTimes, + resultSignalInStartTime = signalInStartTime, + resultSignalInStopTime = signalInStopTime } + +instance Monoid (Results m) where + + mempty = results mempty + mappend x y = results $ resultSourceList x <> resultSourceList y + +-- | Prepare the simulation results. +results :: [ResultSource m] -> Results m +results ms = + Results { resultSourceMap = M.fromList $ map (\x -> (resultSourceName x, x)) ms, + resultSourceList = ms } + +-- | Represent the results as integer numbers. +resultsToIntValues :: MonadComp m => Results m -> [ResultValue Int m] +resultsToIntValues = concat . map resultSourceToIntValues . resultSourceList + +-- | Represent the results as lists of integer numbers. +resultsToIntListValues :: MonadComp m => Results m -> [ResultValue [Int] m] +resultsToIntListValues = concat . map resultSourceToIntListValues . resultSourceList + +-- | Represent the results as statistics based on integer numbers. +resultsToIntStatsValues :: MonadComp m => Results m -> [ResultValue (SamplingStats Int) m] +resultsToIntStatsValues = concat . map resultSourceToIntStatsValues . resultSourceList + +-- | Represent the results as statistics based on integer numbers and optimised for fast aggregation. +resultsToIntStatsEitherValues :: MonadComp m => Results m -> [ResultValue (Either Int (SamplingStats Int)) m] +resultsToIntStatsEitherValues = concat . map resultSourceToIntStatsEitherValues . resultSourceList + +-- | Represent the results as timing statistics based on integer numbers. +resultsToIntTimingStatsValues :: MonadComp m => Results m -> [ResultValue (TimingStats Int) m] +resultsToIntTimingStatsValues = concat . map resultSourceToIntTimingStatsValues . resultSourceList + +-- | Represent the results as double floating point numbers. +resultsToDoubleValues :: MonadComp m => Results m -> [ResultValue Double m] +resultsToDoubleValues = concat . map resultSourceToDoubleValues . resultSourceList + +-- | Represent the results as lists of double floating point numbers. +resultsToDoubleListValues :: MonadComp m => Results m -> [ResultValue [Double] m] +resultsToDoubleListValues = concat . map resultSourceToDoubleListValues . resultSourceList + +-- | Represent the results as statistics based on double floating point numbers. +resultsToDoubleStatsValues :: MonadComp m => Results m -> [ResultValue (SamplingStats Double) m] +resultsToDoubleStatsValues = concat . map resultSourceToDoubleStatsValues . resultSourceList + +-- | Represent the results as statistics based on double floating point numbers and optimised for fast aggregation. +resultsToDoubleStatsEitherValues :: MonadComp m => Results m -> [ResultValue (Either Double (SamplingStats Double)) m] +resultsToDoubleStatsEitherValues = concat . map resultSourceToDoubleStatsEitherValues . resultSourceList + +-- | Represent the results as timing statistics based on double floating point numbers. +resultsToDoubleTimingStatsValues :: MonadComp m => Results m -> [ResultValue (TimingStats Double) m] +resultsToDoubleTimingStatsValues = concat . map resultSourceToDoubleTimingStatsValues . resultSourceList + +-- | Represent the results as string values. +resultsToStringValues :: MonadComp m => Results m -> [ResultValue String m] +resultsToStringValues = concat . map resultSourceToStringValues . resultSourceList + +-- | Return a signal emitted by the specified results. +resultSignal :: MonadComp m => Results m -> ResultSignal m +resultSignal = mconcat . map resultSourceSignal . resultSourceList + +-- | Return an expanded version of the simulation results expanding the properties as possible, which +-- takes place for expanding statistics to show the count, average, deviation, minimum, maximum etc. +-- as separate values. +expandResults :: MonadComp m => ResultTransform m +expandResults = results . map expandResultSource . resultSourceList + +-- | Return a short version of the simulation results, i.e. their summary, expanding the main properties +-- or excluding auxiliary properties if required. +resultSummary :: MonadComp m => ResultTransform m +resultSummary = results . map resultSourceSummary . resultSourceList + +-- | Take a result by its name. +resultByName :: ResultName -> ResultTransform m +resultByName name rs = + case M.lookup name (resultSourceMap rs) of + Just x -> results [x] + Nothing -> + error $ + "Not found result source with name " ++ name ++ + ": resultByName" + +-- | Take a result from the object with the specified property label, +-- but it is more preferrable to refer to the property by its 'ResultId' +-- identifier with help of the 'resultById' function. +resultByProperty :: ResultName -> ResultTransform m +resultByProperty label rs = flip composeResults rs loop + where + loop x = + case x of + ResultObjectSource s -> + let ps = + flip filter (resultObjectProperties s) $ \p -> + resultPropertyLabel p == label + in case ps of + [] -> + error $ + "Not found property " ++ label ++ + " for object " ++ resultObjectName s ++ + ": resultByProperty" + ps -> + map resultPropertySource ps + ResultVectorSource s -> + concat $ map loop $ A.elems $ resultVectorItems s + x -> + error $ + "Result source " ++ resultSourceName x ++ + " is neither object, nor vector " ++ + ": resultByProperty" + +-- | Take a result from the object with the specified identifier. It can identify +-- an item, object property, the object iself, vector or its elements. +resultById :: ResultId -> ResultTransform m +resultById i rs = flip composeResults rs loop + where + loop x = + case x of + ResultItemSource (ResultItem s) -> + if resultItemId s == i + then [x] + else error $ + "Expected to find item with Id = " ++ show i ++ + ", while the item " ++ resultItemName s ++ + " has actual Id = " ++ show (resultItemId s) ++ + ": resultById" + ResultObjectSource s -> + if resultObjectId s == i + then [x] + else let ps = + flip filter (resultObjectProperties s) $ \p -> + resultPropertyId p == i + in case ps of + [] -> + error $ + "Not found property with Id = " ++ show i ++ + " for object " ++ resultObjectName s ++ + " that has actual Id = " ++ show (resultObjectId s) ++ + ": resultById" + ps -> + map resultPropertySource ps + ResultVectorSource s -> + if resultVectorId s == i + then [x] + else concat $ map loop $ A.elems $ resultVectorItems s + x -> + error $ + "Result source " ++ resultSourceName x ++ + " is neither item, nor object, nor vector " ++ + ": resultById" + +-- | Take a result from the vector by the specified integer index. +resultByIndex :: Int -> ResultTransform m +resultByIndex index rs = flip composeResults rs loop + where + loop x = + case x of + ResultVectorSource s -> + [resultVectorItems s A.! index] + x -> + error $ + "Result source " ++ resultSourceName x ++ + " is not vector " ++ + ": resultByIndex" + +-- | Take a result from the vector by the specified string subscript. +resultBySubscript :: ResultName -> ResultTransform m +resultBySubscript subscript rs = flip composeResults rs loop + where + loop x = + case x of + ResultVectorSource s -> + let ys = A.elems $ resultVectorItems s + zs = A.elems $ resultVectorSubscript s + ps = + flip filter (zip ys zs) $ \(y, z) -> + z == subscript + in case ps of + [] -> + error $ + "Not found subscript " ++ subscript ++ + " for vector " ++ resultVectorName s ++ + ": resultBySubscript" + ps -> + map fst ps + x -> + error $ + "Result source " ++ resultSourceName x ++ + " is not vector " ++ + ": resultBySubscript" + +-- | Compose the results using the specified transformation function. +composeResults :: (ResultSource m -> [ResultSource m]) -> ResultTransform m +composeResults f = + results . concat . map f . resultSourceList + +-- | Concatenate the results using the specified list of transformation functions. +concatResults :: [ResultTransform m] -> ResultTransform m +concatResults trs rs = + results $ concat $ map (\tr -> resultSourceList $ tr rs) trs + +-- | Append the results using the specified transformation functions. +appendResults :: ResultTransform m -> ResultTransform m -> ResultTransform m +appendResults x y = + concatResults [x, y] + +-- | Return a pure signal as a result of combination of the predefined signals +-- with the specified result signal usually provided by the sources. +-- +-- The signal returned is triggered when the source signal is triggered. +-- The pure signal is also triggered in the integration time points +-- if the source signal is unknown or it was combined with any unknown signal. +pureResultSignal :: MonadComp m => ResultPredefinedSignals m -> ResultSignal m -> Signal m () +pureResultSignal rs EmptyResultSignal = + void (resultSignalInStartTime rs) +pureResultSignal rs UnknownResultSignal = + void (resultSignalInIntegTimes rs) +pureResultSignal rs (ResultSignal s) = + void (resultSignalInStartTime rs) <> void (resultSignalInStopTime rs) <> s +pureResultSignal rs (ResultSignalMix s) = + void (resultSignalInIntegTimes rs) <> s + +-- | Defines a final result extract: its name, values and other data. +data ResultExtract e m = + ResultExtract { resultExtractName :: ResultName, + -- ^ The result name. + resultExtractId :: ResultId, + -- ^ The result identifier. + resultExtractData :: Event m e, + -- ^ The result values. + resultExtractSignal :: ResultSignal m + -- ^ Whether the result emits a signal. + } + +-- | Extract the results as integer values, or raise a conversion error. +extractIntResults :: MonadComp m => Results m -> [ResultExtract Int m] +extractIntResults rs = flip map (resultsToIntValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of integer values: extractIntResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as lists of integer values, or raise a conversion error. +extractIntListResults :: MonadComp m => Results m -> [ResultExtract [Int] m] +extractIntListResults rs = flip map (resultsToIntListValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of lists of integer values: extractIntListResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as statistics based on integer values, +-- or raise a conversion error. +extractIntStatsResults :: MonadComp m => Results m -> [ResultExtract (SamplingStats Int) m] +extractIntStatsResults rs = flip map (resultsToIntStatsValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of statistics based on integer values: extractIntStatsResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as statistics based on integer values and optimised +-- for fast aggregation, or raise a conversion error. +extractIntStatsEitherResults :: MonadComp m => Results m -> [ResultExtract (Either Int (SamplingStats Int)) m] +extractIntStatsEitherResults rs = flip map (resultsToIntStatsEitherValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of statistics based on integer values: extractIntStatsEitherResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as timing statistics based on integer values, +-- or raise a conversion error. +extractIntTimingStatsResults :: MonadComp m => Results m -> [ResultExtract (TimingStats Int) m] +extractIntTimingStatsResults rs = flip map (resultsToIntTimingStatsValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of timing statistics based on integer values: extractIntTimingStatsResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as double floating point values, or raise a conversion error. +extractDoubleResults :: MonadComp m => Results m -> [ResultExtract Double m] +extractDoubleResults rs = flip map (resultsToDoubleValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of double floating point values: extractDoubleResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as lists of double floating point values, +-- or raise a conversion error. +extractDoubleListResults :: MonadComp m => Results m -> [ResultExtract [Double] m] +extractDoubleListResults rs = flip map (resultsToDoubleListValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of lists of double floating point values: extractDoubleListResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as statistics based on double floating point values, +-- or raise a conversion error. +extractDoubleStatsResults :: MonadComp m => Results m -> [ResultExtract (SamplingStats Double) m] +extractDoubleStatsResults rs = flip map (resultsToDoubleStatsValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of statistics based on double floating point values: extractDoubleStatsResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as statistics based on double floating point values +-- and optimised for fast aggregation, or raise a conversion error. +extractDoubleStatsEitherResults :: MonadComp m => Results m -> [ResultExtract (Either Double (SamplingStats Double)) m] +extractDoubleStatsEitherResults rs = flip map (resultsToDoubleStatsEitherValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of statistics based on double floating point values: extractDoubleStatsEitherResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as timing statistics based on double floating point values, +-- or raise a conversion error. +extractDoubleTimingStatsResults :: MonadComp m => Results m -> [ResultExtract (TimingStats Double) m] +extractDoubleTimingStatsResults rs = flip map (resultsToDoubleTimingStatsValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of timing statistics based on double floating point values: extractDoubleTimingStatsResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as string values, or raise a conversion error. +extractStringResults :: MonadComp m => Results m -> [ResultExtract String m] +extractStringResults rs = flip map (resultsToStringValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of string values: extractStringResults" + Just a -> + ResultExtract n i a s + +-- | Represents a computation that can return the simulation data. +class MonadComp m => ResultComputing t m where + + -- | Compute data with the results of simulation. + computeResultData :: t m a -> ResultData a m + + -- | Return the signal triggered when data change if such a signal exists. + computeResultSignal :: t m a -> ResultSignal m + +-- | Return a new result value by the specified name, identifier and computation. +computeResultValue :: ResultComputing t m + => ResultName + -- ^ the result name + -> ResultId + -- ^ the result identifier + -> t m a + -- ^ the result computation + -> ResultValue a m +computeResultValue name i m = + ResultValue { + resultValueName = name, + resultValueId = i, + resultValueData = computeResultData m, + resultValueSignal = computeResultSignal m } + +instance MonadComp m => ResultComputing Parameter m where + + computeResultData = Just . liftParameter + computeResultSignal = const UnknownResultSignal + +instance MonadComp m => ResultComputing Simulation m where + + computeResultData = Just . liftSimulation + computeResultSignal = const UnknownResultSignal + +instance MonadComp m => ResultComputing Dynamics m where + + computeResultData = Just . liftDynamics + computeResultSignal = const UnknownResultSignal + +instance MonadComp m => ResultComputing Event m where + + computeResultData = Just . id + computeResultSignal = const UnknownResultSignal + +instance MonadComp m => ResultComputing Ref m where + + computeResultData = Just . readRef + computeResultSignal = ResultSignal . refChanged_ + +instance MonadComp m => ResultComputing LR.Ref m where + + computeResultData = Just . LR.readRef + computeResultSignal = const UnknownResultSignal + +instance MonadComp m => ResultComputing Var m where + + computeResultData = Just . readVar + computeResultSignal = ResultSignal . varChanged_ + +instance MonadComp m => ResultComputing Signalable m where + + computeResultData = Just . readSignalable + computeResultSignal = ResultSignal . signalableChanged_ + +-- | Return a source by the specified statistics. +samplingStatsResultSource :: (MonadComp m, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (SamplingStats a))) + => ResultValue (SamplingStats a) m + -- ^ the statistics + -> ResultSource m +samplingStatsResultSource x = + ResultObjectSource $ + ResultObject { + resultObjectName = resultValueName x, + resultObjectId = resultValueId x, + resultObjectTypeId = SamplingStatsId, + resultObjectSignal = resultValueSignal x, + resultObjectSummary = samplingStatsResultSummary x, + resultObjectProperties = [ + resultContainerMapProperty c "count" SamplingStatsCountId samplingStatsCount, + resultContainerMapProperty c "mean" SamplingStatsMeanId samplingStatsMean, + resultContainerMapProperty c "mean2" SamplingStatsMean2Id samplingStatsMean2, + resultContainerMapProperty c "std" SamplingStatsDeviationId samplingStatsDeviation, + resultContainerMapProperty c "var" SamplingStatsVarianceId samplingStatsVariance, + resultContainerMapProperty c "min" SamplingStatsMinId samplingStatsMin, + resultContainerMapProperty c "max" SamplingStatsMaxId samplingStatsMax ] } + where + c = resultValueToContainer x + +-- | Return the summary by the specified statistics. +samplingStatsResultSummary :: (MonadComp m, + ResultItemable (ResultValue (SamplingStats a))) + => ResultValue (SamplingStats a) m + -- ^ the statistics + -> ResultSource m +samplingStatsResultSummary = ResultItemSource . ResultItem . resultItemToStringValue + +-- | Return a source by the specified timing statistics. +timingStatsResultSource :: (MonadComp m, + TimingData a, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (TimingStats a))) + => ResultValue (TimingStats a) m + -- ^ the statistics + -> ResultSource m +timingStatsResultSource x = + ResultObjectSource $ + ResultObject { + resultObjectName = resultValueName x, + resultObjectId = resultValueId x, + resultObjectTypeId = TimingStatsId, + resultObjectSignal = resultValueSignal x, + resultObjectSummary = timingStatsResultSummary x, + resultObjectProperties = [ + resultContainerMapProperty c "count" TimingStatsCountId timingStatsCount, + resultContainerMapProperty c "mean" TimingStatsMeanId timingStatsMean, + resultContainerMapProperty c "std" TimingStatsDeviationId timingStatsDeviation, + resultContainerMapProperty c "var" TimingStatsVarianceId timingStatsVariance, + resultContainerMapProperty c "min" TimingStatsMinId timingStatsMin, + resultContainerMapProperty c "max" TimingStatsMaxId timingStatsMax, + resultContainerMapProperty c "minTime" TimingStatsMinTimeId timingStatsMinTime, + resultContainerMapProperty c "maxTime" TimingStatsMaxTimeId timingStatsMaxTime, + resultContainerMapProperty c "startTime" TimingStatsStartTimeId timingStatsStartTime, + resultContainerMapProperty c "lastTime" TimingStatsLastTimeId timingStatsLastTime, + resultContainerMapProperty c "sum" TimingStatsSumId timingStatsSum, + resultContainerMapProperty c "sum2" TimingStatsSum2Id timingStatsSum2 ] } + where + c = resultValueToContainer x + +-- | Return the summary by the specified timing statistics. +timingStatsResultSummary :: (MonadComp m, + TimingData a, + ResultItemable (ResultValue (TimingStats a))) + => ResultValue (TimingStats a) m + -- ^ the statistics + -> ResultSource m +timingStatsResultSummary = ResultItemSource . ResultItem . resultItemToStringValue + +-- | Return a source by the specified finite queue. +queueResultSource :: (MonadComp m, + Show si, Show sm, Show so, + ResultItemable (ResultValue si), + ResultItemable (ResultValue sm), + ResultItemable (ResultValue so)) + => ResultContainer (Q.Queue m si sm so a) m + -- ^ the queue container + -> ResultSource m +queueResultSource c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = FiniteQueueId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = queueResultSummary c, + resultObjectProperties = [ + resultContainerConstProperty c "enqueueStrategy" EnqueueStrategyId Q.enqueueStrategy, + resultContainerConstProperty c "enqueueStoringStrategy" EnqueueStoringStrategyId Q.enqueueStoringStrategy, + resultContainerConstProperty c "dequeueStrategy" DequeueStrategyId Q.dequeueStrategy, + resultContainerProperty c "queueNull" QueueNullId Q.queueNull Q.queueNullChanged_, + resultContainerProperty c "queueFull" QueueFullId Q.queueFull Q.queueFullChanged_, + resultContainerConstProperty c "queueMaxCount" QueueMaxCountId Q.queueMaxCount, + resultContainerProperty c "queueCount" QueueCountId Q.queueCount Q.queueCountChanged_, + resultContainerProperty c "queueCountStats" QueueCountStatsId Q.queueCountStats Q.queueCountChanged_, + resultContainerProperty c "enqueueCount" EnqueueCountId Q.enqueueCount Q.enqueueCountChanged_, + resultContainerProperty c "enqueueLostCount" EnqueueLostCountId Q.enqueueLostCount Q.enqueueLostCountChanged_, + resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId Q.enqueueStoreCount Q.enqueueStoreCountChanged_, + resultContainerProperty c "dequeueCount" DequeueCountId Q.dequeueCount Q.dequeueCountChanged_, + resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId Q.dequeueExtractCount Q.dequeueExtractCountChanged_, + resultContainerProperty c "queueLoadFactor" QueueLoadFactorId Q.queueLoadFactor Q.queueLoadFactorChanged_, + resultContainerIntegProperty c "enqueueRate" EnqueueRateId Q.enqueueRate, + resultContainerIntegProperty c "enqueueStoreRate" EnqueueStoreRateId Q.enqueueStoreRate, + resultContainerIntegProperty c "dequeueRate" DequeueRateId Q.dequeueRate, + resultContainerIntegProperty c "dequeueExtractRate" DequeueExtractRateId Q.dequeueExtractRate, + resultContainerProperty c "queueWaitTime" QueueWaitTimeId Q.queueWaitTime Q.queueWaitTimeChanged_, + resultContainerProperty c "queueTotalWaitTime" QueueTotalWaitTimeId Q.queueTotalWaitTime Q.queueTotalWaitTimeChanged_, + resultContainerProperty c "enqueueWaitTime" EnqueueWaitTimeId Q.enqueueWaitTime Q.enqueueWaitTimeChanged_, + resultContainerProperty c "dequeueWaitTime" DequeueWaitTimeId Q.dequeueWaitTime Q.dequeueWaitTimeChanged_, + resultContainerProperty c "queueRate" QueueRateId Q.queueRate Q.queueRateChanged_ ] } + +-- | Return the summary by the specified finite queue. +queueResultSummary :: (MonadComp m, + Show si, Show sm, Show so) + => ResultContainer (Q.Queue m si sm so a) m + -- ^ the queue container + -> ResultSource m +queueResultSummary c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = FiniteQueueId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = queueResultSummary c, + resultObjectProperties = [ + resultContainerConstProperty c "queueMaxCount" QueueMaxCountId Q.queueMaxCount, + resultContainerProperty c "queueCountStats" QueueCountStatsId Q.queueCountStats Q.queueCountChanged_, + resultContainerProperty c "enqueueCount" EnqueueCountId Q.enqueueCount Q.enqueueCountChanged_, + resultContainerProperty c "enqueueLostCount" EnqueueLostCountId Q.enqueueLostCount Q.enqueueLostCountChanged_, + resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId Q.enqueueStoreCount Q.enqueueStoreCountChanged_, + resultContainerProperty c "dequeueCount" DequeueCountId Q.dequeueCount Q.dequeueCountChanged_, + resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId Q.dequeueExtractCount Q.dequeueExtractCountChanged_, + resultContainerProperty c "queueLoadFactor" QueueLoadFactorId Q.queueLoadFactor Q.queueLoadFactorChanged_, + resultContainerProperty c "queueWaitTime" QueueWaitTimeId Q.queueWaitTime Q.queueWaitTimeChanged_, + resultContainerProperty c "queueRate" QueueRateId Q.queueRate Q.queueRateChanged_ ] } + +-- | Return a source by the specified infinite queue. +infiniteQueueResultSource :: (MonadComp m, + Show sm, Show so, + ResultItemable (ResultValue sm), + ResultItemable (ResultValue so)) + => ResultContainer (IQ.Queue m sm so a) m + -- ^ the queue container + -> ResultSource m +infiniteQueueResultSource c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = FiniteQueueId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = infiniteQueueResultSummary c, + resultObjectProperties = [ + resultContainerConstProperty c "enqueueStoringStrategy" EnqueueStoringStrategyId IQ.enqueueStoringStrategy, + resultContainerConstProperty c "dequeueStrategy" DequeueStrategyId IQ.dequeueStrategy, + resultContainerProperty c "queueNull" QueueNullId IQ.queueNull IQ.queueNullChanged_, + resultContainerProperty c "queueCount" QueueCountId IQ.queueCount IQ.queueCountChanged_, + resultContainerProperty c "queueCountStats" QueueCountStatsId IQ.queueCountStats IQ.queueCountChanged_, + resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId IQ.enqueueStoreCount IQ.enqueueStoreCountChanged_, + resultContainerProperty c "dequeueCount" DequeueCountId IQ.dequeueCount IQ.dequeueCountChanged_, + resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId IQ.dequeueExtractCount IQ.dequeueExtractCountChanged_, + resultContainerIntegProperty c "enqueueStoreRate" EnqueueStoreRateId IQ.enqueueStoreRate, + resultContainerIntegProperty c "dequeueRate" DequeueRateId IQ.dequeueRate, + resultContainerIntegProperty c "dequeueExtractRate" DequeueExtractRateId IQ.dequeueExtractRate, + resultContainerProperty c "queueWaitTime" QueueWaitTimeId IQ.queueWaitTime IQ.queueWaitTimeChanged_, + resultContainerProperty c "dequeueWaitTime" DequeueWaitTimeId IQ.dequeueWaitTime IQ.dequeueWaitTimeChanged_, + resultContainerProperty c "queueRate" QueueRateId IQ.queueRate IQ.queueRateChanged_ ] } + +-- | Return the summary by the specified infinite queue. +infiniteQueueResultSummary :: (MonadComp m, + Show sm, Show so) + => ResultContainer (IQ.Queue m sm so a) m + -- ^ the queue container + -> ResultSource m +infiniteQueueResultSummary c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = FiniteQueueId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = infiniteQueueResultSummary c, + resultObjectProperties = [ + resultContainerProperty c "queueCountStats" QueueCountStatsId IQ.queueCountStats IQ.queueCountChanged_, + resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId IQ.enqueueStoreCount IQ.enqueueStoreCountChanged_, + resultContainerProperty c "dequeueCount" DequeueCountId IQ.dequeueCount IQ.dequeueCountChanged_, + resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId IQ.dequeueExtractCount IQ.dequeueExtractCountChanged_, + resultContainerProperty c "queueWaitTime" QueueWaitTimeId IQ.queueWaitTime IQ.queueWaitTimeChanged_, + resultContainerProperty c "queueRate" QueueRateId IQ.queueRate IQ.queueRateChanged_ ] } + +-- | Return a source by the specified arrival timer. +arrivalTimerResultSource :: MonadComp m + => ResultContainer (ArrivalTimer m) m + -- ^ the arrival timer container + -> ResultSource m +arrivalTimerResultSource c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = ArrivalTimerId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = arrivalTimerResultSummary c, + resultObjectProperties = [ + resultContainerProperty c "processingTime" ArrivalProcessingTimeId arrivalProcessingTime arrivalProcessingTimeChanged_ ] } + +-- | Return the summary by the specified arrival timer. +arrivalTimerResultSummary :: MonadComp m + => ResultContainer (ArrivalTimer m) m + -- ^ the arrival timer container + -> ResultSource m +arrivalTimerResultSummary c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = ArrivalTimerId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = arrivalTimerResultSummary c, + resultObjectProperties = [ + resultContainerProperty c "processingTime" ArrivalProcessingTimeId arrivalProcessingTime arrivalProcessingTimeChanged_ ] } + +-- | Return a source by the specified server. +serverResultSource :: (MonadComp m, + Show s, ResultItemable (ResultValue s)) + => ResultContainer (Server m s a b) m + -- ^ the server container + -> ResultSource m +serverResultSource c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = ServerId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = serverResultSummary c, + resultObjectProperties = [ + resultContainerConstProperty c "initState" ServerInitStateId serverInitState, + resultContainerProperty c "state" ServerStateId serverState serverStateChanged_, + resultContainerProperty c "totalInputWaitTime" ServerTotalInputWaitTimeId serverTotalInputWaitTime serverTotalInputWaitTimeChanged_, + resultContainerProperty c "totalProcessingTime" ServerTotalProcessingTimeId serverTotalProcessingTime serverTotalProcessingTimeChanged_, + resultContainerProperty c "totalOutputWaitTime" ServerTotalOutputWaitTimeId serverTotalOutputWaitTime serverTotalOutputWaitTimeChanged_, + resultContainerProperty c "inputWaitTime" ServerInputWaitTimeId serverInputWaitTime serverInputWaitTimeChanged_, + resultContainerProperty c "processingTime" ServerProcessingTimeId serverProcessingTime serverProcessingTimeChanged_, + resultContainerProperty c "outputWaitTime" ServerOutputWaitTimeId serverOutputWaitTime serverOutputWaitTimeChanged_, + resultContainerProperty c "inputWaitFactor" ServerInputWaitFactorId serverInputWaitFactor serverInputWaitFactorChanged_, + resultContainerProperty c "processingFactor" ServerProcessingFactorId serverProcessingFactor serverProcessingFactorChanged_, + resultContainerProperty c "outputWaitFactor" ServerOutputWaitFactorId serverOutputWaitFactor serverOutputWaitFactorChanged_ ] } + +-- | Return the summary by the specified server. +serverResultSummary :: MonadComp m + => ResultContainer (Server m s a b) m + -- ^ the server container + -> ResultSource m +serverResultSummary c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = ServerId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = serverResultSummary c, + resultObjectProperties = [ + resultContainerProperty c "inputWaitTime" ServerInputWaitTimeId serverInputWaitTime serverInputWaitTimeChanged_, + resultContainerProperty c "processingTime" ServerProcessingTimeId serverProcessingTime serverProcessingTimeChanged_, + resultContainerProperty c "outputWaitTime" ServerOutputWaitTimeId serverOutputWaitTime serverOutputWaitTimeChanged_, + resultContainerProperty c "inputWaitFactor" ServerInputWaitFactorId serverInputWaitFactor serverInputWaitFactorChanged_, + resultContainerProperty c "processingFactor" ServerProcessingFactorId serverProcessingFactor serverProcessingFactorChanged_, + resultContainerProperty c "outputWaitFactor" ServerOutputWaitFactorId serverOutputWaitFactor serverOutputWaitFactorChanged_ ] } + +-- | Return a source by the specified activity. +activityResultSource :: (MonadComp m, + Show s, ResultItemable (ResultValue s)) + => ResultContainer (Activity m s a b) m + -- ^ the activity container + -> ResultSource m +activityResultSource c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = ActivityId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = activityResultSummary c, + resultObjectProperties = [ + resultContainerConstProperty c "initState" ActivityInitStateId activityInitState, + resultContainerProperty c "state" ActivityStateId activityState activityStateChanged_, + resultContainerProperty c "totalUtilisationTime" ActivityTotalUtilisationTimeId activityTotalUtilisationTime activityTotalUtilisationTimeChanged_, + resultContainerProperty c "totalIdleTime" ActivityTotalIdleTimeId activityTotalIdleTime activityTotalIdleTimeChanged_, + resultContainerProperty c "utilisationTime" ActivityUtilisationTimeId activityUtilisationTime activityUtilisationTimeChanged_, + resultContainerProperty c "idleTime" ActivityIdleTimeId activityIdleTime activityIdleTimeChanged_, + resultContainerProperty c "utilisationFactor" ActivityUtilisationFactorId activityUtilisationFactor activityUtilisationFactorChanged_, + resultContainerProperty c "idleFactor" ActivityIdleTimeId activityIdleFactor activityIdleFactorChanged_ ] } + +-- | Return a summary by the specified activity. +activityResultSummary :: MonadComp m + => ResultContainer (Activity m s a b) m + -- ^ the activity container + -> ResultSource m +activityResultSummary c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = ActivityId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = activityResultSummary c, + resultObjectProperties = [ + resultContainerProperty c "utilisationTime" ActivityUtilisationTimeId activityUtilisationTime activityUtilisationTimeChanged_, + resultContainerProperty c "idleTime" ActivityIdleTimeId activityIdleTime activityIdleTimeChanged_, + resultContainerProperty c "utilisationFactor" ActivityUtilisationFactorId activityUtilisationFactor activityUtilisationFactorChanged_, + resultContainerProperty c "idleFactor" ActivityIdleTimeId activityIdleFactor activityIdleFactorChanged_ ] } + +-- | Return an arbitrary text as a separator source. +textResultSource :: String -> ResultSource m +textResultSource text = + ResultSeparatorSource $ + ResultSeparator { resultSeparatorText = text } + +-- | Return the source of the modeling time. +timeResultSource :: MonadComp m => ResultSource m +timeResultSource = resultSource' "t" TimeId time + +-- | Make an integer subscript +intSubscript :: Int -> ResultName +intSubscript i = "[" ++ show i ++ "]" + +instance ResultComputing t m => ResultProvider (t m Double) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing t m => ResultProvider (t m [Double]) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing t m => ResultProvider (t m (SamplingStats Double)) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing t m => ResultProvider (t m (TimingStats Double)) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing t m => ResultProvider (t m Int) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing t m => ResultProvider (t m [Int]) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing t m => ResultProvider (t m (SamplingStats Int)) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing t m => ResultProvider (t m (TimingStats Int)) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing t m => ResultProvider (t m String) m where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultProvider p m => ResultProvider [p] m where + + resultSource' name i m = + resultSource' name i $ ResultListWithSubscript m subscript where + subscript = map snd $ zip m $ map intSubscript [0..] + +instance (Show i, Ix i, ResultProvider p m) => ResultProvider (A.Array i p) m where + + resultSource' name i m = + resultSource' name i $ ResultListWithSubscript items subscript where + items = A.elems m + subscript = map (\i -> "[" ++ show i ++ "]") (A.indices m) + +#ifndef __HASTE__ + +instance ResultProvider p m => ResultProvider (V.Vector p) m where + + resultSource' name i m = + resultSource' name i $ ResultVectorWithSubscript m subscript where + subscript = V.imap (\i x -> intSubscript i) m + +#endif + +-- | Represents a list with the specified subscript. +data ResultListWithSubscript p = + ResultListWithSubscript [p] [String] + +-- | Represents an array with the specified subscript. +data ResultArrayWithSubscript i p = + ResultArrayWithSubscript (A.Array i p) (A.Array i String) + +#ifndef __HASTE__ + +-- | Represents a vector with the specified subscript. +data ResultVectorWithSubscript p = + ResultVectorWithSubscript (V.Vector p) (V.Vector String) + +#endif + +instance ResultProvider p m => ResultProvider (ResultListWithSubscript p) m where + + resultSource' name i (ResultListWithSubscript xs ys) = + ResultVectorSource $ + memoResultVectorSignal $ + memoResultVectorSummary $ + ResultVector { resultVectorName = name, + resultVectorId = i, + resultVectorItems = axs, + resultVectorSubscript = ays, + resultVectorSignal = undefined, + resultVectorSummary = undefined } + where + bnds = (0, length xs - 1) + axs = A.listArray bnds items + ays = A.listArray bnds ys + items = + flip map (zip ys xs) $ \(y, x) -> + let name' = name ++ y + in resultSource' name' (VectorItemId y) x + items' = map resultSourceSummary items + +instance (Show i, Ix i, ResultProvider p m) => ResultProvider (ResultArrayWithSubscript i p) m where + + resultSource' name i (ResultArrayWithSubscript xs ys) = + resultSource' name i $ ResultListWithSubscript items subscript where + items = A.elems xs + subscript = A.elems ys + +#ifndef __HASTE__ + +instance ResultProvider p m => ResultProvider (ResultVectorWithSubscript p) m where + + resultSource' name i (ResultVectorWithSubscript xs ys) = + ResultVectorSource $ + memoResultVectorSignal $ + memoResultVectorSummary $ + ResultVector { resultVectorName = name, + resultVectorId = i, + resultVectorItems = axs, + resultVectorSubscript = ays, + resultVectorSignal = undefined, + resultVectorSummary = undefined } + where + bnds = (0, V.length xs - 1) + axs = A.listArray bnds (V.toList items) + ays = A.listArray bnds (V.toList ys) + items = + V.generate (V.length xs) $ \i -> + let x = xs V.! i + y = ys V.! i + name' = name ++ y + in resultSource' name' (VectorItemId y) x + items' = V.map resultSourceSummary items + +#endif + +instance (Ix i, Show i, ResultComputing t m) => ResultProvider (t m (A.Array i Double)) 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 + + resultSource' name i m = + ResultItemSource $ ResultItem $ mapResultValue A.elems $ computeResultValue name i m + +#ifndef __HASTE__ + +instance ResultComputing t m => ResultProvider (t m (V.Vector Double)) 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 + + resultSource' name i m = + ResultItemSource $ ResultItem $ mapResultValue V.toList $ computeResultValue name i m + +#endif + +instance (MonadComp m, + Show si, Show sm, Show so, + ResultItemable (ResultValue si), + ResultItemable (ResultValue sm), + ResultItemable (ResultValue so)) + => ResultProvider (Q.Queue m si sm so a) m where + + resultSource' name i m = + queueResultSource $ ResultContainer name i m (ResultSignal $ Q.queueChanged_ m) + +instance (MonadComp m, + Show sm, Show so, + ResultItemable (ResultValue sm), + ResultItemable (ResultValue so)) + => ResultProvider (IQ.Queue m sm so a) m where + + resultSource' name i m = + infiniteQueueResultSource $ ResultContainer name i m (ResultSignal $ IQ.queueChanged_ m) + +instance MonadComp m => ResultProvider (ArrivalTimer m) m where + + resultSource' name i m = + arrivalTimerResultSource $ ResultContainer name i m (ResultSignal $ arrivalProcessingTimeChanged_ m) + +instance (MonadComp m, Show s, ResultItemable (ResultValue s)) => ResultProvider (Server m s a b) m where + + resultSource' name i m = + serverResultSource $ ResultContainer name i m (ResultSignal $ serverChanged_ m) + +instance (MonadComp m, Show s, ResultItemable (ResultValue s)) => ResultProvider (Activity m s a b) m where + + resultSource' name i m = + activityResultSource $ ResultContainer name i m (ResultSignal $ activityChanged_ m) diff --git a/Simulation/Aivika/Trans/Results/IO.hs b/Simulation/Aivika/Trans/Results/IO.hs --- a/Simulation/Aivika/Trans/Results/IO.hs +++ b/Simulation/Aivika/Trans/Results/IO.hs @@ -1,485 +1,485 @@ - --- | --- Module : Simulation.Aivika.Trans.Results.IO --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module allows printing and converting the 'Simulation' 'Results' to a 'String'. --- -module Simulation.Aivika.Trans.Results.IO - (-- * Basic Types - ResultSourcePrint, - ResultSourceShowS, - -- * Printing the Results - printResultsWithTime, - printResultsInStartTime, - printResultsInStopTime, - printResultsInIntegTimes, - printResultsInTime, - printResultsInTimes, - -- * Simulating and Printing the Results - printSimulationResultsInStartTime, - printSimulationResultsInStopTime, - printSimulationResultsInIntegTimes, - printSimulationResultsInTime, - printSimulationResultsInTimes, - -- * Showing the Results - showResultsWithTime, - showResultsInStartTime, - showResultsInStopTime, - showResultsInIntegTimes, - showResultsInTime, - showResultsInTimes, - -- * Simulating and Showing the Results - showSimulationResultsInStartTime, - showSimulationResultsInStopTime, - showSimulationResultsInIntegTimes, - showSimulationResultsInTime, - showSimulationResultsInTimes, - -- * Printing the Result Source - hPrintResultSourceIndented, - hPrintResultSource, - hPrintResultSourceInRussian, - hPrintResultSourceInEnglish, - printResultSourceIndented, - printResultSource, - printResultSourceInRussian, - printResultSourceInEnglish, - -- * Showing the Result Source - showResultSourceIndented, - showResultSource, - showResultSourceInRussian, - showResultSourceInEnglish) where - -import Control.Monad -import Control.Monad.Trans - -import qualified Data.Map as M -import qualified Data.Array as A - -import System.IO - -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Specs -import Simulation.Aivika.Trans.Simulation -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Event -import Simulation.Aivika.Trans.Results -import Simulation.Aivika.Trans.Results.Locale - --- | This is a function that shows the simulation results within --- the 'Event' computation synchronized with the event queue. -type ResultSourceShowS m = ResultSource m -> Event m ShowS - --- | This is a function that prints the simulation results within --- the 'Event' computation synchronized with the event queue. -type ResultSourcePrint m = ResultSource m -> Event m () - --- | Print a localised text representation of the results by the specified source --- and with the given indent. -hPrintResultSourceIndented :: (MonadComp m, MonadIO m) - => Handle - -- ^ a handle - -> Int - -- ^ an indent - -> ResultLocalisation - -- ^ a localisation - -> ResultSourcePrint m -hPrintResultSourceIndented h indent loc source@(ResultItemSource (ResultItem x)) = - hPrintResultSourceIndentedLabelled h indent (resultItemName x) loc source -hPrintResultSourceIndented h indent loc source@(ResultVectorSource x) = - hPrintResultSourceIndentedLabelled h indent (resultVectorName x) loc source -hPrintResultSourceIndented h indent loc source@(ResultObjectSource x) = - hPrintResultSourceIndentedLabelled h indent (resultObjectName x) loc source -hPrintResultSourceIndented h indent loc source@(ResultSeparatorSource x) = - hPrintResultSourceIndentedLabelled h indent (resultSeparatorText x) loc source - --- | Print an indented and labelled text representation of the results by --- the specified source. -hPrintResultSourceIndentedLabelled :: (MonadComp m, MonadIO m) - => Handle - -- ^ a handle - -> Int - -- ^ an indent - -> ResultName - -- ^ a label - -> ResultLocalisation - -- ^ a localisation - -> ResultSourcePrint m -hPrintResultSourceIndentedLabelled h indent label loc (ResultItemSource (ResultItem x)) = - case resultValueData (resultItemToStringValue x) of - Just m -> - do a <- m - let tab = replicate indent ' ' - liftIO $ - do hPutStr h tab - hPutStr h "-- " - hPutStr h (loc $ resultItemId x) - hPutStrLn h "" - hPutStr h tab - hPutStr h label - hPutStr h " = " - hPutStrLn h a - hPutStrLn h "" - _ -> - error $ - "Expected to see a string value for variable " ++ - (resultItemName x) ++ ": hPrintResultSourceIndentedLabelled" -hPrintResultSourceIndentedLabelled h indent label loc (ResultVectorSource x) = - do let tab = replicate indent ' ' - liftIO $ - do hPutStr h tab - hPutStr h "-- " - hPutStr h (loc $ resultVectorId x) - hPutStrLn h "" - hPutStr h tab - hPutStr h label - hPutStrLn h ":" - hPutStrLn h "" - let items = A.elems (resultVectorItems x) - subscript = A.elems (resultVectorSubscript x) - forM_ (zip items subscript) $ \(i, s) -> - hPrintResultSourceIndentedLabelled h (indent + 2) (label ++ s) loc i -hPrintResultSourceIndentedLabelled h indent label loc (ResultObjectSource x) = - do let tab = replicate indent ' ' - liftIO $ - do hPutStr h tab - hPutStr h "-- " - hPutStr h (loc $ resultObjectId x) - hPutStrLn h "" - hPutStr h tab - hPutStr h label - hPutStrLn h ":" - hPutStrLn h "" - forM_ (resultObjectProperties x) $ \p -> - do let indent' = 2 + indent - tab' = " " ++ tab - label' = resultPropertyLabel p - source' = resultPropertySource p - hPrintResultSourceIndentedLabelled h indent' label' loc source' -hPrintResultSourceIndentedLabelled h indent label loc (ResultSeparatorSource x) = - do let tab = replicate indent ' ' - liftIO $ - do hPutStr h tab - hPutStr h label - hPutStrLn h "" - hPutStrLn h "" - --- | Print a localised text representation of the results by the specified source --- and with the given indent. -printResultSourceIndented :: (MonadComp m, MonadIO m) - => Int - -- ^ an indent - -> ResultLocalisation - -- ^ a localisation - -> ResultSourcePrint m -printResultSourceIndented = hPrintResultSourceIndented stdout - --- | Print a localised text representation of the results by the specified source. -hPrintResultSource :: (MonadComp m, MonadIO m) - => Handle - -- ^ a handle - -> ResultLocalisation - -- ^ a localisation - -> ResultSourcePrint m -hPrintResultSource h = hPrintResultSourceIndented h 0 - --- | Print a localised text representation of the results by the specified source. -printResultSource :: (MonadComp m, MonadIO m) - => ResultLocalisation - -- ^ a localisation - -> ResultSourcePrint m -printResultSource = hPrintResultSource stdout - --- | Print in Russian a text representation of the results by the specified source. -hPrintResultSourceInRussian :: (MonadComp m, MonadIO m) => Handle -> ResultSourcePrint m -hPrintResultSourceInRussian h = hPrintResultSource h russianResultLocalisation - --- | Print in English a text representation of the results by the specified source. -hPrintResultSourceInEnglish :: (MonadComp m, MonadIO m) => Handle -> ResultSourcePrint m -hPrintResultSourceInEnglish h = hPrintResultSource h englishResultLocalisation - --- | Print in Russian a text representation of the results by the specified source. -printResultSourceInRussian :: (MonadComp m, MonadIO m) => ResultSourcePrint m -printResultSourceInRussian = hPrintResultSourceInRussian stdout - --- | Print in English a text representation of the results by the specified source. -printResultSourceInEnglish :: (MonadComp m, MonadIO m) => ResultSourcePrint m -printResultSourceInEnglish = hPrintResultSourceInEnglish stdout - --- | Show a localised text representation of the results by the specified source --- and with the given indent. -showResultSourceIndented :: MonadComp m - => Int - -- ^ an indent - -> ResultLocalisation - -- ^ a localisation - -> ResultSourceShowS m -showResultSourceIndented indent loc source@(ResultItemSource (ResultItem x)) = - showResultSourceIndentedLabelled indent (resultItemName x) loc source -showResultSourceIndented indent loc source@(ResultVectorSource x) = - showResultSourceIndentedLabelled indent (resultVectorName x) loc source -showResultSourceIndented indent loc source@(ResultObjectSource x) = - showResultSourceIndentedLabelled indent (resultObjectName x) loc source -showResultSourceIndented indent loc source@(ResultSeparatorSource x) = - showResultSourceIndentedLabelled indent (resultSeparatorText x) loc source - --- | Show an indented and labelled text representation of the results by the specified source. -showResultSourceIndentedLabelled :: MonadComp m - => Int - -- ^ an indent - -> String - -- ^ a label - -> ResultLocalisation - -- ^ a localisation - -> ResultSourceShowS m -showResultSourceIndentedLabelled indent label loc (ResultItemSource (ResultItem x)) = - case resultValueData (resultItemToStringValue x) of - Just m -> - do a <- m - let tab = replicate indent ' ' - return $ - showString tab . - showString "-- " . - showString (loc $ resultItemId x) . - showString "\n" . - showString tab . - showString label . - showString " = " . - showString a . - showString "\n\n" - _ -> - error $ - "Expected to see a string value for variable " ++ - (resultItemName x) ++ ": showResultSourceIndentedLabelled" -showResultSourceIndentedLabelled indent label loc (ResultVectorSource x) = - do let tab = replicate indent ' ' - items = A.elems (resultVectorItems x) - subscript = A.elems (resultVectorSubscript x) - contents <- - forM (zip items subscript) $ \(i, s) -> - showResultSourceIndentedLabelled (indent + 2) (label ++ s) loc i - let showContents = foldr (.) id contents - return $ - showString tab . - showString "-- " . - showString (loc $ resultVectorId x) . - showString "\n" . - showString tab . - showString label . - showString ":\n\n" . - showContents -showResultSourceIndentedLabelled indent label loc (ResultObjectSource x) = - do let tab = replicate indent ' ' - contents <- - forM (resultObjectProperties x) $ \p -> - do let indent' = 2 + indent - tab' = " " ++ tab - label' = resultPropertyLabel p - output' = resultPropertySource p - showResultSourceIndentedLabelled indent' label' loc output' - let showContents = foldr (.) id contents - return $ - showString tab . - showString "-- " . - showString (loc $ resultObjectId x) . - showString "\n" . - showString tab . - showString label . - showString ":\n\n" . - showContents -showResultSourceIndentedLabelled indent label loc (ResultSeparatorSource x) = - do let tab = replicate indent ' ' - return $ - showString tab . - showString label . - showString "\n\n" - --- | Show a localised text representation of the results by the specified source. -showResultSource :: MonadComp m - => ResultLocalisation - -- ^ a localisation - -> ResultSourceShowS m -showResultSource = showResultSourceIndented 0 - --- | Show in Russian a text representation of the results by the specified source. -showResultSourceInRussian :: MonadComp m => ResultSourceShowS m -showResultSourceInRussian = showResultSource russianResultLocalisation - --- | Show in English a text representation of the results by the specified source. -showResultSourceInEnglish :: MonadComp m => ResultSourceShowS m -showResultSourceInEnglish = showResultSource englishResultLocalisation - --- | Print the results with the information about the modeling time. -printResultsWithTime :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Results m -> Event m () -printResultsWithTime print results = - do let x1 = textResultSource "----------" - x2 = timeResultSource - x3 = textResultSource "" - xs = resultSourceList results - print x1 - print x2 - -- print x3 - mapM_ print xs - -- print x3 - --- | Print the simulation results in start time. -printResultsInStartTime :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Results m -> Simulation m () -printResultsInStartTime print results = - runEventInStartTime $ printResultsWithTime print results - --- | Print the simulation results in stop time. -printResultsInStopTime :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Results m -> Simulation m () -printResultsInStopTime print results = - runEventInStopTime $ printResultsWithTime print results - --- | Print the simulation results in the integration time points. -printResultsInIntegTimes :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Results m -> Simulation m () -printResultsInIntegTimes print results = - do let loop (m : ms) = m >> loop ms - loop [] = return () - ms <- runDynamicsInIntegTimes $ runEvent $ - printResultsWithTime print results - liftComp $ loop ms - --- | Print the simulation results in the specified time. -printResultsInTime :: (MonadComp m, MonadIO m) => Double -> ResultSourcePrint m -> Results m -> Simulation m () -printResultsInTime t print results = - runDynamicsInTime t $ runEvent $ - printResultsWithTime print results - --- | Print the simulation results in the specified time points. -printResultsInTimes :: (MonadComp m, MonadIO m) => [Double] -> ResultSourcePrint m -> Results m -> Simulation m () -printResultsInTimes ts print results = - do let loop (m : ms) = m >> loop ms - loop [] = return () - ms <- runDynamicsInTimes ts $ runEvent $ - printResultsWithTime print results - liftComp $ loop ms - --- | Show the results with the information about the modeling time. -showResultsWithTime :: MonadComp m => ResultSourceShowS m -> Results m -> Event m ShowS -showResultsWithTime f results = - do let x1 = textResultSource "----------" - x2 = timeResultSource - x3 = textResultSource "" - xs = resultSourceList results - y1 <- f x1 - y2 <- f x2 - y3 <- f x3 - ys <- forM xs f - return $ - y1 . - y2 . - -- y3 . - foldr (.) id ys - -- y3 - --- | Show the simulation results in start time. -showResultsInStartTime :: MonadComp m => ResultSourceShowS m -> Results m -> Simulation m ShowS -showResultsInStartTime f results = - runEventInStartTime $ showResultsWithTime f results - --- | Show the simulation results in stop time. -showResultsInStopTime :: MonadComp m => ResultSourceShowS m -> Results m -> Simulation m ShowS -showResultsInStopTime f results = - runEventInStopTime $ showResultsWithTime f results - --- | Show the simulation results in the integration time points. --- --- It may consume much memory, for we have to traverse all the integration --- points to create the resulting function within the 'Simulation' computation. -showResultsInIntegTimes :: MonadComp m => ResultSourceShowS m -> Results m -> Simulation m ShowS -showResultsInIntegTimes f results = - do let loop (m : ms) = return (.) `ap` m `ap` loop ms - loop [] = return id - ms <- runDynamicsInIntegTimes $ runEvent $ - showResultsWithTime f results - liftComp $ loop ms - --- | Show the simulation results in the specified time point. -showResultsInTime :: MonadComp m => Double -> ResultSourceShowS m -> Results m -> Simulation m ShowS -showResultsInTime t f results = - runDynamicsInTime t $ runEvent $ - showResultsWithTime f results - --- | Show the simulation results in the specified time points. --- --- It may consume much memory, for we have to traverse all the specified --- points to create the resulting function within the 'Simulation' computation. -showResultsInTimes :: MonadComp m => [Double] -> ResultSourceShowS m -> Results m -> Simulation m ShowS -showResultsInTimes ts f results = - do let loop (m : ms) = return (.) `ap` m `ap` loop ms - loop [] = return id - ms <- runDynamicsInTimes ts $ runEvent $ - showResultsWithTime f results - liftComp $ loop ms - --- | Run the simulation and then print the results in the start time. -printSimulationResultsInStartTime :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m () -printSimulationResultsInStartTime print model specs = - flip runSimulation specs $ - model >>= printResultsInStartTime print - --- | Run the simulation and then print the results in the final time. -printSimulationResultsInStopTime :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m () -printSimulationResultsInStopTime print model specs = - flip runSimulation specs $ - model >>= printResultsInStopTime print - --- | Run the simulation and then print the results in the integration time points. -printSimulationResultsInIntegTimes :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m () -printSimulationResultsInIntegTimes print model specs = - flip runSimulation specs $ - model >>= printResultsInIntegTimes print - --- | Run the simulation and then print the results in the specified time point. -printSimulationResultsInTime :: (MonadComp m, MonadIO m) => Double -> ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m () -printSimulationResultsInTime t print model specs = - flip runSimulation specs $ - model >>= printResultsInTime t print - --- | Run the simulation and then print the results in the specified time points. -printSimulationResultsInTimes :: (MonadComp m, MonadIO m) => [Double] -> ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m () -printSimulationResultsInTimes ts print model specs = - flip runSimulation specs $ - model >>= printResultsInTimes ts print - --- | Run the simulation and then show the results in the start time. -showSimulationResultsInStartTime :: MonadComp m => ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS -showSimulationResultsInStartTime f model specs = - flip runSimulation specs $ - model >>= showResultsInStartTime f - --- | Run the simulation and then show the results in the final time. -showSimulationResultsInStopTime :: MonadComp m => ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS -showSimulationResultsInStopTime f model specs = - flip runSimulation specs $ - model >>= showResultsInStopTime f - --- | Run the simulation and then show the results in the integration time points. --- --- It may consume much memory, for we have to traverse all the integration --- points to create the resulting function within the 'IO' computation. -showSimulationResultsInIntegTimes :: MonadComp m => ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS -showSimulationResultsInIntegTimes f model specs = - flip runSimulation specs $ - model >>= showResultsInIntegTimes f - --- | Run the simulation and then show the results in the integration time point. -showSimulationResultsInTime :: MonadComp m => Double -> ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS -showSimulationResultsInTime t f model specs = - flip runSimulation specs $ - model >>= showResultsInTime t f - --- | Run the simulation and then show the results in the specified time points. --- --- It may consume much memory, for we have to traverse all the specified --- points to create the resulting function within the 'IO' computation. -showSimulationResultsInTimes :: MonadComp m => [Double] -> ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS -showSimulationResultsInTimes ts f model specs = - flip runSimulation specs $ - model >>= showResultsInTimes ts f + +-- | +-- Module : Simulation.Aivika.Trans.Results.IO +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module allows printing and converting the 'Simulation' 'Results' to a 'String'. +-- +module Simulation.Aivika.Trans.Results.IO + (-- * Basic Types + ResultSourcePrint, + ResultSourceShowS, + -- * Printing the Results + printResultsWithTime, + printResultsInStartTime, + printResultsInStopTime, + printResultsInIntegTimes, + printResultsInTime, + printResultsInTimes, + -- * Simulating and Printing the Results + printSimulationResultsInStartTime, + printSimulationResultsInStopTime, + printSimulationResultsInIntegTimes, + printSimulationResultsInTime, + printSimulationResultsInTimes, + -- * Showing the Results + showResultsWithTime, + showResultsInStartTime, + showResultsInStopTime, + showResultsInIntegTimes, + showResultsInTime, + showResultsInTimes, + -- * Simulating and Showing the Results + showSimulationResultsInStartTime, + showSimulationResultsInStopTime, + showSimulationResultsInIntegTimes, + showSimulationResultsInTime, + showSimulationResultsInTimes, + -- * Printing the Result Source + hPrintResultSourceIndented, + hPrintResultSource, + hPrintResultSourceInRussian, + hPrintResultSourceInEnglish, + printResultSourceIndented, + printResultSource, + printResultSourceInRussian, + printResultSourceInEnglish, + -- * Showing the Result Source + showResultSourceIndented, + showResultSource, + showResultSourceInRussian, + showResultSourceInEnglish) where + +import Control.Monad +import Control.Monad.Trans + +import qualified Data.Map as M +import qualified Data.Array as A + +import System.IO + +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Specs +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Event +import Simulation.Aivika.Trans.Results +import Simulation.Aivika.Trans.Results.Locale + +-- | This is a function that shows the simulation results within +-- the 'Event' computation synchronized with the event queue. +type ResultSourceShowS m = ResultSource m -> Event m ShowS + +-- | This is a function that prints the simulation results within +-- the 'Event' computation synchronized with the event queue. +type ResultSourcePrint m = ResultSource m -> Event m () + +-- | Print a localised text representation of the results by the specified source +-- and with the given indent. +hPrintResultSourceIndented :: (MonadComp m, MonadIO m) + => Handle + -- ^ a handle + -> Int + -- ^ an indent + -> ResultLocalisation + -- ^ a localisation + -> ResultSourcePrint m +hPrintResultSourceIndented h indent loc source@(ResultItemSource (ResultItem x)) = + hPrintResultSourceIndentedLabelled h indent (resultItemName x) loc source +hPrintResultSourceIndented h indent loc source@(ResultVectorSource x) = + hPrintResultSourceIndentedLabelled h indent (resultVectorName x) loc source +hPrintResultSourceIndented h indent loc source@(ResultObjectSource x) = + hPrintResultSourceIndentedLabelled h indent (resultObjectName x) loc source +hPrintResultSourceIndented h indent loc source@(ResultSeparatorSource x) = + hPrintResultSourceIndentedLabelled h indent (resultSeparatorText x) loc source + +-- | Print an indented and labelled text representation of the results by +-- the specified source. +hPrintResultSourceIndentedLabelled :: (MonadComp m, MonadIO m) + => Handle + -- ^ a handle + -> Int + -- ^ an indent + -> ResultName + -- ^ a label + -> ResultLocalisation + -- ^ a localisation + -> ResultSourcePrint m +hPrintResultSourceIndentedLabelled h indent label loc (ResultItemSource (ResultItem x)) = + case resultValueData (resultItemToStringValue x) of + Just m -> + do a <- m + let tab = replicate indent ' ' + liftIO $ + do hPutStr h tab + hPutStr h "-- " + hPutStr h (loc $ resultItemId x) + hPutStrLn h "" + hPutStr h tab + hPutStr h label + hPutStr h " = " + hPutStrLn h a + hPutStrLn h "" + _ -> + error $ + "Expected to see a string value for variable " ++ + (resultItemName x) ++ ": hPrintResultSourceIndentedLabelled" +hPrintResultSourceIndentedLabelled h indent label loc (ResultVectorSource x) = + do let tab = replicate indent ' ' + liftIO $ + do hPutStr h tab + hPutStr h "-- " + hPutStr h (loc $ resultVectorId x) + hPutStrLn h "" + hPutStr h tab + hPutStr h label + hPutStrLn h ":" + hPutStrLn h "" + let items = A.elems (resultVectorItems x) + subscript = A.elems (resultVectorSubscript x) + forM_ (zip items subscript) $ \(i, s) -> + hPrintResultSourceIndentedLabelled h (indent + 2) (label ++ s) loc i +hPrintResultSourceIndentedLabelled h indent label loc (ResultObjectSource x) = + do let tab = replicate indent ' ' + liftIO $ + do hPutStr h tab + hPutStr h "-- " + hPutStr h (loc $ resultObjectId x) + hPutStrLn h "" + hPutStr h tab + hPutStr h label + hPutStrLn h ":" + hPutStrLn h "" + forM_ (resultObjectProperties x) $ \p -> + do let indent' = 2 + indent + tab' = " " ++ tab + label' = resultPropertyLabel p + source' = resultPropertySource p + hPrintResultSourceIndentedLabelled h indent' label' loc source' +hPrintResultSourceIndentedLabelled h indent label loc (ResultSeparatorSource x) = + do let tab = replicate indent ' ' + liftIO $ + do hPutStr h tab + hPutStr h label + hPutStrLn h "" + hPutStrLn h "" + +-- | Print a localised text representation of the results by the specified source +-- and with the given indent. +printResultSourceIndented :: (MonadComp m, MonadIO m) + => Int + -- ^ an indent + -> ResultLocalisation + -- ^ a localisation + -> ResultSourcePrint m +printResultSourceIndented = hPrintResultSourceIndented stdout + +-- | Print a localised text representation of the results by the specified source. +hPrintResultSource :: (MonadComp m, MonadIO m) + => Handle + -- ^ a handle + -> ResultLocalisation + -- ^ a localisation + -> ResultSourcePrint m +hPrintResultSource h = hPrintResultSourceIndented h 0 + +-- | Print a localised text representation of the results by the specified source. +printResultSource :: (MonadComp m, MonadIO m) + => ResultLocalisation + -- ^ a localisation + -> ResultSourcePrint m +printResultSource = hPrintResultSource stdout + +-- | Print in Russian a text representation of the results by the specified source. +hPrintResultSourceInRussian :: (MonadComp m, MonadIO m) => Handle -> ResultSourcePrint m +hPrintResultSourceInRussian h = hPrintResultSource h russianResultLocalisation + +-- | Print in English a text representation of the results by the specified source. +hPrintResultSourceInEnglish :: (MonadComp m, MonadIO m) => Handle -> ResultSourcePrint m +hPrintResultSourceInEnglish h = hPrintResultSource h englishResultLocalisation + +-- | Print in Russian a text representation of the results by the specified source. +printResultSourceInRussian :: (MonadComp m, MonadIO m) => ResultSourcePrint m +printResultSourceInRussian = hPrintResultSourceInRussian stdout + +-- | Print in English a text representation of the results by the specified source. +printResultSourceInEnglish :: (MonadComp m, MonadIO m) => ResultSourcePrint m +printResultSourceInEnglish = hPrintResultSourceInEnglish stdout + +-- | Show a localised text representation of the results by the specified source +-- and with the given indent. +showResultSourceIndented :: MonadComp m + => Int + -- ^ an indent + -> ResultLocalisation + -- ^ a localisation + -> ResultSourceShowS m +showResultSourceIndented indent loc source@(ResultItemSource (ResultItem x)) = + showResultSourceIndentedLabelled indent (resultItemName x) loc source +showResultSourceIndented indent loc source@(ResultVectorSource x) = + showResultSourceIndentedLabelled indent (resultVectorName x) loc source +showResultSourceIndented indent loc source@(ResultObjectSource x) = + showResultSourceIndentedLabelled indent (resultObjectName x) loc source +showResultSourceIndented indent loc source@(ResultSeparatorSource x) = + showResultSourceIndentedLabelled indent (resultSeparatorText x) loc source + +-- | Show an indented and labelled text representation of the results by the specified source. +showResultSourceIndentedLabelled :: MonadComp m + => Int + -- ^ an indent + -> String + -- ^ a label + -> ResultLocalisation + -- ^ a localisation + -> ResultSourceShowS m +showResultSourceIndentedLabelled indent label loc (ResultItemSource (ResultItem x)) = + case resultValueData (resultItemToStringValue x) of + Just m -> + do a <- m + let tab = replicate indent ' ' + return $ + showString tab . + showString "-- " . + showString (loc $ resultItemId x) . + showString "\n" . + showString tab . + showString label . + showString " = " . + showString a . + showString "\n\n" + _ -> + error $ + "Expected to see a string value for variable " ++ + (resultItemName x) ++ ": showResultSourceIndentedLabelled" +showResultSourceIndentedLabelled indent label loc (ResultVectorSource x) = + do let tab = replicate indent ' ' + items = A.elems (resultVectorItems x) + subscript = A.elems (resultVectorSubscript x) + contents <- + forM (zip items subscript) $ \(i, s) -> + showResultSourceIndentedLabelled (indent + 2) (label ++ s) loc i + let showContents = foldr (.) id contents + return $ + showString tab . + showString "-- " . + showString (loc $ resultVectorId x) . + showString "\n" . + showString tab . + showString label . + showString ":\n\n" . + showContents +showResultSourceIndentedLabelled indent label loc (ResultObjectSource x) = + do let tab = replicate indent ' ' + contents <- + forM (resultObjectProperties x) $ \p -> + do let indent' = 2 + indent + tab' = " " ++ tab + label' = resultPropertyLabel p + output' = resultPropertySource p + showResultSourceIndentedLabelled indent' label' loc output' + let showContents = foldr (.) id contents + return $ + showString tab . + showString "-- " . + showString (loc $ resultObjectId x) . + showString "\n" . + showString tab . + showString label . + showString ":\n\n" . + showContents +showResultSourceIndentedLabelled indent label loc (ResultSeparatorSource x) = + do let tab = replicate indent ' ' + return $ + showString tab . + showString label . + showString "\n\n" + +-- | Show a localised text representation of the results by the specified source. +showResultSource :: MonadComp m + => ResultLocalisation + -- ^ a localisation + -> ResultSourceShowS m +showResultSource = showResultSourceIndented 0 + +-- | Show in Russian a text representation of the results by the specified source. +showResultSourceInRussian :: MonadComp m => ResultSourceShowS m +showResultSourceInRussian = showResultSource russianResultLocalisation + +-- | Show in English a text representation of the results by the specified source. +showResultSourceInEnglish :: MonadComp m => ResultSourceShowS m +showResultSourceInEnglish = showResultSource englishResultLocalisation + +-- | Print the results with the information about the modeling time. +printResultsWithTime :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Results m -> Event m () +printResultsWithTime print results = + do let x1 = textResultSource "----------" + x2 = timeResultSource + x3 = textResultSource "" + xs = resultSourceList results + print x1 + print x2 + -- print x3 + mapM_ print xs + -- print x3 + +-- | Print the simulation results in start time. +printResultsInStartTime :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Results m -> Simulation m () +printResultsInStartTime print results = + runEventInStartTime $ printResultsWithTime print results + +-- | Print the simulation results in stop time. +printResultsInStopTime :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Results m -> Simulation m () +printResultsInStopTime print results = + runEventInStopTime $ printResultsWithTime print results + +-- | Print the simulation results in the integration time points. +printResultsInIntegTimes :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Results m -> Simulation m () +printResultsInIntegTimes print results = + do let loop (m : ms) = m >> loop ms + loop [] = return () + ms <- runDynamicsInIntegTimes $ runEvent $ + printResultsWithTime print results + liftComp $ loop ms + +-- | Print the simulation results in the specified time. +printResultsInTime :: (MonadComp m, MonadIO m) => Double -> ResultSourcePrint m -> Results m -> Simulation m () +printResultsInTime t print results = + runDynamicsInTime t $ runEvent $ + printResultsWithTime print results + +-- | Print the simulation results in the specified time points. +printResultsInTimes :: (MonadComp m, MonadIO m) => [Double] -> ResultSourcePrint m -> Results m -> Simulation m () +printResultsInTimes ts print results = + do let loop (m : ms) = m >> loop ms + loop [] = return () + ms <- runDynamicsInTimes ts $ runEvent $ + printResultsWithTime print results + liftComp $ loop ms + +-- | Show the results with the information about the modeling time. +showResultsWithTime :: MonadComp m => ResultSourceShowS m -> Results m -> Event m ShowS +showResultsWithTime f results = + do let x1 = textResultSource "----------" + x2 = timeResultSource + x3 = textResultSource "" + xs = resultSourceList results + y1 <- f x1 + y2 <- f x2 + y3 <- f x3 + ys <- forM xs f + return $ + y1 . + y2 . + -- y3 . + foldr (.) id ys + -- y3 + +-- | Show the simulation results in start time. +showResultsInStartTime :: MonadComp m => ResultSourceShowS m -> Results m -> Simulation m ShowS +showResultsInStartTime f results = + runEventInStartTime $ showResultsWithTime f results + +-- | Show the simulation results in stop time. +showResultsInStopTime :: MonadComp m => ResultSourceShowS m -> Results m -> Simulation m ShowS +showResultsInStopTime f results = + runEventInStopTime $ showResultsWithTime f results + +-- | Show the simulation results in the integration time points. +-- +-- It may consume much memory, for we have to traverse all the integration +-- points to create the resulting function within the 'Simulation' computation. +showResultsInIntegTimes :: MonadComp m => ResultSourceShowS m -> Results m -> Simulation m ShowS +showResultsInIntegTimes f results = + do let loop (m : ms) = return (.) `ap` m `ap` loop ms + loop [] = return id + ms <- runDynamicsInIntegTimes $ runEvent $ + showResultsWithTime f results + liftComp $ loop ms + +-- | Show the simulation results in the specified time point. +showResultsInTime :: MonadComp m => Double -> ResultSourceShowS m -> Results m -> Simulation m ShowS +showResultsInTime t f results = + runDynamicsInTime t $ runEvent $ + showResultsWithTime f results + +-- | Show the simulation results in the specified time points. +-- +-- It may consume much memory, for we have to traverse all the specified +-- points to create the resulting function within the 'Simulation' computation. +showResultsInTimes :: MonadComp m => [Double] -> ResultSourceShowS m -> Results m -> Simulation m ShowS +showResultsInTimes ts f results = + do let loop (m : ms) = return (.) `ap` m `ap` loop ms + loop [] = return id + ms <- runDynamicsInTimes ts $ runEvent $ + showResultsWithTime f results + liftComp $ loop ms + +-- | Run the simulation and then print the results in the start time. +printSimulationResultsInStartTime :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m () +printSimulationResultsInStartTime print model specs = + flip runSimulation specs $ + model >>= printResultsInStartTime print + +-- | Run the simulation and then print the results in the final time. +printSimulationResultsInStopTime :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m () +printSimulationResultsInStopTime print model specs = + flip runSimulation specs $ + model >>= printResultsInStopTime print + +-- | Run the simulation and then print the results in the integration time points. +printSimulationResultsInIntegTimes :: (MonadComp m, MonadIO m) => ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m () +printSimulationResultsInIntegTimes print model specs = + flip runSimulation specs $ + model >>= printResultsInIntegTimes print + +-- | Run the simulation and then print the results in the specified time point. +printSimulationResultsInTime :: (MonadComp m, MonadIO m) => Double -> ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m () +printSimulationResultsInTime t print model specs = + flip runSimulation specs $ + model >>= printResultsInTime t print + +-- | Run the simulation and then print the results in the specified time points. +printSimulationResultsInTimes :: (MonadComp m, MonadIO m) => [Double] -> ResultSourcePrint m -> Simulation m (Results m) -> Specs m -> m () +printSimulationResultsInTimes ts print model specs = + flip runSimulation specs $ + model >>= printResultsInTimes ts print + +-- | Run the simulation and then show the results in the start time. +showSimulationResultsInStartTime :: MonadComp m => ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS +showSimulationResultsInStartTime f model specs = + flip runSimulation specs $ + model >>= showResultsInStartTime f + +-- | Run the simulation and then show the results in the final time. +showSimulationResultsInStopTime :: MonadComp m => ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS +showSimulationResultsInStopTime f model specs = + flip runSimulation specs $ + model >>= showResultsInStopTime f + +-- | Run the simulation and then show the results in the integration time points. +-- +-- It may consume much memory, for we have to traverse all the integration +-- points to create the resulting function within the 'IO' computation. +showSimulationResultsInIntegTimes :: MonadComp m => ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS +showSimulationResultsInIntegTimes f model specs = + flip runSimulation specs $ + model >>= showResultsInIntegTimes f + +-- | Run the simulation and then show the results in the integration time point. +showSimulationResultsInTime :: MonadComp m => Double -> ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS +showSimulationResultsInTime t f model specs = + flip runSimulation specs $ + model >>= showResultsInTime t f + +-- | Run the simulation and then show the results in the specified time points. +-- +-- It may consume much memory, for we have to traverse all the specified +-- points to create the resulting function within the 'IO' computation. +showSimulationResultsInTimes :: MonadComp m => [Double] -> ResultSourceShowS m -> Simulation m (Results m) -> Specs m -> m ShowS +showSimulationResultsInTimes ts f model specs = + flip runSimulation specs $ + model >>= showResultsInTimes ts f diff --git a/Simulation/Aivika/Trans/Results/Locale.hs b/Simulation/Aivika/Trans/Results/Locale.hs --- a/Simulation/Aivika/Trans/Results/Locale.hs +++ b/Simulation/Aivika/Trans/Results/Locale.hs @@ -1,340 +1,377 @@ - --- | --- Module : Simulation.Aivika.Trans.Results.Locale --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines locales for outputting and printing the simulation results. --- -module Simulation.Aivika.Trans.Results.Locale - (-- * Basic Types - ResultLocale, - ResultLocalisation, - ResultDescription, - -- * Locale Codes - russianResultLocale, - englishResultLocale, - -- * Localisations - lookupResultLocalisation, - russianResultLocalisation, - englishResultLocalisation, - -- * Unique Identifiers - ResultId(..)) where - -import qualified Data.Map as M - -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Statistics -import Simulation.Aivika.Trans.Statistics.Accumulator -import qualified Simulation.Aivika.Trans.Queue as Q -import qualified Simulation.Aivika.Trans.Queue.Infinite as IQ -import Simulation.Aivika.Trans.Arrival -import Simulation.Aivika.Trans.Server - --- | A locale to output the simulation results. --- --- Examples are: @\"ru\", @\"en\" etc. -type ResultLocale = String - --- | It localises the description of simulation results. -type ResultLocalisation = ResultId -> ResultDescription - --- | A description used for describing the results when generating output. -type ResultDescription = String - --- | The result entity identifier. -data ResultId = TimeId - -- ^ A 'time' computation. - | VectorId - -- ^ Describes a vector. - | VectorItemId String - -- ^ Describes a vector item with the specified subscript. - | SamplingStatsId - -- ^ A 'SamplingStats' value. - | SamplingStatsCountId - -- ^ Property 'samplingStatsCount'. - | SamplingStatsMinId - -- ^ Property 'samplingStatsMin'. - | SamplingStatsMaxId - -- ^ Property 'samplingStatsMax'. - | SamplingStatsMeanId - -- ^ Property 'samplingStatsMean'. - | SamplingStatsMean2Id - -- ^ Property 'samplingStatsMean2'. - | SamplingStatsVarianceId - -- ^ Property 'samplingStatsVariance'. - | SamplingStatsDeviationId - -- ^ Property 'samplingStatsDeviation'. - | TimingStatsId - -- ^ A 'TimingStats' value. - | TimingStatsCountId - -- ^ Property 'timingStatsCount'. - | TimingStatsMinId - -- ^ Property 'timingStatsMin'. - | TimingStatsMaxId - -- ^ Property 'timingStatsMax'. - | TimingStatsMeanId - -- ^ Property 'timingStatsMean'. - | TimingStatsVarianceId - -- ^ Property 'timingStatsVariance'. - | TimingStatsDeviationId - -- ^ Property 'timingStatsDeviation'. - | TimingStatsMinTimeId - -- ^ Property 'timingStatsMinTime'. - | TimingStatsMaxTimeId - -- ^ Property 'timingStatsMaxTime'. - | TimingStatsStartTimeId - -- ^ Property 'timingStatsStartTime'. - | TimingStatsLastTimeId - -- ^ Property 'timingStatsLastTime'. - | TimingStatsSumId - -- ^ Property 'timingStatsSum'. - | TimingStatsSum2Id - -- ^ Property 'timingStatsSum2'. - | FiniteQueueId - -- ^ A finite 'Q.Queue'. - | InfiniteQueueId - -- ^ An infinite 'IQ.Queue'. - | EnqueueStrategyId - -- ^ Property 'Q.enqueueStrategy'. - | EnqueueStoringStrategyId - -- ^ Property 'Q.enqueueStoringStrategy'. - | DequeueStrategyId - -- ^ Property 'Q.dequeueStrategy'. - | QueueNullId - -- ^ Property 'Q.queueNull'. - | QueueFullId - -- ^ Property 'Q.queueFull'. - | QueueMaxCountId - -- ^ Property 'Q.queueMaxCount'. - | QueueCountId - -- ^ Property 'Q.queueCount'. - | QueueCountStatsId - -- ^ Property 'Q.queueCountStats'. - | EnqueueCountId - -- ^ Property 'Q.enqueueCount'. - | EnqueueLostCountId - -- ^ Property 'Q.enqueueLostCount'. - | EnqueueStoreCountId - -- ^ Property 'Q.enqueueStoreCount'. - | DequeueCountId - -- ^ Property 'Q.dequeueCount'. - | DequeueExtractCountId - -- ^ Property 'Q.dequeueExtractCount'. - | QueueLoadFactorId - -- ^ Property 'Q.queueLoadFactor'. - | EnqueueRateId - -- ^ Property 'Q.enqueueRate'. - | EnqueueStoreRateId - -- ^ Property 'Q.enqueueStoreRate'. - | DequeueRateId - -- ^ Property 'Q.dequeueRate'. - | DequeueExtractRateId - -- ^ Property 'Q.dequeueExtractRate'. - | QueueWaitTimeId - -- ^ Property 'Q.queueWaitTime'. - | QueueTotalWaitTimeId - -- ^ Property 'Q.queueTotalWaitTime'. - | EnqueueWaitTimeId - -- ^ Property 'Q.enqueueWaitTime'. - | DequeueWaitTimeId - -- ^ Property 'Q.dequeueWaitTime'. - | QueueRateId - -- ^ Property 'Q.queueRate'. - | ArrivalTimerId - -- ^ An 'ArrivalTimer'. - | ArrivalProcessingTimeId - -- ^ Property 'arrivalProcessingTime'. - | ServerId - -- ^ Represents a 'Server'. - | ServerInitStateId - -- ^ Property 'serverInitState'. - | ServerStateId - -- ^ Property 'serverState'. - | ServerTotalInputWaitTimeId - -- ^ Property 'serverTotalInputWaitTime'. - | ServerTotalProcessingTimeId - -- ^ Property 'serverTotalProcessingTime'. - | ServerTotalOutputWaitTimeId - -- ^ Property 'serverTotalOutputWaitTime'. - | ServerInputWaitTimeId - -- ^ Property 'serverInputWaitTime'. - | ServerProcessingTimeId - -- ^ Property 'serverProcessingTime'. - | ServerOutputWaitTimeId - -- ^ Property 'serverOutputWaitTime'. - | ServerInputWaitFactorId - -- ^ Property 'serverInputWaitFactor'. - | ServerProcessingFactorId - -- ^ Property 'serverProcessingFactor'. - | ServerOutputWaitFactorId - -- ^ Property 'serverOutputWaitFactor'. - | UserDefinedResultId ResultDescription - -- ^ An user defined description. - | LocalisedResultId (M.Map ResultLocale ResultDescription) - -- ^ A localised property or object name. - deriving (Eq, Ord, Show) - --- | The Russian locale. -russianResultLocale :: ResultLocale -russianResultLocale = "ru" - --- | The English locale. -englishResultLocale :: ResultLocale -englishResultLocale = "en" - --- | The Russian localisation of the simulation results. -russianResultLocalisation :: ResultLocalisation -russianResultLocalisation TimeId = "модельное время" -russianResultLocalisation VectorId = "вектор" -russianResultLocalisation (VectorItemId x) = "элемент с индексом " ++ x -russianResultLocalisation SamplingStatsId = "сводная статистика" -russianResultLocalisation SamplingStatsCountId = "количество" -russianResultLocalisation SamplingStatsMinId = "минимальное значение" -russianResultLocalisation SamplingStatsMaxId = "максимальное значение" -russianResultLocalisation SamplingStatsMeanId = "среднее значение" -russianResultLocalisation SamplingStatsMean2Id = "среднее квадратов" -russianResultLocalisation SamplingStatsVarianceId = "дисперсия" -russianResultLocalisation SamplingStatsDeviationId = "среднеквадратическое отклонение" -russianResultLocalisation TimingStatsId = "временная статистика" -russianResultLocalisation TimingStatsCountId = "количество" -russianResultLocalisation TimingStatsMinId = "минимальное значение" -russianResultLocalisation TimingStatsMaxId = "максимальное значение" -russianResultLocalisation TimingStatsMeanId = "среднее значение" -russianResultLocalisation TimingStatsVarianceId = "дисперсия" -russianResultLocalisation TimingStatsDeviationId = "среднеквадратическое отклонение" -russianResultLocalisation TimingStatsMinTimeId = "время достижения минимума" -russianResultLocalisation TimingStatsMaxTimeId = "время достижения максимума" -russianResultLocalisation TimingStatsStartTimeId = "начальное время сбора статистики" -russianResultLocalisation TimingStatsLastTimeId = "конечное время сбора статистики" -russianResultLocalisation TimingStatsSumId = "сумма" -russianResultLocalisation TimingStatsSum2Id = "сумма квадратов" -russianResultLocalisation FiniteQueueId = "конечная очередь" -russianResultLocalisation InfiniteQueueId = "бесконечная очередь" -russianResultLocalisation EnqueueStrategyId = "стратегия добавления элементов" -russianResultLocalisation EnqueueStoringStrategyId = "стратегия хранения элементов" -russianResultLocalisation DequeueStrategyId = "стратегия извлечения элементов" -russianResultLocalisation QueueNullId = "очередь пуста?" -russianResultLocalisation QueueFullId = "очередь заполнена?" -russianResultLocalisation QueueMaxCountId = "емкость очереди" -russianResultLocalisation QueueCountId = "текущий размер очереди" -russianResultLocalisation QueueCountStatsId = "статистика по размеру очереди" -russianResultLocalisation EnqueueCountId = "общее количество попыток добавить элементы" -russianResultLocalisation EnqueueLostCountId = "общее количество неудачных попыток добавить элементы" -russianResultLocalisation EnqueueStoreCountId = "общее количество сохраненных элементов" -russianResultLocalisation DequeueCountId = "общее количество запросов на извлечение элементов" -russianResultLocalisation DequeueExtractCountId = "общее количество извлеченных элементов" -russianResultLocalisation QueueLoadFactorId = "коэфф. загрузки (размер, поделенный на емкость)" -russianResultLocalisation EnqueueRateId = "количество попыток добавить на ед. времени" -russianResultLocalisation EnqueueStoreRateId = "количество сохраненных на ед. времени" -russianResultLocalisation DequeueRateId = "количество запросов на извлечение в ед. времени" -russianResultLocalisation DequeueExtractRateId = "количество извлеченных на ед. времени" -russianResultLocalisation QueueWaitTimeId = "время ожидания (сохранили -> извлекли)" -russianResultLocalisation QueueTotalWaitTimeId = "общее время ожидания (попытались добавить -> извлекли)" -russianResultLocalisation EnqueueWaitTimeId = "время ожидания добавления (попытались добавить -> сохранили)" -russianResultLocalisation DequeueWaitTimeId = "время ожидания извлечения (запросили извлечь -> извлекли)" -russianResultLocalisation QueueRateId = "усредненная скорость (как средняя длина очереди на среднее время ожидания)" -russianResultLocalisation ArrivalTimerId = "как долго обрабатываются заявки?" -russianResultLocalisation ArrivalProcessingTimeId = "время обработки заявки" -russianResultLocalisation ServerId = "сервер" -russianResultLocalisation ServerInitStateId = "начальное состояние" -russianResultLocalisation ServerStateId = "текущее состояние" -russianResultLocalisation ServerTotalInputWaitTimeId = "общее время блокировки в ожидании ввода" -russianResultLocalisation ServerTotalProcessingTimeId = "общее время, потраченное на саму обработку заданий" -russianResultLocalisation ServerTotalOutputWaitTimeId = "общее время блокировки при попытке доставить вывод" -russianResultLocalisation ServerInputWaitTimeId = "время блокировки в ожидании ввода" -russianResultLocalisation ServerProcessingTimeId = "время, потраченное на саму обработку заданий" -russianResultLocalisation ServerOutputWaitTimeId = "время блокировки при попытке доставить вывод" -russianResultLocalisation ServerInputWaitFactorId = "относительное время блокировки в ожидании ввода (от 0 до 1)" -russianResultLocalisation ServerProcessingFactorId = "относительное время, потраченное на саму обработку заданий (от 0 до 1)" -russianResultLocalisation ServerOutputWaitFactorId = "относительное время блокировки при попытке доставить вывод (от 0 до 1)" -russianResultLocalisation (UserDefinedResultId m) = m -russianResultLocalisation x@(LocalisedResultId m) = - lookupResultLocalisation russianResultLocale x - --- | The English localisation of the simulation results. -englishResultLocalisation :: ResultLocalisation -englishResultLocalisation TimeId = "simulation time" -englishResultLocalisation VectorId = "vector" -englishResultLocalisation (VectorItemId x) = "item #" ++ x -englishResultLocalisation SamplingStatsId = "statistics summary" -englishResultLocalisation SamplingStatsCountId = "count" -englishResultLocalisation SamplingStatsMinId = "minimum" -englishResultLocalisation SamplingStatsMaxId = "maximum" -englishResultLocalisation SamplingStatsMeanId = "mean" -englishResultLocalisation SamplingStatsMean2Id = "mean square" -englishResultLocalisation SamplingStatsVarianceId = "variance" -englishResultLocalisation SamplingStatsDeviationId = "deviation" -englishResultLocalisation TimingStatsId = "timing statistics" -englishResultLocalisation TimingStatsCountId = "count" -englishResultLocalisation TimingStatsMinId = "minimum" -englishResultLocalisation TimingStatsMaxId = "maximum" -englishResultLocalisation TimingStatsMeanId = "mean" -englishResultLocalisation TimingStatsVarianceId = "variance" -englishResultLocalisation TimingStatsDeviationId = "deviation" -englishResultLocalisation TimingStatsMinTimeId = "the time of minimum" -englishResultLocalisation TimingStatsMaxTimeId = "the time of maximum" -englishResultLocalisation TimingStatsStartTimeId = "the start time" -englishResultLocalisation TimingStatsLastTimeId = "the last time" -englishResultLocalisation TimingStatsSumId = "sum" -englishResultLocalisation TimingStatsSum2Id = "sum square" -englishResultLocalisation FiniteQueueId = "the finite queue" -englishResultLocalisation InfiniteQueueId = "the infinite queue" -englishResultLocalisation EnqueueStrategyId = "the enqueueing strategy" -englishResultLocalisation EnqueueStoringStrategyId = "the storing strategy" -englishResultLocalisation DequeueStrategyId = "the dequeueing strategy" -englishResultLocalisation QueueNullId = "is the queue empty?" -englishResultLocalisation QueueFullId = "is the queue full?" -englishResultLocalisation QueueMaxCountId = "the queue capacity" -englishResultLocalisation QueueCountId = "the current queue size" -englishResultLocalisation QueueCountStatsId = "the queue size statistics" -englishResultLocalisation EnqueueCountId = "a total number of attempts to enqueue the items" -englishResultLocalisation EnqueueLostCountId = "a total number of the lost items when trying to enqueue" -englishResultLocalisation EnqueueStoreCountId = "a total number of the stored items" -englishResultLocalisation DequeueCountId = "a total number of requests for dequeueing" -englishResultLocalisation DequeueExtractCountId = "a total number of the dequeued items" -englishResultLocalisation QueueLoadFactorId = "the queue load (its size divided by its capacity)" -englishResultLocalisation EnqueueRateId = "how many attempts to enqueue per time?" -englishResultLocalisation EnqueueStoreRateId = "how many items were stored per time?" -englishResultLocalisation DequeueRateId = "how many requests for dequeueing per time?" -englishResultLocalisation DequeueExtractRateId = "how many items were dequeued per time?" -englishResultLocalisation QueueWaitTimeId = "the wait time (stored -> dequeued)" -englishResultLocalisation QueueTotalWaitTimeId = "the total wait time (tried to enqueue -> dequeued)" -englishResultLocalisation EnqueueWaitTimeId = "the enqueue wait time (tried to enqueue -> stored)" -englishResultLocalisation DequeueWaitTimeId = "the dequeue wait time (requested for dequeueing -> dequeued)" -englishResultLocalisation QueueRateId = "the average queue rate (= queue size / wait time)" -englishResultLocalisation ArrivalTimerId = "how long the arrivals are processed?" -englishResultLocalisation ArrivalProcessingTimeId = "the processing time of arrivals" -englishResultLocalisation ServerId = "the server" -englishResultLocalisation ServerInitStateId = "the initial state" -englishResultLocalisation ServerStateId = "the current state" -englishResultLocalisation ServerTotalInputWaitTimeId = "the total time spent while waiting for input" -englishResultLocalisation ServerTotalProcessingTimeId = "the total time spent on actual processing the tasks" -englishResultLocalisation ServerTotalOutputWaitTimeId = "the total time spent on delivering the output" -englishResultLocalisation ServerInputWaitTimeId = "the time spent while waiting for input" -englishResultLocalisation ServerProcessingTimeId = "the time spent on processing the tasks" -englishResultLocalisation ServerOutputWaitTimeId = "the time spent on delivering the output" -englishResultLocalisation ServerInputWaitFactorId = "the relative time spent while waiting for input (from 0 to 1)" -englishResultLocalisation ServerProcessingFactorId = "the relative time spent on processing the tasks (from 0 to 1)" -englishResultLocalisation ServerOutputWaitFactorId = "the relative time spent on delivering the output (from 0 to 1)" -englishResultLocalisation (UserDefinedResultId m) = m -englishResultLocalisation x@(LocalisedResultId m) = - lookupResultLocalisation englishResultLocale x - --- | Lookup a localisation by the specified locale. -lookupResultLocalisation :: ResultLocale -> ResultLocalisation -lookupResultLocalisation loc (UserDefinedResultId m) = m -lookupResultLocalisation loc (LocalisedResultId m) = - case M.lookup loc m of - Just x -> x - Nothing -> - case M.lookup russianResultLocale m of - Just x -> x - Nothing -> - case M.lookup englishResultLocale m of - Just x -> x - Nothing -> "" -lookupResultLocalisation loc resultId = russianResultLocalisation resultId + +-- | +-- Module : Simulation.Aivika.Trans.Results.Locale +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines locales for outputting and printing the simulation results. +-- +module Simulation.Aivika.Trans.Results.Locale + (-- * Basic Types + ResultLocale, + ResultLocalisation, + ResultDescription, + -- * Locale Codes + russianResultLocale, + englishResultLocale, + -- * Localisations + lookupResultLocalisation, + russianResultLocalisation, + englishResultLocalisation, + -- * Unique Identifiers + ResultId(..)) where + +import qualified Data.Map as M + +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Statistics +import Simulation.Aivika.Trans.Statistics.Accumulator +import qualified Simulation.Aivika.Trans.Queue as Q +import qualified Simulation.Aivika.Trans.Queue.Infinite as IQ +import Simulation.Aivika.Trans.Arrival +import Simulation.Aivika.Trans.Server +import Simulation.Aivika.Trans.Activity + +-- | A locale to output the simulation results. +-- +-- Examples are: @\"ru\", @\"en\" etc. +type ResultLocale = String + +-- | It localises the description of simulation results. +type ResultLocalisation = ResultId -> ResultDescription + +-- | A description used for describing the results when generating output. +type ResultDescription = String + +-- | The result entity identifier. +data ResultId = TimeId + -- ^ A 'time' computation. + | VectorId + -- ^ Describes a vector. + | VectorItemId String + -- ^ Describes a vector item with the specified subscript. + | SamplingStatsId + -- ^ A 'SamplingStats' value. + | SamplingStatsCountId + -- ^ Property 'samplingStatsCount'. + | SamplingStatsMinId + -- ^ Property 'samplingStatsMin'. + | SamplingStatsMaxId + -- ^ Property 'samplingStatsMax'. + | SamplingStatsMeanId + -- ^ Property 'samplingStatsMean'. + | SamplingStatsMean2Id + -- ^ Property 'samplingStatsMean2'. + | SamplingStatsVarianceId + -- ^ Property 'samplingStatsVariance'. + | SamplingStatsDeviationId + -- ^ Property 'samplingStatsDeviation'. + | TimingStatsId + -- ^ A 'TimingStats' value. + | TimingStatsCountId + -- ^ Property 'timingStatsCount'. + | TimingStatsMinId + -- ^ Property 'timingStatsMin'. + | TimingStatsMaxId + -- ^ Property 'timingStatsMax'. + | TimingStatsMeanId + -- ^ Property 'timingStatsMean'. + | TimingStatsVarianceId + -- ^ Property 'timingStatsVariance'. + | TimingStatsDeviationId + -- ^ Property 'timingStatsDeviation'. + | TimingStatsMinTimeId + -- ^ Property 'timingStatsMinTime'. + | TimingStatsMaxTimeId + -- ^ Property 'timingStatsMaxTime'. + | TimingStatsStartTimeId + -- ^ Property 'timingStatsStartTime'. + | TimingStatsLastTimeId + -- ^ Property 'timingStatsLastTime'. + | TimingStatsSumId + -- ^ Property 'timingStatsSum'. + | TimingStatsSum2Id + -- ^ Property 'timingStatsSum2'. + | FiniteQueueId + -- ^ A finite 'Q.Queue'. + | InfiniteQueueId + -- ^ An infinite 'IQ.Queue'. + | EnqueueStrategyId + -- ^ Property 'Q.enqueueStrategy'. + | EnqueueStoringStrategyId + -- ^ Property 'Q.enqueueStoringStrategy'. + | DequeueStrategyId + -- ^ Property 'Q.dequeueStrategy'. + | QueueNullId + -- ^ Property 'Q.queueNull'. + | QueueFullId + -- ^ Property 'Q.queueFull'. + | QueueMaxCountId + -- ^ Property 'Q.queueMaxCount'. + | QueueCountId + -- ^ Property 'Q.queueCount'. + | QueueCountStatsId + -- ^ Property 'Q.queueCountStats'. + | EnqueueCountId + -- ^ Property 'Q.enqueueCount'. + | EnqueueLostCountId + -- ^ Property 'Q.enqueueLostCount'. + | EnqueueStoreCountId + -- ^ Property 'Q.enqueueStoreCount'. + | DequeueCountId + -- ^ Property 'Q.dequeueCount'. + | DequeueExtractCountId + -- ^ Property 'Q.dequeueExtractCount'. + | QueueLoadFactorId + -- ^ Property 'Q.queueLoadFactor'. + | EnqueueRateId + -- ^ Property 'Q.enqueueRate'. + | EnqueueStoreRateId + -- ^ Property 'Q.enqueueStoreRate'. + | DequeueRateId + -- ^ Property 'Q.dequeueRate'. + | DequeueExtractRateId + -- ^ Property 'Q.dequeueExtractRate'. + | QueueWaitTimeId + -- ^ Property 'Q.queueWaitTime'. + | QueueTotalWaitTimeId + -- ^ Property 'Q.queueTotalWaitTime'. + | EnqueueWaitTimeId + -- ^ Property 'Q.enqueueWaitTime'. + | DequeueWaitTimeId + -- ^ Property 'Q.dequeueWaitTime'. + | QueueRateId + -- ^ Property 'Q.queueRate'. + | ArrivalTimerId + -- ^ An 'ArrivalTimer'. + | ArrivalProcessingTimeId + -- ^ Property 'arrivalProcessingTime'. + | ServerId + -- ^ Represents a 'Server'. + | ServerInitStateId + -- ^ Property 'serverInitState'. + | ServerStateId + -- ^ Property 'serverState'. + | ServerTotalInputWaitTimeId + -- ^ Property 'serverTotalInputWaitTime'. + | ServerTotalProcessingTimeId + -- ^ Property 'serverTotalProcessingTime'. + | ServerTotalOutputWaitTimeId + -- ^ Property 'serverTotalOutputWaitTime'. + | ServerInputWaitTimeId + -- ^ Property 'serverInputWaitTime'. + | ServerProcessingTimeId + -- ^ Property 'serverProcessingTime'. + | ServerOutputWaitTimeId + -- ^ Property 'serverOutputWaitTime'. + | ServerInputWaitFactorId + -- ^ Property 'serverInputWaitFactor'. + | ServerProcessingFactorId + -- ^ Property 'serverProcessingFactor'. + | ServerOutputWaitFactorId + -- ^ Property 'serverOutputWaitFactor'. + | ActivityId + -- ^ Represents an 'Activity'. + | ActivityInitStateId + -- ^ Property 'activityInitState'. + | ActivityStateId + -- ^ Property 'activityState'. + | ActivityTotalUtilisationTimeId + -- ^ Property 'activityTotalUtilisationTime'. + | ActivityTotalIdleTimeId + -- ^ Property 'activityTotalIdleTime'. + | ActivityUtilisationTimeId + -- ^ Property 'activityUtilisationTime'. + | ActivityIdleTimeId + -- ^ Property 'activityIdleTime'. + | ActivityUtilisationFactorId + -- ^ Property 'activityUtilisationFactor'. + | ActivityIdleFactorId + -- ^ Property 'activityIdleFactor'. + | UserDefinedResultId ResultDescription + -- ^ An user defined description. + | LocalisedResultId (M.Map ResultLocale ResultDescription) + -- ^ A localised property or object name. + deriving (Eq, Ord, Show) + +-- | The Russian locale. +russianResultLocale :: ResultLocale +russianResultLocale = "ru" + +-- | The English locale. +englishResultLocale :: ResultLocale +englishResultLocale = "en" + +-- | The Russian localisation of the simulation results. +russianResultLocalisation :: ResultLocalisation +russianResultLocalisation TimeId = "модельное время" +russianResultLocalisation VectorId = "вектор" +russianResultLocalisation (VectorItemId x) = "элемент с индексом " ++ x +russianResultLocalisation SamplingStatsId = "сводная статистика" +russianResultLocalisation SamplingStatsCountId = "количество" +russianResultLocalisation SamplingStatsMinId = "минимальное значение" +russianResultLocalisation SamplingStatsMaxId = "максимальное значение" +russianResultLocalisation SamplingStatsMeanId = "среднее значение" +russianResultLocalisation SamplingStatsMean2Id = "среднее квадратов" +russianResultLocalisation SamplingStatsVarianceId = "дисперсия" +russianResultLocalisation SamplingStatsDeviationId = "среднеквадратическое отклонение" +russianResultLocalisation TimingStatsId = "временная статистика" +russianResultLocalisation TimingStatsCountId = "количество" +russianResultLocalisation TimingStatsMinId = "минимальное значение" +russianResultLocalisation TimingStatsMaxId = "максимальное значение" +russianResultLocalisation TimingStatsMeanId = "среднее значение" +russianResultLocalisation TimingStatsVarianceId = "дисперсия" +russianResultLocalisation TimingStatsDeviationId = "среднеквадратическое отклонение" +russianResultLocalisation TimingStatsMinTimeId = "время достижения минимума" +russianResultLocalisation TimingStatsMaxTimeId = "время достижения максимума" +russianResultLocalisation TimingStatsStartTimeId = "начальное время сбора статистики" +russianResultLocalisation TimingStatsLastTimeId = "конечное время сбора статистики" +russianResultLocalisation TimingStatsSumId = "сумма" +russianResultLocalisation TimingStatsSum2Id = "сумма квадратов" +russianResultLocalisation FiniteQueueId = "конечная очередь" +russianResultLocalisation InfiniteQueueId = "бесконечная очередь" +russianResultLocalisation EnqueueStrategyId = "стратегия добавления элементов" +russianResultLocalisation EnqueueStoringStrategyId = "стратегия хранения элементов" +russianResultLocalisation DequeueStrategyId = "стратегия извлечения элементов" +russianResultLocalisation QueueNullId = "очередь пуста?" +russianResultLocalisation QueueFullId = "очередь заполнена?" +russianResultLocalisation QueueMaxCountId = "емкость очереди" +russianResultLocalisation QueueCountId = "текущий размер очереди" +russianResultLocalisation QueueCountStatsId = "статистика по размеру очереди" +russianResultLocalisation EnqueueCountId = "общее количество попыток добавить элементы" +russianResultLocalisation EnqueueLostCountId = "общее количество неудачных попыток добавить элементы" +russianResultLocalisation EnqueueStoreCountId = "общее количество сохраненных элементов" +russianResultLocalisation DequeueCountId = "общее количество запросов на извлечение элементов" +russianResultLocalisation DequeueExtractCountId = "общее количество извлеченных элементов" +russianResultLocalisation QueueLoadFactorId = "коэфф. загрузки (размер, поделенный на емкость)" +russianResultLocalisation EnqueueRateId = "количество попыток добавить на ед. времени" +russianResultLocalisation EnqueueStoreRateId = "количество сохраненных на ед. времени" +russianResultLocalisation DequeueRateId = "количество запросов на извлечение в ед. времени" +russianResultLocalisation DequeueExtractRateId = "количество извлеченных на ед. времени" +russianResultLocalisation QueueWaitTimeId = "время ожидания (сохранили -> извлекли)" +russianResultLocalisation QueueTotalWaitTimeId = "общее время ожидания (попытались добавить -> извлекли)" +russianResultLocalisation EnqueueWaitTimeId = "время ожидания добавления (попытались добавить -> сохранили)" +russianResultLocalisation DequeueWaitTimeId = "время ожидания извлечения (запросили извлечь -> извлекли)" +russianResultLocalisation QueueRateId = "усредненная скорость (как средняя длина очереди на среднее время ожидания)" +russianResultLocalisation ArrivalTimerId = "как долго обрабатываются заявки?" +russianResultLocalisation ArrivalProcessingTimeId = "время обработки заявки" +russianResultLocalisation ServerId = "сервер" +russianResultLocalisation ServerInitStateId = "начальное состояние" +russianResultLocalisation ServerStateId = "текущее состояние" +russianResultLocalisation ServerTotalInputWaitTimeId = "общее время блокировки в ожидании ввода" +russianResultLocalisation ServerTotalProcessingTimeId = "общее время, потраченное на саму обработку заданий" +russianResultLocalisation ServerTotalOutputWaitTimeId = "общее время блокировки при попытке доставить вывод" +russianResultLocalisation ServerInputWaitTimeId = "время блокировки в ожидании ввода" +russianResultLocalisation ServerProcessingTimeId = "время, потраченное на саму обработку заданий" +russianResultLocalisation ServerOutputWaitTimeId = "время блокировки при попытке доставить вывод" +russianResultLocalisation ServerInputWaitFactorId = "относительное время блокировки в ожидании ввода (от 0 до 1)" +russianResultLocalisation ServerProcessingFactorId = "относительное время, потраченное на саму обработку заданий (от 0 до 1)" +russianResultLocalisation ServerOutputWaitFactorId = "относительное время блокировки при попытке доставить вывод (от 0 до 1)" +russianResultLocalisation ActivityId = "активность" +russianResultLocalisation ActivityInitStateId = "начальное состояние" +russianResultLocalisation ActivityStateId = "текущее состояние" +russianResultLocalisation ActivityTotalUtilisationTimeId = "общее время использования" +russianResultLocalisation ActivityTotalIdleTimeId = "общее время простоя" +russianResultLocalisation ActivityUtilisationTimeId = "статистика времени использования" +russianResultLocalisation ActivityIdleTimeId = "статистика времени простоя" +russianResultLocalisation ActivityUtilisationFactorId = "относительное время использования (от 0 до 1)" +russianResultLocalisation ActivityIdleFactorId = "относительное время простоя (от 0 до 1)" +russianResultLocalisation (UserDefinedResultId m) = m +russianResultLocalisation x@(LocalisedResultId m) = + lookupResultLocalisation russianResultLocale x + +-- | The English localisation of the simulation results. +englishResultLocalisation :: ResultLocalisation +englishResultLocalisation TimeId = "simulation time" +englishResultLocalisation VectorId = "vector" +englishResultLocalisation (VectorItemId x) = "item #" ++ x +englishResultLocalisation SamplingStatsId = "statistics summary" +englishResultLocalisation SamplingStatsCountId = "count" +englishResultLocalisation SamplingStatsMinId = "minimum" +englishResultLocalisation SamplingStatsMaxId = "maximum" +englishResultLocalisation SamplingStatsMeanId = "mean" +englishResultLocalisation SamplingStatsMean2Id = "mean square" +englishResultLocalisation SamplingStatsVarianceId = "variance" +englishResultLocalisation SamplingStatsDeviationId = "deviation" +englishResultLocalisation TimingStatsId = "timing statistics" +englishResultLocalisation TimingStatsCountId = "count" +englishResultLocalisation TimingStatsMinId = "minimum" +englishResultLocalisation TimingStatsMaxId = "maximum" +englishResultLocalisation TimingStatsMeanId = "mean" +englishResultLocalisation TimingStatsVarianceId = "variance" +englishResultLocalisation TimingStatsDeviationId = "deviation" +englishResultLocalisation TimingStatsMinTimeId = "the time of minimum" +englishResultLocalisation TimingStatsMaxTimeId = "the time of maximum" +englishResultLocalisation TimingStatsStartTimeId = "the start time" +englishResultLocalisation TimingStatsLastTimeId = "the last time" +englishResultLocalisation TimingStatsSumId = "sum" +englishResultLocalisation TimingStatsSum2Id = "sum square" +englishResultLocalisation FiniteQueueId = "the finite queue" +englishResultLocalisation InfiniteQueueId = "the infinite queue" +englishResultLocalisation EnqueueStrategyId = "the enqueueing strategy" +englishResultLocalisation EnqueueStoringStrategyId = "the storing strategy" +englishResultLocalisation DequeueStrategyId = "the dequeueing strategy" +englishResultLocalisation QueueNullId = "is the queue empty?" +englishResultLocalisation QueueFullId = "is the queue full?" +englishResultLocalisation QueueMaxCountId = "the queue capacity" +englishResultLocalisation QueueCountId = "the current queue size" +englishResultLocalisation QueueCountStatsId = "the queue size statistics" +englishResultLocalisation EnqueueCountId = "a total number of attempts to enqueue the items" +englishResultLocalisation EnqueueLostCountId = "a total number of the lost items when trying to enqueue" +englishResultLocalisation EnqueueStoreCountId = "a total number of the stored items" +englishResultLocalisation DequeueCountId = "a total number of requests for dequeueing" +englishResultLocalisation DequeueExtractCountId = "a total number of the dequeued items" +englishResultLocalisation QueueLoadFactorId = "the queue load (its size divided by its capacity)" +englishResultLocalisation EnqueueRateId = "how many attempts to enqueue per time?" +englishResultLocalisation EnqueueStoreRateId = "how many items were stored per time?" +englishResultLocalisation DequeueRateId = "how many requests for dequeueing per time?" +englishResultLocalisation DequeueExtractRateId = "how many items were dequeued per time?" +englishResultLocalisation QueueWaitTimeId = "the wait time (stored -> dequeued)" +englishResultLocalisation QueueTotalWaitTimeId = "the total wait time (tried to enqueue -> dequeued)" +englishResultLocalisation EnqueueWaitTimeId = "the enqueue wait time (tried to enqueue -> stored)" +englishResultLocalisation DequeueWaitTimeId = "the dequeue wait time (requested for dequeueing -> dequeued)" +englishResultLocalisation QueueRateId = "the average queue rate (= queue size / wait time)" +englishResultLocalisation ArrivalTimerId = "how long the arrivals are processed?" +englishResultLocalisation ArrivalProcessingTimeId = "the processing time of arrivals" +englishResultLocalisation ServerId = "the server" +englishResultLocalisation ServerInitStateId = "the initial state" +englishResultLocalisation ServerStateId = "the current state" +englishResultLocalisation ServerTotalInputWaitTimeId = "the total time spent while waiting for input" +englishResultLocalisation ServerTotalProcessingTimeId = "the total time spent on actual processing the tasks" +englishResultLocalisation ServerTotalOutputWaitTimeId = "the total time spent on delivering the output" +englishResultLocalisation ServerInputWaitTimeId = "the time spent while waiting for input" +englishResultLocalisation ServerProcessingTimeId = "the time spent on processing the tasks" +englishResultLocalisation ServerOutputWaitTimeId = "the time spent on delivering the output" +englishResultLocalisation ServerInputWaitFactorId = "the relative time spent while waiting for input (from 0 to 1)" +englishResultLocalisation ServerProcessingFactorId = "the relative time spent on processing the tasks (from 0 to 1)" +englishResultLocalisation ServerOutputWaitFactorId = "the relative time spent on delivering the output (from 0 to 1)" +englishResultLocalisation ActivityId = "the activity" +englishResultLocalisation ActivityInitStateId = "the initial state" +englishResultLocalisation ActivityStateId = "the current state" +englishResultLocalisation ActivityTotalUtilisationTimeId = "the total time of utilisation" +englishResultLocalisation ActivityTotalIdleTimeId = "the total idle time" +englishResultLocalisation ActivityUtilisationTimeId = "the utilisation time" +englishResultLocalisation ActivityIdleTimeId = "the idle time" +englishResultLocalisation ActivityUtilisationFactorId = "the relative utilisation time (от 0 до 1)" +englishResultLocalisation ActivityIdleFactorId = "the relative idle time (от 0 до 1)" +englishResultLocalisation (UserDefinedResultId m) = m +englishResultLocalisation x@(LocalisedResultId m) = + lookupResultLocalisation englishResultLocale x + +-- | Lookup a localisation by the specified locale. +lookupResultLocalisation :: ResultLocale -> ResultLocalisation +lookupResultLocalisation loc (UserDefinedResultId m) = m +lookupResultLocalisation loc (LocalisedResultId m) = + case M.lookup loc m of + Just x -> x + Nothing -> + case M.lookup russianResultLocale m of + Just x -> x + Nothing -> + case M.lookup englishResultLocale m of + Just x -> x + Nothing -> "" +lookupResultLocalisation loc resultId = russianResultLocalisation resultId 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,516 +1,513 @@ - --- | --- Module : Simulation.Aivika.Trans.Server --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It models the server that prodives a service. -module Simulation.Aivika.Trans.Server - (-- * Server - Server, - newServer, - newStateServer, - -- * Processing - serverProcessor, - -- * Server Properties and Activities - serverInitState, - serverState, - serverTotalInputWaitTime, - serverTotalProcessingTime, - serverTotalOutputWaitTime, - serverInputWaitTime, - serverProcessingTime, - serverOutputWaitTime, - serverInputWaitFactor, - serverProcessingFactor, - serverOutputWaitFactor, - -- * Summary - serverSummary, - -- * Derived Signals for Properties - serverStateChanged, - serverStateChanged_, - serverTotalInputWaitTimeChanged, - serverTotalInputWaitTimeChanged_, - serverTotalProcessingTimeChanged, - serverTotalProcessingTimeChanged_, - serverTotalOutputWaitTimeChanged, - serverTotalOutputWaitTimeChanged_, - serverInputWaitTimeChanged, - serverInputWaitTimeChanged_, - serverProcessingTimeChanged, - serverProcessingTimeChanged_, - serverOutputWaitTimeChanged, - serverOutputWaitTimeChanged_, - serverInputWaitFactorChanged, - serverInputWaitFactorChanged_, - serverProcessingFactorChanged, - serverProcessingFactorChanged_, - serverOutputWaitFactorChanged, - serverOutputWaitFactorChanged_, - -- * Basic Signals - serverInputReceived, - serverTaskProcessed, - serverOutputProvided, - -- * Overall Signal - serverChanged_) where - -import Data.Monoid - -import Control.Arrow - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Parameter -import Simulation.Aivika.Trans.Simulation -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Event -import Simulation.Aivika.Trans.Internal.Signal -import Simulation.Aivika.Trans.Resource -import Simulation.Aivika.Trans.Cont -import Simulation.Aivika.Trans.Process -import Simulation.Aivika.Trans.Processor -import Simulation.Aivika.Trans.Stream -import Simulation.Aivika.Trans.Statistics - --- | It models a server that takes @a@ and provides @b@ having state @s@ within underlying computation @m@. -data Server m s a b = - Server { serverInitState :: s, - -- ^ The initial state of the server. - serverStateRef :: ProtoRef m s, - -- ^ The current state of the server. - serverProcess :: s -> a -> Process m (s, b), - -- ^ Provide @b@ by specified @a@. - serverTotalInputWaitTimeRef :: ProtoRef m Double, - -- ^ The counted total time spent in awating the input. - serverTotalProcessingTimeRef :: ProtoRef m Double, - -- ^ The counted total time spent to process the input and prepare the output. - serverTotalOutputWaitTimeRef :: ProtoRef m Double, - -- ^ The counted total time spent for delivering the output. - serverInputWaitTimeRef :: ProtoRef m (SamplingStats Double), - -- ^ The statistics for the time spent in awaiting the input. - serverProcessingTimeRef :: ProtoRef m (SamplingStats Double), - -- ^ The statistics for the time spent to process the input and prepare the output. - serverOutputWaitTimeRef :: ProtoRef m (SamplingStats Double), - -- ^ The statistics for the time spent for delivering the output. - serverInputReceivedSource :: SignalSource m a, - -- ^ A signal raised when the server recieves a new input to process. - serverTaskProcessedSource :: SignalSource m (a, b), - -- ^ A signal raised when the input is processed and - -- the output is prepared for deliverying. - serverOutputProvidedSource :: SignalSource m (a, b) - -- ^ A signal raised when the server has supplied the output. - } - --- | Create a new server that can provide output @b@ by input @a@. --- Also it returns the corresponded processor that being applied --- updates the server state. -newServer :: MonadComp m - => (a -> Process m b) - -- ^ provide an output by the specified input - -> Simulation m (Server m () a b) -newServer provide = - flip newStateServer () $ \s a -> - do b <- provide a - return (s, b) - --- | Create a new server that can provide output @b@ by input @a@ --- starting from state @s@. Also it returns the corresponded processor --- that being applied updates the server state. -newStateServer :: MonadComp m - => (s -> a -> Process m (s, b)) - -- ^ provide a new state and output by the specified - -- old state and input - -> s - -- ^ the initial state - -> Simulation m (Server m s a b) -newStateServer provide state = - do sn <- liftParameter simulationSession - r0 <- liftComp $ newProtoRef sn state - r1 <- liftComp $ newProtoRef sn 0 - r2 <- liftComp $ newProtoRef sn 0 - r3 <- liftComp $ newProtoRef sn 0 - r4 <- liftComp $ newProtoRef sn emptySamplingStats - r5 <- liftComp $ newProtoRef sn emptySamplingStats - r6 <- liftComp $ newProtoRef sn emptySamplingStats - s1 <- newSignalSource - s2 <- newSignalSource - s3 <- newSignalSource - let server = Server { serverInitState = state, - serverStateRef = r0, - serverProcess = provide, - serverTotalInputWaitTimeRef = r1, - serverTotalProcessingTimeRef = r2, - serverTotalOutputWaitTimeRef = r3, - serverInputWaitTimeRef = r4, - serverProcessingTimeRef = r5, - serverOutputWaitTimeRef = r6, - serverInputReceivedSource = s1, - serverTaskProcessedSource = s2, - serverOutputProvidedSource = s3 } - return server - --- | Return a processor for the specified server. --- --- The processor updates the internal state of the server. The usual case is when --- the processor is applied only once in a chain of data processing. Otherwise; --- every time the processor is used, the state of the server changes. Sometimes --- it can be indeed useful if you want to aggregate the statistics for different --- servers simultaneously, but it would be more preferable to avoid this. --- --- If you connect different server processors returned by this function in a chain --- with help of '>>>' or other category combinator then this chain will act as one --- whole, where the first server will take a new task only after the last server --- finishes its current task and requests for the next one from the previous processor --- in the chain. This is not always that thing you might need. --- --- To model a sequence of the server processors working independently, you --- should separate them with help of the 'prefetchProcessor' that plays a role --- of a small one-place buffer in that case. --- --- The queue processors usually have the prefetching capabilities per se, where --- the items are already stored in the queue. Therefore, the server processor --- should not be prefetched if it is connected directly with the queue processor. -serverProcessor :: MonadComp m => Server m s a b -> Processor m a b -serverProcessor server = - Processor $ \xs -> loop (serverInitState server) Nothing xs - where - loop s r xs = - Cons $ - do t0 <- liftDynamics time - liftEvent $ - case r of - Nothing -> return () - Just (t', a', b') -> - do liftComp $ - do modifyProtoRef' (serverTotalOutputWaitTimeRef server) (+ (t0 - t')) - modifyProtoRef' (serverOutputWaitTimeRef server) $ - addSamplingStats (t0 - t') - triggerSignal (serverOutputProvidedSource server) (a', b') - -- get input - (a, xs') <- runStream xs - t1 <- liftDynamics time - liftEvent $ - do liftComp $ - do modifyProtoRef' (serverTotalInputWaitTimeRef server) (+ (t1 - t0)) - modifyProtoRef' (serverInputWaitTimeRef server) $ - addSamplingStats (t1 - t0) - triggerSignal (serverInputReceivedSource server) a - -- provide the service - (s', b) <- serverProcess server s a - t2 <- liftDynamics time - liftEvent $ - do liftComp $ - do writeProtoRef (serverStateRef server) $! s' - modifyProtoRef' (serverTotalProcessingTimeRef server) (+ (t2 - t1)) - modifyProtoRef' (serverProcessingTimeRef server) $ - addSamplingStats (t2 - t1) - triggerSignal (serverTaskProcessedSource server) (a, b) - return (b, loop s' (Just (t2, a, b)) xs') - --- | Return the current state of the server. --- --- See also 'serverStateChanged' and 'serverStateChanged_'. -serverState :: MonadComp m => Server m s a b -> Event m s -serverState server = - Event $ \p -> readProtoRef (serverStateRef server) - --- | Signal when the 'serverState' property value has changed. -serverStateChanged :: MonadComp m => Server m s a b -> Signal m s -serverStateChanged server = - mapSignalM (const $ serverState server) (serverStateChanged_ server) - --- | Signal when the 'serverState' property value has changed. -serverStateChanged_ :: MonadComp m => Server m s a b -> Signal m () -serverStateChanged_ server = - mapSignal (const ()) (serverTaskProcessed server) - --- | Return the counted total time when the server was locked while awaiting the input. --- --- The value returned changes discretely and it is usually delayed relative --- to the current simulation time. --- --- See also 'serverTotalInputWaitTimeChanged' and 'serverTotalInputWaitTimeChanged_'. -serverTotalInputWaitTime :: MonadComp m => Server m s a b -> Event m Double -serverTotalInputWaitTime server = - Event $ \p -> readProtoRef (serverTotalInputWaitTimeRef server) - --- | Signal when the 'serverTotalInputWaitTime' property value has changed. -serverTotalInputWaitTimeChanged :: MonadComp m => Server m s a b -> Signal m Double -serverTotalInputWaitTimeChanged server = - mapSignalM (const $ serverTotalInputWaitTime server) (serverTotalInputWaitTimeChanged_ server) - --- | Signal when the 'serverTotalInputWaitTime' property value has changed. -serverTotalInputWaitTimeChanged_ :: MonadComp m => Server m s a b -> Signal m () -serverTotalInputWaitTimeChanged_ server = - mapSignal (const ()) (serverInputReceived server) - --- | Return the counted total time spent by the server while processing the tasks. --- --- The value returned changes discretely and it is usually delayed relative --- to the current simulation time. --- --- See also 'serverTotalProcessingTimeChanged' and 'serverTotalProcessingTimeChanged_'. -serverTotalProcessingTime :: MonadComp m => Server m s a b -> Event m Double -serverTotalProcessingTime server = - Event $ \p -> readProtoRef (serverTotalProcessingTimeRef server) - --- | Signal when the 'serverTotalProcessingTime' property value has changed. -serverTotalProcessingTimeChanged :: MonadComp m => Server m s a b -> Signal m Double -serverTotalProcessingTimeChanged server = - mapSignalM (const $ serverTotalProcessingTime server) (serverTotalProcessingTimeChanged_ server) - --- | Signal when the 'serverTotalProcessingTime' property value has changed. -serverTotalProcessingTimeChanged_ :: MonadComp m => Server m s a b -> Signal m () -serverTotalProcessingTimeChanged_ server = - mapSignal (const ()) (serverTaskProcessed server) - --- | Return the counted total time when the server was locked while trying --- to deliver the output. --- --- The value returned changes discretely and it is usually delayed relative --- to the current simulation time. --- --- See also 'serverTotalOutputWaitTimeChanged' and 'serverTotalOutputWaitTimeChanged_'. -serverTotalOutputWaitTime :: MonadComp m => Server m s a b -> Event m Double -serverTotalOutputWaitTime server = - Event $ \p -> readProtoRef (serverTotalOutputWaitTimeRef server) - --- | Signal when the 'serverTotalOutputWaitTime' property value has changed. -serverTotalOutputWaitTimeChanged :: MonadComp m => Server m s a b -> Signal m Double -serverTotalOutputWaitTimeChanged server = - mapSignalM (const $ serverTotalOutputWaitTime server) (serverTotalOutputWaitTimeChanged_ server) - --- | Signal when the 'serverTotalOutputWaitTime' property value has changed. -serverTotalOutputWaitTimeChanged_ :: MonadComp m => Server m s a b -> Signal m () -serverTotalOutputWaitTimeChanged_ server = - mapSignal (const ()) (serverOutputProvided server) - --- | Return the statistics of the time when the server was locked while awaiting the input. --- --- The value returned changes discretely and it is usually delayed relative --- to the current simulation time. --- --- See also 'serverInputWaitTimeChanged' and 'serverInputWaitTimeChanged_'. -serverInputWaitTime :: MonadComp m => Server m s a b -> Event m (SamplingStats Double) -serverInputWaitTime server = - Event $ \p -> readProtoRef (serverInputWaitTimeRef server) - --- | Signal when the 'serverInputWaitTime' property value has changed. -serverInputWaitTimeChanged :: MonadComp m => Server m s a b -> Signal m (SamplingStats Double) -serverInputWaitTimeChanged server = - mapSignalM (const $ serverInputWaitTime server) (serverInputWaitTimeChanged_ server) - --- | Signal when the 'serverInputWaitTime' property value has changed. -serverInputWaitTimeChanged_ :: MonadComp m => Server m s a b -> Signal m () -serverInputWaitTimeChanged_ server = - mapSignal (const ()) (serverInputReceived server) - --- | Return the statistics of the time spent by the server while processing the tasks. --- --- The value returned changes discretely and it is usually delayed relative --- to the current simulation time. --- --- See also 'serverProcessingTimeChanged' and 'serverProcessingTimeChanged_'. -serverProcessingTime :: MonadComp m => Server m s a b -> Event m (SamplingStats Double) -serverProcessingTime server = - Event $ \p -> readProtoRef (serverProcessingTimeRef server) - --- | Signal when the 'serverProcessingTime' property value has changed. -serverProcessingTimeChanged :: MonadComp m => Server m s a b -> Signal m (SamplingStats Double) -serverProcessingTimeChanged server = - mapSignalM (const $ serverProcessingTime server) (serverProcessingTimeChanged_ server) - --- | Signal when the 'serverProcessingTime' property value has changed. -serverProcessingTimeChanged_ :: MonadComp m => Server m s a b -> Signal m () -serverProcessingTimeChanged_ server = - mapSignal (const ()) (serverTaskProcessed server) - --- | Return the statistics of the time when the server was locked while trying --- to deliver the output. --- --- The value returned changes discretely and it is usually delayed relative --- to the current simulation time. --- --- See also 'serverOutputWaitTimeChanged' and 'serverOutputWaitTimeChanged_'. -serverOutputWaitTime :: MonadComp m => Server m s a b -> Event m (SamplingStats Double) -serverOutputWaitTime server = - Event $ \p -> readProtoRef (serverOutputWaitTimeRef server) - --- | Signal when the 'serverOutputWaitTime' property value has changed. -serverOutputWaitTimeChanged :: MonadComp m => Server m s a b -> Signal m (SamplingStats Double) -serverOutputWaitTimeChanged server = - mapSignalM (const $ serverOutputWaitTime server) (serverOutputWaitTimeChanged_ server) - --- | Signal when the 'serverOutputWaitTime' property value has changed. -serverOutputWaitTimeChanged_ :: MonadComp m => Server m s a b -> Signal m () -serverOutputWaitTimeChanged_ server = - mapSignal (const ()) (serverOutputProvided server) - --- | It returns the factor changing from 0 to 1, which estimates how often --- the server was awaiting for the next input task. --- --- This factor is calculated as --- --- @ --- totalInputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime) --- @ --- --- As before in this module, the value returned changes discretely and --- it is usually delayed relative to the current simulation time. --- --- See also 'serverInputWaitFactorChanged' and 'serverInputWaitFactorChanged_'. -serverInputWaitFactor :: MonadComp m => Server m s a b -> Event m Double -serverInputWaitFactor server = - Event $ \p -> - do x1 <- readProtoRef (serverTotalInputWaitTimeRef server) - x2 <- readProtoRef (serverTotalProcessingTimeRef server) - x3 <- readProtoRef (serverTotalOutputWaitTimeRef server) - return (x1 / (x1 + x2 + x3)) - --- | Signal when the 'serverInputWaitFactor' property value has changed. -serverInputWaitFactorChanged :: MonadComp m => Server m s a b -> Signal m Double -serverInputWaitFactorChanged server = - mapSignalM (const $ serverInputWaitFactor server) (serverInputWaitFactorChanged_ server) - --- | Signal when the 'serverInputWaitFactor' property value has changed. -serverInputWaitFactorChanged_ :: MonadComp m => Server m s a b -> Signal m () -serverInputWaitFactorChanged_ server = - mapSignal (const ()) (serverInputReceived server) <> - mapSignal (const ()) (serverTaskProcessed server) <> - mapSignal (const ()) (serverOutputProvided server) - --- | It returns the factor changing from 0 to 1, which estimates how often --- the server was busy with direct processing its tasks. --- --- This factor is calculated as --- --- @ --- totalProcessingTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime) --- @ --- --- As before in this module, the value returned changes discretely and --- it is usually delayed relative to the current simulation time. --- --- See also 'serverProcessingFactorChanged' and 'serverProcessingFactorChanged_'. -serverProcessingFactor :: MonadComp m => Server m s a b -> Event m Double -serverProcessingFactor server = - Event $ \p -> - do x1 <- readProtoRef (serverTotalInputWaitTimeRef server) - x2 <- readProtoRef (serverTotalProcessingTimeRef server) - x3 <- readProtoRef (serverTotalOutputWaitTimeRef server) - return (x2 / (x1 + x2 + x3)) - --- | Signal when the 'serverProcessingFactor' property value has changed. -serverProcessingFactorChanged :: MonadComp m => Server m s a b -> Signal m Double -serverProcessingFactorChanged server = - mapSignalM (const $ serverProcessingFactor server) (serverProcessingFactorChanged_ server) - --- | Signal when the 'serverProcessingFactor' property value has changed. -serverProcessingFactorChanged_ :: MonadComp m => Server m s a b -> Signal m () -serverProcessingFactorChanged_ server = - mapSignal (const ()) (serverInputReceived server) <> - mapSignal (const ()) (serverTaskProcessed server) <> - mapSignal (const ()) (serverOutputProvided server) - --- | It returns the factor changing from 0 to 1, which estimates how often --- the server was locked trying to deliver the output after the task is finished. --- --- This factor is calculated as --- --- @ --- totalOutputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime) --- @ --- --- As before in this module, the value returned changes discretely and --- it is usually delayed relative to the current simulation time. --- --- See also 'serverOutputWaitFactorChanged' and 'serverOutputWaitFactorChanged_'. -serverOutputWaitFactor :: MonadComp m => Server m s a b -> Event m Double -serverOutputWaitFactor server = - Event $ \p -> - do x1 <- readProtoRef (serverTotalInputWaitTimeRef server) - x2 <- readProtoRef (serverTotalProcessingTimeRef server) - x3 <- readProtoRef (serverTotalOutputWaitTimeRef server) - return (x3 / (x1 + x2 + x3)) - --- | Signal when the 'serverOutputWaitFactor' property value has changed. -serverOutputWaitFactorChanged :: MonadComp m => Server m s a b -> Signal m Double -serverOutputWaitFactorChanged server = - mapSignalM (const $ serverOutputWaitFactor server) (serverOutputWaitFactorChanged_ server) - --- | Signal when the 'serverOutputWaitFactor' property value has changed. -serverOutputWaitFactorChanged_ :: MonadComp m => Server m s a b -> Signal m () -serverOutputWaitFactorChanged_ server = - mapSignal (const ()) (serverInputReceived server) <> - mapSignal (const ()) (serverTaskProcessed server) <> - mapSignal (const ()) (serverOutputProvided server) - --- | Raised when the server receives a new input task. -serverInputReceived :: MonadComp m => Server m s a b -> Signal m a -serverInputReceived = publishSignal . serverInputReceivedSource - --- | Raised when the server has just processed the task. -serverTaskProcessed :: MonadComp m => Server m s a b -> Signal m (a, b) -serverTaskProcessed = publishSignal . serverTaskProcessedSource - --- | Raised when the server has just delivered the output. -serverOutputProvided :: MonadComp m => Server m s a b -> Signal m (a, b) -serverOutputProvided = publishSignal . serverOutputProvidedSource - --- | Signal whenever any property of the server changes. -serverChanged_ :: MonadComp m => Server m s a b -> Signal m () -serverChanged_ server = - mapSignal (const ()) (serverInputReceived server) <> - mapSignal (const ()) (serverTaskProcessed server) <> - mapSignal (const ()) (serverOutputProvided server) - --- | Return the summary for the server with desciption of its --- properties and activities using the specified indent. -serverSummary :: MonadComp m => Server m s a b -> Int -> Event m ShowS -serverSummary server indent = - Event $ \p -> - do tx1 <- readProtoRef (serverTotalInputWaitTimeRef server) - tx2 <- readProtoRef (serverTotalProcessingTimeRef server) - tx3 <- readProtoRef (serverTotalOutputWaitTimeRef server) - let xf1 = tx1 / (tx1 + tx2 + tx3) - xf2 = tx2 / (tx1 + tx2 + tx3) - xf3 = tx3 / (tx1 + tx2 + tx3) - xs1 <- readProtoRef (serverInputWaitTimeRef server) - xs2 <- readProtoRef (serverProcessingTimeRef server) - xs3 <- readProtoRef (serverOutputWaitTimeRef server) - let tab = replicate indent ' ' - return $ - showString tab . - showString "total input wait time (locked while awaiting the input) = " . shows tx1 . - showString "\n" . - showString tab . - showString "total processing time = " . shows tx2 . - showString "\n" . - showString tab . - showString "total output wait time (locked while delivering the output) = " . shows tx3 . - showString "\n\n" . - showString tab . - showString "input wait factor (from 0 to 1) = " . shows xf1 . - showString "\n" . - showString tab . - showString "processing factor (from 0 to 1) = " . shows xf2 . - showString "\n" . - showString tab . - showString "output wait factor (from 0 to 1) = " . shows xf3 . - showString "\n\n" . - showString tab . - showString "input wait time (locked while awaiting the input):\n\n" . - samplingStatsSummary xs1 (2 + indent) . - showString "\n\n" . - showString tab . - showString "processing time:\n\n" . - samplingStatsSummary xs2 (2 + indent) . - showString "\n\n" . - showString tab . - showString "output wait time (locked while delivering the output):\n\n" . - samplingStatsSummary xs3 (2 + indent) + +-- | +-- Module : Simulation.Aivika.Trans.Server +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It models the server that prodives a service. +module Simulation.Aivika.Trans.Server + (-- * Server + Server, + newServer, + newStateServer, + -- * Processing + serverProcessor, + -- * Server Properties and Activities + serverInitState, + serverState, + serverTotalInputWaitTime, + serverTotalProcessingTime, + serverTotalOutputWaitTime, + serverInputWaitTime, + serverProcessingTime, + serverOutputWaitTime, + serverInputWaitFactor, + serverProcessingFactor, + serverOutputWaitFactor, + -- * Summary + serverSummary, + -- * Derived Signals for Properties + serverStateChanged, + serverStateChanged_, + serverTotalInputWaitTimeChanged, + serverTotalInputWaitTimeChanged_, + serverTotalProcessingTimeChanged, + serverTotalProcessingTimeChanged_, + serverTotalOutputWaitTimeChanged, + serverTotalOutputWaitTimeChanged_, + serverInputWaitTimeChanged, + serverInputWaitTimeChanged_, + serverProcessingTimeChanged, + serverProcessingTimeChanged_, + serverOutputWaitTimeChanged, + serverOutputWaitTimeChanged_, + serverInputWaitFactorChanged, + serverInputWaitFactorChanged_, + serverProcessingFactorChanged, + serverProcessingFactorChanged_, + serverOutputWaitFactorChanged, + serverOutputWaitFactorChanged_, + -- * Basic Signals + serverInputReceived, + serverTaskProcessed, + serverOutputProvided, + -- * Overall Signal + serverChanged_) where + +import Data.Monoid + +import Control.Arrow + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Parameter +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Signal +import Simulation.Aivika.Trans.Resource +import Simulation.Aivika.Trans.Cont +import Simulation.Aivika.Trans.Process +import Simulation.Aivika.Trans.Processor +import Simulation.Aivika.Trans.Stream +import Simulation.Aivika.Trans.Statistics + +-- | It models a server that takes @a@ and provides @b@ having state @s@ within underlying computation @m@. +data Server m s a b = + Server { serverInitState :: s, + -- ^ The initial state of the server. + serverStateRef :: ProtoRef m s, + -- ^ The current state of the server. + serverProcess :: s -> a -> Process m (s, b), + -- ^ Provide @b@ by specified @a@. + serverTotalInputWaitTimeRef :: ProtoRef m Double, + -- ^ The counted total time spent in awating the input. + serverTotalProcessingTimeRef :: ProtoRef m Double, + -- ^ The counted total time spent to process the input and prepare the output. + serverTotalOutputWaitTimeRef :: ProtoRef m Double, + -- ^ The counted total time spent for delivering the output. + serverInputWaitTimeRef :: ProtoRef m (SamplingStats Double), + -- ^ The statistics for the time spent in awaiting the input. + serverProcessingTimeRef :: ProtoRef m (SamplingStats Double), + -- ^ The statistics for the time spent to process the input and prepare the output. + serverOutputWaitTimeRef :: ProtoRef m (SamplingStats Double), + -- ^ The statistics for the time spent for delivering the output. + serverInputReceivedSource :: SignalSource m a, + -- ^ A signal raised when the server recieves a new input to process. + serverTaskProcessedSource :: SignalSource m (a, b), + -- ^ A signal raised when the input is processed and + -- the output is prepared for deliverying. + serverOutputProvidedSource :: SignalSource m (a, b) + -- ^ A signal raised when the server has supplied the output. + } + +-- | Create a new server that can provide output @b@ by input @a@. +newServer :: MonadComp m + => (a -> Process m b) + -- ^ provide an output by the specified input + -> Simulation m (Server m () a b) +newServer provide = + flip newStateServer () $ \s a -> + do b <- provide a + return (s, b) + +-- | Create a new server that can provide output @b@ by input @a@ +-- starting from state @s@. +newStateServer :: MonadComp m + => (s -> a -> Process m (s, b)) + -- ^ provide a new state and output by the specified + -- old state and input + -> s + -- ^ the initial state + -> Simulation m (Server m s a b) +newStateServer provide state = + do sn <- liftParameter simulationSession + r0 <- liftComp $ newProtoRef sn state + r1 <- liftComp $ newProtoRef sn 0 + r2 <- liftComp $ newProtoRef sn 0 + r3 <- liftComp $ newProtoRef sn 0 + r4 <- liftComp $ newProtoRef sn emptySamplingStats + r5 <- liftComp $ newProtoRef sn emptySamplingStats + r6 <- liftComp $ newProtoRef sn emptySamplingStats + s1 <- newSignalSource + s2 <- newSignalSource + s3 <- newSignalSource + let server = Server { serverInitState = state, + serverStateRef = r0, + serverProcess = provide, + serverTotalInputWaitTimeRef = r1, + serverTotalProcessingTimeRef = r2, + serverTotalOutputWaitTimeRef = r3, + serverInputWaitTimeRef = r4, + serverProcessingTimeRef = r5, + serverOutputWaitTimeRef = r6, + serverInputReceivedSource = s1, + serverTaskProcessedSource = s2, + serverOutputProvidedSource = s3 } + return server + +-- | Return a processor for the specified server. +-- +-- The processor updates the internal state of the server. The usual case is when +-- the processor is applied only once in a chain of data processing. Otherwise; +-- every time the processor is used, the state of the server changes. Sometimes +-- it can be indeed useful if you want to aggregate the statistics for different +-- servers simultaneously, but it would be more preferable to avoid this. +-- +-- If you connect different server processors returned by this function in a chain +-- with help of '>>>' or other category combinator then this chain will act as one +-- whole, where the first server will take a new task only after the last server +-- finishes its current task and requests for the next one from the previous processor +-- in the chain. This is not always that thing you might need. +-- +-- To model a sequence of the server processors working independently, you +-- should use the 'processorSeq' function which separates the processors with help of +-- the 'prefetchProcessor' that plays a role of a small one-place buffer in that case. +-- +-- The queue processors usually have the prefetching capabilities per se, where +-- the items are already stored in the queue. Therefore, the server processor +-- should not be prefetched if it is connected directly with the queue processor. +serverProcessor :: MonadComp m => Server m s a b -> Processor m a b +serverProcessor server = + Processor $ \xs -> loop (serverInitState server) Nothing xs + where + loop s r xs = + Cons $ + do t0 <- liftDynamics time + liftEvent $ + case r of + Nothing -> return () + Just (t', a', b') -> + do liftComp $ + do modifyProtoRef' (serverTotalOutputWaitTimeRef server) (+ (t0 - t')) + modifyProtoRef' (serverOutputWaitTimeRef server) $ + addSamplingStats (t0 - t') + triggerSignal (serverOutputProvidedSource server) (a', b') + -- get input + (a, xs') <- runStream xs + t1 <- liftDynamics time + liftEvent $ + do liftComp $ + do modifyProtoRef' (serverTotalInputWaitTimeRef server) (+ (t1 - t0)) + modifyProtoRef' (serverInputWaitTimeRef server) $ + addSamplingStats (t1 - t0) + triggerSignal (serverInputReceivedSource server) a + -- provide the service + (s', b) <- serverProcess server s a + t2 <- liftDynamics time + liftEvent $ + do liftComp $ + do writeProtoRef (serverStateRef server) $! s' + modifyProtoRef' (serverTotalProcessingTimeRef server) (+ (t2 - t1)) + modifyProtoRef' (serverProcessingTimeRef server) $ + addSamplingStats (t2 - t1) + triggerSignal (serverTaskProcessedSource server) (a, b) + return (b, loop s' (Just (t2, a, b)) xs') + +-- | Return the current state of the server. +-- +-- See also 'serverStateChanged' and 'serverStateChanged_'. +serverState :: MonadComp m => Server m s a b -> Event m s +serverState server = + Event $ \p -> readProtoRef (serverStateRef server) + +-- | Signal when the 'serverState' property value has changed. +serverStateChanged :: MonadComp m => Server m s a b -> Signal m s +serverStateChanged server = + mapSignalM (const $ serverState server) (serverStateChanged_ server) + +-- | Signal when the 'serverState' property value has changed. +serverStateChanged_ :: MonadComp m => Server m s a b -> Signal m () +serverStateChanged_ server = + mapSignal (const ()) (serverTaskProcessed server) + +-- | Return the counted total time when the server was locked while awaiting the input. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverTotalInputWaitTimeChanged' and 'serverTotalInputWaitTimeChanged_'. +serverTotalInputWaitTime :: MonadComp m => Server m s a b -> Event m Double +serverTotalInputWaitTime server = + Event $ \p -> readProtoRef (serverTotalInputWaitTimeRef server) + +-- | Signal when the 'serverTotalInputWaitTime' property value has changed. +serverTotalInputWaitTimeChanged :: MonadComp m => Server m s a b -> Signal m Double +serverTotalInputWaitTimeChanged server = + mapSignalM (const $ serverTotalInputWaitTime server) (serverTotalInputWaitTimeChanged_ server) + +-- | Signal when the 'serverTotalInputWaitTime' property value has changed. +serverTotalInputWaitTimeChanged_ :: MonadComp m => Server m s a b -> Signal m () +serverTotalInputWaitTimeChanged_ server = + mapSignal (const ()) (serverInputReceived server) + +-- | Return the counted total time spent by the server while processing the tasks. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverTotalProcessingTimeChanged' and 'serverTotalProcessingTimeChanged_'. +serverTotalProcessingTime :: MonadComp m => Server m s a b -> Event m Double +serverTotalProcessingTime server = + Event $ \p -> readProtoRef (serverTotalProcessingTimeRef server) + +-- | Signal when the 'serverTotalProcessingTime' property value has changed. +serverTotalProcessingTimeChanged :: MonadComp m => Server m s a b -> Signal m Double +serverTotalProcessingTimeChanged server = + mapSignalM (const $ serverTotalProcessingTime server) (serverTotalProcessingTimeChanged_ server) + +-- | Signal when the 'serverTotalProcessingTime' property value has changed. +serverTotalProcessingTimeChanged_ :: MonadComp m => Server m s a b -> Signal m () +serverTotalProcessingTimeChanged_ server = + mapSignal (const ()) (serverTaskProcessed server) + +-- | Return the counted total time when the server was locked while trying +-- to deliver the output. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverTotalOutputWaitTimeChanged' and 'serverTotalOutputWaitTimeChanged_'. +serverTotalOutputWaitTime :: MonadComp m => Server m s a b -> Event m Double +serverTotalOutputWaitTime server = + Event $ \p -> readProtoRef (serverTotalOutputWaitTimeRef server) + +-- | Signal when the 'serverTotalOutputWaitTime' property value has changed. +serverTotalOutputWaitTimeChanged :: MonadComp m => Server m s a b -> Signal m Double +serverTotalOutputWaitTimeChanged server = + mapSignalM (const $ serverTotalOutputWaitTime server) (serverTotalOutputWaitTimeChanged_ server) + +-- | Signal when the 'serverTotalOutputWaitTime' property value has changed. +serverTotalOutputWaitTimeChanged_ :: MonadComp m => Server m s a b -> Signal m () +serverTotalOutputWaitTimeChanged_ server = + mapSignal (const ()) (serverOutputProvided server) + +-- | Return the statistics of the time when the server was locked while awaiting the input. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverInputWaitTimeChanged' and 'serverInputWaitTimeChanged_'. +serverInputWaitTime :: MonadComp m => Server m s a b -> Event m (SamplingStats Double) +serverInputWaitTime server = + Event $ \p -> readProtoRef (serverInputWaitTimeRef server) + +-- | Signal when the 'serverInputWaitTime' property value has changed. +serverInputWaitTimeChanged :: MonadComp m => Server m s a b -> Signal m (SamplingStats Double) +serverInputWaitTimeChanged server = + mapSignalM (const $ serverInputWaitTime server) (serverInputWaitTimeChanged_ server) + +-- | Signal when the 'serverInputWaitTime' property value has changed. +serverInputWaitTimeChanged_ :: MonadComp m => Server m s a b -> Signal m () +serverInputWaitTimeChanged_ server = + mapSignal (const ()) (serverInputReceived server) + +-- | Return the statistics of the time spent by the server while processing the tasks. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverProcessingTimeChanged' and 'serverProcessingTimeChanged_'. +serverProcessingTime :: MonadComp m => Server m s a b -> Event m (SamplingStats Double) +serverProcessingTime server = + Event $ \p -> readProtoRef (serverProcessingTimeRef server) + +-- | Signal when the 'serverProcessingTime' property value has changed. +serverProcessingTimeChanged :: MonadComp m => Server m s a b -> Signal m (SamplingStats Double) +serverProcessingTimeChanged server = + mapSignalM (const $ serverProcessingTime server) (serverProcessingTimeChanged_ server) + +-- | Signal when the 'serverProcessingTime' property value has changed. +serverProcessingTimeChanged_ :: MonadComp m => Server m s a b -> Signal m () +serverProcessingTimeChanged_ server = + mapSignal (const ()) (serverTaskProcessed server) + +-- | Return the statistics of the time when the server was locked while trying +-- to deliver the output. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverOutputWaitTimeChanged' and 'serverOutputWaitTimeChanged_'. +serverOutputWaitTime :: MonadComp m => Server m s a b -> Event m (SamplingStats Double) +serverOutputWaitTime server = + Event $ \p -> readProtoRef (serverOutputWaitTimeRef server) + +-- | Signal when the 'serverOutputWaitTime' property value has changed. +serverOutputWaitTimeChanged :: MonadComp m => Server m s a b -> Signal m (SamplingStats Double) +serverOutputWaitTimeChanged server = + mapSignalM (const $ serverOutputWaitTime server) (serverOutputWaitTimeChanged_ server) + +-- | Signal when the 'serverOutputWaitTime' property value has changed. +serverOutputWaitTimeChanged_ :: MonadComp m => Server m s a b -> Signal m () +serverOutputWaitTimeChanged_ server = + mapSignal (const ()) (serverOutputProvided server) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the server was awaiting for the next input task. +-- +-- This factor is calculated as +-- +-- @ +-- totalInputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime) +-- @ +-- +-- As before in this module, the value returned changes discretely and +-- it is usually delayed relative to the current simulation time. +-- +-- See also 'serverInputWaitFactorChanged' and 'serverInputWaitFactorChanged_'. +serverInputWaitFactor :: MonadComp m => Server m s a b -> Event m Double +serverInputWaitFactor server = + Event $ \p -> + do x1 <- readProtoRef (serverTotalInputWaitTimeRef server) + x2 <- readProtoRef (serverTotalProcessingTimeRef server) + x3 <- readProtoRef (serverTotalOutputWaitTimeRef server) + return (x1 / (x1 + x2 + x3)) + +-- | Signal when the 'serverInputWaitFactor' property value has changed. +serverInputWaitFactorChanged :: MonadComp m => Server m s a b -> Signal m Double +serverInputWaitFactorChanged server = + mapSignalM (const $ serverInputWaitFactor server) (serverInputWaitFactorChanged_ server) + +-- | Signal when the 'serverInputWaitFactor' property value has changed. +serverInputWaitFactorChanged_ :: MonadComp m => Server m s a b -> Signal m () +serverInputWaitFactorChanged_ server = + mapSignal (const ()) (serverInputReceived server) <> + mapSignal (const ()) (serverTaskProcessed server) <> + mapSignal (const ()) (serverOutputProvided server) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the server was busy with direct processing its tasks. +-- +-- This factor is calculated as +-- +-- @ +-- totalProcessingTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime) +-- @ +-- +-- As before in this module, the value returned changes discretely and +-- it is usually delayed relative to the current simulation time. +-- +-- See also 'serverProcessingFactorChanged' and 'serverProcessingFactorChanged_'. +serverProcessingFactor :: MonadComp m => Server m s a b -> Event m Double +serverProcessingFactor server = + Event $ \p -> + do x1 <- readProtoRef (serverTotalInputWaitTimeRef server) + x2 <- readProtoRef (serverTotalProcessingTimeRef server) + x3 <- readProtoRef (serverTotalOutputWaitTimeRef server) + return (x2 / (x1 + x2 + x3)) + +-- | Signal when the 'serverProcessingFactor' property value has changed. +serverProcessingFactorChanged :: MonadComp m => Server m s a b -> Signal m Double +serverProcessingFactorChanged server = + mapSignalM (const $ serverProcessingFactor server) (serverProcessingFactorChanged_ server) + +-- | Signal when the 'serverProcessingFactor' property value has changed. +serverProcessingFactorChanged_ :: MonadComp m => Server m s a b -> Signal m () +serverProcessingFactorChanged_ server = + mapSignal (const ()) (serverInputReceived server) <> + mapSignal (const ()) (serverTaskProcessed server) <> + mapSignal (const ()) (serverOutputProvided server) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the server was locked trying to deliver the output after the task is finished. +-- +-- This factor is calculated as +-- +-- @ +-- totalOutputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime) +-- @ +-- +-- As before in this module, the value returned changes discretely and +-- it is usually delayed relative to the current simulation time. +-- +-- See also 'serverOutputWaitFactorChanged' and 'serverOutputWaitFactorChanged_'. +serverOutputWaitFactor :: MonadComp m => Server m s a b -> Event m Double +serverOutputWaitFactor server = + Event $ \p -> + do x1 <- readProtoRef (serverTotalInputWaitTimeRef server) + x2 <- readProtoRef (serverTotalProcessingTimeRef server) + x3 <- readProtoRef (serverTotalOutputWaitTimeRef server) + return (x3 / (x1 + x2 + x3)) + +-- | Signal when the 'serverOutputWaitFactor' property value has changed. +serverOutputWaitFactorChanged :: MonadComp m => Server m s a b -> Signal m Double +serverOutputWaitFactorChanged server = + mapSignalM (const $ serverOutputWaitFactor server) (serverOutputWaitFactorChanged_ server) + +-- | Signal when the 'serverOutputWaitFactor' property value has changed. +serverOutputWaitFactorChanged_ :: MonadComp m => Server m s a b -> Signal m () +serverOutputWaitFactorChanged_ server = + mapSignal (const ()) (serverInputReceived server) <> + mapSignal (const ()) (serverTaskProcessed server) <> + mapSignal (const ()) (serverOutputProvided server) + +-- | Raised when the server receives a new input task. +serverInputReceived :: MonadComp m => Server m s a b -> Signal m a +serverInputReceived = publishSignal . serverInputReceivedSource + +-- | Raised when the server has just processed the task. +serverTaskProcessed :: MonadComp m => Server m s a b -> Signal m (a, b) +serverTaskProcessed = publishSignal . serverTaskProcessedSource + +-- | Raised when the server has just delivered the output. +serverOutputProvided :: MonadComp m => Server m s a b -> Signal m (a, b) +serverOutputProvided = publishSignal . serverOutputProvidedSource + +-- | Signal whenever any property of the server changes. +serverChanged_ :: MonadComp m => Server m s a b -> Signal m () +serverChanged_ server = + mapSignal (const ()) (serverInputReceived server) <> + mapSignal (const ()) (serverTaskProcessed server) <> + mapSignal (const ()) (serverOutputProvided server) + +-- | Return the summary for the server with desciption of its +-- properties and activities using the specified indent. +serverSummary :: MonadComp m => Server m s a b -> Int -> Event m ShowS +serverSummary server indent = + Event $ \p -> + do tx1 <- readProtoRef (serverTotalInputWaitTimeRef server) + tx2 <- readProtoRef (serverTotalProcessingTimeRef server) + tx3 <- readProtoRef (serverTotalOutputWaitTimeRef server) + let xf1 = tx1 / (tx1 + tx2 + tx3) + xf2 = tx2 / (tx1 + tx2 + tx3) + xf3 = tx3 / (tx1 + tx2 + tx3) + xs1 <- readProtoRef (serverInputWaitTimeRef server) + xs2 <- readProtoRef (serverProcessingTimeRef server) + xs3 <- readProtoRef (serverOutputWaitTimeRef server) + let tab = replicate indent ' ' + return $ + showString tab . + showString "total input wait time (locked while awaiting the input) = " . shows tx1 . + showString "\n" . + showString tab . + showString "total processing time = " . shows tx2 . + showString "\n" . + showString tab . + showString "total output wait time (locked while delivering the output) = " . shows tx3 . + showString "\n\n" . + showString tab . + showString "input wait factor (from 0 to 1) = " . shows xf1 . + showString "\n" . + showString tab . + showString "processing factor (from 0 to 1) = " . shows xf2 . + showString "\n" . + showString tab . + showString "output wait factor (from 0 to 1) = " . shows xf3 . + showString "\n\n" . + showString tab . + showString "input wait time (locked while awaiting the input):\n\n" . + samplingStatsSummary xs1 (2 + indent) . + showString "\n\n" . + showString tab . + showString "processing time:\n\n" . + samplingStatsSummary xs2 (2 + indent) . + showString "\n\n" . + showString tab . + showString "output wait time (locked while delivering the output):\n\n" . + samplingStatsSummary xs3 (2 + indent) diff --git a/Simulation/Aivika/Trans/Session.hs b/Simulation/Aivika/Trans/Session.hs --- a/Simulation/Aivika/Trans/Session.hs +++ b/Simulation/Aivika/Trans/Session.hs @@ -1,56 +1,56 @@ - -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Simulation.Aivika.Trans.Session --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It identifies a current simulation session usually associated with the current simulation run. --- -module Simulation.Aivika.Trans.Session - (SessionMonad(..), - Session(..)) where - -import Data.IORef - --- | A monad within which computation we can create and work with a simulation session. -class (Functor m, Monad m) => SessionMonad m where - - -- | A simulation session. - data Session m :: * - - -- | A marker that exists with the session and which can be compared for equality. - data SessionMarker m :: * - - -- | Create a new session. - newSession :: m (Session m) - - -- | Create a new marker within the current session. - newSessionMarker :: Session m -> m (SessionMarker m) - - -- | Compare two markers for equality. - equalSessionMarker :: SessionMarker m -> SessionMarker m -> Bool - -instance SessionMonad IO where - - data Session IO = Session - - newtype SessionMarker IO = SessionMarker (IORef ()) - - {-# SPECIALISE INLINE newSession :: IO (Session IO) #-} - newSession = return Session - - {-# SPECIALISE INLINE newSessionMarker :: Session IO -> IO (SessionMarker IO) #-} - newSessionMarker session = fmap SessionMarker $ newIORef () - - {-# SPECIALISE INLINE equalSessionMarker :: SessionMarker IO -> SessionMarker IO -> Bool #-} - equalSessionMarker (SessionMarker x) (SessionMarker y) = x == y - -instance SessionMonad m => Eq (SessionMarker m) where - - {-# INLINE (==) #-} - (==) = equalSessionMarker + +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Simulation.Aivika.Trans.Session +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It identifies a current simulation session usually associated with the current simulation run. +-- +module Simulation.Aivika.Trans.Session + (SessionMonad(..), + Session(..)) where + +import Data.IORef + +-- | A monad within which computation we can create and work with a simulation session. +class (Functor m, Monad m) => SessionMonad m where + + -- | A simulation session. + data Session m :: * + + -- | A marker that exists with the session and which can be compared for equality. + data SessionMarker m :: * + + -- | Create a new session. + newSession :: m (Session m) + + -- | Create a new marker within the current session. + newSessionMarker :: Session m -> m (SessionMarker m) + + -- | Compare two markers for equality. + equalSessionMarker :: SessionMarker m -> SessionMarker m -> Bool + +instance SessionMonad IO where + + data Session IO = Session + + newtype SessionMarker IO = SessionMarker (IORef ()) + + {-# SPECIALISE INLINE newSession :: IO (Session IO) #-} + newSession = return Session + + {-# SPECIALISE INLINE newSessionMarker :: Session IO -> IO (SessionMarker IO) #-} + newSessionMarker session = fmap SessionMarker $ newIORef () + + {-# SPECIALISE INLINE equalSessionMarker :: SessionMarker IO -> SessionMarker IO -> Bool #-} + equalSessionMarker (SessionMarker x) (SessionMarker y) = x == y + +instance SessionMonad m => Eq (SessionMarker m) where + + {-# INLINE (==) #-} + (==) = equalSessionMarker diff --git a/Simulation/Aivika/Trans/Signal.hs b/Simulation/Aivika/Trans/Signal.hs --- a/Simulation/Aivika/Trans/Signal.hs +++ b/Simulation/Aivika/Trans/Signal.hs @@ -1,53 +1,53 @@ - --- | --- Module : Simulation.Aivika.Trans.Signal --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines the signal which we can subscribe handlers to. --- These handlers can be disposed. The signal is triggered in the --- current time point actuating the corresponded computations from --- the handlers. --- -module Simulation.Aivika.Trans.Signal - (-- * Handling and Triggering Signal - Signal(..), - handleSignal_, - SignalSource, - newSignalSource, - publishSignal, - triggerSignal, - -- * Useful Combinators - mapSignal, - mapSignalM, - apSignal, - filterSignal, - filterSignalM, - emptySignal, - merge2Signals, - merge3Signals, - merge4Signals, - merge5Signals, - -- * Signal Arriving - arrivalSignal, - -- * Creating Signal in Time Points - newSignalInTimes, - newSignalInIntegTimes, - newSignalInStartTime, - newSignalInStopTime, - -- * Signal History - SignalHistory, - signalHistorySignal, - newSignalHistory, - newSignalHistoryStartingWith, - readSignalHistory, - -- * Signalable Computations - Signalable(..), - signalableChanged, - emptySignalable, - appendSignalable) where - -import Simulation.Aivika.Trans.Internal.Signal + +-- | +-- Module : Simulation.Aivika.Trans.Signal +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the signal which we can subscribe handlers to. +-- These handlers can be disposed. The signal is triggered in the +-- current time point actuating the corresponded computations from +-- the handlers. +-- +module Simulation.Aivika.Trans.Signal + (-- * Handling and Triggering Signal + Signal(..), + handleSignal_, + SignalSource, + newSignalSource, + publishSignal, + triggerSignal, + -- * Useful Combinators + mapSignal, + mapSignalM, + apSignal, + filterSignal, + filterSignalM, + emptySignal, + merge2Signals, + merge3Signals, + merge4Signals, + merge5Signals, + -- * Signal Arriving + arrivalSignal, + -- * Creating Signal in Time Points + newSignalInTimes, + newSignalInIntegTimes, + newSignalInStartTime, + newSignalInStopTime, + -- * Signal History + SignalHistory, + signalHistorySignal, + newSignalHistory, + newSignalHistoryStartingWith, + readSignalHistory, + -- * Signalable Computations + Signalable(..), + signalableChanged, + emptySignalable, + appendSignalable) where + +import Simulation.Aivika.Trans.Internal.Signal 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,26 +1,26 @@ - --- | --- Module : Simulation.Aivika.Trans.Simulation --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines the 'SimulationT' monad transformer that represents a simulation run. --- -module Simulation.Aivika.Trans.Simulation - (-- * Simulation - Simulation, - SimulationLift(..), - runSimulation, - runSimulations, - -- * Error Handling - catchSimulation, - finallySimulation, - throwSimulation, - -- * Memoization - memoSimulation) where - -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Simulation + +-- | +-- Module : Simulation.Aivika.Trans.Simulation +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the 'SimulationT' monad transformer that represents a simulation run. +-- +module Simulation.Aivika.Trans.Simulation + (-- * Simulation + Simulation, + SimulationLift(..), + runSimulation, + runSimulations, + -- * Error Handling + catchSimulation, + finallySimulation, + throwSimulation, + -- * Memoization + memoSimulation) where + +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Simulation diff --git a/Simulation/Aivika/Trans/Specs.hs b/Simulation/Aivika/Trans/Specs.hs --- a/Simulation/Aivika/Trans/Specs.hs +++ b/Simulation/Aivika/Trans/Specs.hs @@ -1,25 +1,25 @@ - --- | --- Module : Simulation.Aivika.Trans.Specs --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It defines the simulation specs and functions for this data type. -module Simulation.Aivika.Trans.Specs - (-- * Simulation Specs - Specs(..), - Method(..), - -- * Auxiliary Functions - basicTime, - integIterationBnds, - integIterationHiBnd, - integIterationLoBnd, - integPhaseBnds, - integPhaseHiBnd, - integPhaseLoBnd, - integTimes) where - -import Simulation.Aivika.Trans.Internal.Specs + +-- | +-- Module : Simulation.Aivika.Trans.Specs +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It defines the simulation specs and functions for this data type. +module Simulation.Aivika.Trans.Specs + (-- * Simulation Specs + Specs(..), + Method(..), + -- * Auxiliary Functions + basicTime, + integIterationBnds, + integIterationHiBnd, + integIterationLoBnd, + integPhaseBnds, + integPhaseHiBnd, + integPhaseLoBnd, + integTimes) where + +import Simulation.Aivika.Trans.Internal.Specs diff --git a/Simulation/Aivika/Trans/Statistics.hs b/Simulation/Aivika/Trans/Statistics.hs --- a/Simulation/Aivika/Trans/Statistics.hs +++ b/Simulation/Aivika/Trans/Statistics.hs @@ -1,32 +1,32 @@ - --- | --- Module : Simulation.Aivika.Trans.Statistics --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- Represents statistics. --- - -module Simulation.Aivika.Trans.Statistics - (-- * Simple Statistics - SamplingStats(..), - SamplingData(..), - combineSamplingStatsEither, - samplingStatsVariance, - samplingStatsDeviation, - samplingStatsSummary, - returnSamplingStats, - listSamplingStats, - fromIntSamplingStats, - -- * Timing Statistics - TimingStats(..), - TimingData(..), - timingStatsDeviation, - timingStatsSummary, - returnTimingStats, - fromIntTimingStats) where - -import Simulation.Aivika.Statistics + +-- | +-- Module : Simulation.Aivika.Trans.Statistics +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- Represents statistics. +-- + +module Simulation.Aivika.Trans.Statistics + (-- * Simple Statistics + SamplingStats(..), + SamplingData(..), + combineSamplingStatsEither, + samplingStatsVariance, + samplingStatsDeviation, + samplingStatsSummary, + returnSamplingStats, + listSamplingStats, + fromIntSamplingStats, + -- * Timing Statistics + TimingStats(..), + TimingData(..), + timingStatsDeviation, + timingStatsSummary, + returnTimingStats, + fromIntTimingStats) where + +import Simulation.Aivika.Statistics diff --git a/Simulation/Aivika/Trans/Statistics/Accumulator.hs b/Simulation/Aivika/Trans/Statistics/Accumulator.hs --- a/Simulation/Aivika/Trans/Statistics/Accumulator.hs +++ b/Simulation/Aivika/Trans/Statistics/Accumulator.hs @@ -1,45 +1,45 @@ - --- | --- Module : Simulation.Aivika.Trans.Statistics.Accumulator --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This small utility module allows accumulating the timing statistics based on 'Signalable' data --- such as the queue size or the number of lost items in the queue. --- - -module Simulation.Aivika.Trans.Statistics.Accumulator - (-- * Timing Statistics Accumulator - TimingStatsAccumulator, - newTimingStatsAccumulator, - timingStatsAccumulated) where - -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Simulation -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Event -import Simulation.Aivika.Trans.Ref -import Simulation.Aivika.Trans.Statistics -import Simulation.Aivika.Trans.Signal - --- | Represents an accumulator for the timing statistics. -newtype TimingStatsAccumulator m a = - TimingStatsAccumulator { timingStatsAccumulatedRef :: Ref m (TimingStats a) } - --- | Return the accumulated statistics. -timingStatsAccumulated :: MonadComp m => TimingStatsAccumulator m a -> Event m (TimingStats a) -timingStatsAccumulated = readRef . timingStatsAccumulatedRef - --- | Start gathering the timing statistics from the current simulation time. -newTimingStatsAccumulator :: (MonadComp m, TimingData a) => Signalable m a -> Event m (TimingStatsAccumulator m a) -newTimingStatsAccumulator x = - do t0 <- liftDynamics time - a0 <- readSignalable x - r <- liftSimulation $ newRef (returnTimingStats t0 a0) - handleSignal_ (signalableChanged x) $ \a -> - do t <- liftDynamics time - modifyRef r $ addTimingStats t a - return TimingStatsAccumulator { timingStatsAccumulatedRef = r } + +-- | +-- Module : Simulation.Aivika.Trans.Statistics.Accumulator +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This small utility module allows accumulating the timing statistics based on 'Signalable' data +-- such as the queue size or the number of lost items in the queue. +-- + +module Simulation.Aivika.Trans.Statistics.Accumulator + (-- * Timing Statistics Accumulator + TimingStatsAccumulator, + newTimingStatsAccumulator, + timingStatsAccumulated) where + +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Event +import Simulation.Aivika.Trans.Ref +import Simulation.Aivika.Trans.Statistics +import Simulation.Aivika.Trans.Signal + +-- | Represents an accumulator for the timing statistics. +newtype TimingStatsAccumulator m a = + TimingStatsAccumulator { timingStatsAccumulatedRef :: Ref m (TimingStats a) } + +-- | Return the accumulated statistics. +timingStatsAccumulated :: MonadComp m => TimingStatsAccumulator m a -> Event m (TimingStats a) +timingStatsAccumulated = readRef . timingStatsAccumulatedRef + +-- | Start gathering the timing statistics from the current simulation time. +newTimingStatsAccumulator :: (MonadComp m, TimingData a) => Signalable m a -> Event m (TimingStatsAccumulator m a) +newTimingStatsAccumulator x = + do t0 <- liftDynamics time + a0 <- readSignalable x + r <- liftSimulation $ newRef (returnTimingStats t0 a0) + handleSignal_ (signalableChanged x) $ \a -> + do t <- liftDynamics time + modifyRef r $ addTimingStats t a + return TimingStatsAccumulator { timingStatsAccumulatedRef = r } 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 @@ -1,550 +1,550 @@ - -{-# LANGUAGE FlexibleContexts #-} - --- | --- Module : Simulation.Aivika.Trans.Stream --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The infinite stream of data in time. --- -module Simulation.Aivika.Trans.Stream - (-- * Stream Type - Stream(..), - -- * Merging and Splitting Stream - emptyStream, - mergeStreams, - mergeQueuedStreams, - mergePriorityStreams, - concatStreams, - concatQueuedStreams, - concatPriorityStreams, - splitStream, - splitStreamQueueing, - splitStreamPrioritising, - -- * Specifying Identifier - streamUsingId, - -- * Prefetching and Delaying Stream - prefetchStream, - delayStream, - -- * Stream Arriving - arrivalStream, - -- * Memoizing, Zipping and Uzipping Stream - memoStream, - zipStreamSeq, - zipStreamParallel, - zip3StreamSeq, - zip3StreamParallel, - unzipStream, - streamSeq, - streamParallel, - -- * Consuming and Sinking Stream - consumeStream, - sinkStream, - -- * Useful Combinators - repeatProcess, - mapStream, - mapStreamM, - apStream, - apStreamM, - filterStream, - filterStreamM, - -- * Integrating with Signals - signalStream, - streamSignal, - -- * Utilities - leftStream, - rightStream, - replaceLeftStream, - replaceRightStream, - partitionEitherStream) where - -import Data.Maybe -import Data.Monoid - -import Control.Applicative -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Parameter -import Simulation.Aivika.Trans.Simulation -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Event -import Simulation.Aivika.Trans.Cont -import Simulation.Aivika.Trans.Process -import Simulation.Aivika.Trans.Signal -import Simulation.Aivika.Trans.Resource -import Simulation.Aivika.Trans.QueueStrategy -import Simulation.Aivika.Trans.Queue.Infinite -import Simulation.Aivika.Arrival (Arrival(..)) - --- | Represents an infinite stream of data in time, --- some kind of never-ending cons cell. -newtype Stream m a = Cons { runStream :: Process m (a, Stream m a) - -- ^ Run the stream. - } - -instance MonadComp m => Functor (Stream m) where - - {-# INLINE fmap #-} - fmap = mapStream - -instance MonadComp m => Applicative (Stream m) where - - {-# INLINE pure #-} - pure a = let y = Cons (return (a, y)) in y - - {-# INLINE (<*>) #-} - (<*>) = apStream - -instance MonadComp m => Monoid (Stream m a) where - - {-# INLINE mempty #-} - mempty = emptyStream - - {-# INLINE mappend #-} - mappend = mergeStreams - - {-# INLINE mconcat #-} - mconcat = concatStreams - --- | Create a stream that will use the specified process identifier. --- It can be useful to refer to the underlying 'Process' computation which --- can be passivated, interrupted, canceled and so on. See also the --- 'processUsingId' function for more details. -streamUsingId :: MonadComp m => ProcessId m -> Stream m a -> Stream m a -streamUsingId pid (Cons s) = - Cons $ processUsingId pid s - --- | Memoize the stream so that it would always return the same data --- within the simulation run. -memoStream :: MonadComp m => Stream m a -> Simulation m (Stream m a) -memoStream (Cons s) = - do p <- memoProcess $ - do ~(x, xs) <- s - xs' <- liftSimulation $ memoStream xs - return (x, xs') - return (Cons p) - --- | Zip two streams trying to get data sequentially. -zipStreamSeq :: MonadComp m => Stream m a -> Stream m b -> Stream m (a, b) -zipStreamSeq (Cons sa) (Cons sb) = Cons y where - y = do ~(x, xs) <- sa - ~(y, ys) <- sb - return ((x, y), zipStreamSeq xs ys) - --- | Zip two streams trying to get data as soon as possible, --- launching the sub-processes in parallel. -zipStreamParallel :: MonadComp m => Stream m a -> Stream m b -> Stream m (a, b) -zipStreamParallel (Cons sa) (Cons sb) = Cons y where - y = do ~((x, xs), (y, ys)) <- zipProcessParallel sa sb - return ((x, y), zipStreamParallel xs ys) - --- | Zip three streams trying to get data sequentially. -zip3StreamSeq :: MonadComp m => Stream m a -> Stream m b -> Stream m c -> Stream m (a, b, c) -zip3StreamSeq (Cons sa) (Cons sb) (Cons sc) = Cons y where - y = do ~(x, xs) <- sa - ~(y, ys) <- sb - ~(z, zs) <- sc - return ((x, y, z), zip3StreamSeq xs ys zs) - --- | Zip three streams trying to get data as soon as possible, --- launching the sub-processes in parallel. -zip3StreamParallel :: MonadComp m => Stream m a -> Stream m b -> Stream m c -> Stream m (a, b, c) -zip3StreamParallel (Cons sa) (Cons sb) (Cons sc) = Cons y where - y = do ~((x, xs), (y, ys), (z, zs)) <- zip3ProcessParallel sa sb sc - return ((x, y, z), zip3StreamParallel xs ys zs) - --- | Unzip the stream. -unzipStream :: MonadComp m => Stream m (a, b) -> Simulation m (Stream m a, Stream m b) -unzipStream s = - do s' <- memoStream s - let sa = mapStream fst s' - sb = mapStream snd s' - return (sa, sb) - --- | To form each new portion of data for the output stream, --- read data sequentially from the input streams. --- --- This is a generalization of 'zipStreamSeq'. -streamSeq :: MonadComp m => [Stream m a] -> Stream m [a] -streamSeq xs = Cons y where - y = do ps <- forM xs runStream - return (map fst ps, streamSeq $ map snd ps) - --- | To form each new portion of data for the output stream, --- read data from the input streams in parallel. --- --- This is a generalization of 'zipStreamParallel'. -streamParallel :: MonadComp m => [Stream m a] -> Stream m [a] -streamParallel xs = Cons y where - y = do ps <- processParallel $ map runStream xs - return (map fst ps, streamParallel $ map snd ps) - --- | Return a stream of values generated by the specified process. -repeatProcess :: MonadComp m => Process m a -> Stream m a -repeatProcess p = Cons y where - y = do a <- p - return (a, repeatProcess p) - --- | Map the stream according the specified function. -mapStream :: MonadComp m => (a -> b) -> Stream m a -> Stream m b -mapStream f (Cons s) = Cons y where - y = do (a, xs) <- s - return (f a, mapStream f xs) - --- | Compose the stream. -mapStreamM :: MonadComp m => (a -> Process m b) -> Stream m a -> Stream m b -mapStreamM f (Cons s) = Cons y where - y = do (a, xs) <- s - b <- f a - return (b, mapStreamM f xs) - --- | Sequential application. -apStream :: MonadComp m => Stream m (a -> b) -> Stream m a -> Stream m b -apStream (Cons sf) (Cons sa) = Cons y where - y = do (f, sf') <- sf - (a, sa') <- sa - return (f a, apStream sf' sa') - --- | Sequential application. -apStreamM :: MonadComp m => Stream m (a -> Process m b) -> Stream m a -> Stream m b -apStreamM (Cons sf) (Cons sa) = Cons y where - y = do (f, sf') <- sf - (a, sa') <- sa - x <- f a - return (x, apStreamM sf' sa') - --- | Filter only those data values that satisfy to the specified predicate. -filterStream :: MonadComp m => (a -> Bool) -> Stream m a -> Stream m a -filterStream p (Cons s) = Cons y where - y = do (a, xs) <- s - if p a - then return (a, filterStream p xs) - else let Cons z = filterStream p xs in z - --- | Filter only those data values that satisfy to the specified predicate. -filterStreamM :: MonadComp m => (a -> Process m Bool) -> Stream m a -> Stream m a -filterStreamM p (Cons s) = Cons y where - y = do (a, xs) <- s - b <- p a - if b - then return (a, filterStreamM p xs) - else let Cons z = filterStreamM p xs in z - --- | The stream of 'Left' values. -leftStream :: MonadComp m => Stream m (Either a b) -> Stream m a -leftStream (Cons s) = Cons y where - y = do (a, xs) <- s - case a of - Left a -> return (a, leftStream xs) - Right _ -> let Cons z = leftStream xs in z - --- | The stream of 'Right' values. -rightStream :: MonadComp m => Stream m (Either a b) -> Stream m b -rightStream (Cons s) = Cons y where - y = do (a, xs) <- s - case a of - Left _ -> let Cons z = rightStream xs in z - Right a -> return (a, rightStream xs) - --- | Replace the 'Left' values. -replaceLeftStream :: MonadComp m => Stream m (Either a b) -> Stream m c -> Stream m (Either c b) -replaceLeftStream (Cons sab) (ys0 @ ~(Cons sc)) = Cons z where - z = do (a, xs) <- sab - case a of - Left _ -> - do (b, ys) <- sc - return (Left b, replaceLeftStream xs ys) - Right a -> - return (Right a, replaceLeftStream xs ys0) - --- | Replace the 'Right' values. -replaceRightStream :: MonadComp m => Stream m (Either a b) -> Stream m c -> Stream m (Either a c) -replaceRightStream (Cons sab) (ys0 @ ~(Cons sc)) = Cons z where - z = do (a, xs) <- sab - case a of - Right _ -> - do (b, ys) <- sc - return (Right b, replaceRightStream xs ys) - Left a -> - return (Left a, replaceRightStream xs ys0) - --- | Partition the stream of 'Either' values into two streams. -partitionEitherStream :: MonadComp m => Stream m (Either a b) -> Simulation m (Stream m a, Stream m b) -partitionEitherStream s = - do s' <- memoStream s - return (leftStream s', rightStream s') - --- | Split the input stream into the specified number of output streams --- after applying the 'FCFS' strategy for enqueuing the output requests. -splitStream :: MonadComp m => Int -> Stream m a -> Simulation m [Stream m a] -splitStream = splitStreamQueueing FCFS - --- | Split the input stream into the specified number of output streams. --- --- If you don't know what the strategy to apply, then you probably --- need the 'FCFS' strategy, or function 'splitStream' that --- does namely this. -splitStreamQueueing :: (MonadComp m, EnqueueStrategy m s) - => s - -- ^ the strategy applied for enqueuing the output requests - -> Int - -- ^ the number of output streams - -> Stream m a - -- ^ the input stream - -> Simulation m [Stream m a] - -- ^ the splitted output streams -splitStreamQueueing s n x = - do session <- liftParameter simulationSession - ref <- liftComp $ newProtoRef session x - res <- newResource s 1 - let reader = - usingResource res $ - do p <- liftComp $ readProtoRef ref - (a, xs) <- runStream p - liftComp $ writeProtoRef ref xs - return a - return $ map (\i -> repeatProcess reader) [1..n] - --- | Split the input stream into a list of output streams --- using the specified priorities. -splitStreamPrioritising :: (MonadComp m, PriorityQueueStrategy m s p) - => s - -- ^ the strategy applied for enqueuing the output requests - -> [Stream m p] - -- ^ the streams of priorities - -> Stream m a - -- ^ the input stream - -> Simulation m [Stream m a] - -- ^ the splitted output streams -splitStreamPrioritising s ps x = - do session <- liftParameter simulationSession - ref <- liftComp $ newProtoRef session x - res <- newResource s 1 - let stream (Cons p) = Cons z where - z = do (p', ps) <- p - a <- usingResourceWithPriority res p' $ - do p <- liftComp $ readProtoRef ref - (a, xs) <- runStream p - liftComp $ writeProtoRef ref xs - return a - return (a, stream ps) - return $ map stream ps - --- | Concatenate the input streams applying the 'FCFS' strategy and --- producing one output stream. -concatStreams :: MonadComp m => [Stream m a] -> Stream m a -concatStreams = concatQueuedStreams FCFS - --- | Concatenate the input streams producing one output stream. --- --- If you don't know what the strategy to apply, then you probably --- need the 'FCFS' strategy, or function 'concatStreams' that --- does namely this. -concatQueuedStreams :: (MonadComp m, EnqueueStrategy m s) - => s - -- ^ the strategy applied for enqueuing the input data - -> [Stream m a] - -- ^ the input stream - -> Stream m a - -- ^ the combined output stream -concatQueuedStreams s streams = Cons z where - z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - writing <- liftSimulation $ newResourceWithMaxCount s 1 (Just 1) - conting <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - session <- liftParameter simulationSession - ref <- liftComp $ newProtoRef session Nothing - let writer p = - do (a, xs) <- runStream p - requestResource writing - liftComp $ writeProtoRef ref (Just a) - releaseResource reading - requestResource conting - writer xs - reader = - do requestResource reading - Just a <- liftComp $ readProtoRef ref - liftComp $ writeProtoRef ref Nothing - releaseResource writing - return a - forM_ streams $ spawnProcess CancelTogether . writer - a <- reader - let xs = repeatProcess (releaseResource conting >> reader) - return (a, xs) - --- | Concatenate the input priority streams producing one output stream. -concatPriorityStreams :: (MonadComp m, PriorityQueueStrategy m s p) - => s - -- ^ the strategy applied for enqueuing the input data - -> [Stream m (p, a)] - -- ^ the input stream - -> Stream m a - -- ^ the combined output stream -concatPriorityStreams s streams = Cons z where - z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - writing <- liftSimulation $ newResourceWithMaxCount s 1 (Just 1) - conting <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - session <- liftParameter simulationSession - ref <- liftComp $ newProtoRef session Nothing - let writer p = - do ((priority, a), xs) <- runStream p - requestResourceWithPriority writing priority - liftComp $ writeProtoRef ref (Just a) - releaseResource reading - requestResource conting - writer xs - reader = - do requestResource reading - Just a <- liftComp $ readProtoRef ref - liftComp $ writeProtoRef ref Nothing - releaseResource writing - return a - forM_ streams $ spawnProcess CancelTogether . writer - a <- reader - let xs = repeatProcess (releaseResource conting >> reader) - return (a, xs) - --- | Merge two streams applying the 'FCFS' strategy for enqueuing the input data. -mergeStreams :: MonadComp m => Stream m a -> Stream m a -> Stream m a -mergeStreams = mergeQueuedStreams FCFS - --- | Merge two streams. --- --- If you don't know what the strategy to apply, then you probably --- need the 'FCFS' strategy, or function 'mergeStreams' that --- does namely this. -mergeQueuedStreams :: (MonadComp m, EnqueueStrategy m s) - => s - -- ^ the strategy applied for enqueuing the input data - -> Stream m a - -- ^ the fist input stream - -> Stream m a - -- ^ the second input stream - -> Stream m a - -- ^ the output combined stream -mergeQueuedStreams s x y = concatQueuedStreams s [x, y] - --- | Merge two priority streams. -mergePriorityStreams :: (MonadComp m, PriorityQueueStrategy m s p) - => s - -- ^ the strategy applied for enqueuing the input data - -> Stream m (p, a) - -- ^ the fist input stream - -> Stream m (p, a) - -- ^ the second input stream - -> Stream m a - -- ^ the output combined stream -mergePriorityStreams s x y = concatPriorityStreams s [x, y] - --- | An empty stream that never returns data. -emptyStream :: MonadComp m => Stream m a -emptyStream = Cons neverProcess - --- | Consume the stream. It returns a process that infinitely reads data --- from the stream and then redirects them to the provided function. --- It is useful for modeling the process of enqueueing data in the queue --- from the input stream. -consumeStream :: MonadComp m => (a -> Process m ()) -> Stream m a -> Process m () -consumeStream f = p where - p (Cons s) = do (a, xs) <- s - f a - p xs - --- | Sink the stream. It returns a process that infinitely reads data --- from the stream. The resulting computation can be a moving force --- to simulate the whole system of the interconnected streams and --- processors. -sinkStream :: MonadComp m => Stream m a -> Process m () -sinkStream = p where - p (Cons s) = do (a, xs) <- s - p xs - --- | Prefetch the input stream requesting for one more data item in advance --- while the last received item is not yet fully processed in the chain of --- streams, usually by the processors. --- --- You can think of this as the prefetched stream could place its latest --- data item in some temporary space for later use, which is very useful --- for modeling a sequence of separate and independent work places. -prefetchStream :: MonadComp m => Stream m a -> Stream m a -prefetchStream s = Cons z where - z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - writing <- liftSimulation $ newResourceWithMaxCount FCFS 1 (Just 1) - session <- liftParameter simulationSession - ref <- liftComp $ newProtoRef session Nothing - let writer p = - do (a, xs) <- runStream p - requestResource writing - liftComp $ writeProtoRef ref (Just a) - releaseResource reading - writer xs - reader = - do requestResource reading - Just a <- liftComp $ readProtoRef ref - liftComp $ writeProtoRef ref Nothing - releaseResource writing - return a - spawnProcess CancelTogether $ writer s - runStream $ repeatProcess reader - --- | Return a stream of values triggered by the specified signal. --- --- Since the time at which the values of the stream are requested for may differ from --- the time at which the signal is triggered, it can be useful to apply the 'arrivalSignal' --- function to add the information about the time points at which the signal was --- actually received. --- --- The point is that the 'Stream' is requested outside, while the 'Signal' is triggered --- inside. They are different by nature. The former is passive, while the latter is active. --- --- The resulting stream may be a root of space leak as it uses an internal queue to store --- the values received from the signal. The oldest value is dequeued each time we request --- the stream and it is returned within the computation. --- --- Cancel the stream's process to unsubscribe from the specified signal. -signalStream :: MonadComp m => Signal m a -> Process m (Stream m a) -signalStream s = - do q <- liftEvent newFCFSQueue - h <- liftEvent $ - handleSignal s $ - enqueue q - whenCancellingProcess $ disposeEvent h - return $ repeatProcess $ dequeue q - --- | Return a computation of the signal that triggers values from the specified stream, --- each time the next value of the stream is received within the underlying 'Process' --- computation. --- --- Cancel the returned process to stop reading from the specified stream. -streamSignal :: MonadComp m => Stream m a -> Process m (Signal m a) -streamSignal z = - do s <- liftSimulation newSignalSource - spawnProcess CancelTogether $ - consumeStream (liftEvent . triggerSignal s) z - return $ publishSignal s - --- | Transform a stream so that the resulting stream returns a sequence of arrivals --- saving the information about the time points at which the original stream items --- were received by demand. -arrivalStream :: MonadComp m => Stream m a -> Stream m (Arrival a) -arrivalStream s = Cons $ loop s Nothing where - loop s t0 = do (a, xs) <- runStream s - t <- liftDynamics time - let b = Arrival { arrivalValue = a, - arrivalTime = t, - arrivalDelay = - case t0 of - Nothing -> Nothing - Just t0 -> Just (t - t0) } - return (b, Cons $ loop xs (Just t)) - --- | Delay the stream by one step using the specified initial value. -delayStream :: MonadComp m => a -> Stream m a -> Stream m a -delayStream a0 s = Cons $ return (a0, s) + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.Stream +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The infinite stream of data in time. +-- +module Simulation.Aivika.Trans.Stream + (-- * Stream Type + Stream(..), + -- * Merging and Splitting Stream + emptyStream, + mergeStreams, + mergeQueuedStreams, + mergePriorityStreams, + concatStreams, + concatQueuedStreams, + concatPriorityStreams, + splitStream, + splitStreamQueueing, + splitStreamPrioritising, + -- * Specifying Identifier + streamUsingId, + -- * Prefetching and Delaying Stream + prefetchStream, + delayStream, + -- * Stream Arriving + arrivalStream, + -- * Memoizing, Zipping and Uzipping Stream + memoStream, + zipStreamSeq, + zipStreamParallel, + zip3StreamSeq, + zip3StreamParallel, + unzipStream, + streamSeq, + streamParallel, + -- * Consuming and Sinking Stream + consumeStream, + sinkStream, + -- * Useful Combinators + repeatProcess, + mapStream, + mapStreamM, + apStream, + apStreamM, + filterStream, + filterStreamM, + -- * Integrating with Signals + signalStream, + streamSignal, + -- * Utilities + leftStream, + rightStream, + replaceLeftStream, + replaceRightStream, + partitionEitherStream) where + +import Data.Maybe +import Data.Monoid + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Parameter +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Event +import Simulation.Aivika.Trans.Cont +import Simulation.Aivika.Trans.Process +import Simulation.Aivika.Trans.Signal +import Simulation.Aivika.Trans.Resource +import Simulation.Aivika.Trans.QueueStrategy +import Simulation.Aivika.Trans.Queue.Infinite +import Simulation.Aivika.Arrival (Arrival(..)) + +-- | Represents an infinite stream of data in time, +-- some kind of never-ending cons cell. +newtype Stream m a = Cons { runStream :: Process m (a, Stream m a) + -- ^ Run the stream. + } + +instance MonadComp m => Functor (Stream m) where + + {-# INLINE fmap #-} + fmap = mapStream + +instance MonadComp m => Applicative (Stream m) where + + {-# INLINE pure #-} + pure a = let y = Cons (return (a, y)) in y + + {-# INLINE (<*>) #-} + (<*>) = apStream + +instance MonadComp m => Monoid (Stream m a) where + + {-# INLINE mempty #-} + mempty = emptyStream + + {-# INLINE mappend #-} + mappend = mergeStreams + + {-# INLINE mconcat #-} + mconcat = concatStreams + +-- | Create a stream that will use the specified process identifier. +-- It can be useful to refer to the underlying 'Process' computation which +-- can be passivated, interrupted, canceled and so on. See also the +-- 'processUsingId' function for more details. +streamUsingId :: MonadComp m => ProcessId m -> Stream m a -> Stream m a +streamUsingId pid (Cons s) = + Cons $ processUsingId pid s + +-- | Memoize the stream so that it would always return the same data +-- within the simulation run. +memoStream :: MonadComp m => Stream m a -> Simulation m (Stream m a) +memoStream (Cons s) = + do p <- memoProcess $ + do ~(x, xs) <- s + xs' <- liftSimulation $ memoStream xs + return (x, xs') + return (Cons p) + +-- | Zip two streams trying to get data sequentially. +zipStreamSeq :: MonadComp m => Stream m a -> Stream m b -> Stream m (a, b) +zipStreamSeq (Cons sa) (Cons sb) = Cons y where + y = do ~(x, xs) <- sa + ~(y, ys) <- sb + return ((x, y), zipStreamSeq xs ys) + +-- | Zip two streams trying to get data as soon as possible, +-- launching the sub-processes in parallel. +zipStreamParallel :: MonadComp m => Stream m a -> Stream m b -> Stream m (a, b) +zipStreamParallel (Cons sa) (Cons sb) = Cons y where + y = do ~((x, xs), (y, ys)) <- zipProcessParallel sa sb + return ((x, y), zipStreamParallel xs ys) + +-- | Zip three streams trying to get data sequentially. +zip3StreamSeq :: MonadComp m => Stream m a -> Stream m b -> Stream m c -> Stream m (a, b, c) +zip3StreamSeq (Cons sa) (Cons sb) (Cons sc) = Cons y where + y = do ~(x, xs) <- sa + ~(y, ys) <- sb + ~(z, zs) <- sc + return ((x, y, z), zip3StreamSeq xs ys zs) + +-- | Zip three streams trying to get data as soon as possible, +-- launching the sub-processes in parallel. +zip3StreamParallel :: MonadComp m => Stream m a -> Stream m b -> Stream m c -> Stream m (a, b, c) +zip3StreamParallel (Cons sa) (Cons sb) (Cons sc) = Cons y where + y = do ~((x, xs), (y, ys), (z, zs)) <- zip3ProcessParallel sa sb sc + return ((x, y, z), zip3StreamParallel xs ys zs) + +-- | Unzip the stream. +unzipStream :: MonadComp m => Stream m (a, b) -> Simulation m (Stream m a, Stream m b) +unzipStream s = + do s' <- memoStream s + let sa = mapStream fst s' + sb = mapStream snd s' + return (sa, sb) + +-- | To form each new portion of data for the output stream, +-- read data sequentially from the input streams. +-- +-- This is a generalization of 'zipStreamSeq'. +streamSeq :: MonadComp m => [Stream m a] -> Stream m [a] +streamSeq xs = Cons y where + y = do ps <- forM xs runStream + return (map fst ps, streamSeq $ map snd ps) + +-- | To form each new portion of data for the output stream, +-- read data from the input streams in parallel. +-- +-- This is a generalization of 'zipStreamParallel'. +streamParallel :: MonadComp m => [Stream m a] -> Stream m [a] +streamParallel xs = Cons y where + y = do ps <- processParallel $ map runStream xs + return (map fst ps, streamParallel $ map snd ps) + +-- | Return a stream of values generated by the specified process. +repeatProcess :: MonadComp m => Process m a -> Stream m a +repeatProcess p = Cons y where + y = do a <- p + return (a, repeatProcess p) + +-- | Map the stream according the specified function. +mapStream :: MonadComp m => (a -> b) -> Stream m a -> Stream m b +mapStream f (Cons s) = Cons y where + y = do (a, xs) <- s + return (f a, mapStream f xs) + +-- | Compose the stream. +mapStreamM :: MonadComp m => (a -> Process m b) -> Stream m a -> Stream m b +mapStreamM f (Cons s) = Cons y where + y = do (a, xs) <- s + b <- f a + return (b, mapStreamM f xs) + +-- | Sequential application. +apStream :: MonadComp m => Stream m (a -> b) -> Stream m a -> Stream m b +apStream (Cons sf) (Cons sa) = Cons y where + y = do (f, sf') <- sf + (a, sa') <- sa + return (f a, apStream sf' sa') + +-- | Sequential application. +apStreamM :: MonadComp m => Stream m (a -> Process m b) -> Stream m a -> Stream m b +apStreamM (Cons sf) (Cons sa) = Cons y where + y = do (f, sf') <- sf + (a, sa') <- sa + x <- f a + return (x, apStreamM sf' sa') + +-- | Filter only those data values that satisfy to the specified predicate. +filterStream :: MonadComp m => (a -> Bool) -> Stream m a -> Stream m a +filterStream p (Cons s) = Cons y where + y = do (a, xs) <- s + if p a + then return (a, filterStream p xs) + else let Cons z = filterStream p xs in z + +-- | Filter only those data values that satisfy to the specified predicate. +filterStreamM :: MonadComp m => (a -> Process m Bool) -> Stream m a -> Stream m a +filterStreamM p (Cons s) = Cons y where + y = do (a, xs) <- s + b <- p a + if b + then return (a, filterStreamM p xs) + else let Cons z = filterStreamM p xs in z + +-- | The stream of 'Left' values. +leftStream :: MonadComp m => Stream m (Either a b) -> Stream m a +leftStream (Cons s) = Cons y where + y = do (a, xs) <- s + case a of + Left a -> return (a, leftStream xs) + Right _ -> let Cons z = leftStream xs in z + +-- | The stream of 'Right' values. +rightStream :: MonadComp m => Stream m (Either a b) -> Stream m b +rightStream (Cons s) = Cons y where + y = do (a, xs) <- s + case a of + Left _ -> let Cons z = rightStream xs in z + Right a -> return (a, rightStream xs) + +-- | Replace the 'Left' values. +replaceLeftStream :: MonadComp m => Stream m (Either a b) -> Stream m c -> Stream m (Either c b) +replaceLeftStream (Cons sab) (ys0 @ ~(Cons sc)) = Cons z where + z = do (a, xs) <- sab + case a of + Left _ -> + do (b, ys) <- sc + return (Left b, replaceLeftStream xs ys) + Right a -> + return (Right a, replaceLeftStream xs ys0) + +-- | Replace the 'Right' values. +replaceRightStream :: MonadComp m => Stream m (Either a b) -> Stream m c -> Stream m (Either a c) +replaceRightStream (Cons sab) (ys0 @ ~(Cons sc)) = Cons z where + z = do (a, xs) <- sab + case a of + Right _ -> + do (b, ys) <- sc + return (Right b, replaceRightStream xs ys) + Left a -> + return (Left a, replaceRightStream xs ys0) + +-- | Partition the stream of 'Either' values into two streams. +partitionEitherStream :: MonadComp m => Stream m (Either a b) -> Simulation m (Stream m a, Stream m b) +partitionEitherStream s = + do s' <- memoStream s + return (leftStream s', rightStream s') + +-- | Split the input stream into the specified number of output streams +-- after applying the 'FCFS' strategy for enqueuing the output requests. +splitStream :: MonadComp m => Int -> Stream m a -> Simulation m [Stream m a] +splitStream = splitStreamQueueing FCFS + +-- | Split the input stream into the specified number of output streams. +-- +-- If you don't know what the strategy to apply, then you probably +-- need the 'FCFS' strategy, or function 'splitStream' that +-- does namely this. +splitStreamQueueing :: (MonadComp m, EnqueueStrategy m s) + => s + -- ^ the strategy applied for enqueuing the output requests + -> Int + -- ^ the number of output streams + -> Stream m a + -- ^ the input stream + -> Simulation m [Stream m a] + -- ^ the splitted output streams +splitStreamQueueing s n x = + do session <- liftParameter simulationSession + ref <- liftComp $ newProtoRef session x + res <- newResource s 1 + let reader = + usingResource res $ + do p <- liftComp $ readProtoRef ref + (a, xs) <- runStream p + liftComp $ writeProtoRef ref xs + return a + return $ map (\i -> repeatProcess reader) [1..n] + +-- | Split the input stream into a list of output streams +-- using the specified priorities. +splitStreamPrioritising :: (MonadComp m, PriorityQueueStrategy m s p) + => s + -- ^ the strategy applied for enqueuing the output requests + -> [Stream m p] + -- ^ the streams of priorities + -> Stream m a + -- ^ the input stream + -> Simulation m [Stream m a] + -- ^ the splitted output streams +splitStreamPrioritising s ps x = + do session <- liftParameter simulationSession + ref <- liftComp $ newProtoRef session x + res <- newResource s 1 + let stream (Cons p) = Cons z where + z = do (p', ps) <- p + a <- usingResourceWithPriority res p' $ + do p <- liftComp $ readProtoRef ref + (a, xs) <- runStream p + liftComp $ writeProtoRef ref xs + return a + return (a, stream ps) + return $ map stream ps + +-- | Concatenate the input streams applying the 'FCFS' strategy and +-- producing one output stream. +concatStreams :: MonadComp m => [Stream m a] -> Stream m a +concatStreams = concatQueuedStreams FCFS + +-- | Concatenate the input streams producing one output stream. +-- +-- If you don't know what the strategy to apply, then you probably +-- need the 'FCFS' strategy, or function 'concatStreams' that +-- does namely this. +concatQueuedStreams :: (MonadComp m, EnqueueStrategy m s) + => s + -- ^ the strategy applied for enqueuing the input data + -> [Stream m a] + -- ^ the input stream + -> Stream m a + -- ^ the combined output stream +concatQueuedStreams s streams = Cons z where + z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + writing <- liftSimulation $ newResourceWithMaxCount s 1 (Just 1) + conting <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + session <- liftParameter simulationSession + ref <- liftComp $ newProtoRef session Nothing + let writer p = + do (a, xs) <- runStream p + requestResource writing + liftComp $ writeProtoRef ref (Just a) + releaseResource reading + requestResource conting + writer xs + reader = + do requestResource reading + Just a <- liftComp $ readProtoRef ref + liftComp $ writeProtoRef ref Nothing + releaseResource writing + return a + forM_ streams $ spawnProcess . writer + a <- reader + let xs = repeatProcess (releaseResource conting >> reader) + return (a, xs) + +-- | Concatenate the input priority streams producing one output stream. +concatPriorityStreams :: (MonadComp m, PriorityQueueStrategy m s p) + => s + -- ^ the strategy applied for enqueuing the input data + -> [Stream m (p, a)] + -- ^ the input stream + -> Stream m a + -- ^ the combined output stream +concatPriorityStreams s streams = Cons z where + z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + writing <- liftSimulation $ newResourceWithMaxCount s 1 (Just 1) + conting <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + session <- liftParameter simulationSession + ref <- liftComp $ newProtoRef session Nothing + let writer p = + do ((priority, a), xs) <- runStream p + requestResourceWithPriority writing priority + liftComp $ writeProtoRef ref (Just a) + releaseResource reading + requestResource conting + writer xs + reader = + do requestResource reading + Just a <- liftComp $ readProtoRef ref + liftComp $ writeProtoRef ref Nothing + releaseResource writing + return a + forM_ streams $ spawnProcess . writer + a <- reader + let xs = repeatProcess (releaseResource conting >> reader) + return (a, xs) + +-- | Merge two streams applying the 'FCFS' strategy for enqueuing the input data. +mergeStreams :: MonadComp m => Stream m a -> Stream m a -> Stream m a +mergeStreams = mergeQueuedStreams FCFS + +-- | Merge two streams. +-- +-- If you don't know what the strategy to apply, then you probably +-- need the 'FCFS' strategy, or function 'mergeStreams' that +-- does namely this. +mergeQueuedStreams :: (MonadComp m, EnqueueStrategy m s) + => s + -- ^ the strategy applied for enqueuing the input data + -> Stream m a + -- ^ the fist input stream + -> Stream m a + -- ^ the second input stream + -> Stream m a + -- ^ the output combined stream +mergeQueuedStreams s x y = concatQueuedStreams s [x, y] + +-- | Merge two priority streams. +mergePriorityStreams :: (MonadComp m, PriorityQueueStrategy m s p) + => s + -- ^ the strategy applied for enqueuing the input data + -> Stream m (p, a) + -- ^ the fist input stream + -> Stream m (p, a) + -- ^ the second input stream + -> Stream m a + -- ^ the output combined stream +mergePriorityStreams s x y = concatPriorityStreams s [x, y] + +-- | An empty stream that never returns data. +emptyStream :: MonadComp m => Stream m a +emptyStream = Cons neverProcess + +-- | Consume the stream. It returns a process that infinitely reads data +-- from the stream and then redirects them to the provided function. +-- It is useful for modeling the process of enqueueing data in the queue +-- from the input stream. +consumeStream :: MonadComp m => (a -> Process m ()) -> Stream m a -> Process m () +consumeStream f = p where + p (Cons s) = do (a, xs) <- s + f a + p xs + +-- | Sink the stream. It returns a process that infinitely reads data +-- from the stream. The resulting computation can be a moving force +-- to simulate the whole system of the interconnected streams and +-- processors. +sinkStream :: MonadComp m => Stream m a -> Process m () +sinkStream = p where + p (Cons s) = do (a, xs) <- s + p xs + +-- | Prefetch the input stream requesting for one more data item in advance +-- while the last received item is not yet fully processed in the chain of +-- streams, usually by the processors. +-- +-- You can think of this as the prefetched stream could place its latest +-- data item in some temporary space for later use, which is very useful +-- for modeling a sequence of separate and independent work places. +prefetchStream :: MonadComp m => Stream m a -> Stream m a +prefetchStream s = Cons z where + z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + writing <- liftSimulation $ newResourceWithMaxCount FCFS 1 (Just 1) + session <- liftParameter simulationSession + ref <- liftComp $ newProtoRef session Nothing + let writer p = + do (a, xs) <- runStream p + requestResource writing + liftComp $ writeProtoRef ref (Just a) + releaseResource reading + writer xs + reader = + do requestResource reading + Just a <- liftComp $ readProtoRef ref + liftComp $ writeProtoRef ref Nothing + releaseResource writing + return a + spawnProcess $ writer s + runStream $ repeatProcess reader + +-- | Return a stream of values triggered by the specified signal. +-- +-- Since the time at which the values of the stream are requested for may differ from +-- the time at which the signal is triggered, it can be useful to apply the 'arrivalSignal' +-- function to add the information about the time points at which the signal was +-- actually received. +-- +-- The point is that the 'Stream' is requested outside, while the 'Signal' is triggered +-- inside. They are different by nature. The former is passive, while the latter is active. +-- +-- The resulting stream may be a root of space leak as it uses an internal queue to store +-- the values received from the signal. The oldest value is dequeued each time we request +-- the stream and it is returned within the computation. +-- +-- Cancel the stream's process to unsubscribe from the specified signal. +signalStream :: MonadComp m => Signal m a -> Process m (Stream m a) +signalStream s = + do q <- liftEvent newFCFSQueue + h <- liftEvent $ + handleSignal s $ + enqueue q + whenCancellingProcess $ disposeEvent h + return $ repeatProcess $ dequeue q + +-- | Return a computation of the signal that triggers values from the specified stream, +-- each time the next value of the stream is received within the underlying 'Process' +-- computation. +-- +-- Cancel the returned process to stop reading from the specified stream. +streamSignal :: MonadComp m => Stream m a -> Process m (Signal m a) +streamSignal z = + do s <- liftSimulation newSignalSource + spawnProcess $ + consumeStream (liftEvent . triggerSignal s) z + return $ publishSignal s + +-- | Transform a stream so that the resulting stream returns a sequence of arrivals +-- saving the information about the time points at which the original stream items +-- were received by demand. +arrivalStream :: MonadComp m => Stream m a -> Stream m (Arrival a) +arrivalStream s = Cons $ loop s Nothing where + loop s t0 = do (a, xs) <- runStream s + t <- liftDynamics time + let b = Arrival { arrivalValue = a, + arrivalTime = t, + arrivalDelay = + case t0 of + Nothing -> Nothing + Just t0 -> Just (t - t0) } + return (b, Cons $ loop xs (Just t)) + +-- | Delay the stream by one step using the specified initial value. +delayStream :: MonadComp m => a -> Stream m a -> Stream m a +delayStream a0 s = Cons $ return (a0, s) 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,162 +1,162 @@ - --- | --- Module : Simulation.Aivika.Trans.Stream.Random --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines random streams of events, which are useful --- for describing the input of the model. --- - -module Simulation.Aivika.Trans.Stream.Random - (-- * Stream of Random Events - randomStream, - randomUniformStream, - randomUniformIntStream, - randomNormalStream, - randomExponentialStream, - randomErlangStream, - randomPoissonStream, - randomBinomialStream) where - -import System.Random - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Parameter -import Simulation.Aivika.Trans.Parameter.Random -import Simulation.Aivika.Trans.Simulation -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Event -import Simulation.Aivika.Trans.Process -import Simulation.Aivika.Trans.Processor -import Simulation.Aivika.Trans.Stream -import Simulation.Aivika.Trans.Statistics -import Simulation.Aivika.Trans.Ref -import Simulation.Aivika.Trans.Arrival - --- | Return a sream of random events that arrive with the specified delay. -randomStream :: MonadComp m - => Parameter m (Double, a) - -- ^ compute a pair of the delay and event of type @a@ - -> Stream m (Arrival a) - -- ^ a stream of delayed events -randomStream delay = Cons $ loop Nothing where - loop t0 = - do t1 <- liftDynamics time - case t0 of - Nothing -> return () - Just t0 -> - when (t1 /= t0) $ - error $ - "The time of requesting for a new random event is different from " ++ - "the time when the previous event has arrived. Probably, your model " ++ - "contains a logical error. The random events should be requested permanently. " ++ - "At least, they can be lost, for example, when trying to enqueue them, but " ++ - "the random stream itself must always execute: randomStream." - (delay, a) <- liftParameter delay - holdProcess delay - t2 <- liftDynamics time - let arrival = Arrival { arrivalValue = a, - arrivalTime = t2, - arrivalDelay = - case t0 of - Nothing -> Nothing - Just t0 -> Just delay } - return (arrival, Cons $ loop (Just t2)) - --- | Create a new stream with delays distributed uniformly. -randomUniformStream :: MonadComp m - => Double - -- ^ the minimum delay - -> Double - -- ^ the maximum delay - -> Stream m (Arrival Double) - -- ^ the stream of random events with the delays generated -randomUniformStream min max = - randomStream $ - randomUniform min max >>= \x -> - return (x, x) - --- | Create a new stream with integer delays distributed uniformly. -randomUniformIntStream :: MonadComp m - => Int - -- ^ the minimum delay - -> Int - -- ^ the maximum delay - -> Stream m (Arrival Int) - -- ^ the stream of random events with the delays generated -randomUniformIntStream min max = - randomStream $ - randomUniformInt min max >>= \x -> - return (fromIntegral x, x) - --- | Create a new stream with delays distributed normally. -randomNormalStream :: MonadComp m - => Double - -- ^ the mean delay - -> Double - -- ^ the delay deviation - -> Stream m (Arrival Double) - -- ^ the stream of random events with the delays generated -randomNormalStream mu nu = - randomStream $ - randomNormal mu nu >>= \x -> - return (x, x) - --- | Return a new stream with delays distibuted exponentially with the specified mean --- (the reciprocal of the rate). -randomExponentialStream :: MonadComp m - => Double - -- ^ the mean delay (the reciprocal of the rate) - -> Stream m (Arrival Double) - -- ^ the stream of random events with the delays generated -randomExponentialStream mu = - randomStream $ - randomExponential mu >>= \x -> - return (x, x) - --- | Return a new stream with delays having the Erlang distribution with the specified --- scale (the reciprocal of the rate) and shape parameters. -randomErlangStream :: MonadComp m - => Double - -- ^ the scale (the reciprocal of the rate) - -> Int - -- ^ the shape - -> Stream m (Arrival Double) - -- ^ the stream of random events with the delays generated -randomErlangStream beta m = - randomStream $ - randomErlang beta m >>= \x -> - return (x, x) - --- | Return a new stream with delays having the Poisson distribution with --- the specified mean. -randomPoissonStream :: MonadComp m - => Double - -- ^ the mean delay - -> Stream m (Arrival Int) - -- ^ the stream of random events with the delays generated -randomPoissonStream mu = - randomStream $ - randomPoisson mu >>= \x -> - return (fromIntegral x, x) - --- | Return a new stream with delays having the binomial distribution with the specified --- probability and trials. -randomBinomialStream :: MonadComp m - => Double - -- ^ the probability - -> Int - -- ^ the number of trials - -> Stream m (Arrival Int) - -- ^ the stream of random events with the delays generated -randomBinomialStream prob trials = - randomStream $ - randomBinomial prob trials >>= \x -> - return (fromIntegral x, x) + +-- | +-- Module : Simulation.Aivika.Trans.Stream.Random +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines random streams of events, which are useful +-- for describing the input of the model. +-- + +module Simulation.Aivika.Trans.Stream.Random + (-- * Stream of Random Events + randomStream, + randomUniformStream, + randomUniformIntStream, + randomNormalStream, + randomExponentialStream, + randomErlangStream, + randomPoissonStream, + randomBinomialStream) where + +import System.Random + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Parameter +import Simulation.Aivika.Trans.Parameter.Random +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Event +import Simulation.Aivika.Trans.Process +import Simulation.Aivika.Trans.Processor +import Simulation.Aivika.Trans.Stream +import Simulation.Aivika.Trans.Statistics +import Simulation.Aivika.Trans.Ref +import Simulation.Aivika.Trans.Arrival + +-- | Return a sream of random events that arrive with the specified delay. +randomStream :: MonadComp m + => Parameter m (Double, a) + -- ^ compute a pair of the delay and event of type @a@ + -> Stream m (Arrival a) + -- ^ a stream of delayed events +randomStream delay = Cons $ loop Nothing where + loop t0 = + do t1 <- liftDynamics time + case t0 of + Nothing -> return () + Just t0 -> + when (t1 /= t0) $ + error $ + "The time of requesting for a new random event is different from " ++ + "the time when the previous event has arrived. Probably, your model " ++ + "contains a logical error. The random events should be requested permanently. " ++ + "At least, they can be lost, for example, when trying to enqueue them, but " ++ + "the random stream itself must always execute: randomStream." + (delay, a) <- liftParameter delay + holdProcess delay + t2 <- liftDynamics time + let arrival = Arrival { arrivalValue = a, + arrivalTime = t2, + arrivalDelay = + case t0 of + Nothing -> Nothing + Just t0 -> Just delay } + return (arrival, Cons $ loop (Just t2)) + +-- | Create a new stream with delays distributed uniformly. +randomUniformStream :: MonadComp m + => Double + -- ^ the minimum delay + -> Double + -- ^ the maximum delay + -> Stream m (Arrival Double) + -- ^ the stream of random events with the delays generated +randomUniformStream min max = + randomStream $ + randomUniform min max >>= \x -> + return (x, x) + +-- | Create a new stream with integer delays distributed uniformly. +randomUniformIntStream :: MonadComp m + => Int + -- ^ the minimum delay + -> Int + -- ^ the maximum delay + -> Stream m (Arrival Int) + -- ^ the stream of random events with the delays generated +randomUniformIntStream min max = + randomStream $ + randomUniformInt min max >>= \x -> + return (fromIntegral x, x) + +-- | Create a new stream with delays distributed normally. +randomNormalStream :: MonadComp m + => Double + -- ^ the mean delay + -> Double + -- ^ the delay deviation + -> Stream m (Arrival Double) + -- ^ the stream of random events with the delays generated +randomNormalStream mu nu = + randomStream $ + randomNormal mu nu >>= \x -> + return (x, x) + +-- | Return a new stream with delays distibuted exponentially with the specified mean +-- (the reciprocal of the rate). +randomExponentialStream :: MonadComp m + => Double + -- ^ the mean delay (the reciprocal of the rate) + -> Stream m (Arrival Double) + -- ^ the stream of random events with the delays generated +randomExponentialStream mu = + randomStream $ + randomExponential mu >>= \x -> + return (x, x) + +-- | Return a new stream with delays having the Erlang distribution with the specified +-- scale (the reciprocal of the rate) and shape parameters. +randomErlangStream :: MonadComp m + => Double + -- ^ the scale (the reciprocal of the rate) + -> Int + -- ^ the shape + -> Stream m (Arrival Double) + -- ^ the stream of random events with the delays generated +randomErlangStream beta m = + randomStream $ + randomErlang beta m >>= \x -> + return (x, x) + +-- | Return a new stream with delays having the Poisson distribution with +-- the specified mean. +randomPoissonStream :: MonadComp m + => Double + -- ^ the mean delay + -> Stream m (Arrival Int) + -- ^ the stream of random events with the delays generated +randomPoissonStream mu = + randomStream $ + randomPoisson mu >>= \x -> + return (fromIntegral x, x) + +-- | Return a new stream with delays having the binomial distribution with the specified +-- probability and trials. +randomBinomialStream :: MonadComp m + => Double + -- ^ the probability + -> Int + -- ^ the number of trials + -> Stream m (Arrival Int) + -- ^ the stream of random events with the delays generated +randomBinomialStream prob trials = + randomStream $ + randomBinomial prob trials >>= \x -> + return (fromIntegral x, x) diff --git a/Simulation/Aivika/Trans/SystemDynamics.hs b/Simulation/Aivika/Trans/SystemDynamics.hs --- a/Simulation/Aivika/Trans/SystemDynamics.hs +++ b/Simulation/Aivika/Trans/SystemDynamics.hs @@ -1,747 +1,820 @@ - -{-# LANGUAGE BangPatterns, RecursiveDo, FlexibleContexts #-} - --- | --- Module : Simulation.Aivika.Trans.SystemDynamics --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines integrals and other functions of System Dynamics. --- - -module Simulation.Aivika.Trans.SystemDynamics - (-- * Equality and Ordering - (.==.), - (./=.), - (.<.), - (.>=.), - (.>.), - (.<=.), - maxDynamics, - minDynamics, - ifDynamics, - -- * Ordinary Differential Equations - integ, - smoothI, - smooth, - smooth3I, - smooth3, - smoothNI, - smoothN, - delay1I, - delay1, - delay3I, - delay3, - delayNI, - delayN, - forecast, - trend, - -- * Difference Equations - diffsum, - -- * Table Functions - lookupDynamics, - lookupStepwiseDynamics, - -- * Discrete Functions - delay, - delayI, - step, - pulse, - pulseP, - ramp, - -- * Financial Functions - npv, - npve) where - -import Data.Array - -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Fix - -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Parameter -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Dynamics -import Simulation.Aivika.Trans.Dynamics.Extra -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Comp.IO -import Simulation.Aivika.Trans.Unboxed -import Simulation.Aivika.Trans.Table - -import qualified Simulation.Aivika.Trans.Dynamics.Memo as M -import qualified Simulation.Aivika.Trans.Dynamics.Memo.Unboxed as MU - --- --- Equality and Ordering --- - --- | Compare for equality. -(.==.) :: (MonadComp m, Eq a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool -{-# INLINE (.==.) #-} -(.==.) = liftM2 (==) - --- | Compare for inequality. -(./=.) :: (MonadComp m, Eq a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool -{-# INLINE (./=.) #-} -(./=.) = liftM2 (/=) - --- | Compare for ordering. -(.<.) :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool -{-# INLINE (.<.) #-} -(.<.) = liftM2 (<) - --- | Compare for ordering. -(.>=.) :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool -{-# INLINE (.>=.) #-} -(.>=.) = liftM2 (>=) - --- | Compare for ordering. -(.>.) :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool -{-# INLINE (.>.) #-} -(.>.) = liftM2 (>) - --- | Compare for ordering. -(.<=.) :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool -{-# INLINE (.<=.) #-} -(.<=.) = liftM2 (<=) - --- | Return the maximum. -maxDynamics :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m a -{-# INLINE maxDynamics #-} -maxDynamics = liftM2 max - --- | Return the minimum. -minDynamics :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m a -{-# INLINE minDynamics #-} -minDynamics = liftM2 min - --- | Implement the if-then-else operator. -ifDynamics :: MonadComp m => Dynamics m Bool -> Dynamics m a -> Dynamics m a -> Dynamics m a -{-# INLINE ifDynamics #-} -ifDynamics cond x y = - do a <- cond - if a then x else y - --- --- Ordinary Differential Equations --- - -integEuler :: MonadComp m - => Dynamics m Double - -> Dynamics m Double - -> Dynamics m Double - -> Point m - -> m Double -integEuler (Dynamics f) (Dynamics i) (Dynamics y) p = - case pointIteration p of - 0 -> - i p - n -> do - let sc = pointSpecs p - ty = basicTime sc (n - 1) 0 - py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } - a <- y py - b <- f py - let !v = a + spcDT (pointSpecs p) * b - return v - -integRK2 :: MonadComp m - => Dynamics m Double - -> Dynamics m Double - -> Dynamics m Double - -> Point m - -> m Double -integRK2 (Dynamics f) (Dynamics i) (Dynamics y) p = - case pointPhase p of - 0 -> case pointIteration p of - 0 -> - i p - n -> do - let sc = pointSpecs p - ty = basicTime sc (n - 1) 0 - t1 = ty - t2 = basicTime sc (n - 1) 1 - py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } - p1 = py - p2 = p { pointTime = t2, pointIteration = n - 1, pointPhase = 1 } - vy <- y py - k1 <- f p1 - k2 <- f p2 - let !v = vy + spcDT sc / 2.0 * (k1 + k2) - return v - 1 -> do - let sc = pointSpecs p - n = pointIteration p - ty = basicTime sc n 0 - t1 = ty - py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } - p1 = py - vy <- y py - k1 <- f p1 - let !v = vy + spcDT sc * k1 - return v - _ -> - error "Incorrect phase: integRK2" - -integRK4 :: MonadComp m - => Dynamics m Double - -> Dynamics m Double - -> Dynamics m Double - -> Point m - -> m Double -integRK4 (Dynamics f) (Dynamics i) (Dynamics y) p = - case pointPhase p of - 0 -> case pointIteration p of - 0 -> - i p - n -> do - let sc = pointSpecs p - ty = basicTime sc (n - 1) 0 - t1 = ty - t2 = basicTime sc (n - 1) 1 - t3 = basicTime sc (n - 1) 2 - t4 = basicTime sc (n - 1) 3 - py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } - p1 = py - p2 = p { pointTime = t2, pointIteration = n - 1, pointPhase = 1 } - p3 = p { pointTime = t3, pointIteration = n - 1, pointPhase = 2 } - p4 = p { pointTime = t4, pointIteration = n - 1, pointPhase = 3 } - vy <- y py - k1 <- f p1 - k2 <- f p2 - k3 <- f p3 - k4 <- f p4 - let !v = vy + spcDT sc / 6.0 * (k1 + 2.0 * k2 + 2.0 * k3 + k4) - return v - 1 -> do - let sc = pointSpecs p - n = pointIteration p - ty = basicTime sc n 0 - t1 = ty - py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } - p1 = py - vy <- y py - k1 <- f p1 - let !v = vy + spcDT sc / 2.0 * k1 - return v - 2 -> do - let sc = pointSpecs p - n = pointIteration p - ty = basicTime sc n 0 - t2 = basicTime sc n 1 - py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } - p2 = p { pointTime = t2, pointIteration = n, pointPhase = 1 } - vy <- y py - k2 <- f p2 - let !v = vy + spcDT sc / 2.0 * k2 - return v - 3 -> do - let sc = pointSpecs p - n = pointIteration p - ty = basicTime sc n 0 - t3 = basicTime sc n 2 - py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } - p3 = p { pointTime = t3, pointIteration = n, pointPhase = 2 } - vy <- y py - k3 <- f p3 - let !v = vy + spcDT sc * k3 - return v - _ -> - error "Incorrect phase: integRK4" - --- | Return an integral with the specified derivative and initial value. --- --- To create a loopback, you should use the recursive do-notation. --- It allows defining the differential equations unordered as --- in mathematics: --- --- @ --- model = --- mdo a <- integ (- ka * a) 100 --- b <- integ (ka * a - kb * b) 0 --- c <- integ (kb * b) 0 --- let ka = 1 --- kb = 1 --- runDynamicsInStopTime $ sequence [a, b, c] --- @ -integ :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the derivative - -> Dynamics m Double -- ^ the initial value - -> Simulation m (Dynamics m Double) -- ^ the integral -integ diff i = - mdo y <- MU.memoDynamics z - z <- Simulation $ \r -> - case spcMethod (runSpecs r) of - Euler -> return $ Dynamics $ integEuler diff i y - RungeKutta2 -> return $ Dynamics $ integRK2 diff i y - RungeKutta4 -> return $ Dynamics $ integRK4 diff i y - return y - --- | Return the first order exponential smooth. --- --- To create a loopback, you should use the recursive do-notation --- with help of which the function itself is defined: --- --- @ --- smoothI x t i = --- mdo y <- integ ((x - y) \/ t) i --- return y --- @ -smoothI :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the value to smooth over time - -> Dynamics m Double -- ^ time - -> Dynamics m Double -- ^ the initial value - -> Simulation m (Dynamics m Double) -- ^ the first order exponential smooth -smoothI x t i = - mdo y <- integ ((x - y) / t) i - return y - --- | Return the first order exponential smooth. --- --- This is a simplified version of the 'smoothI' function --- without specifing the initial value. -smooth :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the value to smooth over time - -> Dynamics m Double -- ^ time - -> Simulation m (Dynamics m Double) -- ^ the first order exponential smooth -smooth x t = smoothI x t x - --- | Return the third order exponential smooth. --- --- To create a loopback, you should use the recursive do-notation --- with help of which the function itself is defined: --- --- @ --- smooth3I x t i = --- mdo y <- integ ((s2 - y) \/ t') i --- s2 <- integ ((s1 - s2) \/ t') i --- s1 <- integ ((x - s1) \/ t') i --- let t' = t \/ 3.0 --- return y --- @ -smooth3I :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the value to smooth over time - -> Dynamics m Double -- ^ time - -> Dynamics m Double -- ^ the initial value - -> Simulation m (Dynamics m Double) -- ^ the third order exponential smooth -smooth3I x t i = - mdo y <- integ ((s2 - y) / t') i - s2 <- integ ((s1 - s2) / t') i - s1 <- integ ((x - s1) / t') i - let t' = t / 3.0 - return y - --- | Return the third order exponential smooth. --- --- This is a simplified version of the 'smooth3I' function --- without specifying the initial value. -smooth3 :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the value to smooth over time - -> Dynamics m Double -- ^ time - -> Simulation m (Dynamics m Double) -- ^ the third order exponential smooth -smooth3 x t = smooth3I x t x - --- | Return the n'th order exponential smooth. --- --- The result is not discrete in that sense that it may change within the integration time --- interval depending on the integration method used. Probably, you should apply --- the 'discreteDynamics' function to the result if you want to achieve an effect when --- the value is not changed within the time interval, which is used sometimes. -smoothNI :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the value to smooth over time - -> Dynamics m Double -- ^ time - -> Int -- ^ the order - -> Dynamics m Double -- ^ the initial value - -> Simulation m (Dynamics m Double) -- ^ the n'th order exponential smooth -smoothNI x t n i = - mdo s <- forM [1 .. n] $ \k -> - if k == 1 - then integ ((x - a ! 1) / t') i - else integ ((a ! (k - 1) - a ! k) / t') i - let a = listArray (1, n) s - t' = t / fromIntegral n - return $ a ! n - --- | Return the n'th order exponential smooth. --- --- This is a simplified version of the 'smoothNI' function --- without specifying the initial value. -smoothN :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the value to smooth over time - -> Dynamics m Double -- ^ time - -> Int -- ^ the order - -> Simulation m (Dynamics m Double) -- ^ the n'th order exponential smooth -smoothN x t n = smoothNI x t n x - --- | Return the first order exponential delay. --- --- To create a loopback, you should use the recursive do-notation --- with help of which the function itself is defined: --- --- @ --- delay1I x t i = --- mdo y <- integ (x - y \/ t) (i * t) --- return $ y \/ t --- @ -delay1I :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the value to conserve - -> Dynamics m Double -- ^ time - -> Dynamics m Double -- ^ the initial value - -> Simulation m (Dynamics m Double) -- ^ the first order exponential delay -delay1I x t i = - mdo y <- integ (x - y / t) (i * t) - return $ y / t - --- | Return the first order exponential delay. --- --- This is a simplified version of the 'delay1I' function --- without specifying the initial value. -delay1 :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the value to conserve - -> Dynamics m Double -- ^ time - -> Simulation m (Dynamics m Double) -- ^ the first order exponential delay -delay1 x t = delay1I x t x - --- | Return the third order exponential delay. -delay3I :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the value to conserve - -> Dynamics m Double -- ^ time - -> Dynamics m Double -- ^ the initial value - -> Simulation m (Dynamics m Double) -- ^ the third order exponential delay -delay3I x t i = - mdo y <- integ (s2 / t' - y / t') (i * t') - s2 <- integ (s1 / t' - s2 / t') (i * t') - s1 <- integ (x - s1 / t') (i * t') - let t' = t / 3.0 - return $ y / t' - --- | Return the third order exponential delay. --- --- This is a simplified version of the 'delay3I' function --- without specifying the initial value. -delay3 :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the value to conserve - -> Dynamics m Double -- ^ time - -> Simulation m (Dynamics m Double) -- ^ the third order exponential delay -delay3 x t = delay3I x t x - --- | Return the n'th order exponential delay. -delayNI :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the value to conserve - -> Dynamics m Double -- ^ time - -> Int -- ^ the order - -> Dynamics m Double -- ^ the initial value - -> Simulation m (Dynamics m Double) -- ^ the n'th order exponential delay -delayNI x t n i = - mdo s <- forM [1 .. n] $ \k -> - if k == 1 - then integ (x - (a ! 1) / t') (i * t') - else integ ((a ! (k - 1)) / t' - (a ! k) / t') (i * t') - let a = listArray (1, n) s - t' = t / fromIntegral n - return $ (a ! n) / t' - --- | Return the n'th order exponential delay. --- --- This is a simplified version of the 'delayNI' function --- without specifying the initial value. -delayN :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the value to conserve - -> Dynamics m Double -- ^ time - -> Int -- ^ the order - -> Simulation m (Dynamics m Double) -- ^ the n'th order exponential delay -delayN x t n = delayNI x t n x - --- | Return the forecast. --- --- The function has the following definition: --- --- @ --- forecast x at hz = --- do y <- smooth x at --- return $ x * (1.0 + (x \/ y - 1.0) \/ at * hz) --- @ -forecast :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the value to forecast - -> Dynamics m Double -- ^ the average time - -> Dynamics m Double -- ^ the time horizon - -> Simulation m (Dynamics m Double) -- ^ the forecast -forecast x at hz = - do y <- smooth x at - return $ x * (1.0 + (x / y - 1.0) / at * hz) - --- | Return the trend. --- --- The function has the following definition: --- --- @ --- trend x at i = --- do y <- smoothI x at (x \/ (1.0 + i * at)) --- return $ (x \/ y - 1.0) \/ at --- @ -trend :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the value for which the trend is calculated - -> Dynamics m Double -- ^ the average time - -> Dynamics m Double -- ^ the initial value - -> Simulation m (Dynamics m Double) -- ^ the fractional change rate -trend x at i = - do y <- smoothI x at (x / (1.0 + i * at)) - return $ (x / y - 1.0) / at - --- --- Difference Equations --- - --- | Retun the sum for the difference equation. --- It is like an integral returned by the 'integ' function, only now --- the difference is used instead of derivative. --- --- As usual, to create a loopback, you should use the recursive do-notation. -diffsum :: (MonadComp m, MonadFix m, - Unboxed m a, Num a) - => Dynamics m a -- ^ the difference - -> Dynamics m a -- ^ the initial value - -> Simulation m (Dynamics m a) -- ^ the sum -diffsum (Dynamics diff) (Dynamics i) = - mdo y <- - MU.memo0Dynamics $ - Dynamics $ \p -> - case pointIteration p of - 0 -> i p - n -> do - let Dynamics m = y - sc = pointSpecs p - ty = basicTime sc (n - 1) 0 - py = p { pointTime = ty, - pointIteration = n - 1, - pointPhase = 0 } - a <- m py - b <- diff py - let !v = a + b - return v - return y - --- --- Table Functions --- - --- | Lookup @x@ in a table of pairs @(x, y)@ using linear interpolation. -lookupDynamics :: MonadComp m => Dynamics m Double -> Array Int (Double, Double) -> Dynamics m Double -lookupDynamics (Dynamics m) tbl = - Dynamics $ \p -> - do a <- m p - return $ tableLookup a tbl - --- | Lookup @x@ in a table of pairs @(x, y)@ using stepwise function. -lookupStepwiseDynamics :: MonadComp m => Dynamics m Double -> Array Int (Double, Double) -> Dynamics m Double -lookupStepwiseDynamics (Dynamics m) tbl = - Dynamics $ \p -> - do a <- m p - return $ tableLookupStepwise a tbl - --- --- Discrete Functions --- - --- | Return the delayed value using the specified lag time. -delay :: MonadComp m - => Dynamics m a -- ^ the value to delay - -> Dynamics m Double -- ^ the lag time - -> Dynamics m a -- ^ the delayed value -delay (Dynamics x) (Dynamics d) = discreteDynamics $ Dynamics r - where - r p = do - let t = pointTime p - sc = pointSpecs p - n = pointIteration p - a <- d p - let t' = t - a - n' = fromIntegral $ floor $ (t' - spcStartTime sc) / spcDT sc - y | n' < 0 = x $ p { pointTime = spcStartTime sc, - pointIteration = 0, - pointPhase = 0 } - | n' < n = x $ p { pointTime = t', - pointIteration = n', - pointPhase = -1 } - | n' > n = error $ - "Cannot return the future data: delay. " ++ - "The lag time cannot be negative." - | otherwise = error $ - "Cannot return the current data: delay. " ++ - "The lag time is too small." - y - --- | Return the delayed value using the specified lag time and initial value. --- Because of the latter, it allows creating a loop back. -delayI :: MonadComp m - => Dynamics m a -- ^ the value to delay - -> Dynamics m Double -- ^ the lag time - -> Dynamics m a -- ^ the initial value - -> Simulation m (Dynamics m a) -- ^ the delayed value -delayI (Dynamics x) (Dynamics d) (Dynamics i) = M.memo0Dynamics $ Dynamics r - where - r p = do - let t = pointTime p - sc = pointSpecs p - n = pointIteration p - a <- d p - let t' = t - a - n' = fromIntegral $ floor $ (t' - spcStartTime sc) / spcDT sc - y | n' < 0 = i $ p { pointTime = spcStartTime sc, - pointIteration = 0, - pointPhase = 0 } - | n' < n = x $ p { pointTime = t', - pointIteration = n', - pointPhase = -1 } - | n' > n = error $ - "Cannot return the future data: delay. " ++ - "The lag time cannot be negative." - | otherwise = error $ - "Cannot return the current data: delay. " ++ - "The lag time is too small." - y - --- --- Financial Functions --- - --- | Return the Net Present Value (NPV) of the stream computed using the specified --- discount rate, the initial value and some factor (usually 1). --- --- It is defined in the following way: --- --- @ --- npv stream rate init factor = --- mdo let dt' = liftParameter dt --- df <- integ (- df * rate) 1 --- accum <- integ (stream * df) init --- return $ (accum + dt' * stream * df) * factor --- @ -npv :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the stream - -> Dynamics m Double -- ^ the discount rate - -> Dynamics m Double -- ^ the initial value - -> Dynamics m Double -- ^ factor - -> Simulation m (Dynamics m Double) -- ^ the Net Present Value (NPV) -npv stream rate init factor = - mdo let dt' = liftParameter dt - df <- integ (- df * rate) 1 - accum <- integ (stream * df) init - return $ (accum + dt' * stream * df) * factor - --- | Return the Net Present Value End of period (NPVE) of the stream computed --- using the specified discount rate, the initial value and some factor. --- --- It is defined in the following way: --- --- @ --- npve stream rate init factor = --- mdo let dt' = liftParameter dt --- df <- integ (- df * rate \/ (1 + rate * dt')) (1 \/ (1 + rate * dt')) --- accum <- integ (stream * df) init --- return $ (accum + dt' * stream * df) * factor --- @ -npve :: (MonadComp m, MonadFix m) - => Dynamics m Double -- ^ the stream - -> Dynamics m Double -- ^ the discount rate - -> Dynamics m Double -- ^ the initial value - -> Dynamics m Double -- ^ factor - -> Simulation m (Dynamics m Double) -- ^ the Net Present Value End (NPVE) -npve stream rate init factor = - mdo let dt' = liftParameter dt - df <- integ (- df * rate / (1 + rate * dt')) (1 / (1 + rate * dt')) - accum <- integ (stream * df) init - return $ (accum + dt' * stream * df) * factor - --- | Computation that returns 0 until the step time and then returns the specified height. -step :: MonadComp m - => Dynamics m Double - -- ^ the height - -> Dynamics m Double - -- ^ the step time - -> Dynamics m Double -step h st = - discreteDynamics $ - Dynamics $ \p -> - do let sc = pointSpecs p - t = pointTime p - st' <- invokeDynamics p st - let t' = t + spcDT sc / 2 - if st' < t' - then invokeDynamics p h - else return 0 - --- | Computation that returns 1, starting at the time start, and lasting for the interval --- width; 0 is returned at all other times. -pulse :: MonadComp m - => Dynamics m Double - -- ^ the time start - -> Dynamics m Double - -- ^ the interval width - -> Dynamics m Double -pulse st w = - discreteDynamics $ - Dynamics $ \p -> - do let sc = pointSpecs p - t = pointTime p - st' <- invokeDynamics p st - let t' = t + spcDT sc / 2 - if st' < t' - then do w' <- invokeDynamics p w - return $ if t' < st' + w' then 1 else 0 - else return 0 - --- | Computation that returns 1, starting at the time start, and lasting for the interval --- width and then repeats this pattern with the specified period; 0 is returned at all --- other times. -pulseP :: MonadComp m - => Dynamics m Double - -- ^ the time start - -> Dynamics m Double - -- ^ the interval width - -> Dynamics m Double - -- ^ the time period - -> Dynamics m Double -pulseP st w period = - discreteDynamics $ - Dynamics $ \p -> - do let sc = pointSpecs p - t = pointTime p - p' <- invokeDynamics p period - st' <- invokeDynamics p st - let y' = if (p' > 0) && (t > st') - then fromIntegral (floor $ (t - st') / p') * p' - else 0 - let st' = st' + y' - let t' = t + spcDT sc / 2 - if st' < t' - then do w' <- invokeDynamics p w - return $ if t' < st' + w' then 1 else 0 - else return 0 - --- | Computation that returns 0 until the specified time start and then --- slopes upward until the end time and then holds constant. -ramp :: MonadComp m - => Dynamics m Double - -- ^ the slope parameter - -> Dynamics m Double - -- ^ the time start - -> Dynamics m Double - -- ^ the end time - -> Dynamics m Double -ramp slope st e = - discreteDynamics $ - Dynamics $ \p -> - do let sc = pointSpecs p - t = pointTime p - st' <- invokeDynamics p st - if st' < t - then do slope' <- invokeDynamics p slope - e' <- invokeDynamics p e - if t < e' - then return $ slope' * (t - st') - else return $ slope' * (e' - st') - else return 0 + +{-# LANGUAGE BangPatterns, RecursiveDo, FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.SystemDynamics +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines integrals and other functions of System Dynamics. +-- + +module Simulation.Aivika.Trans.SystemDynamics + (-- * Equality and Ordering + (.==.), + (./=.), + (.<.), + (.>=.), + (.>.), + (.<=.), + maxDynamics, + minDynamics, + ifDynamics, + -- * Ordinary Differential Equations + integ, + integEither, + smoothI, + smooth, + smooth3I, + smooth3, + smoothNI, + smoothN, + delay1I, + delay1, + delay3I, + delay3, + delayNI, + delayN, + forecast, + trend, + -- * Difference Equations + diffsum, + diffsumEither, + -- * Table Functions + lookupDynamics, + lookupStepwiseDynamics, + -- * Discrete Functions + delay, + delayI, + step, + pulse, + pulseP, + ramp, + -- * Financial Functions + npv, + npve) where + +import Data.Array + +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Fix + +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics +import Simulation.Aivika.Trans.Dynamics.Extra +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Comp.IO +import Simulation.Aivika.Trans.Unboxed +import Simulation.Aivika.Trans.Table + +import qualified Simulation.Aivika.Trans.Dynamics.Memo as M +import qualified Simulation.Aivika.Trans.Dynamics.Memo.Unboxed as MU + +-- +-- Equality and Ordering +-- + +-- | Compare for equality. +(.==.) :: (MonadComp m, Eq a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool +{-# INLINE (.==.) #-} +(.==.) = liftM2 (==) + +-- | Compare for inequality. +(./=.) :: (MonadComp m, Eq a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool +{-# INLINE (./=.) #-} +(./=.) = liftM2 (/=) + +-- | Compare for ordering. +(.<.) :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool +{-# INLINE (.<.) #-} +(.<.) = liftM2 (<) + +-- | Compare for ordering. +(.>=.) :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool +{-# INLINE (.>=.) #-} +(.>=.) = liftM2 (>=) + +-- | Compare for ordering. +(.>.) :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool +{-# INLINE (.>.) #-} +(.>.) = liftM2 (>) + +-- | Compare for ordering. +(.<=.) :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m Bool +{-# INLINE (.<=.) #-} +(.<=.) = liftM2 (<=) + +-- | Return the maximum. +maxDynamics :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m a +{-# INLINE maxDynamics #-} +maxDynamics = liftM2 max + +-- | Return the minimum. +minDynamics :: (MonadComp m, Ord a) => Dynamics m a -> Dynamics m a -> Dynamics m a +{-# INLINE minDynamics #-} +minDynamics = liftM2 min + +-- | Implement the if-then-else operator. +ifDynamics :: MonadComp m => Dynamics m Bool -> Dynamics m a -> Dynamics m a -> Dynamics m a +{-# INLINE ifDynamics #-} +ifDynamics cond x y = + do a <- cond + if a then x else y + +-- +-- Ordinary Differential Equations +-- + +integEuler :: MonadComp m + => Dynamics m Double + -> Dynamics m Double + -> Dynamics m Double + -> Point m + -> m Double +integEuler (Dynamics f) (Dynamics i) (Dynamics y) p = + case pointIteration p of + 0 -> + i p + n -> do + let sc = pointSpecs p + ty = basicTime sc (n - 1) 0 + py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } + a <- y py + b <- f py + let !v = a + spcDT (pointSpecs p) * b + return v + +integRK2 :: MonadComp m + => Dynamics m Double + -> Dynamics m Double + -> Dynamics m Double + -> Point m + -> m Double +integRK2 (Dynamics f) (Dynamics i) (Dynamics y) p = + case pointPhase p of + 0 -> case pointIteration p of + 0 -> + i p + n -> do + let sc = pointSpecs p + ty = basicTime sc (n - 1) 0 + t1 = ty + t2 = basicTime sc (n - 1) 1 + py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } + p1 = py + p2 = p { pointTime = t2, pointIteration = n - 1, pointPhase = 1 } + vy <- y py + k1 <- f p1 + k2 <- f p2 + let !v = vy + spcDT sc / 2.0 * (k1 + k2) + return v + 1 -> do + let sc = pointSpecs p + n = pointIteration p + ty = basicTime sc n 0 + t1 = ty + py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } + p1 = py + vy <- y py + k1 <- f p1 + let !v = vy + spcDT sc * k1 + return v + _ -> + error "Incorrect phase: integRK2" + +integRK4 :: MonadComp m + => Dynamics m Double + -> Dynamics m Double + -> Dynamics m Double + -> Point m + -> m Double +integRK4 (Dynamics f) (Dynamics i) (Dynamics y) p = + case pointPhase p of + 0 -> case pointIteration p of + 0 -> + i p + n -> do + let sc = pointSpecs p + ty = basicTime sc (n - 1) 0 + t1 = ty + t2 = basicTime sc (n - 1) 1 + t3 = basicTime sc (n - 1) 2 + t4 = basicTime sc (n - 1) 3 + py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } + p1 = py + p2 = p { pointTime = t2, pointIteration = n - 1, pointPhase = 1 } + p3 = p { pointTime = t3, pointIteration = n - 1, pointPhase = 2 } + p4 = p { pointTime = t4, pointIteration = n - 1, pointPhase = 3 } + vy <- y py + k1 <- f p1 + k2 <- f p2 + k3 <- f p3 + k4 <- f p4 + let !v = vy + spcDT sc / 6.0 * (k1 + 2.0 * k2 + 2.0 * k3 + k4) + return v + 1 -> do + let sc = pointSpecs p + n = pointIteration p + ty = basicTime sc n 0 + t1 = ty + py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } + p1 = py + vy <- y py + k1 <- f p1 + let !v = vy + spcDT sc / 2.0 * k1 + return v + 2 -> do + let sc = pointSpecs p + n = pointIteration p + ty = basicTime sc n 0 + t2 = basicTime sc n 1 + py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } + p2 = p { pointTime = t2, pointIteration = n, pointPhase = 1 } + vy <- y py + k2 <- f p2 + let !v = vy + spcDT sc / 2.0 * k2 + return v + 3 -> do + let sc = pointSpecs p + n = pointIteration p + ty = basicTime sc n 0 + t3 = basicTime sc n 2 + py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } + p3 = p { pointTime = t3, pointIteration = n, pointPhase = 2 } + vy <- y py + k3 <- f p3 + let !v = vy + spcDT sc * k3 + return v + _ -> + error "Incorrect phase: integRK4" + +-- | Return an integral with the specified derivative and initial value. +-- +-- To create a loopback, you should use the recursive do-notation. +-- It allows defining the differential equations unordered as +-- in mathematics: +-- +-- @ +-- model = +-- mdo a <- integ (- ka * a) 100 +-- b <- integ (ka * a - kb * b) 0 +-- c <- integ (kb * b) 0 +-- let ka = 1 +-- kb = 1 +-- runDynamicsInStopTime $ sequence [a, b, c] +-- @ +integ :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the derivative + -> Dynamics m Double -- ^ the initial value + -> Simulation m (Dynamics m Double) -- ^ the integral +integ diff i = + mdo y <- MU.memoDynamics z + z <- Simulation $ \r -> + case spcMethod (runSpecs r) of + Euler -> return $ Dynamics $ integEuler diff i y + RungeKutta2 -> return $ Dynamics $ integRK2 diff i y + RungeKutta4 -> return $ Dynamics $ integRK4 diff i y + return y + +integEulerEither :: MonadComp m + => Dynamics m (Either Double Double) + -> Dynamics m Double + -> Dynamics m Double + -> Point m + -> m Double +integEulerEither (Dynamics f) (Dynamics i) (Dynamics y) p = + case pointIteration p of + 0 -> + i p + n -> do + let sc = pointSpecs p + ty = basicTime sc (n - 1) 0 + py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } + b <- f py + case b of + Left v -> + return v + Right b -> do + a <- y py + let !v = a + spcDT (pointSpecs p) * b + return v + +-- | Like 'integ' but allows either setting a new 'Left' integral value, +-- or integrating using the 'Right' derivative directly within computation. +-- +-- This function always uses Euler's method. +integEither :: (MonadComp m, MonadFix m) + => Dynamics m (Either Double Double) + -- ^ either set a new 'Left' integral value, or use a 'Right' derivative + -> Dynamics m Double + -- ^ the initial value + -> Simulation m (Dynamics m Double) +integEither diff i = + mdo y <- MU.memoDynamics z + z <- Simulation $ \r -> + return $ Dynamics $ integEulerEither diff i y + return y + +-- | Return the first order exponential smooth. +-- +-- To create a loopback, you should use the recursive do-notation +-- with help of which the function itself is defined: +-- +-- @ +-- smoothI x t i = +-- mdo y <- integ ((x - y) \/ t) i +-- return y +-- @ +smoothI :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the value to smooth over time + -> Dynamics m Double -- ^ time + -> Dynamics m Double -- ^ the initial value + -> Simulation m (Dynamics m Double) -- ^ the first order exponential smooth +smoothI x t i = + mdo y <- integ ((x - y) / t) i + return y + +-- | Return the first order exponential smooth. +-- +-- This is a simplified version of the 'smoothI' function +-- without specifing the initial value. +smooth :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the value to smooth over time + -> Dynamics m Double -- ^ time + -> Simulation m (Dynamics m Double) -- ^ the first order exponential smooth +smooth x t = smoothI x t x + +-- | Return the third order exponential smooth. +-- +-- To create a loopback, you should use the recursive do-notation +-- with help of which the function itself is defined: +-- +-- @ +-- smooth3I x t i = +-- mdo y <- integ ((s2 - y) \/ t') i +-- s2 <- integ ((s1 - s2) \/ t') i +-- s1 <- integ ((x - s1) \/ t') i +-- let t' = t \/ 3.0 +-- return y +-- @ +smooth3I :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the value to smooth over time + -> Dynamics m Double -- ^ time + -> Dynamics m Double -- ^ the initial value + -> Simulation m (Dynamics m Double) -- ^ the third order exponential smooth +smooth3I x t i = + mdo y <- integ ((s2 - y) / t') i + s2 <- integ ((s1 - s2) / t') i + s1 <- integ ((x - s1) / t') i + let t' = t / 3.0 + return y + +-- | Return the third order exponential smooth. +-- +-- This is a simplified version of the 'smooth3I' function +-- without specifying the initial value. +smooth3 :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the value to smooth over time + -> Dynamics m Double -- ^ time + -> Simulation m (Dynamics m Double) -- ^ the third order exponential smooth +smooth3 x t = smooth3I x t x + +-- | Return the n'th order exponential smooth. +-- +-- The result is not discrete in that sense that it may change within the integration time +-- interval depending on the integration method used. Probably, you should apply +-- the 'discreteDynamics' function to the result if you want to achieve an effect when +-- the value is not changed within the time interval, which is used sometimes. +smoothNI :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the value to smooth over time + -> Dynamics m Double -- ^ time + -> Int -- ^ the order + -> Dynamics m Double -- ^ the initial value + -> Simulation m (Dynamics m Double) -- ^ the n'th order exponential smooth +smoothNI x t n i = + mdo s <- forM [1 .. n] $ \k -> + if k == 1 + then integ ((x - a ! 1) / t') i + else integ ((a ! (k - 1) - a ! k) / t') i + let a = listArray (1, n) s + t' = t / fromIntegral n + return $ a ! n + +-- | Return the n'th order exponential smooth. +-- +-- This is a simplified version of the 'smoothNI' function +-- without specifying the initial value. +smoothN :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the value to smooth over time + -> Dynamics m Double -- ^ time + -> Int -- ^ the order + -> Simulation m (Dynamics m Double) -- ^ the n'th order exponential smooth +smoothN x t n = smoothNI x t n x + +-- | Return the first order exponential delay. +-- +-- To create a loopback, you should use the recursive do-notation +-- with help of which the function itself is defined: +-- +-- @ +-- delay1I x t i = +-- mdo y <- integ (x - y \/ t) (i * t) +-- return $ y \/ t +-- @ +delay1I :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the value to conserve + -> Dynamics m Double -- ^ time + -> Dynamics m Double -- ^ the initial value + -> Simulation m (Dynamics m Double) -- ^ the first order exponential delay +delay1I x t i = + mdo y <- integ (x - y / t) (i * t) + return $ y / t + +-- | Return the first order exponential delay. +-- +-- This is a simplified version of the 'delay1I' function +-- without specifying the initial value. +delay1 :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the value to conserve + -> Dynamics m Double -- ^ time + -> Simulation m (Dynamics m Double) -- ^ the first order exponential delay +delay1 x t = delay1I x t x + +-- | Return the third order exponential delay. +delay3I :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the value to conserve + -> Dynamics m Double -- ^ time + -> Dynamics m Double -- ^ the initial value + -> Simulation m (Dynamics m Double) -- ^ the third order exponential delay +delay3I x t i = + mdo y <- integ (s2 / t' - y / t') (i * t') + s2 <- integ (s1 / t' - s2 / t') (i * t') + s1 <- integ (x - s1 / t') (i * t') + let t' = t / 3.0 + return $ y / t' + +-- | Return the third order exponential delay. +-- +-- This is a simplified version of the 'delay3I' function +-- without specifying the initial value. +delay3 :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the value to conserve + -> Dynamics m Double -- ^ time + -> Simulation m (Dynamics m Double) -- ^ the third order exponential delay +delay3 x t = delay3I x t x + +-- | Return the n'th order exponential delay. +delayNI :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the value to conserve + -> Dynamics m Double -- ^ time + -> Int -- ^ the order + -> Dynamics m Double -- ^ the initial value + -> Simulation m (Dynamics m Double) -- ^ the n'th order exponential delay +delayNI x t n i = + mdo s <- forM [1 .. n] $ \k -> + if k == 1 + then integ (x - (a ! 1) / t') (i * t') + else integ ((a ! (k - 1)) / t' - (a ! k) / t') (i * t') + let a = listArray (1, n) s + t' = t / fromIntegral n + return $ (a ! n) / t' + +-- | Return the n'th order exponential delay. +-- +-- This is a simplified version of the 'delayNI' function +-- without specifying the initial value. +delayN :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the value to conserve + -> Dynamics m Double -- ^ time + -> Int -- ^ the order + -> Simulation m (Dynamics m Double) -- ^ the n'th order exponential delay +delayN x t n = delayNI x t n x + +-- | Return the forecast. +-- +-- The function has the following definition: +-- +-- @ +-- forecast x at hz = +-- do y <- smooth x at +-- return $ x * (1.0 + (x \/ y - 1.0) \/ at * hz) +-- @ +forecast :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the value to forecast + -> Dynamics m Double -- ^ the average time + -> Dynamics m Double -- ^ the time horizon + -> Simulation m (Dynamics m Double) -- ^ the forecast +forecast x at hz = + do y <- smooth x at + return $ x * (1.0 + (x / y - 1.0) / at * hz) + +-- | Return the trend. +-- +-- The function has the following definition: +-- +-- @ +-- trend x at i = +-- do y <- smoothI x at (x \/ (1.0 + i * at)) +-- return $ (x \/ y - 1.0) \/ at +-- @ +trend :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the value for which the trend is calculated + -> Dynamics m Double -- ^ the average time + -> Dynamics m Double -- ^ the initial value + -> Simulation m (Dynamics m Double) -- ^ the fractional change rate +trend x at i = + do y <- smoothI x at (x / (1.0 + i * at)) + return $ (x / y - 1.0) / at + +-- +-- Difference Equations +-- + +-- | Retun the sum for the difference equation. +-- It is like an integral returned by the 'integ' function, only now +-- the difference is used instead of derivative. +-- +-- As usual, to create a loopback, you should use the recursive do-notation. +diffsum :: (MonadComp m, MonadFix m, + Unboxed m a, Num a) + => Dynamics m a -- ^ the difference + -> Dynamics m a -- ^ the initial value + -> Simulation m (Dynamics m a) -- ^ the sum +diffsum (Dynamics diff) (Dynamics i) = + mdo y <- + MU.memo0Dynamics $ + Dynamics $ \p -> + case pointIteration p of + 0 -> i p + n -> do + let Dynamics m = y + sc = pointSpecs p + ty = basicTime sc (n - 1) 0 + py = p { pointTime = ty, + pointIteration = n - 1, + pointPhase = 0 } + a <- m py + b <- diff py + let !v = a + b + return v + return y + +-- | Like 'diffsum' but allows either setting a new 'Left' sum value, or adding the 'Right' difference. +diffsumEither :: (MonadComp m, MonadFix m, + Unboxed m a, Num a) + => Dynamics m (Either a a) + -- ^ either set the 'Left' value for the sum, or add the 'Right' difference to the sum + -> Dynamics m a + -- ^ the initial value + -> Simulation m (Dynamics m a) + -- ^ the sum +diffsumEither (Dynamics diff) (Dynamics i) = + mdo y <- + MU.memo0Dynamics $ + Dynamics $ \p -> + case pointIteration p of + 0 -> i p + n -> do + let Dynamics m = y + sc = pointSpecs p + ty = basicTime sc (n - 1) 0 + py = p { pointTime = ty, + pointIteration = n - 1, + pointPhase = 0 } + b <- diff py + case b of + Left v -> + return v + Right b -> do + a <- m py + let !v = a + b + return v + return y + +-- +-- Table Functions +-- + +-- | Lookup @x@ in a table of pairs @(x, y)@ using linear interpolation. +lookupDynamics :: MonadComp m => Dynamics m Double -> Array Int (Double, Double) -> Dynamics m Double +lookupDynamics (Dynamics m) tbl = + Dynamics $ \p -> + do a <- m p + return $ tableLookup a tbl + +-- | Lookup @x@ in a table of pairs @(x, y)@ using stepwise function. +lookupStepwiseDynamics :: MonadComp m => Dynamics m Double -> Array Int (Double, Double) -> Dynamics m Double +lookupStepwiseDynamics (Dynamics m) tbl = + Dynamics $ \p -> + do a <- m p + return $ tableLookupStepwise a tbl + +-- +-- Discrete Functions +-- + +-- | Return the delayed value using the specified lag time. +delay :: MonadComp m + => Dynamics m a -- ^ the value to delay + -> Dynamics m Double -- ^ the lag time + -> Dynamics m a -- ^ the delayed value +delay (Dynamics x) (Dynamics d) = discreteDynamics $ Dynamics r + where + r p = do + let t = pointTime p + sc = pointSpecs p + n = pointIteration p + a <- d p + let t' = t - a + n' = fromIntegral $ floor $ (t' - spcStartTime sc) / spcDT sc + y | n' < 0 = x $ p { pointTime = spcStartTime sc, + pointIteration = 0, + pointPhase = 0 } + | n' < n = x $ p { pointTime = t', + pointIteration = n', + pointPhase = -1 } + | n' > n = error $ + "Cannot return the future data: delay. " ++ + "The lag time cannot be negative." + | otherwise = error $ + "Cannot return the current data: delay. " ++ + "The lag time is too small." + y + +-- | Return the delayed value using the specified lag time and initial value. +-- Because of the latter, it allows creating a loop back. +delayI :: MonadComp m + => Dynamics m a -- ^ the value to delay + -> Dynamics m Double -- ^ the lag time + -> Dynamics m a -- ^ the initial value + -> Simulation m (Dynamics m a) -- ^ the delayed value +delayI (Dynamics x) (Dynamics d) (Dynamics i) = M.memo0Dynamics $ Dynamics r + where + r p = do + let t = pointTime p + sc = pointSpecs p + n = pointIteration p + a <- d p + let t' = t - a + n' = fromIntegral $ floor $ (t' - spcStartTime sc) / spcDT sc + y | n' < 0 = i $ p { pointTime = spcStartTime sc, + pointIteration = 0, + pointPhase = 0 } + | n' < n = x $ p { pointTime = t', + pointIteration = n', + pointPhase = -1 } + | n' > n = error $ + "Cannot return the future data: delay. " ++ + "The lag time cannot be negative." + | otherwise = error $ + "Cannot return the current data: delay. " ++ + "The lag time is too small." + y + +-- +-- Financial Functions +-- + +-- | Return the Net Present Value (NPV) of the stream computed using the specified +-- discount rate, the initial value and some factor (usually 1). +-- +-- It is defined in the following way: +-- +-- @ +-- npv stream rate init factor = +-- mdo let dt' = liftParameter dt +-- df <- integ (- df * rate) 1 +-- accum <- integ (stream * df) init +-- return $ (accum + dt' * stream * df) * factor +-- @ +npv :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the stream + -> Dynamics m Double -- ^ the discount rate + -> Dynamics m Double -- ^ the initial value + -> Dynamics m Double -- ^ factor + -> Simulation m (Dynamics m Double) -- ^ the Net Present Value (NPV) +npv stream rate init factor = + mdo let dt' = liftParameter dt + df <- integ (- df * rate) 1 + accum <- integ (stream * df) init + return $ (accum + dt' * stream * df) * factor + +-- | Return the Net Present Value End of period (NPVE) of the stream computed +-- using the specified discount rate, the initial value and some factor. +-- +-- It is defined in the following way: +-- +-- @ +-- npve stream rate init factor = +-- mdo let dt' = liftParameter dt +-- df <- integ (- df * rate \/ (1 + rate * dt')) (1 \/ (1 + rate * dt')) +-- accum <- integ (stream * df) init +-- return $ (accum + dt' * stream * df) * factor +-- @ +npve :: (MonadComp m, MonadFix m) + => Dynamics m Double -- ^ the stream + -> Dynamics m Double -- ^ the discount rate + -> Dynamics m Double -- ^ the initial value + -> Dynamics m Double -- ^ factor + -> Simulation m (Dynamics m Double) -- ^ the Net Present Value End (NPVE) +npve stream rate init factor = + mdo let dt' = liftParameter dt + df <- integ (- df * rate / (1 + rate * dt')) (1 / (1 + rate * dt')) + accum <- integ (stream * df) init + return $ (accum + dt' * stream * df) * factor + +-- | Computation that returns 0 until the step time and then returns the specified height. +step :: MonadComp m + => Dynamics m Double + -- ^ the height + -> Dynamics m Double + -- ^ the step time + -> Dynamics m Double +step h st = + discreteDynamics $ + Dynamics $ \p -> + do let sc = pointSpecs p + t = pointTime p + st' <- invokeDynamics p st + let t' = t + spcDT sc / 2 + if st' < t' + then invokeDynamics p h + else return 0 + +-- | Computation that returns 1, starting at the time start, and lasting for the interval +-- width; 0 is returned at all other times. +pulse :: MonadComp m + => Dynamics m Double + -- ^ the time start + -> Dynamics m Double + -- ^ the interval width + -> Dynamics m Double +pulse st w = + discreteDynamics $ + Dynamics $ \p -> + do let sc = pointSpecs p + t = pointTime p + st' <- invokeDynamics p st + let t' = t + spcDT sc / 2 + if st' < t' + then do w' <- invokeDynamics p w + return $ if t' < st' + w' then 1 else 0 + else return 0 + +-- | Computation that returns 1, starting at the time start, and lasting for the interval +-- width and then repeats this pattern with the specified period; 0 is returned at all +-- other times. +pulseP :: MonadComp m + => Dynamics m Double + -- ^ the time start + -> Dynamics m Double + -- ^ the interval width + -> Dynamics m Double + -- ^ the time period + -> Dynamics m Double +pulseP st w period = + discreteDynamics $ + Dynamics $ \p -> + do let sc = pointSpecs p + t = pointTime p + p' <- invokeDynamics p period + st' <- invokeDynamics p st + let y' = if (p' > 0) && (t > st') + then fromIntegral (floor $ (t - st') / p') * p' + else 0 + let st' = st' + y' + let t' = t + spcDT sc / 2 + if st' < t' + then do w' <- invokeDynamics p w + return $ if t' < st' + w' then 1 else 0 + else return 0 + +-- | Computation that returns 0 until the specified time start and then +-- slopes upward until the end time and then holds constant. +ramp :: MonadComp m + => Dynamics m Double + -- ^ the slope parameter + -> Dynamics m Double + -- ^ the time start + -> Dynamics m Double + -- ^ the end time + -> Dynamics m Double +ramp slope st e = + discreteDynamics $ + Dynamics $ \p -> + do let sc = pointSpecs p + t = pointTime p + st' <- invokeDynamics p st + if st' < t + then do slope' <- invokeDynamics p slope + e' <- invokeDynamics p e + if t < e' + then return $ slope' * (t - st') + else return $ slope' * (e' - st') + else return 0 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,16 +1,16 @@ - --- | --- Module : Simulation.Aivika.Trans.Table --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It defines the table functions. --- -module Simulation.Aivika.Trans.Table - (tableLookup, - tableLookupStepwise) where - -import Simulation.Aivika.Table + +-- | +-- Module : Simulation.Aivika.Trans.Table +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It defines the table functions. +-- +module Simulation.Aivika.Trans.Table + (tableLookup, + tableLookupStepwise) where + +import Simulation.Aivika.Table 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,173 +1,184 @@ - --- | --- Module : Simulation.Aivika.Trans.Task --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The 'Task' value represents a process that was already started in background. --- We can check the completion of the task, receive notifications about changing --- its state and even suspend an outer process awaiting the final result of the task. --- It complements the 'Process' monad as it allows immediately continuing the main --- computation without suspension. --- -module Simulation.Aivika.Trans.Task - (-- * Task - Task, - TaskResult(..), - taskId, - tryGetTaskResult, - taskResult, - taskResultReceived, - taskProcess, - cancelTask, - taskCancelled, - -- * Running Task - runTask, - runTaskUsingId, - -- * Spawning Tasks - spawnTask, - spawnTaskUsingId, - -- * Enqueueing Task - enqueueTask, - enqueueTaskUsingId) where - -import Data.Monoid - -import Control.Monad -import Control.Monad.Trans -import Control.Exception - -import Simulation.Aivika.Trans.Specs -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Parameter -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Dynamics -import Simulation.Aivika.Trans.Internal.Event -import Simulation.Aivika.Trans.Internal.Cont -import Simulation.Aivika.Trans.Internal.Process -import Simulation.Aivika.Trans.Internal.Signal - --- | The task represents a process that was already started in background. -data Task m a = - Task { taskId :: ProcessId m, - -- ^ Return an identifier for the process that was launched - -- in background for this task. - taskResultRef :: ProtoRef m (Maybe (TaskResult a)), - -- ^ It contains the result of the computation. - taskResultReceived :: Signal m (TaskResult a) - -- ^ Return a signal that notifies about receiving - -- the result of the task. - } - --- | Represents the result of the task. -data TaskResult a = TaskCompleted a - -- ^ the task was successfully completed and - -- it returned the specified result - | TaskError SomeException - -- ^ the specified exception was raised when performing the task. - | TaskCancelled - -- ^ the task was cancelled - --- | Try to get the task result immediately without suspension. -tryGetTaskResult :: MonadComp m => Task m a -> Event m (Maybe (TaskResult a)) -tryGetTaskResult t = - Event $ \p -> readProtoRef (taskResultRef t) - --- | Return the task result suspending the outer process if required. -taskResult :: MonadComp m => Task m a -> Process m (TaskResult a) -taskResult t = - do x <- liftComp $ readProtoRef (taskResultRef t) - case x of - Just x -> return x - Nothing -> processAwait (taskResultReceived t) - --- | Cancel the task. -cancelTask :: MonadComp m => Task m a -> Event m () -cancelTask t = - cancelProcessWithId (taskId t) - --- | Test whether the task was cancelled. -taskCancelled :: MonadComp m => Task m a -> Event m Bool -taskCancelled t = - processCancelled (taskId t) - --- | Create a task by the specified process and its identifier. -newTaskUsingId :: MonadComp m => ProcessId m -> Process m a -> Event m (Task m a, Process m ()) -newTaskUsingId pid p = - do sn <- liftParameter simulationSession - r <- liftComp $ newProtoRef sn Nothing - s <- liftSimulation newSignalSource - let t = Task { taskId = pid, - taskResultRef = r, - taskResultReceived = publishSignal s } - let m = - do v <- liftComp $ newProtoRef sn TaskCancelled - finallyProcess - (catchProcess - (do a <- p - liftComp $ writeProtoRef v (TaskCompleted a)) - (\e -> - liftComp $ writeProtoRef v (TaskError e))) - (liftEvent $ - do x <- liftComp $ readProtoRef v - liftComp $ writeProtoRef r (Just x) - triggerSignal s x) - return (t, m) - --- | Run the process with the specified identifier in background and --- return the corresponded task immediately. -runTaskUsingId :: MonadComp m => ProcessId m -> Process m a -> Event m (Task m a) -runTaskUsingId pid p = - do (t, m) <- newTaskUsingId pid p - runProcessUsingId pid m - return t - --- | Run the process in background and return the corresponded task immediately. -runTask :: MonadComp m => Process m a -> Event m (Task m a) -runTask p = - do pid <- liftSimulation newProcessId - runTaskUsingId pid p - --- | Enqueue the process that will be started at the specified time with the given --- identifier from the event queue. It returns the corresponded task immediately. -enqueueTaskUsingId :: MonadComp m => Double -> ProcessId m -> Process m a -> Event m (Task m a) -enqueueTaskUsingId time pid p = - do (t, m) <- newTaskUsingId pid p - enqueueProcessUsingId time pid m - return t - --- | Enqueue the process that will be started at the specified time from the event queue. --- It returns the corresponded task immediately. -enqueueTask :: MonadComp m => Double -> Process m a -> Event m (Task m a) -enqueueTask time p = - do pid <- liftSimulation newProcessId - enqueueTaskUsingId time pid p - --- | Run using the specified identifier a child process in background and return --- immediately the corresponded task. -spawnTaskUsingId :: MonadComp m => ContCancellation -> ProcessId m -> Process m a -> Process m (Task m a) -spawnTaskUsingId cancellation pid p = - do (t, m) <- liftEvent $ newTaskUsingId pid p - spawnProcessUsingId cancellation pid m - return t - --- | Run a child process in background and return immediately the corresponded task. -spawnTask :: MonadComp m => ContCancellation -> Process m a -> Process m (Task m a) -spawnTask cancellation p = - do pid <- liftSimulation newProcessId - spawnTaskUsingId cancellation pid p - --- | Return an outer process that behaves like the task itself except for one thing: --- if the outer process is cancelled then it is not enough to cancel the task. -taskProcess :: MonadComp m => Task m a -> Process m a -taskProcess t = - do x <- taskResult t - case x of - TaskCompleted a -> return a - TaskError e -> throwProcess e - TaskCancelled -> cancelProcess + +-- | +-- Module : Simulation.Aivika.Trans.Task +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The 'Task' value represents a process that was already started in background. +-- We can check the completion of the task, receive notifications about changing +-- its state and even suspend an outer process awaiting the final result of the task. +-- It complements the 'Process' monad as it allows immediately continuing the main +-- computation without suspension. +-- +module Simulation.Aivika.Trans.Task + (-- * Task + Task, + TaskResult(..), + taskId, + tryGetTaskResult, + taskResult, + taskResultReceived, + taskProcess, + cancelTask, + taskCancelled, + -- * Running Task + runTask, + runTaskUsingId, + -- * Spawning Tasks + spawnTask, + spawnTaskUsingId, + spawnTaskWith, + spawnTaskUsingIdWith, + -- * Enqueueing Task + enqueueTask, + enqueueTaskUsingId) where + +import Data.Monoid + +import Control.Monad +import Control.Monad.Trans +import Control.Exception + +import Simulation.Aivika.Trans.Specs +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Parameter +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Cont +import Simulation.Aivika.Trans.Internal.Process +import Simulation.Aivika.Trans.Internal.Signal + +-- | The task represents a process that was already started in background. +data Task m a = + Task { taskId :: ProcessId m, + -- ^ Return an identifier for the process that was launched + -- in background for this task. + taskResultRef :: ProtoRef m (Maybe (TaskResult a)), + -- ^ It contains the result of the computation. + taskResultReceived :: Signal m (TaskResult a) + -- ^ Return a signal that notifies about receiving + -- the result of the task. + } + +-- | Represents the result of the task. +data TaskResult a = TaskCompleted a + -- ^ the task was successfully completed and + -- it returned the specified result + | TaskError SomeException + -- ^ the specified exception was raised when performing the task. + | TaskCancelled + -- ^ the task was cancelled + +-- | Try to get the task result immediately without suspension. +tryGetTaskResult :: MonadComp m => Task m a -> Event m (Maybe (TaskResult a)) +tryGetTaskResult t = + Event $ \p -> readProtoRef (taskResultRef t) + +-- | Return the task result suspending the outer process if required. +taskResult :: MonadComp m => Task m a -> Process m (TaskResult a) +taskResult t = + do x <- liftComp $ readProtoRef (taskResultRef t) + case x of + Just x -> return x + Nothing -> processAwait (taskResultReceived t) + +-- | Cancel the task. +cancelTask :: MonadComp m => Task m a -> Event m () +cancelTask t = + cancelProcessWithId (taskId t) + +-- | Test whether the task was cancelled. +taskCancelled :: MonadComp m => Task m a -> Event m Bool +taskCancelled t = + processCancelled (taskId t) + +-- | Create a task by the specified process and its identifier. +newTaskUsingId :: MonadComp m => ProcessId m -> Process m a -> Event m (Task m a, Process m ()) +newTaskUsingId pid p = + do sn <- liftParameter simulationSession + r <- liftComp $ newProtoRef sn Nothing + s <- liftSimulation newSignalSource + let t = Task { taskId = pid, + taskResultRef = r, + taskResultReceived = publishSignal s } + let m = + do v <- liftComp $ newProtoRef sn TaskCancelled + finallyProcess + (catchProcess + (do a <- p + liftComp $ writeProtoRef v (TaskCompleted a)) + (\e -> + liftComp $ writeProtoRef v (TaskError e))) + (liftEvent $ + do x <- liftComp $ readProtoRef v + liftComp $ writeProtoRef r (Just x) + triggerSignal s x) + return (t, m) + +-- | Run the process with the specified identifier in background and +-- return the corresponded task immediately. +runTaskUsingId :: MonadComp m => ProcessId m -> Process m a -> Event m (Task m a) +runTaskUsingId pid p = + do (t, m) <- newTaskUsingId pid p + runProcessUsingId pid m + return t + +-- | Run the process in background and return the corresponded task immediately. +runTask :: MonadComp m => Process m a -> Event m (Task m a) +runTask p = + do pid <- liftSimulation newProcessId + runTaskUsingId pid p + +-- | Enqueue the process that will be started at the specified time with the given +-- identifier from the event queue. It returns the corresponded task immediately. +enqueueTaskUsingId :: MonadComp m => Double -> ProcessId m -> Process m a -> Event m (Task m a) +enqueueTaskUsingId time pid p = + do (t, m) <- newTaskUsingId pid p + enqueueProcessUsingId time pid m + return t + +-- | Enqueue the process that will be started at the specified time from the event queue. +-- It returns the corresponded task immediately. +enqueueTask :: MonadComp m => Double -> Process m a -> Event m (Task m a) +enqueueTask time p = + do pid <- liftSimulation newProcessId + enqueueTaskUsingId time pid p + +-- | Run using the specified identifier a child process in background and return +-- immediately the corresponded task. +spawnTaskUsingId :: MonadComp m => ProcessId m -> Process m a -> Process m (Task m a) +spawnTaskUsingId = spawnTaskUsingIdWith CancelTogether + +-- | Run a child process in background and return immediately the corresponded task. +spawnTask :: MonadComp m => Process m a -> Process m (Task m a) +spawnTask = spawnTaskWith CancelTogether + +-- | Run using the specified identifier a child process in background and return +-- immediately the corresponded task. +spawnTaskUsingIdWith :: MonadComp m => ContCancellation -> ProcessId m -> Process m a -> Process m (Task m a) +spawnTaskUsingIdWith cancellation pid p = + do (t, m) <- liftEvent $ newTaskUsingId pid p + spawnProcessUsingIdWith cancellation pid m + return t + +-- | Run a child process in background and return immediately the corresponded task. +spawnTaskWith :: MonadComp m => ContCancellation -> Process m a -> Process m (Task m a) +spawnTaskWith cancellation p = + do pid <- liftSimulation newProcessId + spawnTaskUsingIdWith cancellation pid p + +-- | Return an outer process that behaves like the task itself except for one thing: +-- if the outer process is cancelled then it is not enough to cancel the task. +taskProcess :: MonadComp m => Task m a -> Process m a +taskProcess t = + do x <- taskResult t + case x of + TaskCompleted a -> return a + TaskError e -> throwProcess e + TaskCancelled -> cancelProcess 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 @@ -1,130 +1,150 @@ - -{-# LANGUAGE RecursiveDo #-} - --- | --- Module : Simulation.Aivika.Trans.Transform --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines something which is most close to the notion of --- analogous circuit as an opposite to the digital one. --- -module Simulation.Aivika.Trans.Transform - (-- * The Transform Arrow - Transform(..), - -- * Delaying the Transform - delayTransform, - -- * The Time Transform - timeTransform, - -- * Differential and Difference Equations - integTransform, - sumTransform) where - -import qualified Control.Category as C -import Control.Arrow -import Control.Monad -import Control.Monad.Fix - -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Simulation -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Dynamics.Memo -import Simulation.Aivika.Trans.Unboxed -import Simulation.Aivika.Trans.SystemDynamics - --- | It allows representing an analogous circuit as an opposite to --- the digital one. --- --- This is a transform of one time varying function to another usually --- specified in the integration time points and then interpolated in --- other time points with help of one of the memoization functions --- like 'memo0Dynamics'. --- -newtype Transform m a b = - Transform { runTransform :: Dynamics m a -> Simulation m (Dynamics m b) - -- ^ Run the transform. - } - -instance MonadComp m => C.Category (Transform m) where - - id = Transform return - - (Transform g) . (Transform f) = - Transform $ \a -> f a >>= g - -instance MonadComp m => Arrow (Transform m) where - - arr f = Transform $ return . fmap f - - first (Transform f) = - Transform $ \bd -> - do (b, d) <- unzip0Dynamics bd - c <- f b - return $ liftM2 (,) c d - - second (Transform f) = - Transform $ \db -> - do (d, b) <- unzip0Dynamics db - c <- f b - return $ liftM2 (,) d c - - (Transform f) *** (Transform g) = - Transform $ \bb' -> - do (b, b') <- unzip0Dynamics bb' - c <- f b - c' <- g b' - return $ liftM2 (,) c c' - - (Transform f) &&& (Transform g) = - Transform $ \b -> - do c <- f b - c' <- g b - return $ liftM2 (,) c c' - -instance (MonadComp m, MonadFix m) => ArrowLoop (Transform m) where - - loop (Transform f) = - Transform $ \b -> - mdo let bd = liftM2 (,) b d - cd <- f bd - (c, d) <- unzip0Dynamics cd - return c - --- | A transform that returns the current modeling time. -timeTransform :: MonadComp m => Transform m a Double -timeTransform = Transform $ const $ return time - --- | Return a delayed transform by the specified lag time and initial value. --- --- This is actually the 'delayI' function wrapped in the 'Transform' type. -delayTransform :: MonadComp m - => Dynamics m Double -- ^ the lag time - -> Dynamics m a -- ^ the initial value - -> Transform m a a -- ^ the delayed transform -delayTransform lagTime init = - Transform $ \a -> delayI a lagTime init - --- | Return a transform that maps the derivative to an integral --- by the specified initial value. --- --- This is actually the 'integ' function wrapped in the 'Transform' type. -integTransform :: (MonadComp m, MonadFix m) - => Dynamics m Double - -- ^ the initial value - -> Transform m Double Double - -- ^ map the derivative to an integral -integTransform = Transform . integ - --- | Return a transform that maps the difference to a sum --- by the specified initial value. --- --- This is actually the 'diffsum' function wrapped in the 'Transform' type. -sumTransform :: (MonadComp m, MonadFix m, Num a, Unboxed m a) => - Dynamics m a - -- ^ the initial value - -> Transform m a a - -- ^ map the difference to a sum -sumTransform = Transform . diffsum + +{-# LANGUAGE RecursiveDo #-} + +-- | +-- Module : Simulation.Aivika.Trans.Transform +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines something which is most close to the notion of +-- analogous circuit as an opposite to the digital one. +-- +module Simulation.Aivika.Trans.Transform + (-- * The Transform Arrow + Transform(..), + -- * Delaying the Transform + delayTransform, + -- * The Time Transform + timeTransform, + -- * Differential and Difference Equations + integTransform, + integTransformEither, + sumTransform, + sumTransformEither) where + +import qualified Control.Category as C +import Control.Arrow +import Control.Monad +import Control.Monad.Fix + +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Simulation +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Dynamics.Memo +import Simulation.Aivika.Trans.Unboxed +import Simulation.Aivika.Trans.SystemDynamics + +-- | It allows representing an analogous circuit as an opposite to +-- the digital one. +-- +-- This is a transform of one time varying function to another usually +-- specified in the integration time points and then interpolated in +-- other time points with help of one of the memoization functions +-- like 'memo0Dynamics'. +-- +newtype Transform m a b = + Transform { runTransform :: Dynamics m a -> Simulation m (Dynamics m b) + -- ^ Run the transform. + } + +instance MonadComp m => C.Category (Transform m) where + + id = Transform return + + (Transform g) . (Transform f) = + Transform $ \a -> f a >>= g + +instance MonadComp m => Arrow (Transform m) where + + arr f = Transform $ return . fmap f + + first (Transform f) = + Transform $ \bd -> + do (b, d) <- unzip0Dynamics bd + c <- f b + return $ liftM2 (,) c d + + second (Transform f) = + Transform $ \db -> + do (d, b) <- unzip0Dynamics db + c <- f b + return $ liftM2 (,) d c + + (Transform f) *** (Transform g) = + Transform $ \bb' -> + do (b, b') <- unzip0Dynamics bb' + c <- f b + c' <- g b' + return $ liftM2 (,) c c' + + (Transform f) &&& (Transform g) = + Transform $ \b -> + do c <- f b + c' <- g b + return $ liftM2 (,) c c' + +instance (MonadComp m, MonadFix m) => ArrowLoop (Transform m) where + + loop (Transform f) = + Transform $ \b -> + mdo let bd = liftM2 (,) b d + cd <- f bd + (c, d) <- unzip0Dynamics cd + return c + +-- | A transform that returns the current modeling time. +timeTransform :: MonadComp m => Transform m a Double +timeTransform = Transform $ const $ return time + +-- | Return a delayed transform by the specified lag time and initial value. +-- +-- This is actually the 'delayI' function wrapped in the 'Transform' type. +delayTransform :: MonadComp m + => Dynamics m Double -- ^ the lag time + -> Dynamics m a -- ^ the initial value + -> Transform m a a -- ^ the delayed transform +delayTransform lagTime init = + Transform $ \a -> delayI a lagTime init + +-- | Return a transform that maps the derivative to an integral +-- by the specified initial value. +-- +-- This is actually the 'integ' function wrapped in the 'Transform' type. +integTransform :: (MonadComp m, MonadFix m) + => Dynamics m Double + -- ^ the initial value + -> Transform m Double Double + -- ^ map the derivative to an integral +integTransform init = Transform $ \diff -> integ diff init + +-- | Like 'integTransform' but allows either setting a new 'Left' value of the integral, +-- or updating it by the specified 'Right' derivative. +integTransformEither :: (MonadComp m, MonadFix m) + => Dynamics m Double + -- ^ the initial value + -> Transform m (Either Double Double) Double + -- ^ map either a new 'Left' value or the 'Right' derivative to an integral +integTransformEither init = Transform $ \diff -> integEither diff init + +-- | Return a transform that maps the difference to a sum +-- by the specified initial value. +-- +-- This is actually the 'diffsum' function wrapped in the 'Transform' type. +sumTransform :: (MonadComp m, MonadFix m, Num a, Unboxed m a) + => Dynamics m a + -- ^ the initial value + -> Transform m a a + -- ^ map the difference to a sum +sumTransform init = Transform $ \diff -> diffsum diff init + +-- | Like 'sumTransform' but allows either setting a new 'Left' value of the sum, +-- or updating it by the specified 'Right' difference. +sumTransformEither :: (MonadComp m, MonadFix m, Num a, Unboxed m a) + => Dynamics m a + -- ^ the initial value + -> Transform m (Either a a) a + -- ^ map either a new 'Left' value or the 'Right' difference to a sum +sumTransformEither init = Transform $ \diff -> diffsumEither diff init diff --git a/Simulation/Aivika/Trans/Transform/Extra.hs b/Simulation/Aivika/Trans/Transform/Extra.hs --- a/Simulation/Aivika/Trans/Transform/Extra.hs +++ b/Simulation/Aivika/Trans/Transform/Extra.hs @@ -1,58 +1,58 @@ - --- | --- Module : Simulation.Aivika.Trans.Transform.Extra --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines auxiliary computations such as interpolation ones --- that complement the memoization, for example. There are scan computations too. --- - -module Simulation.Aivika.Trans.Transform.Extra - (-- * Interpolation - initTransform, - discreteTransform, - interpolatingTransform, - -- * Scans - scanTransform, - scan1Transform) where - -import Control.Monad -import Control.Monad.Fix - -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Dynamics.Extra -import Simulation.Aivika.Trans.Transform -import Simulation.Aivika.Trans.Transform.Memo - --- | A transform that returns the initial value. -initTransform :: Monad m => Transform m a a -initTransform = Transform $ return . initDynamics - --- | A transform that discretizes the computation in the integration time points. -discreteTransform :: Monad m => Transform m a a -discreteTransform = Transform $ return . discreteDynamics - --- | A tranform that interpolates the computation based on the integration time points only. --- Unlike the 'discreteTransform' computation it knows about the intermediate --- time points that are used in the Runge-Kutta method. -interpolatingTransform :: Monad m => Transform m a a -interpolatingTransform = Transform $ return . interpolateDynamics - --- | Like the standard 'scanl1' function but applied to values in --- the integration time points. The accumulator values are transformed --- according to the second argument, which should be either --- 'memo0Transform' or its unboxed version. -scan1Transform :: (MonadComp m, MonadFix m) => (a -> a -> a) -> Transform m a a -> Transform m a a -scan1Transform f (Transform tr) = Transform $ scan1Dynamics f tr - --- | Like the standard 'scanl' function but applied to values in --- the integration time points. The accumulator values are transformed --- according to the third argument, which should be either --- 'memo0Transform' or its unboxed version. -scanTransform :: (MonadComp m, MonadFix m) => (a -> b -> a) -> a -> Transform m a a -> Transform m b a -scanTransform f acc (Transform tr) = Transform $ scanDynamics f acc tr + +-- | +-- Module : Simulation.Aivika.Trans.Transform.Extra +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines auxiliary computations such as interpolation ones +-- that complement the memoization, for example. There are scan computations too. +-- + +module Simulation.Aivika.Trans.Transform.Extra + (-- * Interpolation + initTransform, + discreteTransform, + interpolatingTransform, + -- * Scans + scanTransform, + scan1Transform) where + +import Control.Monad +import Control.Monad.Fix + +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Dynamics.Extra +import Simulation.Aivika.Trans.Transform +import Simulation.Aivika.Trans.Transform.Memo + +-- | A transform that returns the initial value. +initTransform :: Monad m => Transform m a a +initTransform = Transform $ return . initDynamics + +-- | A transform that discretizes the computation in the integration time points. +discreteTransform :: Monad m => Transform m a a +discreteTransform = Transform $ return . discreteDynamics + +-- | A tranform that interpolates the computation based on the integration time points only. +-- Unlike the 'discreteTransform' computation it knows about the intermediate +-- time points that are used in the Runge-Kutta method. +interpolatingTransform :: Monad m => Transform m a a +interpolatingTransform = Transform $ return . interpolateDynamics + +-- | Like the standard 'scanl1' function but applied to values in +-- the integration time points. The accumulator values are transformed +-- according to the second argument, which should be either +-- 'memo0Transform' or its unboxed version. +scan1Transform :: (MonadComp m, MonadFix m) => (a -> a -> a) -> Transform m a a -> Transform m a a +scan1Transform f (Transform tr) = Transform $ scan1Dynamics f tr + +-- | Like the standard 'scanl' function but applied to values in +-- the integration time points. The accumulator values are transformed +-- according to the third argument, which should be either +-- 'memo0Transform' or its unboxed version. +scanTransform :: (MonadComp m, MonadFix m) => (a -> b -> a) -> a -> Transform m a a -> Transform m b a +scanTransform f acc (Transform tr) = Transform $ scanDynamics f acc tr diff --git a/Simulation/Aivika/Trans/Transform/Memo.hs b/Simulation/Aivika/Trans/Transform/Memo.hs --- a/Simulation/Aivika/Trans/Transform/Memo.hs +++ b/Simulation/Aivika/Trans/Transform/Memo.hs @@ -1,46 +1,46 @@ - --- | --- Module : Simulation.Aivika.Trans.Transform.Memo --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines memoization transforms. The memoization creates such 'Dynamics' --- computations, which values are cached in the integration time points. Then --- these values are interpolated in all other time points. --- - -module Simulation.Aivika.Trans.Transform.Memo - (memoTransform, - memo0Transform, - iteratingTransform) where - -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Parameter -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Dynamics.Extra -import Simulation.Aivika.Trans.Dynamics.Memo -import Simulation.Aivika.Trans.Transform - --- | A transform that memoizes and order the computation in the integration time points --- using the interpolation that knows of the Runge-Kutta method. The values are --- calculated sequentially starting from 'starttime'. -memoTransform :: MonadComp m => Transform m e e -memoTransform = Transform memoDynamics - --- | A transform that memoizes and order the computation in the integration time points using --- the 'discreteDynamics' interpolation. It consumes less memory than the 'memoTransform' --- computation but it is not aware of the Runge-Kutta method. There is a subtle --- difference when we request for values in the intermediate time points --- that are used by this method to integrate. In general case you should --- prefer the 'memo0Transform' computation above 'memoTransform'. -memo0Transform :: MonadComp m => Transform m e e -memo0Transform = Transform memo0Dynamics - --- | A transform that iterates sequentially the dynamic process with side effects in --- the integration time points. It is equivalent to the 'memo0Transform' computation --- but significantly more efficient, for the internal array is not created. -iteratingTransform :: MonadComp m => Transform m () () -iteratingTransform = Transform iterateDynamics + +-- | +-- Module : Simulation.Aivika.Trans.Transform.Memo +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines memoization transforms. The memoization creates such 'Dynamics' +-- computations, which values are cached in the integration time points. Then +-- these values are interpolated in all other time points. +-- + +module Simulation.Aivika.Trans.Transform.Memo + (memoTransform, + memo0Transform, + iteratingTransform) where + +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Parameter +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Dynamics.Extra +import Simulation.Aivika.Trans.Dynamics.Memo +import Simulation.Aivika.Trans.Transform + +-- | A transform that memoizes and order the computation in the integration time points +-- using the interpolation that knows of the Runge-Kutta method. The values are +-- calculated sequentially starting from 'starttime'. +memoTransform :: MonadComp m => Transform m e e +memoTransform = Transform memoDynamics + +-- | A transform that memoizes and order the computation in the integration time points using +-- the 'discreteDynamics' interpolation. It consumes less memory than the 'memoTransform' +-- computation but it is not aware of the Runge-Kutta method. There is a subtle +-- difference when we request for values in the intermediate time points +-- that are used by this method to integrate. In general case you should +-- prefer the 'memo0Transform' computation above 'memoTransform'. +memo0Transform :: MonadComp m => Transform m e e +memo0Transform = Transform memo0Dynamics + +-- | A transform that iterates sequentially the dynamic process with side effects in +-- the integration time points. It is equivalent to the 'memo0Transform' computation +-- but significantly more efficient, for the internal array is not created. +iteratingTransform :: MonadComp m => Transform m () () +iteratingTransform = Transform iterateDynamics diff --git a/Simulation/Aivika/Trans/Transform/Memo/Unboxed.hs b/Simulation/Aivika/Trans/Transform/Memo/Unboxed.hs --- a/Simulation/Aivika/Trans/Transform/Memo/Unboxed.hs +++ b/Simulation/Aivika/Trans/Transform/Memo/Unboxed.hs @@ -1,42 +1,42 @@ - -{-# LANGUAGE FlexibleContexts #-} - --- | --- Module : Simulation.Aivika.Trans.Transform.Memo.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines the unboxed memoization transforms. The memoization creates such 'Dynamics' --- computations, which values are cached in the integration time points. Then --- these values are interpolated in all other time points. --- - -module Simulation.Aivika.Trans.Transform.Memo.Unboxed - (memoTransform, - memo0Transform) where - -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Parameter -import Simulation.Aivika.Trans.Dynamics -import Simulation.Aivika.Trans.Dynamics.Extra -import Simulation.Aivika.Trans.Dynamics.Memo.Unboxed -import Simulation.Aivika.Trans.Transform -import Simulation.Aivika.Trans.Unboxed - --- | A transform that memoizes and order the computation in the integration time points --- using the interpolation that knows of the Runge-Kutta method. The values are --- calculated sequentially starting from 'starttime'. -memoTransform :: (MonadComp m, Unboxed m e) => Transform m e e -memoTransform = Transform memoDynamics - --- | A transform that memoizes and order the computation in the integration time points using --- the 'discreteDynamics' interpolation. It consumes less memory than the 'memoTransform' --- computation but it is not aware of the Runge-Kutta method. There is a subtle --- difference when we request for values in the intermediate time points --- that are used by this method to integrate. In general case you should --- prefer the 'memo0Transform' computation above 'memoTransform'. -memo0Transform :: (MonadComp m, Unboxed m e) => Transform m e e -memo0Transform = Transform memo0Dynamics + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.Transform.Memo.Unboxed +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the unboxed memoization transforms. The memoization creates such 'Dynamics' +-- computations, which values are cached in the integration time points. Then +-- these values are interpolated in all other time points. +-- + +module Simulation.Aivika.Trans.Transform.Memo.Unboxed + (memoTransform, + memo0Transform) where + +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Parameter +import Simulation.Aivika.Trans.Dynamics +import Simulation.Aivika.Trans.Dynamics.Extra +import Simulation.Aivika.Trans.Dynamics.Memo.Unboxed +import Simulation.Aivika.Trans.Transform +import Simulation.Aivika.Trans.Unboxed + +-- | A transform that memoizes and order the computation in the integration time points +-- using the interpolation that knows of the Runge-Kutta method. The values are +-- calculated sequentially starting from 'starttime'. +memoTransform :: (MonadComp m, Unboxed m e) => Transform m e e +memoTransform = Transform memoDynamics + +-- | A transform that memoizes and order the computation in the integration time points using +-- the 'discreteDynamics' interpolation. It consumes less memory than the 'memoTransform' +-- computation but it is not aware of the Runge-Kutta method. There is a subtle +-- difference when we request for values in the intermediate time points +-- that are used by this method to integrate. In general case you should +-- prefer the 'memo0Transform' computation above 'memoTransform'. +memo0Transform :: (MonadComp m, Unboxed m e) => Transform m e e +memo0Transform = Transform memo0Dynamics diff --git a/Simulation/Aivika/Trans/Unboxed.hs b/Simulation/Aivika/Trans/Unboxed.hs --- a/Simulation/Aivika/Trans/Unboxed.hs +++ b/Simulation/Aivika/Trans/Unboxed.hs @@ -1,45 +1,45 @@ - -{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses #-} - --- | --- Module : Simulation.Aivika.Trans.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The 'Unboxed' class allows creating unboxed arrays in monad 'IO'. --- - -module Simulation.Aivika.Trans.Unboxed - (Unboxed(..)) where - -import Simulation.Aivika.Trans.ProtoArray.Unboxed - -import Data.Array -import Data.Int -import Data.Word - --- | The type which values can be contained in an unboxed array. -class ProtoArrayMonad m e => Unboxed m e - -instance Unboxed IO Bool -instance Unboxed IO Char -instance Unboxed IO Double -instance Unboxed IO Float -instance Unboxed IO Int -instance Unboxed IO Int8 -instance Unboxed IO Int16 -instance Unboxed IO Int32 -instance Unboxed IO Word -instance Unboxed IO Word8 -instance Unboxed IO Word16 -instance Unboxed IO Word32 - -#ifndef __HASTE__ - -instance Unboxed IO Int64 -instance Unboxed IO Word64 - -#endif + +{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses #-} + +-- | +-- Module : Simulation.Aivika.Trans.Unboxed +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The 'Unboxed' class allows creating unboxed arrays in monad 'IO'. +-- + +module Simulation.Aivika.Trans.Unboxed + (Unboxed(..)) where + +import Simulation.Aivika.Trans.ProtoArray.Unboxed + +import Data.Array +import Data.Int +import Data.Word + +-- | The type which values can be contained in an unboxed array. +class ProtoArrayMonad m e => Unboxed m e + +instance Unboxed IO Bool +instance Unboxed IO Char +instance Unboxed IO Double +instance Unboxed IO Float +instance Unboxed IO Int +instance Unboxed IO Int8 +instance Unboxed IO Int16 +instance Unboxed IO Int32 +instance Unboxed IO Word +instance Unboxed IO Word8 +instance Unboxed IO Word16 +instance Unboxed IO Word32 + +#ifndef __HASTE__ + +instance Unboxed IO Int64 +instance Unboxed IO Word64 + +#endif diff --git a/Simulation/Aivika/Trans/Var.hs b/Simulation/Aivika/Trans/Var.hs --- a/Simulation/Aivika/Trans/Var.hs +++ b/Simulation/Aivika/Trans/Var.hs @@ -1,190 +1,190 @@ - --- | --- Module : Simulation.Aivika.Trans.Var --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines a variable that is bound up with the event queue and --- that keeps the history of changes storing the values in arrays, which --- allows using the variable in differential and difference equations of --- System Dynamics within hybrid discrete-continuous simulation. --- -module Simulation.Aivika.Trans.Var - (Var, - varChanged, - varChanged_, - newVar, - readVar, - varMemo, - writeVar, - modifyVar, - freezeVar) where - -import Data.Array - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Dynamics -import Simulation.Aivika.Trans.Internal.Event -import Simulation.Aivika.Trans.Internal.Signal -import Simulation.Aivika.Trans.Ref -import Simulation.Aivika.Trans.Signal - -import qualified Simulation.Aivika.Trans.Vector as V -import qualified Simulation.Aivika.Trans.Vector.Unboxed as UV - --- | Like the 'Ref' reference but keeps the history of changes in --- different time points. The 'Var' variable is safe to be used in --- the hybrid discrete-continuous simulation. --- --- For example, the memoised values of a variable can be used in --- the differential or difference equations of System Dynamics, while --- the variable iself can be updated wihin the discrete event simulation. --- --- Only this variable is much slower than the reference. -data Var m a = - Var { varXS :: UV.Vector m Double, - varMS :: V.Vector m a, - varYS :: V.Vector m a, - varChangedSource :: SignalSource m a } - --- | Create a new variable. -newVar :: MonadComp m => a -> Simulation m (Var m a) -newVar a = - Simulation $ \r -> - do let sn = runSession r - xs <- UV.newVector sn - ms <- V.newVector sn - ys <- V.newVector sn - UV.appendVector xs $ spcStartTime $ runSpecs r - V.appendVector ms a - V.appendVector ys a - s <- invokeSimulation r newSignalSource - return Var { varXS = xs, - varMS = ms, - varYS = ms, - varChangedSource = s } - --- | Read the first actual, i.e. memoised, value of a variable for the requested time --- actuating the current events from the queue if needed. --- --- This computation can be used in the ordinary differential and --- difference equations of System Dynamics. -varMemo :: MonadComp m => Var m a -> Dynamics m a -varMemo v = - runEventWith CurrentEventsOrFromPast $ - Event $ \p -> - do let xs = varXS v - ms = varMS v - ys = varYS v - t = pointTime p - count <- UV.vectorCount xs - let i = count - 1 - x <- UV.readVector xs i - if x < t - then do a <- V.readVector ys i - UV.appendVector xs t - V.appendVector ms a - V.appendVector ys a - return a - else if x == t - then V.readVector ms i - else do i <- UV.vectorBinarySearch xs t - if i >= 0 - then V.readVector ms i - else V.readVector ms $ - (i + 1) - 1 - --- | Read the recent actual value of a variable for the requested time. --- --- This computation is destined for using within discrete event simulation. -readVar :: MonadComp m => Var m a -> Event m a -readVar v = - Event $ \p -> - do let xs = varXS v - ys = varYS v - t = pointTime p - count <- UV.vectorCount xs - let i = count - 1 - x <- UV.readVector xs i - if x <= t - then V.readVector ys i - else do i <- UV.vectorBinarySearch xs t - if i >= 0 - then V.readVector ys i - else V.readVector ys $ - (i + 1) - 1 - --- | Write a new value into the variable. -writeVar :: MonadComp m => Var m a -> a -> Event m () -writeVar v a = - Event $ \p -> - do let xs = varXS v - ms = varMS v - ys = varYS v - t = pointTime p - s = varChangedSource v - count <- UV.vectorCount xs - let i = count - 1 - x <- UV.readVector xs i - if t < x - then error "Cannot update the past data: writeVar." - else if t == x - then V.writeVector ys i $! a - else do UV.appendVector xs t - V.appendVector ms $! a - V.appendVector ys $! a - invokeEvent p $ triggerSignal s a - --- | Mutate the contents of the variable. -modifyVar :: MonadComp m => Var m a -> (a -> a) -> Event m () -modifyVar v f = - Event $ \p -> - do let xs = varXS v - ms = varMS v - ys = varYS v - t = pointTime p - s = varChangedSource v - count <- UV.vectorCount xs - let i = count - 1 - x <- UV.readVector xs i - if t < x - then error "Cannot update the past data: modifyVar." - else if t == x - then do a <- V.readVector ys i - let b = f a - V.writeVector ys i $! b - invokeEvent p $ triggerSignal s b - else do a <- V.readVector ys i - let b = f a - UV.appendVector xs t - V.appendVector ms $! b - V.appendVector ys $! b - invokeEvent p $ triggerSignal s b - --- | Freeze the variable and return in arrays the time points and corresponded --- first and last values when the variable had changed or had been memoised in --- different time points: (1) the time points are sorted in ascending order; --- (2) the first and last actual values per each time point are provided. --- --- If you need to get all changes including those ones that correspond to the same --- simulation time points then you can use the 'newSignalHistory' function passing --- in the 'varChanged' signal to it and then call function 'readSignalHistory'. -freezeVar :: MonadComp m => Var m a -> Event m (Array Int Double, Array Int a, Array Int a) -freezeVar v = - Event $ \p -> - do xs <- UV.freezeVector (varXS v) - ms <- V.freezeVector (varMS v) - ys <- V.freezeVector (varYS v) - return (xs, ms, ys) - --- | Return a signal that notifies about every change of the variable state. -varChanged :: Var m a -> Signal m a -varChanged v = publishSignal (varChangedSource v) - --- | Return a signal that notifies about every change of the variable state. -varChanged_ :: MonadComp m => Var m a -> Signal m () -varChanged_ v = mapSignal (const ()) $ varChanged v + +-- | +-- Module : Simulation.Aivika.Trans.Var +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines a variable that is bound up with the event queue and +-- that keeps the history of changes storing the values in arrays, which +-- allows using the variable in differential and difference equations of +-- System Dynamics within hybrid discrete-continuous simulation. +-- +module Simulation.Aivika.Trans.Var + (Var, + varChanged, + varChanged_, + newVar, + readVar, + varMemo, + writeVar, + modifyVar, + freezeVar) where + +import Data.Array + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Signal +import Simulation.Aivika.Trans.Ref +import Simulation.Aivika.Trans.Signal + +import qualified Simulation.Aivika.Trans.Vector as V +import qualified Simulation.Aivika.Trans.Vector.Unboxed as UV + +-- | Like the 'Ref' reference but keeps the history of changes in +-- different time points. The 'Var' variable is safe to be used in +-- the hybrid discrete-continuous simulation. +-- +-- For example, the memoised values of a variable can be used in +-- the differential or difference equations of System Dynamics, while +-- the variable iself can be updated wihin the discrete event simulation. +-- +-- Only this variable is much slower than the reference. +data Var m a = + Var { varXS :: UV.Vector m Double, + varMS :: V.Vector m a, + varYS :: V.Vector m a, + varChangedSource :: SignalSource m a } + +-- | Create a new variable. +newVar :: MonadComp m => a -> Simulation m (Var m a) +newVar a = + Simulation $ \r -> + do let sn = runSession r + xs <- UV.newVector sn + ms <- V.newVector sn + ys <- V.newVector sn + UV.appendVector xs $ spcStartTime $ runSpecs r + V.appendVector ms a + V.appendVector ys a + s <- invokeSimulation r newSignalSource + return Var { varXS = xs, + varMS = ms, + varYS = ms, + varChangedSource = s } + +-- | Read the first actual, i.e. memoised, value of a variable for the requested time +-- actuating the current events from the queue if needed. +-- +-- This computation can be used in the ordinary differential and +-- difference equations of System Dynamics. +varMemo :: MonadComp m => Var m a -> Dynamics m a +varMemo v = + runEventWith CurrentEventsOrFromPast $ + Event $ \p -> + do let xs = varXS v + ms = varMS v + ys = varYS v + t = pointTime p + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if x < t + then do a <- V.readVector ys i + UV.appendVector xs t + V.appendVector ms a + V.appendVector ys a + return a + else if x == t + then V.readVector ms i + else do i <- UV.vectorBinarySearch xs t + if i >= 0 + then V.readVector ms i + else V.readVector ms $ - (i + 1) - 1 + +-- | Read the recent actual value of a variable for the requested time. +-- +-- This computation is destined for using within discrete event simulation. +readVar :: MonadComp m => Var m a -> Event m a +readVar v = + Event $ \p -> + do let xs = varXS v + ys = varYS v + t = pointTime p + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if x <= t + then V.readVector ys i + else do i <- UV.vectorBinarySearch xs t + if i >= 0 + then V.readVector ys i + else V.readVector ys $ - (i + 1) - 1 + +-- | Write a new value into the variable. +writeVar :: MonadComp m => Var m a -> a -> Event m () +writeVar v a = + Event $ \p -> + do let xs = varXS v + ms = varMS v + ys = varYS v + t = pointTime p + s = varChangedSource v + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if t < x + then error "Cannot update the past data: writeVar." + else if t == x + then V.writeVector ys i $! a + else do UV.appendVector xs t + V.appendVector ms $! a + V.appendVector ys $! a + invokeEvent p $ triggerSignal s a + +-- | Mutate the contents of the variable. +modifyVar :: MonadComp m => Var m a -> (a -> a) -> Event m () +modifyVar v f = + Event $ \p -> + do let xs = varXS v + ms = varMS v + ys = varYS v + t = pointTime p + s = varChangedSource v + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if t < x + then error "Cannot update the past data: modifyVar." + else if t == x + then do a <- V.readVector ys i + let b = f a + V.writeVector ys i $! b + invokeEvent p $ triggerSignal s b + else do a <- V.readVector ys i + let b = f a + UV.appendVector xs t + V.appendVector ms $! b + V.appendVector ys $! b + invokeEvent p $ triggerSignal s b + +-- | Freeze the variable and return in arrays the time points and corresponded +-- first and last values when the variable had changed or had been memoised in +-- different time points: (1) the time points are sorted in ascending order; +-- (2) the first and last actual values per each time point are provided. +-- +-- If you need to get all changes including those ones that correspond to the same +-- simulation time points then you can use the 'newSignalHistory' function passing +-- in the 'varChanged' signal to it and then call function 'readSignalHistory'. +freezeVar :: MonadComp m => Var m a -> Event m (Array Int Double, Array Int a, Array Int a) +freezeVar v = + Event $ \p -> + do xs <- UV.freezeVector (varXS v) + ms <- V.freezeVector (varMS v) + ys <- V.freezeVector (varYS v) + return (xs, ms, ys) + +-- | Return a signal that notifies about every change of the variable state. +varChanged :: Var m a -> Signal m a +varChanged v = publishSignal (varChangedSource v) + +-- | Return a signal that notifies about every change of the variable state. +varChanged_ :: MonadComp m => Var m a -> Signal m () +varChanged_ v = mapSignal (const ()) $ varChanged v diff --git a/Simulation/Aivika/Trans/Var/Unboxed.hs b/Simulation/Aivika/Trans/Var/Unboxed.hs --- a/Simulation/Aivika/Trans/Var/Unboxed.hs +++ b/Simulation/Aivika/Trans/Var/Unboxed.hs @@ -1,190 +1,190 @@ - --- | --- Module : Simulation.Aivika.Trans.Var.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines an unboxed variable that is bound up with the event queue and --- that keeps the history of changes storing the values in unboxed arrays, which --- allows using the variable in differential and difference equations of --- System Dynamics within hybrid discrete-continuous simulation. --- -module Simulation.Aivika.Trans.Var.Unboxed - (Var, - varChanged, - varChanged_, - newVar, - readVar, - varMemo, - writeVar, - modifyVar, - freezeVar) where - -import Data.Array - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.Comp -import Simulation.Aivika.Trans.Internal.Specs -import Simulation.Aivika.Trans.Internal.Simulation -import Simulation.Aivika.Trans.Internal.Dynamics -import Simulation.Aivika.Trans.Internal.Event -import Simulation.Aivika.Trans.Internal.Signal -import Simulation.Aivika.Trans.Ref -import Simulation.Aivika.Trans.Signal -import Simulation.Aivika.Trans.Unboxed - -import qualified Simulation.Aivika.Trans.Vector.Unboxed as UV - --- | Like the 'Ref' reference but keeps the history of changes in --- different time points. The 'Var' variable is safe to be used in --- the hybrid discrete-continuous simulation. --- --- For example, the memoised values of a variable can be used in --- the differential or difference equations of System Dynamics, while --- the variable iself can be updated wihin the discrete event simulation. --- --- Only this variable is much slower than the reference. -data Var m a = - Var { varXS :: UV.Vector m Double, - varMS :: UV.Vector m a, - varYS :: UV.Vector m a, - varChangedSource :: SignalSource m a } - --- | Create a new variable. -newVar :: (MonadComp m, Unboxed m a) => a -> Simulation m (Var m a) -newVar a = - Simulation $ \r -> - do let sn = runSession r - xs <- UV.newVector sn - ms <- UV.newVector sn - ys <- UV.newVector sn - UV.appendVector xs $ spcStartTime $ runSpecs r - UV.appendVector ms a - UV.appendVector ys a - s <- invokeSimulation r newSignalSource - return Var { varXS = xs, - varMS = ms, - varYS = ms, - varChangedSource = s } - --- | Read the first actual, i.e. memoised, value of a variable for the requested time --- actuating the current events from the queue if needed. --- --- This computation can be used in the ordinary differential and --- difference equations of System Dynamics. -varMemo :: (MonadComp m, Unboxed m a) => Var m a -> Dynamics m a -varMemo v = - runEventWith CurrentEventsOrFromPast $ - Event $ \p -> - do let xs = varXS v - ms = varMS v - ys = varYS v - t = pointTime p - count <- UV.vectorCount xs - let i = count - 1 - x <- UV.readVector xs i - if x < t - then do a <- UV.readVector ys i - UV.appendVector xs t - UV.appendVector ms a - UV.appendVector ys a - return a - else if x == t - then UV.readVector ms i - else do i <- UV.vectorBinarySearch xs t - if i >= 0 - then UV.readVector ms i - else UV.readVector ms $ - (i + 1) - 1 - --- | Read the recent actual value of a variable for the requested time. --- --- This computation is destined for using within discrete event simulation. -readVar :: (MonadComp m, Unboxed m a) => Var m a -> Event m a -readVar v = - Event $ \p -> - do let xs = varXS v - ys = varYS v - t = pointTime p - count <- UV.vectorCount xs - let i = count - 1 - x <- UV.readVector xs i - if x <= t - then UV.readVector ys i - else do i <- UV.vectorBinarySearch xs t - if i >= 0 - then UV.readVector ys i - else UV.readVector ys $ - (i + 1) - 1 - --- | Write a new value into the variable. -writeVar :: (MonadComp m, Unboxed m a) => Var m a -> a -> Event m () -writeVar v a = - Event $ \p -> - do let xs = varXS v - ms = varMS v - ys = varYS v - t = pointTime p - s = varChangedSource v - count <- UV.vectorCount xs - let i = count - 1 - x <- UV.readVector xs i - if t < x - then error "Cannot update the past data: writeVar." - else if t == x - then UV.writeVector ys i $! a - else do UV.appendVector xs t - UV.appendVector ms $! a - UV.appendVector ys $! a - invokeEvent p $ triggerSignal s a - --- | Mutate the contents of the variable. -modifyVar :: (MonadComp m, Unboxed m a) => Var m a -> (a -> a) -> Event m () -modifyVar v f = - Event $ \p -> - do let xs = varXS v - ms = varMS v - ys = varYS v - t = pointTime p - s = varChangedSource v - count <- UV.vectorCount xs - let i = count - 1 - x <- UV.readVector xs i - if t < x - then error "Cannot update the past data: modifyVar." - else if t == x - then do a <- UV.readVector ys i - let b = f a - UV.writeVector ys i $! b - invokeEvent p $ triggerSignal s b - else do a <- UV.readVector ys i - let b = f a - UV.appendVector xs t - UV.appendVector ms $! b - UV.appendVector ys $! b - invokeEvent p $ triggerSignal s b - --- | Freeze the variable and return in arrays the time points and corresponded --- first and last values when the variable had changed or had been memoised in --- different time points: (1) the time points are sorted in ascending order; --- (2) the first and last actual values per each time point are provided. --- --- If you need to get all changes including those ones that correspond to the same --- simulation time points then you can use the 'newSignalHistory' function passing --- in the 'varChanged' signal to it and then call function 'readSignalHistory'. -freezeVar :: (MonadComp m, Unboxed m a) => Var m a -> Event m (Array Int Double, Array Int a, Array Int a) -freezeVar v = - Event $ \p -> - do xs <- UV.freezeVector (varXS v) - ms <- UV.freezeVector (varMS v) - ys <- UV.freezeVector (varYS v) - return (xs, ms, ys) - --- | Return a signal that notifies about every change of the variable state. -varChanged :: Var m a -> Signal m a -varChanged v = publishSignal (varChangedSource v) - --- | Return a signal that notifies about every change of the variable state. -varChanged_ :: MonadComp m => Var m a -> Signal m () -varChanged_ v = mapSignal (const ()) $ varChanged v + +-- | +-- Module : Simulation.Aivika.Trans.Var.Unboxed +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines an unboxed variable that is bound up with the event queue and +-- that keeps the history of changes storing the values in unboxed arrays, which +-- allows using the variable in differential and difference equations of +-- System Dynamics within hybrid discrete-continuous simulation. +-- +module Simulation.Aivika.Trans.Var.Unboxed + (Var, + varChanged, + varChanged_, + newVar, + readVar, + varMemo, + writeVar, + modifyVar, + freezeVar) where + +import Data.Array + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.Comp +import Simulation.Aivika.Trans.Internal.Specs +import Simulation.Aivika.Trans.Internal.Simulation +import Simulation.Aivika.Trans.Internal.Dynamics +import Simulation.Aivika.Trans.Internal.Event +import Simulation.Aivika.Trans.Internal.Signal +import Simulation.Aivika.Trans.Ref +import Simulation.Aivika.Trans.Signal +import Simulation.Aivika.Trans.Unboxed + +import qualified Simulation.Aivika.Trans.Vector.Unboxed as UV + +-- | Like the 'Ref' reference but keeps the history of changes in +-- different time points. The 'Var' variable is safe to be used in +-- the hybrid discrete-continuous simulation. +-- +-- For example, the memoised values of a variable can be used in +-- the differential or difference equations of System Dynamics, while +-- the variable iself can be updated wihin the discrete event simulation. +-- +-- Only this variable is much slower than the reference. +data Var m a = + Var { varXS :: UV.Vector m Double, + varMS :: UV.Vector m a, + varYS :: UV.Vector m a, + varChangedSource :: SignalSource m a } + +-- | Create a new variable. +newVar :: (MonadComp m, Unboxed m a) => a -> Simulation m (Var m a) +newVar a = + Simulation $ \r -> + do let sn = runSession r + xs <- UV.newVector sn + ms <- UV.newVector sn + ys <- UV.newVector sn + UV.appendVector xs $ spcStartTime $ runSpecs r + UV.appendVector ms a + UV.appendVector ys a + s <- invokeSimulation r newSignalSource + return Var { varXS = xs, + varMS = ms, + varYS = ms, + varChangedSource = s } + +-- | Read the first actual, i.e. memoised, value of a variable for the requested time +-- actuating the current events from the queue if needed. +-- +-- This computation can be used in the ordinary differential and +-- difference equations of System Dynamics. +varMemo :: (MonadComp m, Unboxed m a) => Var m a -> Dynamics m a +varMemo v = + runEventWith CurrentEventsOrFromPast $ + Event $ \p -> + do let xs = varXS v + ms = varMS v + ys = varYS v + t = pointTime p + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if x < t + then do a <- UV.readVector ys i + UV.appendVector xs t + UV.appendVector ms a + UV.appendVector ys a + return a + else if x == t + then UV.readVector ms i + else do i <- UV.vectorBinarySearch xs t + if i >= 0 + then UV.readVector ms i + else UV.readVector ms $ - (i + 1) - 1 + +-- | Read the recent actual value of a variable for the requested time. +-- +-- This computation is destined for using within discrete event simulation. +readVar :: (MonadComp m, Unboxed m a) => Var m a -> Event m a +readVar v = + Event $ \p -> + do let xs = varXS v + ys = varYS v + t = pointTime p + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if x <= t + then UV.readVector ys i + else do i <- UV.vectorBinarySearch xs t + if i >= 0 + then UV.readVector ys i + else UV.readVector ys $ - (i + 1) - 1 + +-- | Write a new value into the variable. +writeVar :: (MonadComp m, Unboxed m a) => Var m a -> a -> Event m () +writeVar v a = + Event $ \p -> + do let xs = varXS v + ms = varMS v + ys = varYS v + t = pointTime p + s = varChangedSource v + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if t < x + then error "Cannot update the past data: writeVar." + else if t == x + then UV.writeVector ys i $! a + else do UV.appendVector xs t + UV.appendVector ms $! a + UV.appendVector ys $! a + invokeEvent p $ triggerSignal s a + +-- | Mutate the contents of the variable. +modifyVar :: (MonadComp m, Unboxed m a) => Var m a -> (a -> a) -> Event m () +modifyVar v f = + Event $ \p -> + do let xs = varXS v + ms = varMS v + ys = varYS v + t = pointTime p + s = varChangedSource v + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if t < x + then error "Cannot update the past data: modifyVar." + else if t == x + then do a <- UV.readVector ys i + let b = f a + UV.writeVector ys i $! b + invokeEvent p $ triggerSignal s b + else do a <- UV.readVector ys i + let b = f a + UV.appendVector xs t + UV.appendVector ms $! b + UV.appendVector ys $! b + invokeEvent p $ triggerSignal s b + +-- | Freeze the variable and return in arrays the time points and corresponded +-- first and last values when the variable had changed or had been memoised in +-- different time points: (1) the time points are sorted in ascending order; +-- (2) the first and last actual values per each time point are provided. +-- +-- If you need to get all changes including those ones that correspond to the same +-- simulation time points then you can use the 'newSignalHistory' function passing +-- in the 'varChanged' signal to it and then call function 'readSignalHistory'. +freezeVar :: (MonadComp m, Unboxed m a) => Var m a -> Event m (Array Int Double, Array Int a, Array Int a) +freezeVar v = + Event $ \p -> + do xs <- UV.freezeVector (varXS v) + ms <- UV.freezeVector (varMS v) + ys <- UV.freezeVector (varYS v) + return (xs, ms, ys) + +-- | Return a signal that notifies about every change of the variable state. +varChanged :: Var m a -> Signal m a +varChanged v = publishSignal (varChangedSource v) + +-- | Return a signal that notifies about every change of the variable state. +varChanged_ :: MonadComp m => Var m a -> Signal m () +varChanged_ v = mapSignal (const ()) $ varChanged v diff --git a/Simulation/Aivika/Trans/Vector.hs b/Simulation/Aivika/Trans/Vector.hs --- a/Simulation/Aivika/Trans/Vector.hs +++ b/Simulation/Aivika/Trans/Vector.hs @@ -1,199 +1,199 @@ - -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Simulation.Aivika.Trans.Vector --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It defines a prototype of mutable vectors. --- -module Simulation.Aivika.Trans.Vector - (Vector, - newVector, - copyVector, - vectorCount, - appendVector, - readVector, - writeVector, - vectorBinarySearch, - vectorInsert, - vectorDeleteAt, - vectorIndex, - freezeVector) where - -import Data.Array - -import Control.Monad - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.ProtoArray - --- | A prototype of mutable vector. -data Vector m a = - Vector { vectorSession :: Session m, - vectorArrayRef :: ProtoRef m (ProtoArray m a), - vectorCountRef :: ProtoRef m Int, - vectorCapacityRef :: ProtoRef m Int } - --- | Create a new vector within the specified simulation session. -newVector :: ProtoArrayMonad m => Session m -> m (Vector m a) -newVector session = - do array <- newProtoArray_ session 4 - arrayRef <- newProtoRef session array - countRef <- newProtoRef session 0 - capacityRef <- newProtoRef session 4 - return Vector { vectorSession = session, - vectorArrayRef = arrayRef, - vectorCountRef = countRef, - vectorCapacityRef = capacityRef } - --- | Copy the vector. -copyVector :: ProtoArrayMonad m => Vector m a -> m (Vector m a) -copyVector vector = - do let session = vectorSession vector - array <- readProtoRef (vectorArrayRef vector) - count <- readProtoRef (vectorCountRef vector) - array' <- newProtoArray_ session count - arrayRef' <- newProtoRef session array' - countRef' <- newProtoRef session count - capacityRef' <- newProtoRef session count - forM_ [0 .. count - 1] $ \i -> - do x <- readProtoArray array i - writeProtoArray array' i x - return Vector { vectorSession = session, - vectorArrayRef = arrayRef', - vectorCountRef = countRef', - vectorCapacityRef = capacityRef' } - --- | Ensure that the vector has the specified capacity. -vectorEnsureCapacity :: ProtoArrayMonad m => Vector m a -> Int -> m () -vectorEnsureCapacity vector capacity = - do capacity' <- readProtoRef (vectorCapacityRef vector) - when (capacity' < capacity) $ - do array' <- readProtoRef (vectorArrayRef vector) - count' <- readProtoRef (vectorCountRef vector) - let capacity'' = max (2 * capacity') capacity - session = vectorSession vector - array'' <- newProtoArray_ session capacity'' - forM_ [0 .. count' - 1] $ \i -> - do x <- readProtoArray array' i - writeProtoArray array'' i x - writeProtoRef (vectorArrayRef vector) array'' - writeProtoRef (vectorCapacityRef vector) capacity'' - --- | Return the element count. -vectorCount :: ProtoArrayMonad m => Vector m a -> m Int -vectorCount vector = readProtoRef (vectorCountRef vector) - --- | Add the specified element to the end of the vector. -appendVector :: ProtoArrayMonad m => Vector m a -> a -> m () -appendVector vector item = - do count <- readProtoRef (vectorCountRef vector) - vectorEnsureCapacity vector (count + 1) - array <- readProtoRef (vectorArrayRef vector) - writeProtoArray array count item - writeProtoRef (vectorCountRef vector) (count + 1) - --- | Read a value from the vector, where indices are started from 0. -readVector :: ProtoArrayMonad m => Vector m a -> Int -> m a -readVector vector index = - do array <- readProtoRef (vectorArrayRef vector) - readProtoArray array index - --- | Set an array item at the specified index which is started from 0. -writeVector :: ProtoArrayMonad m => Vector m a -> Int -> a -> m () -writeVector vector index item = - do array <- readProtoRef (vectorArrayRef vector) - writeProtoArray array index item - --- | Return the index of the specified element using binary search; otherwise, --- a negated insertion index minus one: 0 -> -0 - 1, ..., i -> -i - 1, .... -vectorBinarySearch :: (ProtoArrayMonad m, Ord a) => Vector m a -> a -> m Int -vectorBinarySearch vector item = - do array <- readProtoRef (vectorArrayRef vector) - count <- readProtoRef (vectorCountRef vector) - vectorBinarySearch' array item 0 (count - 1) - --- | Return the index of the specified element using binary search --- within the specified range; otherwise, a negated insertion index minus one. -vectorBinarySearchWithin :: (ProtoArrayMonad m, Ord a) => Vector m a -> a -> Int -> Int -> m Int -vectorBinarySearchWithin vector item left right = - do array <- readProtoRef (vectorArrayRef vector) - vectorBinarySearch' array item left right - --- | Return the elements of the vector in an immutable array. -freezeVector :: ProtoArrayMonad m => Vector m a -> m (Array Int a) -freezeVector vector = - do array <- readProtoRef (vectorArrayRef vector) - freezeProtoArray array - --- | Insert the element in the vector at the specified index. -vectorInsert :: ProtoArrayMonad m => Vector m a -> Int -> a -> m () -vectorInsert vector index item = - do count <- readProtoRef (vectorCountRef vector) - when (index < 0) $ - error $ - "Index cannot be " ++ - "negative: vectorInsert." - when (index > count) $ - error $ - "Index cannot be greater " ++ - "than the count: vectorInsert." - vectorEnsureCapacity vector (count + 1) - array <- readProtoRef (vectorArrayRef vector) - forM_ [count, count - 1 .. index + 1] $ \i -> - do x <- readProtoArray array (i - 1) - writeProtoArray array i x - writeProtoArray array index item - writeProtoRef (vectorCountRef vector) (count + 1) - --- | Delete the element at the specified index. -vectorDeleteAt :: ProtoArrayMonad m => Vector m a -> Int -> m () -vectorDeleteAt vector index = - do count <- readProtoRef (vectorCountRef vector) - when (index < 0) $ - error $ - "Index cannot be " ++ - "negative: vectorDeleteAt." - when (index >= count) $ - error $ - "Index must be less " ++ - "than the count: vectorDeleteAt." - array <- readProtoRef (vectorArrayRef vector) - forM_ [index, index + 1 .. count - 2] $ \i -> - do x <- readProtoArray array (i + 1) - writeProtoArray array i x - writeProtoArray array (count - 1) undefined - writeProtoRef (vectorCountRef vector) (count - 1) - --- | Return the index of the item or -1. -vectorIndex :: (ProtoArrayMonad m, Eq a) => Vector m a -> a -> m Int -vectorIndex vector item = - do count <- readProtoRef (vectorCountRef vector) - array <- readProtoRef (vectorArrayRef vector) - let loop index = - if index >= count - then return $ -1 - else do x <- readProtoArray array index - if item == x - then return index - else loop $ index + 1 - loop 0 - -vectorBinarySearch' :: (ProtoArrayMonad m, Ord a) => ProtoArray m a -> a -> Int -> Int -> m Int -vectorBinarySearch' array item left right = - if left > right - then return $ - (right + 1) - 1 - else - do let index = (left + right) `div` 2 - curr <- readProtoArray array index - if item < curr - then vectorBinarySearch' array item left (index - 1) - else if item == curr - then return index - else vectorBinarySearch' array item (index + 1) right + +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Simulation.Aivika.Trans.Vector +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It defines a prototype of mutable vectors. +-- +module Simulation.Aivika.Trans.Vector + (Vector, + newVector, + copyVector, + vectorCount, + appendVector, + readVector, + writeVector, + vectorBinarySearch, + vectorInsert, + vectorDeleteAt, + vectorIndex, + freezeVector) where + +import Data.Array + +import Control.Monad + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.ProtoArray + +-- | A prototype of mutable vector. +data Vector m a = + Vector { vectorSession :: Session m, + vectorArrayRef :: ProtoRef m (ProtoArray m a), + vectorCountRef :: ProtoRef m Int, + vectorCapacityRef :: ProtoRef m Int } + +-- | Create a new vector within the specified simulation session. +newVector :: ProtoArrayMonad m => Session m -> m (Vector m a) +newVector session = + do array <- newProtoArray_ session 4 + arrayRef <- newProtoRef session array + countRef <- newProtoRef session 0 + capacityRef <- newProtoRef session 4 + return Vector { vectorSession = session, + vectorArrayRef = arrayRef, + vectorCountRef = countRef, + vectorCapacityRef = capacityRef } + +-- | Copy the vector. +copyVector :: ProtoArrayMonad m => Vector m a -> m (Vector m a) +copyVector vector = + do let session = vectorSession vector + array <- readProtoRef (vectorArrayRef vector) + count <- readProtoRef (vectorCountRef vector) + array' <- newProtoArray_ session count + arrayRef' <- newProtoRef session array' + countRef' <- newProtoRef session count + capacityRef' <- newProtoRef session count + forM_ [0 .. count - 1] $ \i -> + do x <- readProtoArray array i + writeProtoArray array' i x + return Vector { vectorSession = session, + vectorArrayRef = arrayRef', + vectorCountRef = countRef', + vectorCapacityRef = capacityRef' } + +-- | Ensure that the vector has the specified capacity. +vectorEnsureCapacity :: ProtoArrayMonad m => Vector m a -> Int -> m () +vectorEnsureCapacity vector capacity = + do capacity' <- readProtoRef (vectorCapacityRef vector) + when (capacity' < capacity) $ + do array' <- readProtoRef (vectorArrayRef vector) + count' <- readProtoRef (vectorCountRef vector) + let capacity'' = max (2 * capacity') capacity + session = vectorSession vector + array'' <- newProtoArray_ session capacity'' + forM_ [0 .. count' - 1] $ \i -> + do x <- readProtoArray array' i + writeProtoArray array'' i x + writeProtoRef (vectorArrayRef vector) array'' + writeProtoRef (vectorCapacityRef vector) capacity'' + +-- | Return the element count. +vectorCount :: ProtoArrayMonad m => Vector m a -> m Int +vectorCount vector = readProtoRef (vectorCountRef vector) + +-- | Add the specified element to the end of the vector. +appendVector :: ProtoArrayMonad m => Vector m a -> a -> m () +appendVector vector item = + do count <- readProtoRef (vectorCountRef vector) + vectorEnsureCapacity vector (count + 1) + array <- readProtoRef (vectorArrayRef vector) + writeProtoArray array count item + writeProtoRef (vectorCountRef vector) (count + 1) + +-- | Read a value from the vector, where indices are started from 0. +readVector :: ProtoArrayMonad m => Vector m a -> Int -> m a +readVector vector index = + do array <- readProtoRef (vectorArrayRef vector) + readProtoArray array index + +-- | Set an array item at the specified index which is started from 0. +writeVector :: ProtoArrayMonad m => Vector m a -> Int -> a -> m () +writeVector vector index item = + do array <- readProtoRef (vectorArrayRef vector) + writeProtoArray array index item + +-- | Return the index of the specified element using binary search; otherwise, +-- a negated insertion index minus one: 0 -> -0 - 1, ..., i -> -i - 1, .... +vectorBinarySearch :: (ProtoArrayMonad m, Ord a) => Vector m a -> a -> m Int +vectorBinarySearch vector item = + do array <- readProtoRef (vectorArrayRef vector) + count <- readProtoRef (vectorCountRef vector) + vectorBinarySearch' array item 0 (count - 1) + +-- | Return the index of the specified element using binary search +-- within the specified range; otherwise, a negated insertion index minus one. +vectorBinarySearchWithin :: (ProtoArrayMonad m, Ord a) => Vector m a -> a -> Int -> Int -> m Int +vectorBinarySearchWithin vector item left right = + do array <- readProtoRef (vectorArrayRef vector) + vectorBinarySearch' array item left right + +-- | Return the elements of the vector in an immutable array. +freezeVector :: ProtoArrayMonad m => Vector m a -> m (Array Int a) +freezeVector vector = + do array <- readProtoRef (vectorArrayRef vector) + freezeProtoArray array + +-- | Insert the element in the vector at the specified index. +vectorInsert :: ProtoArrayMonad m => Vector m a -> Int -> a -> m () +vectorInsert vector index item = + do count <- readProtoRef (vectorCountRef vector) + when (index < 0) $ + error $ + "Index cannot be " ++ + "negative: vectorInsert." + when (index > count) $ + error $ + "Index cannot be greater " ++ + "than the count: vectorInsert." + vectorEnsureCapacity vector (count + 1) + array <- readProtoRef (vectorArrayRef vector) + forM_ [count, count - 1 .. index + 1] $ \i -> + do x <- readProtoArray array (i - 1) + writeProtoArray array i x + writeProtoArray array index item + writeProtoRef (vectorCountRef vector) (count + 1) + +-- | Delete the element at the specified index. +vectorDeleteAt :: ProtoArrayMonad m => Vector m a -> Int -> m () +vectorDeleteAt vector index = + do count <- readProtoRef (vectorCountRef vector) + when (index < 0) $ + error $ + "Index cannot be " ++ + "negative: vectorDeleteAt." + when (index >= count) $ + error $ + "Index must be less " ++ + "than the count: vectorDeleteAt." + array <- readProtoRef (vectorArrayRef vector) + forM_ [index, index + 1 .. count - 2] $ \i -> + do x <- readProtoArray array (i + 1) + writeProtoArray array i x + writeProtoArray array (count - 1) undefined + writeProtoRef (vectorCountRef vector) (count - 1) + +-- | Return the index of the item or -1. +vectorIndex :: (ProtoArrayMonad m, Eq a) => Vector m a -> a -> m Int +vectorIndex vector item = + do count <- readProtoRef (vectorCountRef vector) + array <- readProtoRef (vectorArrayRef vector) + let loop index = + if index >= count + then return $ -1 + else do x <- readProtoArray array index + if item == x + then return index + else loop $ index + 1 + loop 0 + +vectorBinarySearch' :: (ProtoArrayMonad m, Ord a) => ProtoArray m a -> a -> Int -> Int -> m Int +vectorBinarySearch' array item left right = + if left > right + then return $ - (right + 1) - 1 + else + do let index = (left + right) `div` 2 + curr <- readProtoArray array index + if item < curr + then vectorBinarySearch' array item left (index - 1) + else if item == curr + then return index + else vectorBinarySearch' array item (index + 1) right diff --git a/Simulation/Aivika/Trans/Vector/Unboxed.hs b/Simulation/Aivika/Trans/Vector/Unboxed.hs --- a/Simulation/Aivika/Trans/Vector/Unboxed.hs +++ b/Simulation/Aivika/Trans/Vector/Unboxed.hs @@ -1,199 +1,199 @@ - -{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} - --- | --- Module : Simulation.Aivika.Trans.Vector.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It defines a prototype of mutable unboxed vectors. --- -module Simulation.Aivika.Trans.Vector.Unboxed - (Vector, - newVector, - copyVector, - vectorCount, - appendVector, - readVector, - writeVector, - vectorBinarySearch, - vectorInsert, - vectorDeleteAt, - vectorIndex, - freezeVector) where - -import Data.Array - -import Control.Monad - -import Simulation.Aivika.Trans.Session -import Simulation.Aivika.Trans.ProtoRef -import Simulation.Aivika.Trans.ProtoArray.Unboxed - --- | A prototype of mutable unboxed vector. -data Vector m a = - Vector { vectorSession :: Session m, - vectorArrayRef :: ProtoRef m (ProtoArray m a), - vectorCountRef :: ProtoRef m Int, - vectorCapacityRef :: ProtoRef m Int } - --- | Create a new vector within the specified simulation session. -newVector :: ProtoArrayMonad m a => Session m -> m (Vector m a) -newVector session = - do array <- newProtoArray_ session 4 - arrayRef <- newProtoRef session array - countRef <- newProtoRef session 0 - capacityRef <- newProtoRef session 4 - return Vector { vectorSession = session, - vectorArrayRef = arrayRef, - vectorCountRef = countRef, - vectorCapacityRef = capacityRef } - --- | Copy the vector. -copyVector :: ProtoArrayMonad m a => Vector m a -> m (Vector m a) -copyVector vector = - do let session = vectorSession vector - array <- readProtoRef (vectorArrayRef vector) - count <- readProtoRef (vectorCountRef vector) - array' <- newProtoArray_ session count - arrayRef' <- newProtoRef session array' - countRef' <- newProtoRef session count - capacityRef' <- newProtoRef session count - forM_ [0 .. count - 1] $ \i -> - do x <- readProtoArray array i - writeProtoArray array' i x - return Vector { vectorSession = session, - vectorArrayRef = arrayRef', - vectorCountRef = countRef', - vectorCapacityRef = capacityRef' } - --- | Ensure that the vector has the specified capacity. -vectorEnsureCapacity :: ProtoArrayMonad m a => Vector m a -> Int -> m () -vectorEnsureCapacity vector capacity = - do capacity' <- readProtoRef (vectorCapacityRef vector) - when (capacity' < capacity) $ - do array' <- readProtoRef (vectorArrayRef vector) - count' <- readProtoRef (vectorCountRef vector) - let capacity'' = max (2 * capacity') capacity - session = vectorSession vector - array'' <- newProtoArray_ session capacity'' - forM_ [0 .. count' - 1] $ \i -> - do x <- readProtoArray array' i - writeProtoArray array'' i x - writeProtoRef (vectorArrayRef vector) array'' - writeProtoRef (vectorCapacityRef vector) capacity'' - --- | Return the element count. -vectorCount :: ProtoArrayMonad m a => Vector m a -> m Int -vectorCount vector = readProtoRef (vectorCountRef vector) - --- | Add the specified element to the end of the vector. -appendVector :: ProtoArrayMonad m a => Vector m a -> a -> m () -appendVector vector item = - do count <- readProtoRef (vectorCountRef vector) - vectorEnsureCapacity vector (count + 1) - array <- readProtoRef (vectorArrayRef vector) - writeProtoArray array count item - writeProtoRef (vectorCountRef vector) (count + 1) - --- | Read a value from the vector, where indices are started from 0. -readVector :: ProtoArrayMonad m a => Vector m a -> Int -> m a -readVector vector index = - do array <- readProtoRef (vectorArrayRef vector) - readProtoArray array index - --- | Set an array item at the specified index which is started from 0. -writeVector :: ProtoArrayMonad m a => Vector m a -> Int -> a -> m () -writeVector vector index item = - do array <- readProtoRef (vectorArrayRef vector) - writeProtoArray array index item - --- | Return the index of the specified element using binary search; otherwise, --- a negated insertion index minus one: 0 -> -0 - 1, ..., i -> -i - 1, .... -vectorBinarySearch :: (ProtoArrayMonad m a, Ord a) => Vector m a -> a -> m Int -vectorBinarySearch vector item = - do array <- readProtoRef (vectorArrayRef vector) - count <- readProtoRef (vectorCountRef vector) - vectorBinarySearch' array item 0 (count - 1) - --- | Return the index of the specified element using binary search --- within the specified range; otherwise, a negated insertion index minus one. -vectorBinarySearchWithin :: (ProtoArrayMonad m a, Ord a) => Vector m a -> a -> Int -> Int -> m Int -vectorBinarySearchWithin vector item left right = - do array <- readProtoRef (vectorArrayRef vector) - vectorBinarySearch' array item left right - --- | Return the elements of the vector in an immutable array. -freezeVector :: ProtoArrayMonad m a => Vector m a -> m (Array Int a) -freezeVector vector = - do array <- readProtoRef (vectorArrayRef vector) - freezeProtoArray array - --- | Insert the element in the vector at the specified index. -vectorInsert :: ProtoArrayMonad m a => Vector m a -> Int -> a -> m () -vectorInsert vector index item = - do count <- readProtoRef (vectorCountRef vector) - when (index < 0) $ - error $ - "Index cannot be " ++ - "negative: vectorInsert." - when (index > count) $ - error $ - "Index cannot be greater " ++ - "than the count: vectorInsert." - vectorEnsureCapacity vector (count + 1) - array <- readProtoRef (vectorArrayRef vector) - forM_ [count, count - 1 .. index + 1] $ \i -> - do x <- readProtoArray array (i - 1) - writeProtoArray array i x - writeProtoArray array index item - writeProtoRef (vectorCountRef vector) (count + 1) - --- | Delete the element at the specified index. -vectorDeleteAt :: ProtoArrayMonad m a => Vector m a -> Int -> m () -vectorDeleteAt vector index = - do count <- readProtoRef (vectorCountRef vector) - when (index < 0) $ - error $ - "Index cannot be " ++ - "negative: vectorDeleteAt." - when (index >= count) $ - error $ - "Index must be less " ++ - "than the count: vectorDeleteAt." - array <- readProtoRef (vectorArrayRef vector) - forM_ [index, index + 1 .. count - 2] $ \i -> - do x <- readProtoArray array (i + 1) - writeProtoArray array i x - writeProtoArray array (count - 1) undefined - writeProtoRef (vectorCountRef vector) (count - 1) - --- | Return the index of the item or -1. -vectorIndex :: (ProtoArrayMonad m a, Eq a) => Vector m a -> a -> m Int -vectorIndex vector item = - do count <- readProtoRef (vectorCountRef vector) - array <- readProtoRef (vectorArrayRef vector) - let loop index = - if index >= count - then return $ -1 - else do x <- readProtoArray array index - if item == x - then return index - else loop $ index + 1 - loop 0 - -vectorBinarySearch' :: (ProtoArrayMonad m a, Ord a) => ProtoArray m a -> a -> Int -> Int -> m Int -vectorBinarySearch' array item left right = - if left > right - then return $ - (right + 1) - 1 - else - do let index = (left + right) `div` 2 - curr <- readProtoArray array index - if item < curr - then vectorBinarySearch' array item left (index - 1) - else if item == curr - then return index - else vectorBinarySearch' array item (index + 1) right + +{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} + +-- | +-- Module : Simulation.Aivika.Trans.Vector.Unboxed +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It defines a prototype of mutable unboxed vectors. +-- +module Simulation.Aivika.Trans.Vector.Unboxed + (Vector, + newVector, + copyVector, + vectorCount, + appendVector, + readVector, + writeVector, + vectorBinarySearch, + vectorInsert, + vectorDeleteAt, + vectorIndex, + freezeVector) where + +import Data.Array + +import Control.Monad + +import Simulation.Aivika.Trans.Session +import Simulation.Aivika.Trans.ProtoRef +import Simulation.Aivika.Trans.ProtoArray.Unboxed + +-- | A prototype of mutable unboxed vector. +data Vector m a = + Vector { vectorSession :: Session m, + vectorArrayRef :: ProtoRef m (ProtoArray m a), + vectorCountRef :: ProtoRef m Int, + vectorCapacityRef :: ProtoRef m Int } + +-- | Create a new vector within the specified simulation session. +newVector :: ProtoArrayMonad m a => Session m -> m (Vector m a) +newVector session = + do array <- newProtoArray_ session 4 + arrayRef <- newProtoRef session array + countRef <- newProtoRef session 0 + capacityRef <- newProtoRef session 4 + return Vector { vectorSession = session, + vectorArrayRef = arrayRef, + vectorCountRef = countRef, + vectorCapacityRef = capacityRef } + +-- | Copy the vector. +copyVector :: ProtoArrayMonad m a => Vector m a -> m (Vector m a) +copyVector vector = + do let session = vectorSession vector + array <- readProtoRef (vectorArrayRef vector) + count <- readProtoRef (vectorCountRef vector) + array' <- newProtoArray_ session count + arrayRef' <- newProtoRef session array' + countRef' <- newProtoRef session count + capacityRef' <- newProtoRef session count + forM_ [0 .. count - 1] $ \i -> + do x <- readProtoArray array i + writeProtoArray array' i x + return Vector { vectorSession = session, + vectorArrayRef = arrayRef', + vectorCountRef = countRef', + vectorCapacityRef = capacityRef' } + +-- | Ensure that the vector has the specified capacity. +vectorEnsureCapacity :: ProtoArrayMonad m a => Vector m a -> Int -> m () +vectorEnsureCapacity vector capacity = + do capacity' <- readProtoRef (vectorCapacityRef vector) + when (capacity' < capacity) $ + do array' <- readProtoRef (vectorArrayRef vector) + count' <- readProtoRef (vectorCountRef vector) + let capacity'' = max (2 * capacity') capacity + session = vectorSession vector + array'' <- newProtoArray_ session capacity'' + forM_ [0 .. count' - 1] $ \i -> + do x <- readProtoArray array' i + writeProtoArray array'' i x + writeProtoRef (vectorArrayRef vector) array'' + writeProtoRef (vectorCapacityRef vector) capacity'' + +-- | Return the element count. +vectorCount :: ProtoArrayMonad m a => Vector m a -> m Int +vectorCount vector = readProtoRef (vectorCountRef vector) + +-- | Add the specified element to the end of the vector. +appendVector :: ProtoArrayMonad m a => Vector m a -> a -> m () +appendVector vector item = + do count <- readProtoRef (vectorCountRef vector) + vectorEnsureCapacity vector (count + 1) + array <- readProtoRef (vectorArrayRef vector) + writeProtoArray array count item + writeProtoRef (vectorCountRef vector) (count + 1) + +-- | Read a value from the vector, where indices are started from 0. +readVector :: ProtoArrayMonad m a => Vector m a -> Int -> m a +readVector vector index = + do array <- readProtoRef (vectorArrayRef vector) + readProtoArray array index + +-- | Set an array item at the specified index which is started from 0. +writeVector :: ProtoArrayMonad m a => Vector m a -> Int -> a -> m () +writeVector vector index item = + do array <- readProtoRef (vectorArrayRef vector) + writeProtoArray array index item + +-- | Return the index of the specified element using binary search; otherwise, +-- a negated insertion index minus one: 0 -> -0 - 1, ..., i -> -i - 1, .... +vectorBinarySearch :: (ProtoArrayMonad m a, Ord a) => Vector m a -> a -> m Int +vectorBinarySearch vector item = + do array <- readProtoRef (vectorArrayRef vector) + count <- readProtoRef (vectorCountRef vector) + vectorBinarySearch' array item 0 (count - 1) + +-- | Return the index of the specified element using binary search +-- within the specified range; otherwise, a negated insertion index minus one. +vectorBinarySearchWithin :: (ProtoArrayMonad m a, Ord a) => Vector m a -> a -> Int -> Int -> m Int +vectorBinarySearchWithin vector item left right = + do array <- readProtoRef (vectorArrayRef vector) + vectorBinarySearch' array item left right + +-- | Return the elements of the vector in an immutable array. +freezeVector :: ProtoArrayMonad m a => Vector m a -> m (Array Int a) +freezeVector vector = + do array <- readProtoRef (vectorArrayRef vector) + freezeProtoArray array + +-- | Insert the element in the vector at the specified index. +vectorInsert :: ProtoArrayMonad m a => Vector m a -> Int -> a -> m () +vectorInsert vector index item = + do count <- readProtoRef (vectorCountRef vector) + when (index < 0) $ + error $ + "Index cannot be " ++ + "negative: vectorInsert." + when (index > count) $ + error $ + "Index cannot be greater " ++ + "than the count: vectorInsert." + vectorEnsureCapacity vector (count + 1) + array <- readProtoRef (vectorArrayRef vector) + forM_ [count, count - 1 .. index + 1] $ \i -> + do x <- readProtoArray array (i - 1) + writeProtoArray array i x + writeProtoArray array index item + writeProtoRef (vectorCountRef vector) (count + 1) + +-- | Delete the element at the specified index. +vectorDeleteAt :: ProtoArrayMonad m a => Vector m a -> Int -> m () +vectorDeleteAt vector index = + do count <- readProtoRef (vectorCountRef vector) + when (index < 0) $ + error $ + "Index cannot be " ++ + "negative: vectorDeleteAt." + when (index >= count) $ + error $ + "Index must be less " ++ + "than the count: vectorDeleteAt." + array <- readProtoRef (vectorArrayRef vector) + forM_ [index, index + 1 .. count - 2] $ \i -> + do x <- readProtoArray array (i + 1) + writeProtoArray array i x + writeProtoArray array (count - 1) undefined + writeProtoRef (vectorCountRef vector) (count - 1) + +-- | Return the index of the item or -1. +vectorIndex :: (ProtoArrayMonad m a, Eq a) => Vector m a -> a -> m Int +vectorIndex vector item = + do count <- readProtoRef (vectorCountRef vector) + array <- readProtoRef (vectorArrayRef vector) + let loop index = + if index >= count + then return $ -1 + else do x <- readProtoArray array index + if item == x + then return index + else loop $ index + 1 + loop 0 + +vectorBinarySearch' :: (ProtoArrayMonad m a, Ord a) => ProtoArray m a -> a -> Int -> Int -> m Int +vectorBinarySearch' array item left right = + if left > right + then return $ - (right + 1) - 1 + else + do let index = (left + right) `div` 2 + curr <- readProtoArray array index + if item < curr + then vectorBinarySearch' array item left (index - 1) + else if item == curr + then return index + else vectorBinarySearch' array item (index + 1) right diff --git a/aivika-transformers.cabal b/aivika-transformers.cabal --- a/aivika-transformers.cabal +++ b/aivika-transformers.cabal @@ -1,141 +1,142 @@ -name: aivika-transformers -version: 2.0 -synopsis: Transformers for the Aivika simulation library -description: - The package adds the monad and other computation transformers to - the Aivika [1] library. This is a generalization of the simulation library. - . - \[1] - . -category: Simulation -license: BSD3 -license-file: LICENSE -copyright: (c) 2009-2014. David Sorokin -author: David Sorokin -maintainer: David Sorokin -homepage: http://github.com/dsorokin/aivika -cabal-version: >= 1.10 -build-type: Simple -tested-with: GHC == 7.8.3 - -extra-source-files: examples/BassDiffusion.hs - examples/ChemicalReaction.hs - examples/ChemicalReactionCircuit.hs - examples/FishBank.hs - examples/MachRep1.hs - examples/MachRep1EventDriven.hs - examples/MachRep1TimeDriven.hs - examples/MachRep2.hs - examples/MachRep3.hs - examples/Furnace.hs - examples/InspectionAdjustmentStations.hs - examples/WorkStationsInSeries.hs - examples/TimeOut.hs - examples/TimeOutInt.hs - examples/TimeOutWait.hs - -flag haste-inst - - description: The package is built using haste-inst - default: False - -library - - exposed-modules: Simulation.Aivika.Trans - Simulation.Aivika.Trans.Agent - Simulation.Aivika.Trans.Arrival - Simulation.Aivika.Trans.Circuit - Simulation.Aivika.Trans.Comp - Simulation.Aivika.Trans.Comp.IO - Simulation.Aivika.Trans.Comp.Template - Simulation.Aivika.Trans.Cont - Simulation.Aivika.Trans.DoubleLinkedList - Simulation.Aivika.Trans.Dynamics - Simulation.Aivika.Trans.Dynamics.Extra - Simulation.Aivika.Trans.Dynamics.Memo - Simulation.Aivika.Trans.Dynamics.Memo.Unboxed - Simulation.Aivika.Trans.Dynamics.Random - Simulation.Aivika.Trans.Event - Simulation.Aivika.Trans.Exception - Simulation.Aivika.Trans.Generator - Simulation.Aivika.Trans.Net - Simulation.Aivika.Trans.Parameter - Simulation.Aivika.Trans.Parameter.Random - Simulation.Aivika.Trans.PriorityQueue - Simulation.Aivika.Trans.Process - Simulation.Aivika.Trans.Processor - Simulation.Aivika.Trans.Processor.RoundRobbin - Simulation.Aivika.Trans.ProtoArray - Simulation.Aivika.Trans.ProtoArray.Unboxed - Simulation.Aivika.Trans.ProtoRef - Simulation.Aivika.Trans.Queue - Simulation.Aivika.Trans.Queue.Infinite - Simulation.Aivika.Trans.QueueStrategy - Simulation.Aivika.Trans.Ref - Simulation.Aivika.Trans.Ref.Plain - Simulation.Aivika.Trans.Resource - Simulation.Aivika.Trans.Results.Locale - Simulation.Aivika.Trans.Results - Simulation.Aivika.Trans.Results.IO - Simulation.Aivika.Trans.Session - Simulation.Aivika.Trans.Server - Simulation.Aivika.Trans.Signal - Simulation.Aivika.Trans.Simulation - Simulation.Aivika.Trans.Specs - Simulation.Aivika.Trans.Statistics - Simulation.Aivika.Trans.Statistics.Accumulator - Simulation.Aivika.Trans.Stream - Simulation.Aivika.Trans.Stream.Random - Simulation.Aivika.Trans.SystemDynamics - Simulation.Aivika.Trans.Table - Simulation.Aivika.Trans.Task - Simulation.Aivika.Trans.Transform - Simulation.Aivika.Trans.Transform.Extra - Simulation.Aivika.Trans.Transform.Memo - Simulation.Aivika.Trans.Transform.Memo.Unboxed - Simulation.Aivika.Trans.Unboxed - Simulation.Aivika.Trans.Var - Simulation.Aivika.Trans.Var.Unboxed - Simulation.Aivika.Trans.Vector - Simulation.Aivika.Trans.Vector.Unboxed - - other-modules: Simulation.Aivika.Trans.Internal.Cont - Simulation.Aivika.Trans.Internal.Dynamics - Simulation.Aivika.Trans.Internal.Event - Simulation.Aivika.Trans.Internal.Parameter - Simulation.Aivika.Trans.Internal.Process - Simulation.Aivika.Trans.Internal.Signal - Simulation.Aivika.Trans.Internal.Simulation - Simulation.Aivika.Trans.Internal.Specs - - build-depends: base >= 4.5.0.0 && < 6, - mtl >= 2.1.1, - array >= 0.3.0.0, - containers >= 0.4.0.0, - random >= 1.0.0.3, - aivika >= 2.0 - - if !flag(haste-inst) - build-depends: vector >= 0.10.0.1 - - other-extensions: FlexibleContexts, - FlexibleInstances, - UndecidableInstances, - BangPatterns, - RecursiveDo, - Arrows, - MultiParamTypeClasses, - FunctionalDependencies, - ExistentialQuantification, - TypeFamilies, - TypeSynonymInstances, - CPP - - ghc-options: -O2 - - default-language: Haskell2010 - -source-repository head - - type: git - location: https://github.com/dsorokin/aivika +name: aivika-transformers +version: 2.1 +synopsis: Transformers for the Aivika simulation library +description: + The package adds the monad and other computation transformers to + the Aivika [1] library. This is a generalization of the simulation library. + . + \[1] + . +category: Simulation +license: BSD3 +license-file: LICENSE +copyright: (c) 2009-2014. David Sorokin +author: David Sorokin +maintainer: David Sorokin +homepage: http://github.com/dsorokin/aivika-transformers +cabal-version: >= 1.10 +build-type: Simple +tested-with: GHC == 7.8.3 + +extra-source-files: examples/BassDiffusion.hs + examples/ChemicalReaction.hs + examples/ChemicalReactionCircuit.hs + examples/FishBank.hs + examples/MachRep1.hs + examples/MachRep1EventDriven.hs + examples/MachRep1TimeDriven.hs + examples/MachRep2.hs + examples/MachRep3.hs + examples/Furnace.hs + examples/InspectionAdjustmentStations.hs + examples/WorkStationsInSeries.hs + examples/TimeOut.hs + examples/TimeOutInt.hs + examples/TimeOutWait.hs + +flag haste-inst + + description: The package is built using haste-inst + default: False + +library + + exposed-modules: Simulation.Aivika.Trans + Simulation.Aivika.Trans.Activity + Simulation.Aivika.Trans.Agent + Simulation.Aivika.Trans.Arrival + Simulation.Aivika.Trans.Circuit + Simulation.Aivika.Trans.Comp + Simulation.Aivika.Trans.Comp.IO + Simulation.Aivika.Trans.Comp.Template + Simulation.Aivika.Trans.Cont + Simulation.Aivika.Trans.DoubleLinkedList + Simulation.Aivika.Trans.Dynamics + Simulation.Aivika.Trans.Dynamics.Extra + Simulation.Aivika.Trans.Dynamics.Memo + Simulation.Aivika.Trans.Dynamics.Memo.Unboxed + Simulation.Aivika.Trans.Dynamics.Random + Simulation.Aivika.Trans.Event + Simulation.Aivika.Trans.Exception + Simulation.Aivika.Trans.Generator + Simulation.Aivika.Trans.Net + Simulation.Aivika.Trans.Parameter + Simulation.Aivika.Trans.Parameter.Random + Simulation.Aivika.Trans.PriorityQueue + Simulation.Aivika.Trans.Process + Simulation.Aivika.Trans.Processor + Simulation.Aivika.Trans.Processor.RoundRobbin + Simulation.Aivika.Trans.ProtoArray + Simulation.Aivika.Trans.ProtoArray.Unboxed + Simulation.Aivika.Trans.ProtoRef + Simulation.Aivika.Trans.Queue + Simulation.Aivika.Trans.Queue.Infinite + Simulation.Aivika.Trans.QueueStrategy + Simulation.Aivika.Trans.Ref + Simulation.Aivika.Trans.Ref.Plain + Simulation.Aivika.Trans.Resource + Simulation.Aivika.Trans.Results.Locale + Simulation.Aivika.Trans.Results + Simulation.Aivika.Trans.Results.IO + Simulation.Aivika.Trans.Session + Simulation.Aivika.Trans.Server + Simulation.Aivika.Trans.Signal + Simulation.Aivika.Trans.Simulation + Simulation.Aivika.Trans.Specs + Simulation.Aivika.Trans.Statistics + Simulation.Aivika.Trans.Statistics.Accumulator + Simulation.Aivika.Trans.Stream + Simulation.Aivika.Trans.Stream.Random + Simulation.Aivika.Trans.SystemDynamics + Simulation.Aivika.Trans.Table + Simulation.Aivika.Trans.Task + Simulation.Aivika.Trans.Transform + Simulation.Aivika.Trans.Transform.Extra + Simulation.Aivika.Trans.Transform.Memo + Simulation.Aivika.Trans.Transform.Memo.Unboxed + Simulation.Aivika.Trans.Unboxed + Simulation.Aivika.Trans.Var + Simulation.Aivika.Trans.Var.Unboxed + Simulation.Aivika.Trans.Vector + Simulation.Aivika.Trans.Vector.Unboxed + + other-modules: Simulation.Aivika.Trans.Internal.Cont + Simulation.Aivika.Trans.Internal.Dynamics + Simulation.Aivika.Trans.Internal.Event + Simulation.Aivika.Trans.Internal.Parameter + Simulation.Aivika.Trans.Internal.Process + Simulation.Aivika.Trans.Internal.Signal + Simulation.Aivika.Trans.Internal.Simulation + Simulation.Aivika.Trans.Internal.Specs + + build-depends: base >= 4.5.0.0 && < 6, + mtl >= 2.1.1, + array >= 0.3.0.0, + containers >= 0.4.0.0, + random >= 1.0.0.3, + aivika >= 2.0 + + if !flag(haste-inst) + build-depends: vector >= 0.10.0.1 + + other-extensions: FlexibleContexts, + FlexibleInstances, + UndecidableInstances, + BangPatterns, + RecursiveDo, + Arrows, + MultiParamTypeClasses, + FunctionalDependencies, + ExistentialQuantification, + TypeFamilies, + TypeSynonymInstances, + CPP + + ghc-options: -O2 + + default-language: Haskell2010 + +source-repository head + + type: git + location: https://github.com/dsorokin/aivika-transformers diff --git a/examples/BassDiffusion.hs b/examples/BassDiffusion.hs --- a/examples/BassDiffusion.hs +++ b/examples/BassDiffusion.hs @@ -1,104 +1,104 @@ - --- This is the Bass Diffusion model solved with help of --- the Agent-based Modeling as described in the AnyLogic --- documentation. - -import Data.Array - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Trans - -n = 500 -- the number of agents - -advertisingEffectiveness = 0.011 -contactRate = 100.0 -adoptionFraction = 0.015 - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 8.0, - spcDT = 0.1, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -data Person m = Person { personAgent :: Agent m, - personPotentialAdopter :: AgentState m, - personAdopter :: AgentState m } - -createPerson :: MonadComp m => Simulation m (Person m) -createPerson = - do agent <- newAgent - potentialAdopter <- newState agent - adopter <- newState agent - return Person { personAgent = agent, - personPotentialAdopter = potentialAdopter, - personAdopter = adopter } - -createPersons :: MonadComp m => Simulation m (Array Int (Person m)) -createPersons = - do list <- forM [1 .. n] $ \i -> - do p <- createPerson - return (i, p) - return $ array (1, n) list - -definePerson :: MonadComp m => Person m -> Array Int (Person m) -> Ref m Int -> Ref m Int -> Simulation m () -definePerson p ps potentialAdopters adopters = - do setStateActivation (personPotentialAdopter p) $ - do modifyRef potentialAdopters $ \a -> a + 1 - -- add a timeout - t <- liftParameter $ - randomExponential (1 / advertisingEffectiveness) - let st = personPotentialAdopter p - st' = personAdopter p - addTimeout st t $ selectState st' - setStateActivation (personAdopter p) $ - do modifyRef adopters $ \a -> a + 1 - -- add a timer that works while the state is active - let t = liftParameter $ - randomExponential (1 / contactRate) -- many times! - addTimer (personAdopter p) t $ - do i <- liftParameter $ - randomUniformInt 1 n - let p' = ps ! i - st <- selectedState (personAgent p') - when (st == Just (personPotentialAdopter p')) $ - do b <- liftParameter $ - randomTrue adoptionFraction - when b $ selectState (personAdopter p') - setStateDeactivation (personPotentialAdopter p) $ - modifyRef potentialAdopters $ \a -> a - 1 - setStateDeactivation (personAdopter p) $ - modifyRef adopters $ \a -> a - 1 - -definePersons :: MonadComp m => Array Int (Person m) -> Ref m Int -> Ref m Int -> Simulation m () -definePersons ps potentialAdopters adopters = - forM_ (elems ps) $ \p -> - definePerson p ps potentialAdopters adopters - -activatePerson :: MonadComp m => Person m -> Event m () -activatePerson p = selectState (personPotentialAdopter p) - -activatePersons :: MonadComp m => Array Int (Person m) -> Event m () -activatePersons ps = - forM_ (elems ps) $ \p -> activatePerson p - -model :: MonadComp m => Simulation m (Results m) -model = - do potentialAdopters <- newRef 0 - adopters <- newRef 0 - ps <- createPersons - definePersons ps potentialAdopters adopters - runEventInStartTime $ - activatePersons ps - return $ - results - [resultSource - "potentialAdopter" "potential adopters" potentialAdopters, - resultSource - "adopters" "adopters" adopters] - -main = - printSimulationResultsInIntegTimes - printResultSourceInEnglish - model specs + +-- This is the Bass Diffusion model solved with help of +-- the Agent-based Modeling as described in the AnyLogic +-- documentation. + +import Data.Array + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans + +n = 500 -- the number of agents + +advertisingEffectiveness = 0.011 +contactRate = 100.0 +adoptionFraction = 0.015 + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 8.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +data Person m = Person { personAgent :: Agent m, + personPotentialAdopter :: AgentState m, + personAdopter :: AgentState m } + +createPerson :: MonadComp m => Simulation m (Person m) +createPerson = + do agent <- newAgent + potentialAdopter <- newState agent + adopter <- newState agent + return Person { personAgent = agent, + personPotentialAdopter = potentialAdopter, + personAdopter = adopter } + +createPersons :: MonadComp m => Simulation m (Array Int (Person m)) +createPersons = + do list <- forM [1 .. n] $ \i -> + do p <- createPerson + return (i, p) + return $ array (1, n) list + +definePerson :: MonadComp m => Person m -> Array Int (Person m) -> Ref m Int -> Ref m Int -> Simulation m () +definePerson p ps potentialAdopters adopters = + do setStateActivation (personPotentialAdopter p) $ + do modifyRef potentialAdopters $ \a -> a + 1 + -- add a timeout + t <- liftParameter $ + randomExponential (1 / advertisingEffectiveness) + let st = personPotentialAdopter p + st' = personAdopter p + addTimeout st t $ selectState st' + setStateActivation (personAdopter p) $ + do modifyRef adopters $ \a -> a + 1 + -- add a timer that works while the state is active + let t = liftParameter $ + randomExponential (1 / contactRate) -- many times! + addTimer (personAdopter p) t $ + do i <- liftParameter $ + randomUniformInt 1 n + let p' = ps ! i + st <- selectedState (personAgent p') + when (st == Just (personPotentialAdopter p')) $ + do b <- liftParameter $ + randomTrue adoptionFraction + when b $ selectState (personAdopter p') + setStateDeactivation (personPotentialAdopter p) $ + modifyRef potentialAdopters $ \a -> a - 1 + setStateDeactivation (personAdopter p) $ + modifyRef adopters $ \a -> a - 1 + +definePersons :: MonadComp m => Array Int (Person m) -> Ref m Int -> Ref m Int -> Simulation m () +definePersons ps potentialAdopters adopters = + forM_ (elems ps) $ \p -> + definePerson p ps potentialAdopters adopters + +activatePerson :: MonadComp m => Person m -> Event m () +activatePerson p = selectState (personPotentialAdopter p) + +activatePersons :: MonadComp m => Array Int (Person m) -> Event m () +activatePersons ps = + forM_ (elems ps) $ \p -> activatePerson p + +model :: MonadComp m => Simulation m (Results m) +model = + do potentialAdopters <- newRef 0 + adopters <- newRef 0 + ps <- createPersons + definePersons ps potentialAdopters adopters + runEventInStartTime $ + activatePersons ps + return $ + results + [resultSource + "potentialAdopter" "potential adopters" potentialAdopters, + resultSource + "adopters" "adopters" adopters] + +main = + printSimulationResultsInIntegTimes + printResultSourceInEnglish + model specs diff --git a/examples/ChemicalReaction.hs b/examples/ChemicalReaction.hs --- a/examples/ChemicalReaction.hs +++ b/examples/ChemicalReaction.hs @@ -1,30 +1,30 @@ - -{-# LANGUAGE RecursiveDo #-} - -import Control.Monad.Fix - -import Simulation.Aivika.Trans -import Simulation.Aivika.Trans.SystemDynamics - -specs = Specs { spcStartTime = 0, - spcStopTime = 13, - spcDT = 0.01, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: (MonadComp m, MonadFix m) => Simulation m (Results m) -model = - mdo a <- integ (- ka * a) 100 - b <- integ (ka * a - kb * b) 0 - c <- integ (kb * b) 0 - let ka = 1 - kb = 1 - return $ results - [resultSource "a" "variable A" a, - resultSource "b" "variable B" b, - resultSource "c" "variable C" c] - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - model specs + +{-# LANGUAGE RecursiveDo #-} + +import Control.Monad.Fix + +import Simulation.Aivika.Trans +import Simulation.Aivika.Trans.SystemDynamics + +specs = Specs { spcStartTime = 0, + spcStopTime = 13, + spcDT = 0.01, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: (MonadComp m, MonadFix m) => Simulation m (Results m) +model = + mdo a <- integ (- ka * a) 100 + b <- integ (ka * a - kb * b) 0 + c <- integ (kb * b) 0 + let ka = 1 + kb = 1 + return $ results + [resultSource "a" "variable A" a, + resultSource "b" "variable B" b, + resultSource "c" "variable C" c] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + model specs diff --git a/examples/ChemicalReactionCircuit.hs b/examples/ChemicalReactionCircuit.hs --- a/examples/ChemicalReactionCircuit.hs +++ b/examples/ChemicalReactionCircuit.hs @@ -1,44 +1,44 @@ - --- Note that the integCircut function uses Euler's method regardless of --- the simulation specs specified. Therefore, to receieve almost the same --- results in the old example based on using the integ function, you should --- specify Euler's method in their specs in that file, although the Runge-Kutta --- method gives similar results too, which is expected. --- --- Finally, the integ function can be significantly faster than integCircuit, --- although they have different purposes. - -{-# LANGUAGE Arrows #-} - -import Control.Arrow -import Control.Monad.Fix - -import Simulation.Aivika.Trans - -specs = Specs { spcStartTime = 0, - spcStopTime = 13, - spcDT = 0.01, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -circuit :: (MonadComp m, MonadFix m) => Circuit m () [Double] -circuit = - let ka = 1 - kb = 1 - in proc () -> do - rec let da = - ka * a - db = ka * a - kb * b - dc = kb * b - a <- integCircuit 100 -< da - b <- integCircuit 0 -< db - c <- integCircuit 0 -< dc - returnA -< [a, b, c] - -model :: (MonadComp m, MonadFix m) => Simulation m [Double] -model = - do results <- - runTransform (circuitTransform circuit) $ - return () - runDynamicsInStopTime results - -main = runSimulation model specs >>= print + +-- Note that the integCircut function uses Euler's method regardless of +-- the simulation specs specified. Therefore, to receieve almost the same +-- results in the old example based on using the integ function, you should +-- specify Euler's method in their specs in that file, although the Runge-Kutta +-- method gives similar results too, which is expected. +-- +-- Finally, the integ function can be significantly faster than integCircuit, +-- although they have different purposes. + +{-# LANGUAGE Arrows #-} + +import Control.Arrow +import Control.Monad.Fix + +import Simulation.Aivika.Trans + +specs = Specs { spcStartTime = 0, + spcStopTime = 13, + spcDT = 0.01, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +circuit :: (MonadComp m, MonadFix m) => Circuit m () [Double] +circuit = + let ka = 1 + kb = 1 + in proc () -> do + rec let da = - ka * a + db = ka * a - kb * b + dc = kb * b + a <- integCircuit 100 -< da + b <- integCircuit 0 -< db + c <- integCircuit 0 -< dc + returnA -< [a, b, c] + +model :: (MonadComp m, MonadFix m) => Simulation m [Double] +model = + do results <- + runTransform (circuitTransform circuit) $ + return () + runDynamicsInStopTime results + +main = runSimulation model specs >>= print diff --git a/examples/FishBank.hs b/examples/FishBank.hs --- a/examples/FishBank.hs +++ b/examples/FishBank.hs @@ -1,62 +1,62 @@ - -{-# LANGUAGE RecursiveDo #-} - -import Control.Monad.Fix - -import Data.Array - -import Simulation.Aivika.Trans -import Simulation.Aivika.Trans.SystemDynamics - -specs = Specs { spcStartTime = 0, - spcStopTime = 13, - spcDT = 0.01, - -- spcDT = 0.000005, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: (MonadComp m, MonadFix m) => Simulation m (Results m) -model = - mdo let annualProfit = profit - area = 100 - carryingCapacity = 1000 - catchPerShip = - lookupDynamics density $ - listArray (1, 11) [(0.0, -0.048), (1.2, 10.875), (2.4, 17.194), - (3.6, 20.548), (4.8, 22.086), (6.0, 23.344), - (7.2, 23.903), (8.4, 24.462), (9.6, 24.882), - (10.8, 25.301), (12.0, 25.86)] - deathFraction = - lookupDynamics (fish / carryingCapacity) $ - listArray (1, 11) [(0.0, 5.161), (0.1, 5.161), (0.2, 5.161), - (0.3, 5.161), (0.4, 5.161), (0.5, 5.161), - (0.6, 5.118), (0.7, 5.247), (0.8, 5.849), - (0.9, 6.151), (10.0, 6.194)] - density = fish / area - fish <- integ (fishHatchRate - fishDeathRate - totalCatchPerYear) 1000 - let fishDeathRate = maxDynamics 0 (fish * deathFraction) - fishHatchRate = maxDynamics 0 (fish * hatchFraction) - fishPrice = 20 - fractionInvested = 0.2 - hatchFraction = 6 - operatingCost = ships * 250 - profit = revenue - operatingCost - revenue = totalCatchPerYear * fishPrice - ships <- integ shipBuildingRate 10 - let shipBuildingRate = maxDynamics 0 (profit * fractionInvested / shipCost) - shipCost = 300 - totalProfit <- integ annualProfit 0 - let totalCatchPerYear = maxDynamics 0 (ships * catchPerShip) - -- results -- - return $ results - [resultSource "fish" "fish" fish, - resultSource "annualProfit" "the annual profit" annualProfit, - resultSource "totalProfit" "the total profit" totalProfit] - -main = - flip runSimulation specs $ - model >>= \results -> do - printResultsInStartTime - printResultSourceInEnglish results - printResultsInStopTime - printResultSourceInEnglish results + +{-# LANGUAGE RecursiveDo #-} + +import Control.Monad.Fix + +import Data.Array + +import Simulation.Aivika.Trans +import Simulation.Aivika.Trans.SystemDynamics + +specs = Specs { spcStartTime = 0, + spcStopTime = 13, + spcDT = 0.01, + -- spcDT = 0.000005, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: (MonadComp m, MonadFix m) => Simulation m (Results m) +model = + mdo let annualProfit = profit + area = 100 + carryingCapacity = 1000 + catchPerShip = + lookupDynamics density $ + listArray (1, 11) [(0.0, -0.048), (1.2, 10.875), (2.4, 17.194), + (3.6, 20.548), (4.8, 22.086), (6.0, 23.344), + (7.2, 23.903), (8.4, 24.462), (9.6, 24.882), + (10.8, 25.301), (12.0, 25.86)] + deathFraction = + lookupDynamics (fish / carryingCapacity) $ + listArray (1, 11) [(0.0, 5.161), (0.1, 5.161), (0.2, 5.161), + (0.3, 5.161), (0.4, 5.161), (0.5, 5.161), + (0.6, 5.118), (0.7, 5.247), (0.8, 5.849), + (0.9, 6.151), (10.0, 6.194)] + density = fish / area + fish <- integ (fishHatchRate - fishDeathRate - totalCatchPerYear) 1000 + let fishDeathRate = maxDynamics 0 (fish * deathFraction) + fishHatchRate = maxDynamics 0 (fish * hatchFraction) + fishPrice = 20 + fractionInvested = 0.2 + hatchFraction = 6 + operatingCost = ships * 250 + profit = revenue - operatingCost + revenue = totalCatchPerYear * fishPrice + ships <- integ shipBuildingRate 10 + let shipBuildingRate = maxDynamics 0 (profit * fractionInvested / shipCost) + shipCost = 300 + totalProfit <- integ annualProfit 0 + let totalCatchPerYear = maxDynamics 0 (ships * catchPerShip) + -- results -- + return $ results + [resultSource "fish" "fish" fish, + resultSource "annualProfit" "the annual profit" annualProfit, + resultSource "totalProfit" "the total profit" totalProfit] + +main = + flip runSimulation specs $ + model >>= \results -> do + printResultsInStartTime + printResultSourceInEnglish results + printResultsInStopTime + printResultSourceInEnglish results diff --git a/examples/Furnace.hs b/examples/Furnace.hs --- a/examples/Furnace.hs +++ b/examples/Furnace.hs @@ -1,322 +1,322 @@ - --- This is a model of the Furnace. It is described in different sources [1, 2]. --- --- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. --- --- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 - -import Data.Maybe -import System.Random -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Trans -import Simulation.Aivika.Trans.Queue.Infinite - --- | The simulation specs. -specs = Specs { spcStartTime = 0.0, - -- spcStopTime = 1000.0, - spcStopTime = 300.0, - spcDT = 0.1, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - --- | Return a random initial temperature of the item. -randomTemp :: MonadComp m => Parameter m Double -randomTemp = randomUniform 400 600 - --- | Represents the furnace. -data Furnace m = - Furnace { furnacePits :: [Pit m], - -- ^ The pits for ingots. - furnacePitCount :: Ref m Int, - -- ^ The count of active pits with ingots. - furnaceQueue :: FCFSQueue m (Ingot m), - -- ^ The furnace queue. - furnaceUnloadedSource :: SignalSource m (), - -- ^ Notifies when the ingots have been - -- unloaded from the furnace. - furnaceHeatingTime :: Ref m (SamplingStats Double), - -- ^ The heating time for the ready ingots. - furnaceTemp :: Ref m Double, - -- ^ The furnace temperature. - furnaceReadyCount :: Ref m Int, - -- ^ The count of ready ingots. - furnaceReadyTemps :: Ref m [Double] - -- ^ The temperatures of all ready ingots. - } - --- | Notifies when the ingots have been unloaded from the furnace. -furnaceUnloaded :: Furnace m -> Signal m () -furnaceUnloaded = publishSignal . furnaceUnloadedSource - --- | A pit in the furnace to place the ingots. -data Pit m = - Pit { pitIngot :: Ref m (Maybe (Ingot m)), - -- ^ The ingot in the pit. - pitTemp :: Ref m Double - -- ^ The ingot temperature in the pit. - } - -data Ingot m = - Ingot { ingotFurnace :: Furnace m, - -- ^ The furnace. - ingotReceiveTime :: Double, - -- ^ The time at which the ingot was received. - ingotReceiveTemp :: Double, - -- ^ The temperature with which the ingot was received. - ingotLoadTime :: Double, - -- ^ The time of loading in the furnace. - ingotLoadTemp :: Double, - -- ^ The temperature when the ingot was loaded in the furnace. - ingotCoeff :: Double - -- ^ The heating coefficient. - } - --- | Create a furnace. -newFurnace :: MonadComp m => Simulation m (Furnace m) -newFurnace = - do pits <- sequence [newPit | i <- [1..10]] - pitCount <- newRef 0 - queue <- runEventInStartTime newFCFSQueue - heatingTime <- newRef emptySamplingStats - h <- newRef 1650.0 - readyCount <- newRef 0 - readyTemps <- newRef [] - s <- newSignalSource - return Furnace { furnacePits = pits, - furnacePitCount = pitCount, - furnaceQueue = queue, - furnaceUnloadedSource = s, - furnaceHeatingTime = heatingTime, - furnaceTemp = h, - furnaceReadyCount = readyCount, - furnaceReadyTemps = readyTemps } - --- | Create a new pit. -newPit :: MonadComp m => Simulation m (Pit m) -newPit = - do ingot <- newRef Nothing - h' <- newRef 0.0 - return Pit { pitIngot = ingot, - pitTemp = h' } - --- | Create a new ingot. -newIngot :: MonadComp m => Furnace m -> Event m (Ingot m) -newIngot furnace = - do t <- liftDynamics time - xi <- liftParameter $ randomNormal 0.05 0.01 - h' <- liftParameter randomTemp - let c = 0.1 + xi - return Ingot { ingotFurnace = furnace, - ingotReceiveTime = t, - ingotReceiveTemp = h', - ingotLoadTime = t, - ingotLoadTemp = h', - ingotCoeff = c } - --- | Heat the ingot up in the pit if there is such an ingot. -heatPitUp :: MonadComp m => Pit m -> Event m () -heatPitUp pit = - do ingot <- readRef (pitIngot pit) - case ingot of - Nothing -> - return () - Just ingot -> do - - -- update the temperature of the ingot. - let furnace = ingotFurnace ingot - dt' <- liftParameter dt - h' <- readRef (pitTemp pit) - h <- readRef (furnaceTemp furnace) - writeRef (pitTemp pit) $ - h' + dt' * (h - h') * ingotCoeff ingot - --- | Check whether there are ready ingots in the pits. -ingotsReady :: MonadComp m => Furnace m -> Event m Bool -ingotsReady furnace = - fmap (not . null) $ - filterM (fmap (>= 2200.0) . readRef . pitTemp) $ - furnacePits furnace - --- | Try to unload the ready ingot from the specified pit. -tryUnloadPit :: MonadComp m => Furnace m -> Pit m -> Event m () -tryUnloadPit furnace pit = - do h' <- readRef (pitTemp pit) - when (h' >= 2000.0) $ - do Just ingot <- readRef (pitIngot pit) - unloadIngot furnace ingot pit - --- | Try to load an awaiting ingot in the specified empty pit. -tryLoadPit :: MonadComp m => Furnace m -> Pit m -> Event m () -tryLoadPit furnace pit = - do ingot <- tryDequeue (furnaceQueue furnace) - case ingot of - Nothing -> - return () - Just ingot -> - do t' <- liftDynamics time - loadIngot furnace (ingot { ingotLoadTime = t', - ingotLoadTemp = 400.0 }) pit - --- | Unload the ingot from the specified pit. -unloadIngot :: MonadComp m => Furnace m -> Ingot m -> Pit m -> Event m () -unloadIngot furnace ingot pit = - do h' <- readRef (pitTemp pit) - writeRef (pitIngot pit) Nothing - writeRef (pitTemp pit) 0.0 - - -- count the active pits - modifyRef (furnacePitCount furnace) (+ (- 1)) - - -- how long did we heat the ingot up? - t' <- liftDynamics time - modifyRef (furnaceHeatingTime furnace) $ - addSamplingStats (t' - ingotLoadTime ingot) - - -- what is the temperature of the unloaded ingot? - modifyRef (furnaceReadyTemps furnace) (h' :) - - -- count the ready ingots - modifyRef (furnaceReadyCount furnace) (+ 1) - --- | Load the ingot in the specified pit -loadIngot :: MonadComp m => Furnace m -> Ingot m -> Pit m -> Event m () -loadIngot furnace ingot pit = - do writeRef (pitIngot pit) $ Just ingot - writeRef (pitTemp pit) $ ingotLoadTemp ingot - - -- count the active pits - modifyRef (furnacePitCount furnace) (+ 1) - count <- readRef (furnacePitCount furnace) - - -- decrease the furnace temperature - h <- readRef (furnaceTemp furnace) - let h' = ingotLoadTemp ingot - dh = - (h - h') / fromIntegral count - writeRef (furnaceTemp furnace) $ h + dh - --- | Start iterating the furnace processing through the event queue. -startIteratingFurnace :: MonadComp m => Furnace m -> Event m () -startIteratingFurnace furnace = - let pits = furnacePits furnace - in enqueueEventWithIntegTimes $ - do -- try to unload ready ingots - ready <- ingotsReady furnace - when ready $ - do mapM_ (tryUnloadPit furnace) pits - triggerSignal (furnaceUnloadedSource furnace) () - - -- heat up - mapM_ heatPitUp pits - - -- update the temperature of the furnace - dt' <- liftParameter dt - h <- readRef (furnaceTemp furnace) - writeRef (furnaceTemp furnace) $ - h + dt' * (2600.0 - h) * 0.2 - --- | Return all empty pits. -emptyPits :: MonadComp m => Furnace m -> Event m [Pit m] -emptyPits furnace = - filterM (fmap isNothing . readRef . pitIngot) $ - furnacePits furnace - --- | This process takes ingots from the queue and then --- loads them in the furnace. -loadingProcess :: MonadComp m => Furnace m -> Process m () -loadingProcess furnace = - do ingot <- dequeue (furnaceQueue furnace) - let wait = - do count <- liftEvent $ readRef (furnacePitCount furnace) - when (count >= 10) $ - do processAwait (furnaceUnloaded furnace) - wait - wait - -- take any empty pit and load it - liftEvent $ - do pit: _ <- emptyPits furnace - loadIngot furnace ingot pit - -- repeat it again - loadingProcess furnace - --- | The input process that adds new ingots to the queue. -inputProcess :: MonadComp m => Furnace m -> Process m () -inputProcess furnace = - do delay <- liftParameter $ - randomExponential 2.5 - holdProcess delay - -- we have got a new ingot - liftEvent $ - do ingot <- newIngot furnace - enqueue (furnaceQueue furnace) ingot - -- repeat it again - inputProcess furnace - --- | Initialize the furnace. -initializeFurnace :: MonadComp m => Furnace m -> Event m () -initializeFurnace furnace = - do x1 <- newIngot furnace - x2 <- newIngot furnace - x3 <- newIngot furnace - x4 <- newIngot furnace - x5 <- newIngot furnace - x6 <- newIngot furnace - let p1 : p2 : p3 : p4 : p5 : p6 : ps = - furnacePits furnace - loadIngot furnace (x1 { ingotLoadTemp = 550.0 }) p1 - loadIngot furnace (x2 { ingotLoadTemp = 600.0 }) p2 - loadIngot furnace (x3 { ingotLoadTemp = 650.0 }) p3 - loadIngot furnace (x4 { ingotLoadTemp = 700.0 }) p4 - loadIngot furnace (x5 { ingotLoadTemp = 750.0 }) p5 - loadIngot furnace (x6 { ingotLoadTemp = 800.0 }) p6 - writeRef (furnaceTemp furnace) 1650.0 - --- | The simulation model. -model :: MonadComp m => Simulation m (Results m) -model = - do furnace <- newFurnace - - -- initialize the furnace and start its iterating in start time - runEventInStartTime $ - do initializeFurnace furnace - startIteratingFurnace furnace - - -- generate randomly new input ingots - runProcessInStartTime $ - inputProcess furnace - - -- load permanently the input ingots in the furnace - runProcessInStartTime $ - loadingProcess furnace - - -- return the simulation results - return $ - resultSummary $ - results - [resultSource "inputIngotCount" "the input ingot count" $ - enqueueStoreCount (furnaceQueue furnace), - -- - resultSource "loadedIngotCount" "the loaded ingot count" $ - dequeueCount (furnaceQueue furnace), - -- - resultSource "outputIngotCount" "the output ingot count" $ - furnaceReadyCount furnace, - -- - resultSource "outputIngotTemp" "the output ingot temperature" $ - fmap listSamplingStats $ readRef $ furnaceReadyTemps furnace, - -- - resultSource "heatingTime" "the heating time" $ - furnaceHeatingTime furnace, - -- - resultSource "pitCount" "the number of ingots in pits" $ - furnacePitCount furnace, - -- - resultSource "furnaceQueue" "the furnace queue" $ - furnaceQueue furnace] - --- | The main program. -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - model specs + +-- This is a model of the Furnace. It is described in different sources [1, 2]. +-- +-- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. +-- +-- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 + +import Data.Maybe +import System.Random +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans +import Simulation.Aivika.Trans.Queue.Infinite + +-- | The simulation specs. +specs = Specs { spcStartTime = 0.0, + -- spcStopTime = 1000.0, + spcStopTime = 300.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +-- | Return a random initial temperature of the item. +randomTemp :: MonadComp m => Parameter m Double +randomTemp = randomUniform 400 600 + +-- | Represents the furnace. +data Furnace m = + Furnace { furnacePits :: [Pit m], + -- ^ The pits for ingots. + furnacePitCount :: Ref m Int, + -- ^ The count of active pits with ingots. + furnaceQueue :: FCFSQueue m (Ingot m), + -- ^ The furnace queue. + furnaceUnloadedSource :: SignalSource m (), + -- ^ Notifies when the ingots have been + -- unloaded from the furnace. + furnaceHeatingTime :: Ref m (SamplingStats Double), + -- ^ The heating time for the ready ingots. + furnaceTemp :: Ref m Double, + -- ^ The furnace temperature. + furnaceReadyCount :: Ref m Int, + -- ^ The count of ready ingots. + furnaceReadyTemps :: Ref m [Double] + -- ^ The temperatures of all ready ingots. + } + +-- | Notifies when the ingots have been unloaded from the furnace. +furnaceUnloaded :: Furnace m -> Signal m () +furnaceUnloaded = publishSignal . furnaceUnloadedSource + +-- | A pit in the furnace to place the ingots. +data Pit m = + Pit { pitIngot :: Ref m (Maybe (Ingot m)), + -- ^ The ingot in the pit. + pitTemp :: Ref m Double + -- ^ The ingot temperature in the pit. + } + +data Ingot m = + Ingot { ingotFurnace :: Furnace m, + -- ^ The furnace. + ingotReceiveTime :: Double, + -- ^ The time at which the ingot was received. + ingotReceiveTemp :: Double, + -- ^ The temperature with which the ingot was received. + ingotLoadTime :: Double, + -- ^ The time of loading in the furnace. + ingotLoadTemp :: Double, + -- ^ The temperature when the ingot was loaded in the furnace. + ingotCoeff :: Double + -- ^ The heating coefficient. + } + +-- | Create a furnace. +newFurnace :: MonadComp m => Simulation m (Furnace m) +newFurnace = + do pits <- sequence [newPit | i <- [1..10]] + pitCount <- newRef 0 + queue <- runEventInStartTime newFCFSQueue + heatingTime <- newRef emptySamplingStats + h <- newRef 1650.0 + readyCount <- newRef 0 + readyTemps <- newRef [] + s <- newSignalSource + return Furnace { furnacePits = pits, + furnacePitCount = pitCount, + furnaceQueue = queue, + furnaceUnloadedSource = s, + furnaceHeatingTime = heatingTime, + furnaceTemp = h, + furnaceReadyCount = readyCount, + furnaceReadyTemps = readyTemps } + +-- | Create a new pit. +newPit :: MonadComp m => Simulation m (Pit m) +newPit = + do ingot <- newRef Nothing + h' <- newRef 0.0 + return Pit { pitIngot = ingot, + pitTemp = h' } + +-- | Create a new ingot. +newIngot :: MonadComp m => Furnace m -> Event m (Ingot m) +newIngot furnace = + do t <- liftDynamics time + xi <- liftParameter $ randomNormal 0.05 0.01 + h' <- liftParameter randomTemp + let c = 0.1 + xi + return Ingot { ingotFurnace = furnace, + ingotReceiveTime = t, + ingotReceiveTemp = h', + ingotLoadTime = t, + ingotLoadTemp = h', + ingotCoeff = c } + +-- | Heat the ingot up in the pit if there is such an ingot. +heatPitUp :: MonadComp m => Pit m -> Event m () +heatPitUp pit = + do ingot <- readRef (pitIngot pit) + case ingot of + Nothing -> + return () + Just ingot -> do + + -- update the temperature of the ingot. + let furnace = ingotFurnace ingot + dt' <- liftParameter dt + h' <- readRef (pitTemp pit) + h <- readRef (furnaceTemp furnace) + writeRef (pitTemp pit) $ + h' + dt' * (h - h') * ingotCoeff ingot + +-- | Check whether there are ready ingots in the pits. +ingotsReady :: MonadComp m => Furnace m -> Event m Bool +ingotsReady furnace = + fmap (not . null) $ + filterM (fmap (>= 2200.0) . readRef . pitTemp) $ + furnacePits furnace + +-- | Try to unload the ready ingot from the specified pit. +tryUnloadPit :: MonadComp m => Furnace m -> Pit m -> Event m () +tryUnloadPit furnace pit = + do h' <- readRef (pitTemp pit) + when (h' >= 2000.0) $ + do Just ingot <- readRef (pitIngot pit) + unloadIngot furnace ingot pit + +-- | Try to load an awaiting ingot in the specified empty pit. +tryLoadPit :: MonadComp m => Furnace m -> Pit m -> Event m () +tryLoadPit furnace pit = + do ingot <- tryDequeue (furnaceQueue furnace) + case ingot of + Nothing -> + return () + Just ingot -> + do t' <- liftDynamics time + loadIngot furnace (ingot { ingotLoadTime = t', + ingotLoadTemp = 400.0 }) pit + +-- | Unload the ingot from the specified pit. +unloadIngot :: MonadComp m => Furnace m -> Ingot m -> Pit m -> Event m () +unloadIngot furnace ingot pit = + do h' <- readRef (pitTemp pit) + writeRef (pitIngot pit) Nothing + writeRef (pitTemp pit) 0.0 + + -- count the active pits + modifyRef (furnacePitCount furnace) (+ (- 1)) + + -- how long did we heat the ingot up? + t' <- liftDynamics time + modifyRef (furnaceHeatingTime furnace) $ + addSamplingStats (t' - ingotLoadTime ingot) + + -- what is the temperature of the unloaded ingot? + modifyRef (furnaceReadyTemps furnace) (h' :) + + -- count the ready ingots + modifyRef (furnaceReadyCount furnace) (+ 1) + +-- | Load the ingot in the specified pit +loadIngot :: MonadComp m => Furnace m -> Ingot m -> Pit m -> Event m () +loadIngot furnace ingot pit = + do writeRef (pitIngot pit) $ Just ingot + writeRef (pitTemp pit) $ ingotLoadTemp ingot + + -- count the active pits + modifyRef (furnacePitCount furnace) (+ 1) + count <- readRef (furnacePitCount furnace) + + -- decrease the furnace temperature + h <- readRef (furnaceTemp furnace) + let h' = ingotLoadTemp ingot + dh = - (h - h') / fromIntegral count + writeRef (furnaceTemp furnace) $ h + dh + +-- | Start iterating the furnace processing through the event queue. +startIteratingFurnace :: MonadComp m => Furnace m -> Event m () +startIteratingFurnace furnace = + let pits = furnacePits furnace + in enqueueEventWithIntegTimes $ + do -- try to unload ready ingots + ready <- ingotsReady furnace + when ready $ + do mapM_ (tryUnloadPit furnace) pits + triggerSignal (furnaceUnloadedSource furnace) () + + -- heat up + mapM_ heatPitUp pits + + -- update the temperature of the furnace + dt' <- liftParameter dt + h <- readRef (furnaceTemp furnace) + writeRef (furnaceTemp furnace) $ + h + dt' * (2600.0 - h) * 0.2 + +-- | Return all empty pits. +emptyPits :: MonadComp m => Furnace m -> Event m [Pit m] +emptyPits furnace = + filterM (fmap isNothing . readRef . pitIngot) $ + furnacePits furnace + +-- | This process takes ingots from the queue and then +-- loads them in the furnace. +loadingProcess :: MonadComp m => Furnace m -> Process m () +loadingProcess furnace = + do ingot <- dequeue (furnaceQueue furnace) + let wait = + do count <- liftEvent $ readRef (furnacePitCount furnace) + when (count >= 10) $ + do processAwait (furnaceUnloaded furnace) + wait + wait + -- take any empty pit and load it + liftEvent $ + do pit: _ <- emptyPits furnace + loadIngot furnace ingot pit + -- repeat it again + loadingProcess furnace + +-- | The input process that adds new ingots to the queue. +inputProcess :: MonadComp m => Furnace m -> Process m () +inputProcess furnace = + do delay <- liftParameter $ + randomExponential 2.5 + holdProcess delay + -- we have got a new ingot + liftEvent $ + do ingot <- newIngot furnace + enqueue (furnaceQueue furnace) ingot + -- repeat it again + inputProcess furnace + +-- | Initialize the furnace. +initializeFurnace :: MonadComp m => Furnace m -> Event m () +initializeFurnace furnace = + do x1 <- newIngot furnace + x2 <- newIngot furnace + x3 <- newIngot furnace + x4 <- newIngot furnace + x5 <- newIngot furnace + x6 <- newIngot furnace + let p1 : p2 : p3 : p4 : p5 : p6 : ps = + furnacePits furnace + loadIngot furnace (x1 { ingotLoadTemp = 550.0 }) p1 + loadIngot furnace (x2 { ingotLoadTemp = 600.0 }) p2 + loadIngot furnace (x3 { ingotLoadTemp = 650.0 }) p3 + loadIngot furnace (x4 { ingotLoadTemp = 700.0 }) p4 + loadIngot furnace (x5 { ingotLoadTemp = 750.0 }) p5 + loadIngot furnace (x6 { ingotLoadTemp = 800.0 }) p6 + writeRef (furnaceTemp furnace) 1650.0 + +-- | The simulation model. +model :: MonadComp m => Simulation m (Results m) +model = + do furnace <- newFurnace + + -- initialize the furnace and start its iterating in start time + runEventInStartTime $ + do initializeFurnace furnace + startIteratingFurnace furnace + + -- generate randomly new input ingots + runProcessInStartTime $ + inputProcess furnace + + -- load permanently the input ingots in the furnace + runProcessInStartTime $ + loadingProcess furnace + + -- return the simulation results + return $ + resultSummary $ + results + [resultSource "inputIngotCount" "the input ingot count" $ + enqueueStoreCount (furnaceQueue furnace), + -- + resultSource "loadedIngotCount" "the loaded ingot count" $ + dequeueCount (furnaceQueue furnace), + -- + resultSource "outputIngotCount" "the output ingot count" $ + furnaceReadyCount furnace, + -- + resultSource "outputIngotTemp" "the output ingot temperature" $ + fmap listSamplingStats $ readRef $ furnaceReadyTemps furnace, + -- + resultSource "heatingTime" "the heating time" $ + furnaceHeatingTime furnace, + -- + resultSource "pitCount" "the number of ingots in pits" $ + furnacePitCount furnace, + -- + resultSource "furnaceQueue" "the furnace queue" $ + furnaceQueue furnace] + +-- | The main program. +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + model specs diff --git a/examples/InspectionAdjustmentStations.hs b/examples/InspectionAdjustmentStations.hs --- a/examples/InspectionAdjustmentStations.hs +++ b/examples/InspectionAdjustmentStations.hs @@ -1,164 +1,164 @@ - -{-# LANGUAGE RecursiveDo, Arrows #-} - --- Example: Inspection and Adjustment Stations on a Production Line --- --- This is a model of the workflow with a loop. Also there are two infinite queues. --- --- It is described in different sources [1, 2]. So, this is chapter 8 of [2] and section 5.15 of [1]. --- --- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. --- --- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 - -import Prelude hiding (id, (.)) - -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Fix -import Control.Arrow -import Control.Category (id, (.)) - -import Simulation.Aivika.Trans -import Simulation.Aivika.Trans.Queue.Infinite - --- | The simulation specs. -specs = Specs { spcStartTime = 0.0, - spcStopTime = 480.0, - spcDT = 0.1, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - --- the minimum delay of arriving the next TV set -minArrivalDelay = 3.5 - --- the maximum delay of arriving the next TV set -maxArrivalDelay = 7.5 - --- the minimum time to inspect the TV set -minInspectionTime = 6 - --- the maximum time to inspect the TV set -maxInspectionTime = 12 - --- the probability of passing the inspection phase -inspectionPassingProb = 0.85 - --- how many are inspection stations? -inspectionStationCount = 2 - --- the minimum time to adjust an improper TV set -minAdjustmentTime = 20 - --- the maximum time to adjust an improper TV set -maxAdjustmentTime = 40 - --- how many are adjustment stations? -adjustmentStationCount = 1 - --- create an inspection station (server) -newInspectionStation :: MonadComp m => Simulation m (Server m () a (Either a a)) -newInspectionStation = - newServer $ \a -> - do holdProcess =<< - (liftParameter $ - randomUniform minInspectionTime maxInspectionTime) - passed <- - liftParameter $ - randomTrue inspectionPassingProb - if passed - then return $ Right a - else return $ Left a - --- create an adjustment station (server) -newAdjustmentStation :: MonadComp m => Simulation m (Server m () a a) -newAdjustmentStation = - newServer $ \a -> - do holdProcess =<< - (liftParameter $ - randomUniform minAdjustmentTime maxAdjustmentTime) - return a - -model :: (MonadComp m, MonadFix m) => Simulation m (Results m) -model = mdo - -- to count the arrived TV sets for inspecting and adjusting - inputArrivalTimer <- newArrivalTimer - -- it will gather the statistics of the processing time - outputArrivalTimer <- newArrivalTimer - -- define a stream of input events - let inputStream = - randomUniformStream minArrivalDelay maxArrivalDelay - -- create a queue before the inspection stations - inspectionQueue <- - runEventInStartTime newFCFSQueue - -- create a queue before the adjustment stations - adjustmentQueue <- - runEventInStartTime newFCFSQueue - -- create the inspection stations (servers) - inspectionStations <- - forM [1 .. inspectionStationCount] $ \_ -> - newInspectionStation - -- create the adjustment stations (servers) - adjustmentStations <- - forM [1 .. adjustmentStationCount] $ \_ -> - newAdjustmentStation - -- a processor loop for the inspection stations' queue - let inspectionQueueProcessorLoop = - queueProcessorLoopSeq - (liftEvent . enqueue inspectionQueue) - (dequeue inspectionQueue) - inspectionProcessor - (adjustmentQueueProcessor >>> adjustmentProcessor) - -- a processor for the adjustment stations' queue - let adjustmentQueueProcessor = - queueProcessor - (liftEvent . enqueue adjustmentQueue) - (dequeue adjustmentQueue) - -- a parallel work of the inspection stations - let inspectionProcessor = - processorParallel (map serverProcessor inspectionStations) - -- a parallel work of the adjustment stations - let adjustmentProcessor = - processorParallel (map serverProcessor adjustmentStations) - -- the entire processor from input to output - let entireProcessor = - arrivalTimerProcessor inputArrivalTimer >>> - inspectionQueueProcessorLoop >>> - arrivalTimerProcessor outputArrivalTimer - -- start simulating the model - runProcessInStartTime $ - sinkStream $ runProcessor entireProcessor inputStream - -- return the simulation results in start time - return $ - results - [resultSource - "inspectionQueue" "the inspection queue" - inspectionQueue, - -- - resultSource - "adjustmentQueue" "the adjustment queue" - adjustmentQueue, - -- - resultSource - "inputArrivalTimer" "the input arrival timer" - inputArrivalTimer, - -- - resultSource - "outputArrivalTimer" "the output arrival timer" - outputArrivalTimer, - -- - resultSource - "inspectionStations" "the inspection stations" - inspectionStations, - -- - resultSource - "adjustmentStations" "the adjustment stations" - adjustmentStations] - -modelSummary :: (MonadComp m, MonadFix m) => Simulation m (Results m) -modelSummary = fmap resultSummary model - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - modelSummary specs + +{-# LANGUAGE RecursiveDo, Arrows #-} + +-- Example: Inspection and Adjustment Stations on a Production Line +-- +-- This is a model of the workflow with a loop. Also there are two infinite queues. +-- +-- It is described in different sources [1, 2]. So, this is chapter 8 of [2] and section 5.15 of [1]. +-- +-- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. +-- +-- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 + +import Prelude hiding (id, (.)) + +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Fix +import Control.Arrow +import Control.Category (id, (.)) + +import Simulation.Aivika.Trans +import Simulation.Aivika.Trans.Queue.Infinite + +-- | The simulation specs. +specs = Specs { spcStartTime = 0.0, + spcStopTime = 480.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +-- the minimum delay of arriving the next TV set +minArrivalDelay = 3.5 + +-- the maximum delay of arriving the next TV set +maxArrivalDelay = 7.5 + +-- the minimum time to inspect the TV set +minInspectionTime = 6 + +-- the maximum time to inspect the TV set +maxInspectionTime = 12 + +-- the probability of passing the inspection phase +inspectionPassingProb = 0.85 + +-- how many are inspection stations? +inspectionStationCount = 2 + +-- the minimum time to adjust an improper TV set +minAdjustmentTime = 20 + +-- the maximum time to adjust an improper TV set +maxAdjustmentTime = 40 + +-- how many are adjustment stations? +adjustmentStationCount = 1 + +-- create an inspection station (server) +newInspectionStation :: MonadComp m => Simulation m (Server m () a (Either a a)) +newInspectionStation = + newServer $ \a -> + do holdProcess =<< + (liftParameter $ + randomUniform minInspectionTime maxInspectionTime) + passed <- + liftParameter $ + randomTrue inspectionPassingProb + if passed + then return $ Right a + else return $ Left a + +-- create an adjustment station (server) +newAdjustmentStation :: MonadComp m => Simulation m (Server m () a a) +newAdjustmentStation = + newServer $ \a -> + do holdProcess =<< + (liftParameter $ + randomUniform minAdjustmentTime maxAdjustmentTime) + return a + +model :: (MonadComp m, MonadFix m) => Simulation m (Results m) +model = mdo + -- to count the arrived TV sets for inspecting and adjusting + inputArrivalTimer <- newArrivalTimer + -- it will gather the statistics of the processing time + outputArrivalTimer <- newArrivalTimer + -- define a stream of input events + let inputStream = + randomUniformStream minArrivalDelay maxArrivalDelay + -- create a queue before the inspection stations + inspectionQueue <- + runEventInStartTime newFCFSQueue + -- create a queue before the adjustment stations + adjustmentQueue <- + runEventInStartTime newFCFSQueue + -- create the inspection stations (servers) + inspectionStations <- + forM [1 .. inspectionStationCount] $ \_ -> + newInspectionStation + -- create the adjustment stations (servers) + adjustmentStations <- + forM [1 .. adjustmentStationCount] $ \_ -> + newAdjustmentStation + -- a processor loop for the inspection stations' queue + let inspectionQueueProcessorLoop = + queueProcessorLoopSeq + (liftEvent . enqueue inspectionQueue) + (dequeue inspectionQueue) + inspectionProcessor + (adjustmentQueueProcessor >>> adjustmentProcessor) + -- a processor for the adjustment stations' queue + let adjustmentQueueProcessor = + queueProcessor + (liftEvent . enqueue adjustmentQueue) + (dequeue adjustmentQueue) + -- a parallel work of the inspection stations + let inspectionProcessor = + processorParallel (map serverProcessor inspectionStations) + -- a parallel work of the adjustment stations + let adjustmentProcessor = + processorParallel (map serverProcessor adjustmentStations) + -- the entire processor from input to output + let entireProcessor = + arrivalTimerProcessor inputArrivalTimer >>> + inspectionQueueProcessorLoop >>> + arrivalTimerProcessor outputArrivalTimer + -- start simulating the model + runProcessInStartTime $ + sinkStream $ runProcessor entireProcessor inputStream + -- return the simulation results in start time + return $ + results + [resultSource + "inspectionQueue" "the inspection queue" + inspectionQueue, + -- + resultSource + "adjustmentQueue" "the adjustment queue" + adjustmentQueue, + -- + resultSource + "inputArrivalTimer" "the input arrival timer" + inputArrivalTimer, + -- + resultSource + "outputArrivalTimer" "the output arrival timer" + outputArrivalTimer, + -- + resultSource + "inspectionStations" "the inspection stations" + inspectionStations, + -- + resultSource + "adjustmentStations" "the adjustment stations" + adjustmentStations] + +modelSummary :: (MonadComp m, MonadFix m) => Simulation m (Results m) +modelSummary = fmap resultSummary model + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + modelSummary specs diff --git a/examples/MachRep1.hs b/examples/MachRep1.hs --- a/examples/MachRep1.hs +++ b/examples/MachRep1.hs @@ -1,66 +1,66 @@ - --- It corresponds to model MachRep1 described in document --- Introduction to Discrete-Event Simulation and the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Two machines, which sometimes break down. --- Up time is exponentially distributed with mean 1.0, and repair time is --- exponentially distributed with mean 0.5. There are two repairpersons, --- so the two machines can be repaired simultaneously if they are down --- at the same time. --- --- Output is long-run proportion of up time. Should get value of about --- 0.66. - -import Control.Monad.Trans - -import Simulation.Aivika.Trans - -meanUpTime = 1.0 -meanRepairTime = 0.5 - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 1000.0, - spcDT = 1.0, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: MonadComp m => Simulation m (Results m) -model = - do totalUpTime <- newRef 0.0 - - let machine = - do upTime <- - liftParameter $ - randomExponential meanUpTime - holdProcess upTime - liftEvent $ - modifyRef totalUpTime (+ upTime) - repairTime <- - liftParameter $ - randomExponential meanRepairTime - holdProcess repairTime - machine - - runProcessInStartTime machine - runProcessInStartTime machine - - let upTimeProp = - do x <- readRef totalUpTime - y <- liftDynamics time - return $ x / (2 * y) - - return $ - results - [resultSource - "upTimeProp" - "The long-run proportion of up time (~ 0.66)" - upTimeProp] - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - model specs + +-- It corresponds to model MachRep1 described in document +-- Introduction to Discrete-Event Simulation and the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Two machines, which sometimes break down. +-- Up time is exponentially distributed with mean 1.0, and repair time is +-- exponentially distributed with mean 0.5. There are two repairpersons, +-- so the two machines can be repaired simultaneously if they are down +-- at the same time. +-- +-- Output is long-run proportion of up time. Should get value of about +-- 0.66. + +import Control.Monad.Trans + +import Simulation.Aivika.Trans + +meanUpTime = 1.0 +meanRepairTime = 0.5 + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 1000.0, + spcDT = 1.0, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: MonadComp m => Simulation m (Results m) +model = + do totalUpTime <- newRef 0.0 + + let machine = + do upTime <- + liftParameter $ + randomExponential meanUpTime + holdProcess upTime + liftEvent $ + modifyRef totalUpTime (+ upTime) + repairTime <- + liftParameter $ + randomExponential meanRepairTime + holdProcess repairTime + machine + + runProcessInStartTime machine + runProcessInStartTime machine + + let upTimeProp = + do x <- readRef totalUpTime + y <- liftDynamics time + return $ x / (2 * y) + + return $ + results + [resultSource + "upTimeProp" + "The long-run proportion of up time (~ 0.66)" + upTimeProp] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + model specs diff --git a/examples/MachRep1EventDriven.hs b/examples/MachRep1EventDriven.hs --- a/examples/MachRep1EventDriven.hs +++ b/examples/MachRep1EventDriven.hs @@ -1,79 +1,79 @@ - --- It corresponds to model MachRep1 described in document --- Introduction to Discrete-Event Simulation and the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Two machines, which sometimes break down. --- Up time is exponentially distributed with mean 1.0, and repair time is --- exponentially distributed with mean 0.5. There are two repairpersons, --- so the two machines can be repaired simultaneously if they are down --- at the same time. --- --- Output is long-run proportion of up time. Should get value of about --- 0.66. - -import Control.Monad.Trans - -import Simulation.Aivika.Trans - -meanUpTime = 1.0 -meanRepairTime = 0.5 - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 1000.0, - spcDT = 1.0, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: MonadComp m => Simulation m (Results m) -model = - do totalUpTime <- newRef 0.0 - - let machineBroken startUpTime = - - do finishUpTime <- liftDynamics time - modifyRef totalUpTime (+ (finishUpTime - startUpTime)) - repairTime <- - liftParameter $ - randomExponential meanRepairTime - - -- enqueue a new event - let t = finishUpTime + repairTime - enqueueEvent t machineRepaired - - machineRepaired = - - do startUpTime <- liftDynamics time - upTime <- - liftParameter $ - randomExponential meanUpTime - - -- enqueue a new event - let t = startUpTime + upTime - enqueueEvent t $ machineBroken startUpTime - - runEventInStartTime $ - do -- start the first machine - machineRepaired - -- start the second machine - machineRepaired - - let upTimeProp = - do x <- readRef totalUpTime - y <- liftDynamics time - return $ x / (2 * y) - - return $ - results - [resultSource - "upTimeProp" - "The long-run proportion of up time (~ 0.66)" - upTimeProp] - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - model specs + +-- It corresponds to model MachRep1 described in document +-- Introduction to Discrete-Event Simulation and the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Two machines, which sometimes break down. +-- Up time is exponentially distributed with mean 1.0, and repair time is +-- exponentially distributed with mean 0.5. There are two repairpersons, +-- so the two machines can be repaired simultaneously if they are down +-- at the same time. +-- +-- Output is long-run proportion of up time. Should get value of about +-- 0.66. + +import Control.Monad.Trans + +import Simulation.Aivika.Trans + +meanUpTime = 1.0 +meanRepairTime = 0.5 + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 1000.0, + spcDT = 1.0, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: MonadComp m => Simulation m (Results m) +model = + do totalUpTime <- newRef 0.0 + + let machineBroken startUpTime = + + do finishUpTime <- liftDynamics time + modifyRef totalUpTime (+ (finishUpTime - startUpTime)) + repairTime <- + liftParameter $ + randomExponential meanRepairTime + + -- enqueue a new event + let t = finishUpTime + repairTime + enqueueEvent t machineRepaired + + machineRepaired = + + do startUpTime <- liftDynamics time + upTime <- + liftParameter $ + randomExponential meanUpTime + + -- enqueue a new event + let t = startUpTime + upTime + enqueueEvent t $ machineBroken startUpTime + + runEventInStartTime $ + do -- start the first machine + machineRepaired + -- start the second machine + machineRepaired + + let upTimeProp = + do x <- readRef totalUpTime + y <- liftDynamics time + return $ x / (2 * y) + + return $ + results + [resultSource + "upTimeProp" + "The long-run proportion of up time (~ 0.66)" + upTimeProp] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + model specs diff --git a/examples/MachRep1TimeDriven.hs b/examples/MachRep1TimeDriven.hs --- a/examples/MachRep1TimeDriven.hs +++ b/examples/MachRep1TimeDriven.hs @@ -1,117 +1,117 @@ - --- It corresponds to model MachRep1 described in document --- Introduction to Discrete-Event Simulation and the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Two machines, which sometimes break down. --- Up time is exponentially distributed with mean 1.0, and repair time is --- exponentially distributed with mean 0.5. There are two repairpersons, --- so the two machines can be repaired simultaneously if they are down --- at the same time. --- --- Output is long-run proportion of up time. Should get value of about --- 0.66. - -import Control.Monad.Trans - -import Simulation.Aivika.Trans - -meanUpTime = 1.0 -meanRepairTime = 0.5 - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 1000.0, - spcDT = 0.05, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: MonadComp m => Simulation m (Results m) -model = - do totalUpTime <- newRef 0.0 - - let machine = - do startUpTime <- newRef 0.0 - - -- a number of iterations when - -- the machine works - upNum <- newRef (-1) - - -- a number of iterations when - -- the machine is broken - repairNum <- newRef (-1) - - -- create a simulation model - return $ - do upNum' <- readRef upNum - repairNum' <- readRef repairNum - - let untilBroken = - modifyRef upNum $ \a -> a - 1 - - untilRepaired = - modifyRef repairNum $ \a -> a - 1 - - broken = - do writeRef upNum (-1) - -- the machine is broken - startUpTime' <- readRef startUpTime - finishUpTime' <- liftDynamics time - dt' <- liftParameter dt - modifyRef totalUpTime $ - \a -> a + - (finishUpTime' - startUpTime') - repairTime' <- - liftParameter $ - randomExponential meanRepairTime - writeRef repairNum $ - round (repairTime' / dt') - - repaired = - do writeRef repairNum (-1) - -- the machine is repaired - t' <- liftDynamics time - dt' <- liftParameter dt - writeRef startUpTime t' - upTime' <- - liftParameter $ - randomExponential meanUpTime - writeRef upNum $ - round (upTime' / dt') - - result | upNum' > 0 = untilBroken - | upNum' == 0 = broken - | repairNum' > 0 = untilRepaired - | repairNum' == 0 = repaired - | otherwise = repaired - result - - -- create two machines with type Event () - m1 <- machine - m2 <- machine - - -- start the time-driven simulation of the machines - runEventInStartTime $ - -- in the integration time points - enqueueEventWithIntegTimes $ - do m1 - m2 - - let upTimeProp = - do x <- readRef totalUpTime - y <- liftDynamics time - return $ x / (2 * y) - - return $ - results - [resultSource - "upTimeProp" - "The long-run proportion of up time (~ 0.66)" - upTimeProp] - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - model specs + +-- It corresponds to model MachRep1 described in document +-- Introduction to Discrete-Event Simulation and the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Two machines, which sometimes break down. +-- Up time is exponentially distributed with mean 1.0, and repair time is +-- exponentially distributed with mean 0.5. There are two repairpersons, +-- so the two machines can be repaired simultaneously if they are down +-- at the same time. +-- +-- Output is long-run proportion of up time. Should get value of about +-- 0.66. + +import Control.Monad.Trans + +import Simulation.Aivika.Trans + +meanUpTime = 1.0 +meanRepairTime = 0.5 + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 1000.0, + spcDT = 0.05, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: MonadComp m => Simulation m (Results m) +model = + do totalUpTime <- newRef 0.0 + + let machine = + do startUpTime <- newRef 0.0 + + -- a number of iterations when + -- the machine works + upNum <- newRef (-1) + + -- a number of iterations when + -- the machine is broken + repairNum <- newRef (-1) + + -- create a simulation model + return $ + do upNum' <- readRef upNum + repairNum' <- readRef repairNum + + let untilBroken = + modifyRef upNum $ \a -> a - 1 + + untilRepaired = + modifyRef repairNum $ \a -> a - 1 + + broken = + do writeRef upNum (-1) + -- the machine is broken + startUpTime' <- readRef startUpTime + finishUpTime' <- liftDynamics time + dt' <- liftParameter dt + modifyRef totalUpTime $ + \a -> a + + (finishUpTime' - startUpTime') + repairTime' <- + liftParameter $ + randomExponential meanRepairTime + writeRef repairNum $ + round (repairTime' / dt') + + repaired = + do writeRef repairNum (-1) + -- the machine is repaired + t' <- liftDynamics time + dt' <- liftParameter dt + writeRef startUpTime t' + upTime' <- + liftParameter $ + randomExponential meanUpTime + writeRef upNum $ + round (upTime' / dt') + + result | upNum' > 0 = untilBroken + | upNum' == 0 = broken + | repairNum' > 0 = untilRepaired + | repairNum' == 0 = repaired + | otherwise = repaired + result + + -- create two machines with type Event () + m1 <- machine + m2 <- machine + + -- start the time-driven simulation of the machines + runEventInStartTime $ + -- in the integration time points + enqueueEventWithIntegTimes $ + do m1 + m2 + + let upTimeProp = + do x <- readRef totalUpTime + y <- liftDynamics time + return $ x / (2 * y) + + return $ + results + [resultSource + "upTimeProp" + "The long-run proportion of up time (~ 0.66)" + upTimeProp] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + model specs diff --git a/examples/MachRep2.hs b/examples/MachRep2.hs --- a/examples/MachRep2.hs +++ b/examples/MachRep2.hs @@ -1,103 +1,103 @@ - --- It corresponds to model MachRep2 described in document --- Introduction to Discrete-Event Simulation and the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Two machines, but sometimes break down. Up time is exponentially --- distributed with mean 1.0, and repair time is exponentially distributed --- with mean 0.5. In this example, there is only one repairperson, so --- the two machines cannot be repaired simultaneously if they are down --- at the same time. --- --- In addition to finding the long-run proportion of up time as in --- model MachRep1, let’s also find the long-run proportion of the time --- that a given machine does not have immediate access to the repairperson --- when the machine breaks down. Output values should be about 0.6 and 0.67. - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Trans - -meanUpTime = 1.0 -meanRepairTime = 0.5 - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 1000.0, - spcDT = 1.0, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: MonadComp m => Simulation m (Results m) -model = - do -- number of times the machines have broken down - nRep <- newRef 0 - - -- number of breakdowns in which the machine - -- started repair service right away - nImmedRep <- newRef 0 - - -- total up time for all machines - totalUpTime <- newRef 0.0 - - repairPerson <- newFCFSResource 1 - - let machine = - do upTime <- - liftParameter $ - randomExponential meanUpTime - holdProcess upTime - liftEvent $ - modifyRef totalUpTime (+ upTime) - - -- check the resource availability - liftEvent $ - do modifyRef nRep (+ 1) - n <- resourceCount repairPerson - when (n == 1) $ - modifyRef nImmedRep (+ 1) - - requestResource repairPerson - repairTime <- - liftParameter $ - randomExponential meanRepairTime - holdProcess repairTime - releaseResource repairPerson - - machine - - runProcessInStartTime machine - runProcessInStartTime machine - - let upTimeProp = - do x <- readRef totalUpTime - y <- liftDynamics time - return $ x / (2 * y) - - immedProp = - do n <- readRef nRep - nImmed <- readRef nImmedRep - let x :: Double - x = fromIntegral nImmed / - fromIntegral n - return x - - return $ - results - [resultSource - "upTimeProp" - "The long-run proportion of up time (~ 0.6)" - upTimeProp, - -- - resultSource - "immedProp" - "The proption of time of immediate access (~0.67)" - immedProp] - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - model specs + +-- It corresponds to model MachRep2 described in document +-- Introduction to Discrete-Event Simulation and the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Two machines, but sometimes break down. Up time is exponentially +-- distributed with mean 1.0, and repair time is exponentially distributed +-- with mean 0.5. In this example, there is only one repairperson, so +-- the two machines cannot be repaired simultaneously if they are down +-- at the same time. +-- +-- In addition to finding the long-run proportion of up time as in +-- model MachRep1, let’s also find the long-run proportion of the time +-- that a given machine does not have immediate access to the repairperson +-- when the machine breaks down. Output values should be about 0.6 and 0.67. + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans + +meanUpTime = 1.0 +meanRepairTime = 0.5 + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 1000.0, + spcDT = 1.0, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: MonadComp m => Simulation m (Results m) +model = + do -- number of times the machines have broken down + nRep <- newRef 0 + + -- number of breakdowns in which the machine + -- started repair service right away + nImmedRep <- newRef 0 + + -- total up time for all machines + totalUpTime <- newRef 0.0 + + repairPerson <- newFCFSResource 1 + + let machine = + do upTime <- + liftParameter $ + randomExponential meanUpTime + holdProcess upTime + liftEvent $ + modifyRef totalUpTime (+ upTime) + + -- check the resource availability + liftEvent $ + do modifyRef nRep (+ 1) + n <- resourceCount repairPerson + when (n == 1) $ + modifyRef nImmedRep (+ 1) + + requestResource repairPerson + repairTime <- + liftParameter $ + randomExponential meanRepairTime + holdProcess repairTime + releaseResource repairPerson + + machine + + runProcessInStartTime machine + runProcessInStartTime machine + + let upTimeProp = + do x <- readRef totalUpTime + y <- liftDynamics time + return $ x / (2 * y) + + immedProp = + do n <- readRef nRep + nImmed <- readRef nImmedRep + let x :: Double + x = fromIntegral nImmed / + fromIntegral n + return x + + return $ + results + [resultSource + "upTimeProp" + "The long-run proportion of up time (~ 0.6)" + upTimeProp, + -- + resultSource + "immedProp" + "The proption of time of immediate access (~0.67)" + immedProp] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + model specs diff --git a/examples/MachRep3.hs b/examples/MachRep3.hs --- a/examples/MachRep3.hs +++ b/examples/MachRep3.hs @@ -1,93 +1,93 @@ - --- It corresponds to model MachRep3 described in document --- Introduction to Discrete-Event Simulation and the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Variation of models MachRep1, MachRep2. Two machines, but --- sometimes break down. Up time is exponentially distributed with mean --- 1.0, and repair time is exponentially distributed with mean 0.5. In --- this example, there is only one repairperson, and she is not summoned --- until both machines are down. We find the proportion of up time. It --- should come out to about 0.45. - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Trans - -meanUpTime = 1.0 -meanRepairTime = 0.5 - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 1000.0, - spcDT = 1.0, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: MonadComp m => Simulation m (Results m) -model = - do -- number of machines currently up - nUp <- newRef 2 - - -- total up time for all machines - totalUpTime <- newRef 0.0 - - repairPerson <- newResource FCFS 1 - - pid1 <- newProcessId - pid2 <- newProcessId - - let machine pid = - do upTime <- - liftParameter $ - randomExponential meanUpTime - holdProcess upTime - liftEvent $ - modifyRef totalUpTime (+ upTime) - - liftEvent $ - modifyRef nUp (+ (-1)) - nUp' <- liftEvent $ readRef nUp - if nUp' == 1 - then passivateProcess - else liftEvent $ - do n <- resourceCount repairPerson - when (n == 1) $ - reactivateProcess pid - - requestResource repairPerson - repairTime <- - liftParameter $ - randomExponential meanRepairTime - holdProcess repairTime - liftEvent $ - modifyRef nUp (+ 1) - releaseResource repairPerson - - machine pid - - runProcessInStartTimeUsingId - pid1 (machine pid2) - - runProcessInStartTimeUsingId - pid2 (machine pid1) - - let upTimeProp = - do x <- readRef totalUpTime - y <- liftDynamics time - return $ x / (2 * y) - - return $ - results - [resultSource - "upTimeProp" - "The long-run proportion of up time (~ 0.45)" - upTimeProp] - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - model specs + +-- It corresponds to model MachRep3 described in document +-- Introduction to Discrete-Event Simulation and the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Variation of models MachRep1, MachRep2. Two machines, but +-- sometimes break down. Up time is exponentially distributed with mean +-- 1.0, and repair time is exponentially distributed with mean 0.5. In +-- this example, there is only one repairperson, and she is not summoned +-- until both machines are down. We find the proportion of up time. It +-- should come out to about 0.45. + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans + +meanUpTime = 1.0 +meanRepairTime = 0.5 + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 1000.0, + spcDT = 1.0, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: MonadComp m => Simulation m (Results m) +model = + do -- number of machines currently up + nUp <- newRef 2 + + -- total up time for all machines + totalUpTime <- newRef 0.0 + + repairPerson <- newResource FCFS 1 + + pid1 <- newProcessId + pid2 <- newProcessId + + let machine pid = + do upTime <- + liftParameter $ + randomExponential meanUpTime + holdProcess upTime + liftEvent $ + modifyRef totalUpTime (+ upTime) + + liftEvent $ + modifyRef nUp (+ (-1)) + nUp' <- liftEvent $ readRef nUp + if nUp' == 1 + then passivateProcess + else liftEvent $ + do n <- resourceCount repairPerson + when (n == 1) $ + reactivateProcess pid + + requestResource repairPerson + repairTime <- + liftParameter $ + randomExponential meanRepairTime + holdProcess repairTime + liftEvent $ + modifyRef nUp (+ 1) + releaseResource repairPerson + + machine pid + + runProcessInStartTimeUsingId + pid1 (machine pid2) + + runProcessInStartTimeUsingId + pid2 (machine pid1) + + let upTimeProp = + do x <- readRef totalUpTime + y <- liftDynamics time + return $ x / (2 * y) + + return $ + results + [resultSource + "upTimeProp" + "The long-run proportion of up time (~ 0.45)" + upTimeProp] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + model specs diff --git a/examples/TimeOut.hs b/examples/TimeOut.hs --- a/examples/TimeOut.hs +++ b/examples/TimeOut.hs @@ -1,93 +1,93 @@ - --- It corresponds to model TimeOut described in document --- Advanced Features of the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/AdvancedSimPy.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Introductory example to illustrate the modeling of "competing --- events" such as timeouts, especially using the cancelProcess function. A --- network node sends a message but also sets a timeout period; if the --- node times out, it assumes the message it had sent was lost, and it --- will send again. The time to get an acknowledgement for a message is --- exponentially distributed with mean 1.0, and the timeout period is --- 0.5. Immediately after receiving an acknowledgement, the node sends --- out a new message. --- --- We find the proportion of messages which timeout. The output should --- be about 0.61. - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Trans - -ackRate = 1.0 / 1.0 -- reciprocal of the acknowledge mean time -toPeriod = 0.5 -- timeout period - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 10000.0, - spcDT = 1.0, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: MonadComp m => Simulation m Double -model = - do -- number of messages sent - nMsgs <- newRef 0 - - -- number of timeouts which have occured - nTimeOuts <- newRef 0 - - -- reactivatedCode will 1 if timeout occurred, - -- 2 ACK if received - reactivatedCode <- newRef 0 - - nodePid <- newProcessId - - let node = - do liftEvent $ modifyRef nMsgs $ (+) 1 - -- create process IDs - timeoutPid <- liftSimulation newProcessId - ackPid <- liftSimulation newProcessId - -- set up the timeout - liftEvent $ runProcessUsingId timeoutPid (timeout ackPid) - -- set up the message send/ACK - liftEvent $ runProcessUsingId ackPid (acknowledge timeoutPid) - passivateProcess - liftEvent $ - do code <- readRef reactivatedCode - when (code == 1) $ - modifyRef nTimeOuts $ (+) 1 - writeRef reactivatedCode 0 - node - - timeout ackPid = - do holdProcess toPeriod - liftEvent $ - do writeRef reactivatedCode 1 - reactivateProcess nodePid - cancelProcessWithId ackPid - - acknowledge timeoutPid = - do ackTime <- - liftParameter $ - randomExponential (1 / ackRate) - holdProcess ackTime - liftEvent $ - do writeRef reactivatedCode 2 - reactivateProcess nodePid - cancelProcessWithId timeoutPid - - runProcessInStartTimeUsingId - nodePid node - - runEventInStopTime $ - do x <- readRef nTimeOuts - y <- readRef nMsgs - return $ x / y - -main = - do putStr "The percentage of timeout was " - runSimulation model specs >>= print + +-- It corresponds to model TimeOut described in document +-- Advanced Features of the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/AdvancedSimPy.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Introductory example to illustrate the modeling of "competing +-- events" such as timeouts, especially using the cancelProcess function. A +-- network node sends a message but also sets a timeout period; if the +-- node times out, it assumes the message it had sent was lost, and it +-- will send again. The time to get an acknowledgement for a message is +-- exponentially distributed with mean 1.0, and the timeout period is +-- 0.5. Immediately after receiving an acknowledgement, the node sends +-- out a new message. +-- +-- We find the proportion of messages which timeout. The output should +-- be about 0.61. + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans + +ackRate = 1.0 / 1.0 -- reciprocal of the acknowledge mean time +toPeriod = 0.5 -- timeout period + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 10000.0, + spcDT = 1.0, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: MonadComp m => Simulation m Double +model = + do -- number of messages sent + nMsgs <- newRef 0 + + -- number of timeouts which have occured + nTimeOuts <- newRef 0 + + -- reactivatedCode will 1 if timeout occurred, + -- 2 ACK if received + reactivatedCode <- newRef 0 + + nodePid <- newProcessId + + let node = + do liftEvent $ modifyRef nMsgs $ (+) 1 + -- create process IDs + timeoutPid <- liftSimulation newProcessId + ackPid <- liftSimulation newProcessId + -- set up the timeout + liftEvent $ runProcessUsingId timeoutPid (timeout ackPid) + -- set up the message send/ACK + liftEvent $ runProcessUsingId ackPid (acknowledge timeoutPid) + passivateProcess + liftEvent $ + do code <- readRef reactivatedCode + when (code == 1) $ + modifyRef nTimeOuts $ (+) 1 + writeRef reactivatedCode 0 + node + + timeout ackPid = + do holdProcess toPeriod + liftEvent $ + do writeRef reactivatedCode 1 + reactivateProcess nodePid + cancelProcessWithId ackPid + + acknowledge timeoutPid = + do ackTime <- + liftParameter $ + randomExponential (1 / ackRate) + holdProcess ackTime + liftEvent $ + do writeRef reactivatedCode 2 + reactivateProcess nodePid + cancelProcessWithId timeoutPid + + runProcessInStartTimeUsingId + nodePid node + + runEventInStopTime $ + do x <- readRef nTimeOuts + y <- readRef nMsgs + return $ x / y + +main = + do putStr "The percentage of timeout was " + runSimulation model specs >>= print diff --git a/examples/TimeOutInt.hs b/examples/TimeOutInt.hs --- a/examples/TimeOutInt.hs +++ b/examples/TimeOutInt.hs @@ -1,75 +1,75 @@ - --- It corresponds to model TimeOutInt described in document --- Advanced Features of the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/AdvancedSimPy.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Same as TimeOut.hs but using interrupts. A network node sends a message --- but also sets a timeout period; if the node times out, it assumes the --- message it had sent was lost, and it will send again. The time to get --- an acknowledgement for a message is exponentially distributed with --- mean 1.0, and the timeout period is 0.5. Immediately after receiving --- an acknowledgement, the node sends out a new message. --- --- We find the proportion of messages which timeout. The output should --- be about 0.61. - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Trans - -ackRate = 1.0 / 1.0 -- reciprocal of the acknowledge mean time -toPeriod = 0.5 -- timeout period - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 10000.0, - spcDT = 1.0, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: MonadComp m => Simulation m Double -model = - do -- number of messages sent - nMsgs <- newRef 0 - - -- number of timeouts which have occured - nTimeOuts <- newRef 0 - - nodePid <- newProcessId - - let node = - do liftEvent $ modifyRef nMsgs $ (+) 1 - -- create the process ID - timeoutPid <- liftSimulation newProcessId - -- set up the timeout - liftEvent $ runProcessUsingId timeoutPid timeout - -- wait for ACK, but could be timeout - ackTime <- - liftParameter $ - randomExponential (1 / ackRate) - holdProcess ackTime - liftEvent $ - do interrupted <- processInterrupted nodePid - if interrupted - then modifyRef nTimeOuts $ (+) 1 - else cancelProcessWithId timeoutPid - node - - timeout = - do holdProcess toPeriod - liftEvent $ interruptProcess nodePid - - runProcessInStartTimeUsingId - nodePid node - - runEventInStopTime $ - do x <- readRef nTimeOuts - y <- readRef nMsgs - return $ x / y - -main = - do putStr "The percentage of timeout was " - runSimulation model specs >>= print + +-- It corresponds to model TimeOutInt described in document +-- Advanced Features of the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/AdvancedSimPy.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Same as TimeOut.hs but using interrupts. A network node sends a message +-- but also sets a timeout period; if the node times out, it assumes the +-- message it had sent was lost, and it will send again. The time to get +-- an acknowledgement for a message is exponentially distributed with +-- mean 1.0, and the timeout period is 0.5. Immediately after receiving +-- an acknowledgement, the node sends out a new message. +-- +-- We find the proportion of messages which timeout. The output should +-- be about 0.61. + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans + +ackRate = 1.0 / 1.0 -- reciprocal of the acknowledge mean time +toPeriod = 0.5 -- timeout period + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 10000.0, + spcDT = 1.0, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: MonadComp m => Simulation m Double +model = + do -- number of messages sent + nMsgs <- newRef 0 + + -- number of timeouts which have occured + nTimeOuts <- newRef 0 + + nodePid <- newProcessId + + let node = + do liftEvent $ modifyRef nMsgs $ (+) 1 + -- create the process ID + timeoutPid <- liftSimulation newProcessId + -- set up the timeout + liftEvent $ runProcessUsingId timeoutPid timeout + -- wait for ACK, but could be timeout + ackTime <- + liftParameter $ + randomExponential (1 / ackRate) + holdProcess ackTime + liftEvent $ + do interrupted <- processInterrupted nodePid + if interrupted + then modifyRef nTimeOuts $ (+) 1 + else cancelProcessWithId timeoutPid + node + + timeout = + do holdProcess toPeriod + liftEvent $ interruptProcess nodePid + + runProcessInStartTimeUsingId + nodePid node + + runEventInStopTime $ + do x <- readRef nTimeOuts + y <- readRef nMsgs + return $ x / y + +main = + do putStr "The percentage of timeout was " + runSimulation model specs >>= print diff --git a/examples/TimeOutWait.hs b/examples/TimeOutWait.hs --- a/examples/TimeOutWait.hs +++ b/examples/TimeOutWait.hs @@ -1,69 +1,69 @@ - --- It corresponds to model TimeOut described in document --- Advanced Features of the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/AdvancedSimPy.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Introductory example to illustrate the modeling of "competing --- events" such as timeouts, especially using the timeoutProcess --- function. A network node starts a process within the specified --- timeout and receives a signal that notifies whether the process --- has finished successfully within the timeout; if the node --- times out, it assumes the message it had sent was lost, and it --- will send again. The time to get an acknowledgement for a message is --- exponentially distributed with mean 1.0, and the timeout period is --- 0.5. Immediately after receiving an acknowledgement, the node sends --- out a new message. --- --- We find the proportion of messages which timeout. The output should --- be about 0.61. - -import Control.Monad -import Control.Monad.Trans - -import Data.Maybe - -import Simulation.Aivika.Trans - -ackRate = 1.0 / 1.0 -- reciprocal of the acknowledge mean time -toPeriod = 0.5 -- timeout period - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 10000.0, - spcDT = 1.0, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: MonadComp m => Simulation m Double -model = - do -- number of messages sent - nMsgs <- newRef 0 - - -- number of timeouts which have occured - nTimeOuts <- newRef 0 - - let node = - do liftEvent $ modifyRef nMsgs $ (+) 1 - result <- - timeoutProcess toPeriod $ - do ackTime <- - liftParameter $ - randomExponential (1 / ackRate) - holdProcess ackTime - liftEvent $ - when (isNothing result) $ - modifyRef nTimeOuts $ (+) 1 - node - - runProcessInStartTime node - - runEventInStopTime $ - do x <- readRef nTimeOuts - y <- readRef nMsgs - return $ x / y - -main = - do putStr "The percentage of timeout was " - runSimulation model specs >>= print + +-- It corresponds to model TimeOut described in document +-- Advanced Features of the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/AdvancedSimPy.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Introductory example to illustrate the modeling of "competing +-- events" such as timeouts, especially using the timeoutProcess +-- function. A network node starts a process within the specified +-- timeout and receives a signal that notifies whether the process +-- has finished successfully within the timeout; if the node +-- times out, it assumes the message it had sent was lost, and it +-- will send again. The time to get an acknowledgement for a message is +-- exponentially distributed with mean 1.0, and the timeout period is +-- 0.5. Immediately after receiving an acknowledgement, the node sends +-- out a new message. +-- +-- We find the proportion of messages which timeout. The output should +-- be about 0.61. + +import Control.Monad +import Control.Monad.Trans + +import Data.Maybe + +import Simulation.Aivika.Trans + +ackRate = 1.0 / 1.0 -- reciprocal of the acknowledge mean time +toPeriod = 0.5 -- timeout period + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 10000.0, + spcDT = 1.0, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: MonadComp m => Simulation m Double +model = + do -- number of messages sent + nMsgs <- newRef 0 + + -- number of timeouts which have occured + nTimeOuts <- newRef 0 + + let node = + do liftEvent $ modifyRef nMsgs $ (+) 1 + result <- + timeoutProcess toPeriod $ + do ackTime <- + liftParameter $ + randomExponential (1 / ackRate) + holdProcess ackTime + liftEvent $ + when (isNothing result) $ + modifyRef nTimeOuts $ (+) 1 + node + + runProcessInStartTime node + + runEventInStopTime $ + do x <- readRef nTimeOuts + y <- readRef nMsgs + return $ x / y + +main = + do putStr "The percentage of timeout was " + runSimulation model specs >>= print diff --git a/examples/WorkStationsInSeries.hs b/examples/WorkStationsInSeries.hs --- a/examples/WorkStationsInSeries.hs +++ b/examples/WorkStationsInSeries.hs @@ -1,136 +1,136 @@ - --- Example: Work Stations in Series --- --- This is a model of two work stations connected in a series and separated by finite queues. --- --- It is described in different sources [1, 2]. So, this is chapter 7 of [2] and section 5.14 of [1]. --- --- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. --- --- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 - -import Prelude hiding (id, (.)) - -import Control.Monad -import Control.Monad.Trans -import Control.Arrow -import Control.Category (id, (.)) - -import Simulation.Aivika.Trans -import Simulation.Aivika.Trans.Queue - --- | The simulation specs. -specs = Specs { spcStartTime = 0.0, - spcStopTime = 300.0, - spcDT = 0.1, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - --- the mean delay of the input arrivals distributed exponentially -meanOrderDelay = 0.4 - --- the capacity of the queue before the first work places -queueMaxCount1 = 4 - --- the capacity of the queue before the second work places -queueMaxCount2 = 2 - --- the mean processing time distributed exponentially in --- the first work stations -meanProcessingTime1 = 0.25 - --- the mean processing time distributed exponentially in --- the second work stations -meanProcessingTime2 = 0.5 - --- the number of the first work stations --- (in parallel but the commented code allocates them sequentially) -workStationCount1 = 1 - --- the number of the second work stations --- (in parallel but the commented code allocates them sequentially) -workStationCount2 = 1 - --- create a work station (server) with the exponential processing time -newWorkStationExponential :: MonadComp m => Double -> Simulation m (Server m () a a) -newWorkStationExponential meanTime = - newServer $ \a -> - do holdProcess =<< - (liftParameter $ - randomExponential meanTime) - return a - -model :: MonadComp m => Simulation m (Results m) -model = do - -- it will gather the statistics of the processing time - arrivalTimer <- newArrivalTimer - -- define a stream of input events - let inputStream = randomExponentialStream meanOrderDelay - -- create a queue before the first work stations - queue1 <- - runEventInStartTime $ - newFCFSQueue queueMaxCount1 - -- create a queue before the second work stations - queue2 <- - runEventInStartTime $ - newFCFSQueue queueMaxCount2 - -- create the first work stations (servers) - workStation1s <- forM [1 .. workStationCount1] $ \_ -> - newWorkStationExponential meanProcessingTime1 - -- create the second work stations (servers) - workStation2s <- forM [1 .. workStationCount2] $ \_ -> - newWorkStationExponential meanProcessingTime2 - -- processor for the queue before the first work station - let queueProcessor1 = - queueProcessor - (\a -> liftEvent $ enqueueOrLost_ queue1 a) - (dequeue queue1) - -- processor for the queue before the second work station - let queueProcessor2 = - queueProcessor - (enqueue queue2) - (dequeue queue2) - -- the entire processor from input to output - let entireProcessor = - queueProcessor1 >>> - processorParallel (map serverProcessor workStation1s) >>> - -- processorSeq (map serverProcessor workStation1s) >>> - queueProcessor2 >>> - processorParallel (map serverProcessor workStation2s) >>> - -- processorSeq (map serverProcessor workStation2s) >>> - arrivalTimerProcessor arrivalTimer - -- start simulating the model - runProcessInStartTime $ - sinkStream $ runProcessor entireProcessor inputStream - -- return the simulation results - return $ - results - [resultSource - "queue1" "Queue no. 1" - queue1, - -- - resultSource - "workStation1s" "Work Stations of line no. 1" - workStation1s, - -- - resultSource - "queue2" "Queue no. 2" - queue2, - -- - resultSource - "workStation2s" "Work Stations of line no. 2" - workStation2s, - -- - resultSource - "arrivalTimer" "The arrival timer" - arrivalTimer] - -modelSummary :: MonadComp m => Simulation m (Results m) -modelSummary = - fmap resultSummary model - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - -- model specs - modelSummary specs + +-- Example: Work Stations in Series +-- +-- This is a model of two work stations connected in a series and separated by finite queues. +-- +-- It is described in different sources [1, 2]. So, this is chapter 7 of [2] and section 5.14 of [1]. +-- +-- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. +-- +-- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 + +import Prelude hiding (id, (.)) + +import Control.Monad +import Control.Monad.Trans +import Control.Arrow +import Control.Category (id, (.)) + +import Simulation.Aivika.Trans +import Simulation.Aivika.Trans.Queue + +-- | The simulation specs. +specs = Specs { spcStartTime = 0.0, + spcStopTime = 300.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +-- the mean delay of the input arrivals distributed exponentially +meanOrderDelay = 0.4 + +-- the capacity of the queue before the first work places +queueMaxCount1 = 4 + +-- the capacity of the queue before the second work places +queueMaxCount2 = 2 + +-- the mean processing time distributed exponentially in +-- the first work stations +meanProcessingTime1 = 0.25 + +-- the mean processing time distributed exponentially in +-- the second work stations +meanProcessingTime2 = 0.5 + +-- the number of the first work stations +-- (in parallel but the commented code allocates them sequentially) +workStationCount1 = 1 + +-- the number of the second work stations +-- (in parallel but the commented code allocates them sequentially) +workStationCount2 = 1 + +-- create a work station (server) with the exponential processing time +newWorkStationExponential :: MonadComp m => Double -> Simulation m (Server m () a a) +newWorkStationExponential meanTime = + newServer $ \a -> + do holdProcess =<< + (liftParameter $ + randomExponential meanTime) + return a + +model :: MonadComp m => Simulation m (Results m) +model = do + -- it will gather the statistics of the processing time + arrivalTimer <- newArrivalTimer + -- define a stream of input events + let inputStream = randomExponentialStream meanOrderDelay + -- create a queue before the first work stations + queue1 <- + runEventInStartTime $ + newFCFSQueue queueMaxCount1 + -- create a queue before the second work stations + queue2 <- + runEventInStartTime $ + newFCFSQueue queueMaxCount2 + -- create the first work stations (servers) + workStation1s <- forM [1 .. workStationCount1] $ \_ -> + newWorkStationExponential meanProcessingTime1 + -- create the second work stations (servers) + workStation2s <- forM [1 .. workStationCount2] $ \_ -> + newWorkStationExponential meanProcessingTime2 + -- processor for the queue before the first work station + let queueProcessor1 = + queueProcessor + (\a -> liftEvent $ enqueueOrLost_ queue1 a) + (dequeue queue1) + -- processor for the queue before the second work station + let queueProcessor2 = + queueProcessor + (enqueue queue2) + (dequeue queue2) + -- the entire processor from input to output + let entireProcessor = + queueProcessor1 >>> + processorParallel (map serverProcessor workStation1s) >>> + -- processorSeq (map serverProcessor workStation1s) >>> + queueProcessor2 >>> + processorParallel (map serverProcessor workStation2s) >>> + -- processorSeq (map serverProcessor workStation2s) >>> + arrivalTimerProcessor arrivalTimer + -- start simulating the model + runProcessInStartTime $ + sinkStream $ runProcessor entireProcessor inputStream + -- return the simulation results + return $ + results + [resultSource + "queue1" "Queue no. 1" + queue1, + -- + resultSource + "workStation1s" "Work Stations of line no. 1" + workStation1s, + -- + resultSource + "queue2" "Queue no. 2" + queue2, + -- + resultSource + "workStation2s" "Work Stations of line no. 2" + workStation2s, + -- + resultSource + "arrivalTimer" "The arrival timer" + arrivalTimer] + +modelSummary :: MonadComp m => Simulation m (Results m) +modelSummary = + fmap resultSummary model + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + -- model specs + modelSummary specs