aivika-transformers 2.0 → 2.1

raw patch · 84 files changed

+17878/−17188 lines, 84 filessetup-changedPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

+ Simulation.Aivika.Trans.Activity: activityChanged_ :: MonadComp m => Activity m s a b -> Signal m ()

+ Simulation.Aivika.Trans.Activity: activityIdleFactor :: MonadComp m => Activity m s a b -> Event m Double

+ Simulation.Aivika.Trans.Activity: activityIdleFactorChanged :: MonadComp m => Activity m s a b -> Signal m Double

+ Simulation.Aivika.Trans.Activity: activityIdleFactorChanged_ :: MonadComp m => Activity m s a b -> Signal m ()

+ Simulation.Aivika.Trans.Activity: activityIdleTime :: MonadComp m => Activity m s a b -> Event m (SamplingStats Double)

+ Simulation.Aivika.Trans.Activity: activityIdleTimeChanged :: MonadComp m => Activity m s a b -> Signal m (SamplingStats Double)

+ Simulation.Aivika.Trans.Activity: activityIdleTimeChanged_ :: MonadComp m => Activity m s a b -> Signal m ()

+ Simulation.Aivika.Trans.Activity: activityInitState :: Activity m s a b -> s

+ Simulation.Aivika.Trans.Activity: activityNet :: MonadComp m => Activity m s a b -> Net m a b

+ Simulation.Aivika.Trans.Activity: activityState :: MonadComp m => Activity m s a b -> Event m s

+ Simulation.Aivika.Trans.Activity: activityStateChanged :: MonadComp m => Activity m s a b -> Signal m s

+ Simulation.Aivika.Trans.Activity: activityStateChanged_ :: MonadComp m => Activity m s a b -> Signal m ()

+ Simulation.Aivika.Trans.Activity: activitySummary :: MonadComp m => Activity m s a b -> Int -> Event m ShowS

+ Simulation.Aivika.Trans.Activity: activityTotalIdleTime :: MonadComp m => Activity m s a b -> Event m Double

+ Simulation.Aivika.Trans.Activity: activityTotalIdleTimeChanged :: MonadComp m => Activity m s a b -> Signal m Double

+ Simulation.Aivika.Trans.Activity: activityTotalIdleTimeChanged_ :: MonadComp m => Activity m s a b -> Signal m ()

+ Simulation.Aivika.Trans.Activity: activityTotalUtilisationTime :: MonadComp m => Activity m s a b -> Event m Double

+ Simulation.Aivika.Trans.Activity: activityTotalUtilisationTimeChanged :: MonadComp m => Activity m s a b -> Signal m Double

+ Simulation.Aivika.Trans.Activity: activityTotalUtilisationTimeChanged_ :: MonadComp m => Activity m s a b -> Signal m ()

+ Simulation.Aivika.Trans.Activity: activityUtilisationFactor :: MonadComp m => Activity m s a b -> Event m Double

+ Simulation.Aivika.Trans.Activity: activityUtilisationFactorChanged :: MonadComp m => Activity m s a b -> Signal m Double

+ Simulation.Aivika.Trans.Activity: activityUtilisationFactorChanged_ :: MonadComp m => Activity m s a b -> Signal m ()

+ Simulation.Aivika.Trans.Activity: activityUtilisationTime :: MonadComp m => Activity m s a b -> Event m (SamplingStats Double)

+ Simulation.Aivika.Trans.Activity: activityUtilisationTimeChanged :: MonadComp m => Activity m s a b -> Signal m (SamplingStats Double)

+ Simulation.Aivika.Trans.Activity: activityUtilisationTimeChanged_ :: MonadComp m => Activity m s a b -> Signal m ()

+ Simulation.Aivika.Trans.Activity: activityUtilised :: Activity m s a b -> Signal m (a, b)

+ Simulation.Aivika.Trans.Activity: activityUtilising :: Activity m s a b -> Signal m a

+ Simulation.Aivika.Trans.Activity: data Activity m s a b

+ Simulation.Aivika.Trans.Activity: newActivity :: MonadComp m => (a -> Process m b) -> Simulation m (Activity m () a b)

+ Simulation.Aivika.Trans.Activity: newStateActivity :: MonadComp m => (s -> a -> Process m (s, b)) -> s -> Simulation m (Activity m s a b)

+ Simulation.Aivika.Trans.Circuit: integCircuitEither :: MonadComp m => Double -> Circuit m (Either Double Double) Double

+ Simulation.Aivika.Trans.Circuit: iterateCircuitInIntegTimes :: MonadComp m => Circuit m a a -> a -> Event m (Task m a)

+ Simulation.Aivika.Trans.Circuit: iterateCircuitInIntegTimes_ :: MonadComp m => Circuit m a a -> a -> Event m ()

+ Simulation.Aivika.Trans.Circuit: iterateCircuitInTimes :: MonadComp m => [Double] -> Circuit m a a -> a -> Event m (Task m a)

+ Simulation.Aivika.Trans.Circuit: iterateCircuitInTimes_ :: MonadComp m => [Double] -> Circuit m a a -> a -> Event m ()

+ Simulation.Aivika.Trans.Circuit: sumCircuitEither :: (MonadComp m, Num a) => a -> Circuit m (Either a a) a

+ Simulation.Aivika.Trans.Net: iterateNet :: MonadComp m => Net m a a -> a -> Process m ()

+ Simulation.Aivika.Trans.Process: spawnProcessUsingIdWith :: MonadComp m => ContCancellation -> ProcessId m -> Process m () -> Process m ()

+ Simulation.Aivika.Trans.Process: spawnProcessWith :: MonadComp m => ContCancellation -> Process m () -> Process m ()

+ Simulation.Aivika.Trans.Results: instance (MonadComp m, Show s, ResultItemable (ResultValue s)) => ResultProvider (Activity m s a b) m

+ Simulation.Aivika.Trans.Results.Locale: ActivityId :: ResultId

+ Simulation.Aivika.Trans.Results.Locale: ActivityIdleFactorId :: ResultId

+ Simulation.Aivika.Trans.Results.Locale: ActivityIdleTimeId :: ResultId

+ Simulation.Aivika.Trans.Results.Locale: ActivityInitStateId :: ResultId

+ Simulation.Aivika.Trans.Results.Locale: ActivityStateId :: ResultId

+ Simulation.Aivika.Trans.Results.Locale: ActivityTotalIdleTimeId :: ResultId

+ Simulation.Aivika.Trans.Results.Locale: ActivityTotalUtilisationTimeId :: ResultId

+ Simulation.Aivika.Trans.Results.Locale: ActivityUtilisationFactorId :: ResultId

+ Simulation.Aivika.Trans.Results.Locale: ActivityUtilisationTimeId :: ResultId

+ Simulation.Aivika.Trans.SystemDynamics: diffsumEither :: (MonadComp m, MonadFix m, Unboxed m a, Num a) => Dynamics m (Either a a) -> Dynamics m a -> Simulation m (Dynamics m a)

+ Simulation.Aivika.Trans.SystemDynamics: integEither :: (MonadComp m, MonadFix m) => Dynamics m (Either Double Double) -> Dynamics m Double -> Simulation m (Dynamics m Double)

+ Simulation.Aivika.Trans.Task: spawnTaskUsingIdWith :: MonadComp m => ContCancellation -> ProcessId m -> Process m a -> Process m (Task m a)

+ Simulation.Aivika.Trans.Task: spawnTaskWith :: MonadComp m => ContCancellation -> Process m a -> Process m (Task m a)

+ Simulation.Aivika.Trans.Transform: integTransformEither :: (MonadComp m, MonadFix m) => Dynamics m Double -> Transform m (Either Double Double) Double

+ Simulation.Aivika.Trans.Transform: sumTransformEither :: (MonadComp m, MonadFix m, Num a, Unboxed m a) => Dynamics m a -> Transform m (Either a a) a

- Simulation.Aivika.Trans.Process: spawnProcess :: MonadComp m => ContCancellation -> Process m () -> Process m ()

+ Simulation.Aivika.Trans.Process: spawnProcess :: MonadComp m => Process m () -> Process m ()

- Simulation.Aivika.Trans.Process: spawnProcessUsingId :: MonadComp m => ContCancellation -> ProcessId m -> Process m () -> Process m ()

+ Simulation.Aivika.Trans.Process: spawnProcessUsingId :: MonadComp m => ProcessId m -> Process m () -> Process m ()

- Simulation.Aivika.Trans.Task: spawnTask :: MonadComp m => ContCancellation -> Process m a -> Process m (Task m a)

+ Simulation.Aivika.Trans.Task: spawnTask :: MonadComp m => Process m a -> Process m (Task m a)

- Simulation.Aivika.Trans.Task: spawnTaskUsingId :: MonadComp m => ContCancellation -> ProcessId m -> Process m a -> Process m (Task m a)

+ Simulation.Aivika.Trans.Task: spawnTaskUsingId :: MonadComp m => ProcessId m -> Process m a -> Process m (Task m a)

Files

LICENSE +30/−30
Setup.lhs +3/−3
Simulation/Aivika/Trans.hs +93/−91
Simulation/Aivika/Trans/Activity.hs +376/−0
Simulation/Aivika/Trans/Agent.hs +265/−265
Simulation/Aivika/Trans/Arrival.hs +84/−84
Simulation/Aivika/Trans/Circuit.hs +501/−385
Simulation/Aivika/Trans/Comp.hs +52/−52
Simulation/Aivika/Trans/Comp/IO.hs +128/−128
Simulation/Aivika/Trans/Comp/Template.hs +130/−130
Simulation/Aivika/Trans/Cont.hs +18/−18
Simulation/Aivika/Trans/DoubleLinkedList.hs +172/−172
Simulation/Aivika/Trans/Dynamics.hs +32/−32
Simulation/Aivika/Trans/Dynamics/Extra.hs +114/−114
Simulation/Aivika/Trans/Dynamics/Memo.hs +158/−158
Simulation/Aivika/Trans/Dynamics/Memo/Unboxed.hs +105/−105
Simulation/Aivika/Trans/Dynamics/Random.hs +140/−140
Simulation/Aivika/Trans/Event.hs +42/−42
Simulation/Aivika/Trans/Exception.hs +46/−46
Simulation/Aivika/Trans/Generator.hs +269/−269
Simulation/Aivika/Trans/Internal/Cont.hs +687/−687
Simulation/Aivika/Trans/Internal/Dynamics.hs +270/−270
Simulation/Aivika/Trans/Internal/Event.hs +277/−277
Simulation/Aivika/Trans/Internal/Parameter.hs +341/−341
Simulation/Aivika/Trans/Internal/Process.hs +653/−641
Simulation/Aivika/Trans/Internal/Signal.hs +396/−396
Simulation/Aivika/Trans/Internal/Simulation.hs +167/−167
Simulation/Aivika/Trans/Internal/Specs.hs +295/−307
Simulation/Aivika/Trans/Net.hs +252/−245
Simulation/Aivika/Trans/Parameter.hs +40/−40
Simulation/Aivika/Trans/Parameter/Random.hs +142/−142
Simulation/Aivika/Trans/PriorityQueue.hs +186/−186
Simulation/Aivika/Trans/Process.hs +84/−82
Simulation/Aivika/Trans/Processor.hs +474/−474
Simulation/Aivika/Trans/Processor/RoundRobbin.hs +59/−59
Simulation/Aivika/Trans/ProtoArray.hs +82/−82
Simulation/Aivika/Trans/ProtoArray/Unboxed.hs +98/−98
Simulation/Aivika/Trans/ProtoRef.hs +61/−61
Simulation/Aivika/Trans/Queue.hs +1122/−1122
Simulation/Aivika/Trans/Queue/Infinite.hs +648/−649
Simulation/Aivika/Trans/QueueStrategy.hs +202/−202
Simulation/Aivika/Trans/Ref.hs +76/−76
Simulation/Aivika/Trans/Ref/Plain.hs +60/−60
Simulation/Aivika/Trans/Resource.hs +347/−347
Simulation/Aivika/Trans/Results.hs +1939/−1890
Simulation/Aivika/Trans/Results/IO.hs +485/−485
Simulation/Aivika/Trans/Results/Locale.hs +377/−340
Simulation/Aivika/Trans/Server.hs +513/−516
Simulation/Aivika/Trans/Session.hs +56/−56
Simulation/Aivika/Trans/Signal.hs +53/−53
Simulation/Aivika/Trans/Simulation.hs +26/−26
Simulation/Aivika/Trans/Specs.hs +25/−25
Simulation/Aivika/Trans/Statistics.hs +32/−32
Simulation/Aivika/Trans/Statistics/Accumulator.hs +45/−45
Simulation/Aivika/Trans/Stream.hs +550/−550
Simulation/Aivika/Trans/Stream/Random.hs +162/−162
Simulation/Aivika/Trans/SystemDynamics.hs +820/−747
Simulation/Aivika/Trans/Table.hs +16/−16
Simulation/Aivika/Trans/Task.hs +184/−173
Simulation/Aivika/Trans/Transform.hs +150/−130
Simulation/Aivika/Trans/Transform/Extra.hs +58/−58
Simulation/Aivika/Trans/Transform/Memo.hs +46/−46
Simulation/Aivika/Trans/Transform/Memo/Unboxed.hs +42/−42
Simulation/Aivika/Trans/Unboxed.hs +45/−45
Simulation/Aivika/Trans/Var.hs +190/−190
Simulation/Aivika/Trans/Var/Unboxed.hs +190/−190
Simulation/Aivika/Trans/Vector.hs +199/−199
Simulation/Aivika/Trans/Vector/Unboxed.hs +199/−199
aivika-transformers.cabal +142/−141
examples/BassDiffusion.hs +104/−104
examples/ChemicalReaction.hs +30/−30
examples/ChemicalReactionCircuit.hs +44/−44
examples/FishBank.hs +62/−62
examples/Furnace.hs +322/−322
examples/InspectionAdjustmentStations.hs +164/−164
examples/MachRep1.hs +66/−66
examples/MachRep1EventDriven.hs +79/−79
examples/MachRep1TimeDriven.hs +117/−117
examples/MachRep2.hs +103/−103
examples/MachRep3.hs +93/−93
examples/TimeOut.hs +93/−93
examples/TimeOutInt.hs +75/−75
examples/TimeOutWait.hs +69/−69
examples/WorkStationsInSeries.hs +136/−136

LICENSE view

@@ -1,30 +1,30 @@-Copyright (c) 2009, 2010, 2011, 2012, 2013, 2014 David Sorokin <david.sorokin@gmail.com>
-
-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 <david.sorokin@gmail.com>++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.

Setup.lhs view

@@ -1,3 +1,3 @@-#!/usr/bin/env runhaskell
-> import Distribution.Simple
-> main = defaultMain
+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

Simulation/Aivika/Trans.hs view

@@ -1,91 +1,93 @@-
--- |
--- Module     : Simulation.Aivika.Trans
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

+ Simulation/Aivika/Trans/Activity.hs view

@@ -0,0 +1,376 @@++-- |+-- Module     : Simulation.Aivika.Trans.Activity+-- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- It 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)

Simulation/Aivika/Trans/Agent.hs view

@@ -1,265 +1,265 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Agent
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Arrival.hs view

@@ -1,84 +1,84 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Arrival
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines the 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines the 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)

Simulation/Aivika/Trans/Circuit.hs view

@@ -1,385 +1,501 @@-
-{-# LANGUAGE RecursiveDo, Arrows #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Circuit
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- It 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 <http://en.wikibooks.org/wiki/Haskell/Arrow_tutorial Arrow Tutorial>.
---
-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.
-(<?<) :: MonadComp m
-         => Circuit m b c
-         -- ^ process the event if it presents
-         -> Circuit m a (Maybe b)
-         -- ^ whether there is an event
-         -> Circuit m a (Maybe c)
-         -- ^ the resulting circuit that processes only the represented events
-(<?<) = flip (>?>)
-
--- | Filter the circuit, calculating only those parts of the circuit that satisfy
--- the specified predicate.
-filterCircuit :: MonadComp m => (a -> Bool) -> Circuit m a b -> Circuit m a (Maybe b)
-filterCircuit 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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 <http://en.wikibooks.org/wiki/Haskell/Arrow_tutorial Arrow Tutorial>.+--+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.+(<?<) :: MonadComp m+         => Circuit m b c+         -- ^ process the event if it presents+         -> Circuit m a (Maybe b)+         -- ^ whether there is an event+         -> Circuit m a (Maybe c)+         -- ^ the resulting circuit that processes only the represented events+(<?<) = flip (>?>)++-- | Filter the circuit, calculating only those parts of the circuit that satisfy+-- the specified predicate.+filterCircuit :: MonadComp m => (a -> Bool) -> Circuit m a b -> Circuit m a (Maybe b)+filterCircuit 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

Simulation/Aivika/Trans/Comp.hs view

@@ -1,52 +1,52 @@-
-{-# LANGUAGE FlexibleContexts #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Comp
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- It defines a 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Comp/IO.hs view

@@ -1,128 +1,128 @@-
-{-# LANGUAGE TypeFamilies #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Comp.IO
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module defines the event queue within monad 'IO'.
---
-module Simulation.Aivika.Trans.Comp.IO() where
-
-import Control.Monad
-
-import qualified Simulation.Aivika.Trans.PriorityQueue as PQ
-
-import Simulation.Aivika.Trans.Session
-import Simulation.Aivika.Trans.ProtoRef
-import Simulation.Aivika.Trans.Comp
-import Simulation.Aivika.Trans.Internal.Specs
-
-instance EventQueueing IO where
-
-  data EventQueue IO =
-    EventQueue { queuePQ :: PQ.PriorityQueue IO (Point IO -> IO ()),
-                 -- ^ the underlying priority queue
-                 queueBusy :: ProtoRef IO Bool,
-                 -- ^ whether the queue is currently processing events
-                 queueTime :: ProtoRef IO Double
-                 -- ^ the actual time of the event queue
-               }
-  
-  newEventQueue session specs = 
-    do f <- newProtoRef session False
-       t <- newProtoRef session $ spcStartTime specs
-       pq <- PQ.newQueue session
-       return EventQueue { queuePQ   = pq,
-                           queueBusy = f,
-                           queueTime = t }
-
-  enqueueEvent t (Event m) =
-    Event $ \p ->
-    let pq = queuePQ $ runEventQueue $ pointRun p
-    in PQ.enqueue pq t m
-
-  runEventWith processing (Event e) =
-    Dynamics $ \p ->
-    do invokeDynamics p $ processEvents processing
-       e p
-
-  eventQueueCount =
-    Event $ PQ.queueCount . queuePQ . runEventQueue . pointRun
-
-instance MonadComp IO
-
--- | Process the pending events.
-processPendingEventsCore :: Bool -> Dynamics IO ()
-processPendingEventsCore includingCurrentEvents = Dynamics r where
-  r p =
-    do let q = runEventQueue $ pointRun p
-           f = queueBusy q
-       f' <- readProtoRef f
-       unless f' $
-         do writeProtoRef f True
-            call q p
-            writeProtoRef f False
-  call q p =
-    do let pq = queuePQ q
-           r  = pointRun p
-       f <- PQ.queueNull pq
-       unless f $
-         do (t2, c2) <- PQ.queueFront pq
-            let t = queueTime q
-            t' <- readProtoRef t
-            when (t2 < t') $ 
-              error "The time value is too small: processPendingEventsCore"
-            when ((t2 < pointTime p) ||
-                  (includingCurrentEvents && (t2 == pointTime p))) $
-              do writeProtoRef t t2
-                 PQ.dequeue pq
-                 let sc = pointSpecs p
-                     t0 = spcStartTime sc
-                     dt = spcDT sc
-                     n2 = fromIntegral $ floor ((t2 - t0) / dt)
-                 c2 $ p { pointTime = t2,
-                          pointIteration = n2,
-                          pointPhase = -1 }
-                 call q p
-
--- | Process the pending events synchronously, i.e. without past.
-processPendingEvents :: Bool -> Dynamics IO ()
-processPendingEvents includingCurrentEvents = Dynamics r where
-  r p =
-    do let q = runEventQueue $ pointRun p
-           t = queueTime q
-       t' <- readProtoRef t
-       if pointTime p < t'
-         then error $
-              "The current time is less than " ++
-              "the time in the queue: processPendingEvents"
-         else invokeDynamics p m
-  m = processPendingEventsCore includingCurrentEvents
-
--- | A memoized value.
-processEventsIncludingCurrent :: Dynamics IO ()
-processEventsIncludingCurrent = processPendingEvents True
-
--- | A memoized value.
-processEventsIncludingEarlier :: Dynamics IO ()
-processEventsIncludingEarlier = processPendingEvents False
-
--- | A memoized value.
-processEventsIncludingCurrentCore :: Dynamics IO ()
-processEventsIncludingCurrentCore = processPendingEventsCore True
-
--- | A memoized value.
-processEventsIncludingEarlierCore :: Dynamics IO ()
-processEventsIncludingEarlierCore = processPendingEventsCore True
-
--- | Process the events.
-processEvents :: EventProcessing -> Dynamics IO ()
-processEvents CurrentEvents = processEventsIncludingCurrent
-processEvents EarlierEvents = processEventsIncludingEarlier
-processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore
-processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore
++{-# LANGUAGE TypeFamilies #-}++-- |+-- Module     : Simulation.Aivika.Trans.Comp.IO+-- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- The module defines the event queue within monad 'IO'.+--+module Simulation.Aivika.Trans.Comp.IO() where++import Control.Monad++import qualified Simulation.Aivika.Trans.PriorityQueue as PQ++import Simulation.Aivika.Trans.Session+import Simulation.Aivika.Trans.ProtoRef+import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Internal.Specs++instance EventQueueing IO where++  data EventQueue IO =+    EventQueue { queuePQ :: PQ.PriorityQueue IO (Point IO -> IO ()),+                 -- ^ the underlying priority queue+                 queueBusy :: ProtoRef IO Bool,+                 -- ^ whether the queue is currently processing events+                 queueTime :: ProtoRef IO Double+                 -- ^ the actual time of the event queue+               }+  +  newEventQueue session specs = +    do f <- newProtoRef session False+       t <- newProtoRef session $ spcStartTime specs+       pq <- PQ.newQueue session+       return EventQueue { queuePQ   = pq,+                           queueBusy = f,+                           queueTime = t }++  enqueueEvent t (Event m) =+    Event $ \p ->+    let pq = queuePQ $ runEventQueue $ pointRun p+    in PQ.enqueue pq t m++  runEventWith processing (Event e) =+    Dynamics $ \p ->+    do invokeDynamics p $ processEvents processing+       e p++  eventQueueCount =+    Event $ PQ.queueCount . queuePQ . runEventQueue . pointRun++instance MonadComp IO++-- | Process the pending events.+processPendingEventsCore :: Bool -> Dynamics IO ()+processPendingEventsCore includingCurrentEvents = Dynamics r where+  r p =+    do let q = runEventQueue $ pointRun p+           f = queueBusy q+       f' <- readProtoRef f+       unless f' $+         do writeProtoRef f True+            call q p+            writeProtoRef f False+  call q p =+    do let pq = queuePQ q+           r  = pointRun p+       f <- PQ.queueNull pq+       unless f $+         do (t2, c2) <- PQ.queueFront pq+            let t = queueTime q+            t' <- readProtoRef t+            when (t2 < t') $ +              error "The time value is too small: processPendingEventsCore"+            when ((t2 < pointTime p) ||+                  (includingCurrentEvents && (t2 == pointTime p))) $+              do writeProtoRef t t2+                 PQ.dequeue pq+                 let sc = pointSpecs p+                     t0 = spcStartTime sc+                     dt = spcDT sc+                     n2 = fromIntegral $ floor ((t2 - t0) / dt)+                 c2 $ p { pointTime = t2,+                          pointIteration = n2,+                          pointPhase = -1 }+                 call q p++-- | Process the pending events synchronously, i.e. without past.+processPendingEvents :: Bool -> Dynamics IO ()+processPendingEvents includingCurrentEvents = Dynamics r where+  r p =+    do let q = runEventQueue $ pointRun p+           t = queueTime q+       t' <- readProtoRef t+       if pointTime p < t'+         then error $+              "The current time is less than " +++              "the time in the queue: processPendingEvents"+         else invokeDynamics p m+  m = processPendingEventsCore includingCurrentEvents++-- | A memoized value.+processEventsIncludingCurrent :: Dynamics IO ()+processEventsIncludingCurrent = processPendingEvents True++-- | A memoized value.+processEventsIncludingEarlier :: Dynamics IO ()+processEventsIncludingEarlier = processPendingEvents False++-- | A memoized value.+processEventsIncludingCurrentCore :: Dynamics IO ()+processEventsIncludingCurrentCore = processPendingEventsCore True++-- | A memoized value.+processEventsIncludingEarlierCore :: Dynamics IO ()+processEventsIncludingEarlierCore = processPendingEventsCore True++-- | Process the events.+processEvents :: EventProcessing -> Dynamics IO ()+processEvents CurrentEvents = processEventsIncludingCurrent+processEvents EarlierEvents = processEventsIncludingEarlier+processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore+processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore

Simulation/Aivika/Trans/Comp/Template.hs view

@@ -1,130 +1,130 @@-
-{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Comp.Template
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module defines the event queue.
---
-module Simulation.Aivika.Trans.Comp.Template
-       (TemplateEventQueueing(..)) where
-
-import Control.Monad
-
-import qualified Simulation.Aivika.Trans.PriorityQueue as PQ
-
-import Simulation.Aivika.Trans.Session
-import Simulation.Aivika.Trans.ProtoRef
-import Simulation.Aivika.Trans.Comp
-import Simulation.Aivika.Trans.Internal.Specs
-
--- | A template-based implementation of the 'EventQueueing' class type.
-class ProtoMonadComp m => TemplateEventQueueing m 
-
-instance TemplateEventQueueing m => EventQueueing m where
-
-  data EventQueue m =
-    EventQueue { queuePQ :: PQ.PriorityQueue m (Point m -> m ()),
-                 -- ^ the underlying priority queue
-                 queueBusy :: ProtoRef m Bool,
-                 -- ^ whether the queue is currently processing events
-                 queueTime :: ProtoRef m Double
-                 -- ^ the actual time of the event queue
-               }
-  
-  newEventQueue session specs = 
-    do f <- newProtoRef session False
-       t <- newProtoRef session $ spcStartTime specs
-       pq <- PQ.newQueue session
-       return EventQueue { queuePQ   = pq,
-                           queueBusy = f,
-                           queueTime = t }
-
-  enqueueEvent t (Event m) =
-    Event $ \p ->
-    let pq = queuePQ $ runEventQueue $ pointRun p
-    in PQ.enqueue pq t m
-
-  runEventWith processing (Event e) =
-    Dynamics $ \p ->
-    do invokeDynamics p $ processEvents processing
-       e p
-
-  eventQueueCount =
-    Event $ PQ.queueCount . queuePQ . runEventQueue . pointRun
-
--- | Process the pending events.
-processPendingEventsCore :: ProtoMonadComp m => Bool -> Dynamics m ()
-processPendingEventsCore includingCurrentEvents = Dynamics r where
-  r p =
-    do let q = runEventQueue $ pointRun p
-           f = queueBusy q
-       f' <- readProtoRef f
-       unless f' $
-         do writeProtoRef f True
-            call q p
-            writeProtoRef f False
-  call q p =
-    do let pq = queuePQ q
-           r  = pointRun p
-       f <- PQ.queueNull pq
-       unless f $
-         do (t2, c2) <- PQ.queueFront pq
-            let t = queueTime q
-            t' <- readProtoRef t
-            when (t2 < t') $ 
-              error "The time value is too small: processPendingEventsCore"
-            when ((t2 < pointTime p) ||
-                  (includingCurrentEvents && (t2 == pointTime p))) $
-              do writeProtoRef t t2
-                 PQ.dequeue pq
-                 let sc = pointSpecs p
-                     t0 = spcStartTime sc
-                     dt = spcDT sc
-                     n2 = fromIntegral $ floor ((t2 - t0) / dt)
-                 c2 $ p { pointTime = t2,
-                          pointIteration = n2,
-                          pointPhase = -1 }
-                 call q p
-
--- | Process the pending events synchronously, i.e. without past.
-processPendingEvents :: ProtoMonadComp m => Bool -> Dynamics m ()
-processPendingEvents includingCurrentEvents = Dynamics r where
-  r p =
-    do let q = runEventQueue $ pointRun p
-           t = queueTime q
-       t' <- readProtoRef t
-       if pointTime p < t'
-         then error $
-              "The current time is less than " ++
-              "the time in the queue: processPendingEvents"
-         else invokeDynamics p m
-  m = processPendingEventsCore includingCurrentEvents
-
--- | A memoized value.
-processEventsIncludingCurrent :: ProtoMonadComp m => Dynamics m ()
-processEventsIncludingCurrent = processPendingEvents True
-
--- | A memoized value.
-processEventsIncludingEarlier :: ProtoMonadComp m => Dynamics m ()
-processEventsIncludingEarlier = processPendingEvents False
-
--- | A memoized value.
-processEventsIncludingCurrentCore :: ProtoMonadComp m => Dynamics m ()
-processEventsIncludingCurrentCore = processPendingEventsCore True
-
--- | A memoized value.
-processEventsIncludingEarlierCore :: ProtoMonadComp m => Dynamics m ()
-processEventsIncludingEarlierCore = processPendingEventsCore True
-
--- | Process the events.
-processEvents :: ProtoMonadComp m => EventProcessing -> Dynamics m ()
-processEvents CurrentEvents = processEventsIncludingCurrent
-processEvents EarlierEvents = processEventsIncludingEarlier
-processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore
-processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore
++{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.Trans.Comp.Template+-- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- The module defines the event queue.+--+module Simulation.Aivika.Trans.Comp.Template+       (TemplateEventQueueing(..)) where++import Control.Monad++import qualified Simulation.Aivika.Trans.PriorityQueue as PQ++import Simulation.Aivika.Trans.Session+import Simulation.Aivika.Trans.ProtoRef+import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Internal.Specs++-- | A template-based implementation of the 'EventQueueing' class type.+class ProtoMonadComp m => TemplateEventQueueing m ++instance TemplateEventQueueing m => EventQueueing m where++  data EventQueue m =+    EventQueue { queuePQ :: PQ.PriorityQueue m (Point m -> m ()),+                 -- ^ the underlying priority queue+                 queueBusy :: ProtoRef m Bool,+                 -- ^ whether the queue is currently processing events+                 queueTime :: ProtoRef m Double+                 -- ^ the actual time of the event queue+               }+  +  newEventQueue session specs = +    do f <- newProtoRef session False+       t <- newProtoRef session $ spcStartTime specs+       pq <- PQ.newQueue session+       return EventQueue { queuePQ   = pq,+                           queueBusy = f,+                           queueTime = t }++  enqueueEvent t (Event m) =+    Event $ \p ->+    let pq = queuePQ $ runEventQueue $ pointRun p+    in PQ.enqueue pq t m++  runEventWith processing (Event e) =+    Dynamics $ \p ->+    do invokeDynamics p $ processEvents processing+       e p++  eventQueueCount =+    Event $ PQ.queueCount . queuePQ . runEventQueue . pointRun++-- | Process the pending events.+processPendingEventsCore :: ProtoMonadComp m => Bool -> Dynamics m ()+processPendingEventsCore includingCurrentEvents = Dynamics r where+  r p =+    do let q = runEventQueue $ pointRun p+           f = queueBusy q+       f' <- readProtoRef f+       unless f' $+         do writeProtoRef f True+            call q p+            writeProtoRef f False+  call q p =+    do let pq = queuePQ q+           r  = pointRun p+       f <- PQ.queueNull pq+       unless f $+         do (t2, c2) <- PQ.queueFront pq+            let t = queueTime q+            t' <- readProtoRef t+            when (t2 < t') $ +              error "The time value is too small: processPendingEventsCore"+            when ((t2 < pointTime p) ||+                  (includingCurrentEvents && (t2 == pointTime p))) $+              do writeProtoRef t t2+                 PQ.dequeue pq+                 let sc = pointSpecs p+                     t0 = spcStartTime sc+                     dt = spcDT sc+                     n2 = fromIntegral $ floor ((t2 - t0) / dt)+                 c2 $ p { pointTime = t2,+                          pointIteration = n2,+                          pointPhase = -1 }+                 call q p++-- | Process the pending events synchronously, i.e. without past.+processPendingEvents :: ProtoMonadComp m => Bool -> Dynamics m ()+processPendingEvents includingCurrentEvents = Dynamics r where+  r p =+    do let q = runEventQueue $ pointRun p+           t = queueTime q+       t' <- readProtoRef t+       if pointTime p < t'+         then error $+              "The current time is less than " +++              "the time in the queue: processPendingEvents"+         else invokeDynamics p m+  m = processPendingEventsCore includingCurrentEvents++-- | A memoized value.+processEventsIncludingCurrent :: ProtoMonadComp m => Dynamics m ()+processEventsIncludingCurrent = processPendingEvents True++-- | A memoized value.+processEventsIncludingEarlier :: ProtoMonadComp m => Dynamics m ()+processEventsIncludingEarlier = processPendingEvents False++-- | A memoized value.+processEventsIncludingCurrentCore :: ProtoMonadComp m => Dynamics m ()+processEventsIncludingCurrentCore = processPendingEventsCore True++-- | A memoized value.+processEventsIncludingEarlierCore :: ProtoMonadComp m => Dynamics m ()+processEventsIncludingEarlierCore = processPendingEventsCore True++-- | Process the events.+processEvents :: ProtoMonadComp m => EventProcessing -> Dynamics m ()+processEvents CurrentEvents = processEventsIncludingCurrent+processEvents EarlierEvents = processEventsIncludingEarlier+processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore+processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore

Simulation/Aivika/Trans/Cont.hs view

@@ -1,18 +1,18 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Cont
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The '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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/DoubleLinkedList.hs view

@@ -1,172 +1,172 @@-
--- |
--- Module     : Simulation.Aivika.Trans.DoubleLinkedList
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- An imperative 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Dynamics.hs view

@@ -1,32 +1,32 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Dynamics
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module defines the '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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- The module defines the '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

Simulation/Aivika/Trans/Dynamics/Extra.hs view

@@ -1,114 +1,114 @@-
-{-# LANGUAGE RecursiveDo #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Dynamics.Extra
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Dynamics/Memo.hs view

@@ -1,158 +1,158 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Dynamics.Memo
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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)

Simulation/Aivika/Trans/Dynamics/Memo/Unboxed.hs view

@@ -1,105 +1,105 @@-
-{-# LANGUAGE FlexibleContexts #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Dynamics.Memo.Unboxed
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines the 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

Simulation/Aivika/Trans/Dynamics/Random.hs view

@@ -1,140 +1,140 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Dynamics.Random
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines the 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines the 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'

Simulation/Aivika/Trans/Event.hs view

@@ -1,42 +1,42 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Event
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module defines the 'Event' 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- The module defines the 'Event' 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

Simulation/Aivika/Trans/Exception.hs view

@@ -1,46 +1,46 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Exception
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- It defines a 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Generator.hs view

@@ -1,269 +1,269 @@-
-{-# LANGUAGE TypeFamilies #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Generator
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Internal/Cont.hs view

@@ -1,687 +1,687 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Internal.Cont
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The '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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Internal/Dynamics.hs view

@@ -1,270 +1,270 @@-
-{-# LANGUAGE RecursiveDo #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Internal.Dynamics
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module defines the '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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- The module defines the '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

Simulation/Aivika/Trans/Internal/Event.hs view

@@ -1,277 +1,277 @@-
-{-# LANGUAGE RecursiveDo #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Internal.Event
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module defines the 'Event' 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- The module defines the 'Event' 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

Simulation/Aivika/Trans/Internal/Parameter.hs view

@@ -1,341 +1,341 @@-
-{-# LANGUAGE RecursiveDo, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Internal.Parameter
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module defines the '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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- The module defines the '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

Simulation/Aivika/Trans/Internal/Process.hs view

@@ -1,641 +1,653 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Internal.Process
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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"

Simulation/Aivika/Trans/Internal/Signal.hs view

@@ -1,396 +1,396 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Internal.Signal
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines the signal which we can subscribe handlers to. 
--- These handlers can be disposed. The signal is triggered in the 
--- current time point actuating the corresponded computations from 
--- the handlers. 
---
-
-module Simulation.Aivika.Trans.Internal.Signal
-       (-- * Handling and Triggering Signal
-        Signal(..),
-        handleSignal_,
-        SignalSource,
-        newSignalSource,
-        publishSignal,
-        triggerSignal,
-        -- * Useful Combinators
-        mapSignal,
-        mapSignalM,
-        apSignal,
-        filterSignal,
-        filterSignalM,
-        emptySignal,
-        merge2Signals,
-        merge3Signals,
-        merge4Signals,
-        merge5Signals,
-        -- * Signal Arriving
-        arrivalSignal,
-        -- * Creating Signal in Time Points
-        newSignalInTimes,
-        newSignalInIntegTimes,
-        newSignalInStartTime,
-        newSignalInStopTime,
-        -- * Signal History
-        SignalHistory,
-        signalHistorySignal,
-        newSignalHistory,
-        newSignalHistoryStartingWith,
-        readSignalHistory,
-        -- * Signalable Computations
-        Signalable(..),
-        signalableChanged,
-        emptySignalable,
-        appendSignalable) 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines the signal which we can subscribe handlers to. +-- These handlers can be disposed. The signal is triggered in the +-- current time point actuating the corresponded computations from +-- the handlers. +--++module Simulation.Aivika.Trans.Internal.Signal+       (-- * Handling and Triggering Signal+        Signal(..),+        handleSignal_,+        SignalSource,+        newSignalSource,+        publishSignal,+        triggerSignal,+        -- * Useful Combinators+        mapSignal,+        mapSignalM,+        apSignal,+        filterSignal,+        filterSignalM,+        emptySignal,+        merge2Signals,+        merge3Signals,+        merge4Signals,+        merge5Signals,+        -- * Signal Arriving+        arrivalSignal,+        -- * Creating Signal in Time Points+        newSignalInTimes,+        newSignalInIntegTimes,+        newSignalInStartTime,+        newSignalInStopTime,+        -- * Signal History+        SignalHistory,+        signalHistorySignal,+        newSignalHistory,+        newSignalHistoryStartingWith,+        readSignalHistory,+        -- * Signalable Computations+        Signalable(..),+        signalableChanged,+        emptySignalable,+        appendSignalable) 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) } }

Simulation/Aivika/Trans/Internal/Simulation.hs view

@@ -1,167 +1,167 @@-
-{-# LANGUAGE RecursiveDo, TypeSynonymInstances #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Internal.Simulation
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module defines the '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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- The module defines the '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

Simulation/Aivika/Trans/Internal/Specs.hs view

@@ -1,307 +1,295 @@-
-{-# LANGUAGE TypeFamilies #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Internal.Specs
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- It defines 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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 }

Simulation/Aivika/Trans/Net.hs view

@@ -1,245 +1,252 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Net
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module defines 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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'

Simulation/Aivika/Trans/Parameter.hs view

@@ -1,40 +1,40 @@--- |
--- Module     : Simulation.Aivika.Trans.Parameter
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module defines the '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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- The module defines the '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

Simulation/Aivika/Trans/Parameter/Random.hs view

@@ -1,142 +1,142 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Parameter.Random
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines the 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines the 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)

Simulation/Aivika/Trans/PriorityQueue.hs view

@@ -1,186 +1,186 @@-
--- |
--- Module     : Simulation.Aivika.Trans.PriorityQueue
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- An imperative heap-based priority queue.
---
-module Simulation.Aivika.Trans.PriorityQueue 
-       (PriorityQueue,
-        queueNull, 
-        queueCount,
-        newQueue, 
-        enqueue, 
-        dequeue, 
-        queueFront) where 
-
-import Control.Monad
-
-import Simulation.Aivika.Trans.Session
-import Simulation.Aivika.Trans.ProtoRef
-import Simulation.Aivika.Trans.Comp
-
-import qualified Simulation.Aivika.Trans.ProtoArray as A
-import qualified Simulation.Aivika.Trans.ProtoArray.Unboxed as UA
-
--- | The 'PriorityQueue' type represents an imperative heap-based 
--- priority queue.
-data PriorityQueue m a = 
-  PriorityQueue { pqSession  :: Session m,
-                  pqKeys     :: ProtoRef m (UA.ProtoArray m Double),
-                  pqVals     :: ProtoRef m (A.ProtoArray m a),
-                  pqSize     :: ProtoRef m Int,
-                  pqCapacity :: ProtoRef m Int }
-
-increase :: ProtoMonadComp m => PriorityQueue m a -> m ()
-increase pq = 
-  do let s = pqSession pq
-         keyRef = pqKeys pq
-         valRef = pqVals pq
-         capacityRef = pqCapacity pq
-     keys <- readProtoRef keyRef
-     vals <- readProtoRef valRef
-     len  <- readProtoRef capacityRef
-     let capacity' | len < 64  = 2 * len
-                   | otherwise = (len `div` 2) * 3
-     keys' <- UA.newProtoArray_ s capacity'
-     vals' <- A.newProtoArray_ s capacity'
-     mapM_ (\i -> do { k <- UA.readProtoArray keys i; UA.writeProtoArray keys' i k }) [0 .. len - 1]
-     mapM_ (\i -> do { v <- A.readProtoArray vals i; A.writeProtoArray vals' i v }) [0 .. len - 1]
-     writeProtoRef keyRef keys'
-     writeProtoRef valRef vals'
-     writeProtoRef capacityRef capacity'
-
-siftUp :: ProtoMonadComp m 
-          => UA.ProtoArray m Double
-          -- ^ keys
-          -> A.ProtoArray m a
-          -- ^ values
-          -> Int
-          -- ^ index
-          -> Double
-          -- ^ key
-          -> a
-          -- ^ value
-          -> m ()
-siftUp keys vals i k v =
-  if i == 0 
-  then do UA.writeProtoArray keys i k
-          A.writeProtoArray vals i v
-  else do let n = (i - 1) `div` 2
-          kn <- UA.readProtoArray keys n
-          if k >= kn 
-            then do UA.writeProtoArray keys i k
-                    A.writeProtoArray vals i v
-            else do vn <- A.readProtoArray vals n
-                    UA.writeProtoArray keys i kn
-                    A.writeProtoArray vals i vn
-                    siftUp keys vals n k v
-
-siftDown :: ProtoMonadComp m 
-            => UA.ProtoArray m Double
-            -- ^ keys
-            -> A.ProtoArray m a
-            -- ^ values
-            -> Int
-            -- ^ size
-            -> Int
-            -- ^ index
-            -> Double
-            -- ^ key
-            -> a
-            -- ^ value
-            -> m ()
-siftDown keys vals size i k v =
-  if i >= (size `div` 2)
-  then do UA.writeProtoArray keys i k
-          A.writeProtoArray vals i v
-  else do let n  = 2 * i + 1
-              n' = n + 1
-          kn  <- UA.readProtoArray keys n
-          if n' >= size 
-            then if k <= kn
-                 then do UA.writeProtoArray keys i k
-                         A.writeProtoArray vals i v
-                 else do vn <- A.readProtoArray vals n
-                         UA.writeProtoArray keys i kn
-                         A.writeProtoArray vals i vn
-                         siftDown keys vals size n k v
-            else do kn' <- UA.readProtoArray keys n'
-                    let n''  = if kn > kn' then n' else n
-                        kn'' = min kn' kn
-                    if k <= kn''
-                      then do UA.writeProtoArray keys i k
-                              A.writeProtoArray vals i v
-                      else do vn'' <- A.readProtoArray vals n''
-                              UA.writeProtoArray keys i kn''
-                              A.writeProtoArray vals i vn''
-                              siftDown keys vals size n'' k v
-
--- | Test whether the priority queue is empty.
-queueNull :: ProtoMonadComp m => PriorityQueue m a -> m Bool
-queueNull pq =
-  do size <- readProtoRef (pqSize pq)
-     return $ size == 0
-
--- | Return the number of elements in the priority queue.
-queueCount :: ProtoMonadComp m => PriorityQueue m a -> m Int
-queueCount pq = readProtoRef (pqSize pq)
-
--- | Create a new priority queue.
-newQueue :: ProtoMonadComp m => Session m -> m (PriorityQueue m a)
-newQueue session =
-  do keys        <- UA.newProtoArray_ session 11
-     vals        <- A.newProtoArray_ session 11
-     keyRef      <- newProtoRef session keys
-     valRef      <- newProtoRef session vals
-     sizeRef     <- newProtoRef session 0
-     capacityRef <- newProtoRef session 11
-     return PriorityQueue { pqSession = session,
-                            pqKeys = keyRef, 
-                            pqVals = valRef, 
-                            pqSize = sizeRef,
-                            pqCapacity = capacityRef }
-
--- | Enqueue a new element with the specified priority.
-enqueue :: ProtoMonadComp m => PriorityQueue m a -> Double -> a -> m ()
-enqueue pq k v =
-  do i <- readProtoRef (pqSize pq)
-     n <- readProtoRef (pqCapacity pq)
-     when (i >= n - 1) $ increase pq
-     writeProtoRef (pqSize pq) (i + 1)
-     keys <- readProtoRef (pqKeys pq)
-     vals <- readProtoRef (pqVals pq)
-     siftUp keys vals i k v
-
--- | Dequeue the element with the minimal priority.
-dequeue :: ProtoMonadComp m => PriorityQueue m a -> m ()
-dequeue pq =
-  do size <- readProtoRef (pqSize pq)
-     when (size == 0) $ error "Empty priority queue: dequeue"
-     let i = size - 1
-     writeProtoRef (pqSize pq) i
-     keys <- readProtoRef (pqKeys pq)
-     vals <- readProtoRef (pqVals pq)
-     k  <- UA.readProtoArray keys i
-     v  <- A.readProtoArray vals i
-     let k0 = 0.0
-         v0 = undefined
-     UA.writeProtoArray keys i k0
-     A.writeProtoArray vals i v0
-     siftDown keys vals i 0 k v
-
--- | Return the element with the minimal priority.
-queueFront :: ProtoMonadComp m => PriorityQueue m a -> m (Double, a)
-queueFront pq =
-  do size <- readProtoRef (pqSize pq)
-     when (size == 0) $ error "Empty priority queue: queueFront"
-     keys <- readProtoRef (pqKeys pq)
-     vals <- readProtoRef (pqVals pq)
-     k <- UA.readProtoArray keys 0
-     v <- A.readProtoArray vals 0
-     return (k, v)
++-- |+-- Module     : Simulation.Aivika.Trans.PriorityQueue+-- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- An imperative heap-based priority queue.+--+module Simulation.Aivika.Trans.PriorityQueue +       (PriorityQueue,+        queueNull, +        queueCount,+        newQueue, +        enqueue, +        dequeue, +        queueFront) where ++import Control.Monad++import Simulation.Aivika.Trans.Session+import Simulation.Aivika.Trans.ProtoRef+import Simulation.Aivika.Trans.Comp++import qualified Simulation.Aivika.Trans.ProtoArray as A+import qualified Simulation.Aivika.Trans.ProtoArray.Unboxed as UA++-- | The 'PriorityQueue' type represents an imperative heap-based +-- priority queue.+data PriorityQueue m a = +  PriorityQueue { pqSession  :: Session m,+                  pqKeys     :: ProtoRef m (UA.ProtoArray m Double),+                  pqVals     :: ProtoRef m (A.ProtoArray m a),+                  pqSize     :: ProtoRef m Int,+                  pqCapacity :: ProtoRef m Int }++increase :: ProtoMonadComp m => PriorityQueue m a -> m ()+increase pq = +  do let s = pqSession pq+         keyRef = pqKeys pq+         valRef = pqVals pq+         capacityRef = pqCapacity pq+     keys <- readProtoRef keyRef+     vals <- readProtoRef valRef+     len  <- readProtoRef capacityRef+     let capacity' | len < 64  = 2 * len+                   | otherwise = (len `div` 2) * 3+     keys' <- UA.newProtoArray_ s capacity'+     vals' <- A.newProtoArray_ s capacity'+     mapM_ (\i -> do { k <- UA.readProtoArray keys i; UA.writeProtoArray keys' i k }) [0 .. len - 1]+     mapM_ (\i -> do { v <- A.readProtoArray vals i; A.writeProtoArray vals' i v }) [0 .. len - 1]+     writeProtoRef keyRef keys'+     writeProtoRef valRef vals'+     writeProtoRef capacityRef capacity'++siftUp :: ProtoMonadComp m +          => UA.ProtoArray m Double+          -- ^ keys+          -> A.ProtoArray m a+          -- ^ values+          -> Int+          -- ^ index+          -> Double+          -- ^ key+          -> a+          -- ^ value+          -> m ()+siftUp keys vals i k v =+  if i == 0 +  then do UA.writeProtoArray keys i k+          A.writeProtoArray vals i v+  else do let n = (i - 1) `div` 2+          kn <- UA.readProtoArray keys n+          if k >= kn +            then do UA.writeProtoArray keys i k+                    A.writeProtoArray vals i v+            else do vn <- A.readProtoArray vals n+                    UA.writeProtoArray keys i kn+                    A.writeProtoArray vals i vn+                    siftUp keys vals n k v++siftDown :: ProtoMonadComp m +            => UA.ProtoArray m Double+            -- ^ keys+            -> A.ProtoArray m a+            -- ^ values+            -> Int+            -- ^ size+            -> Int+            -- ^ index+            -> Double+            -- ^ key+            -> a+            -- ^ value+            -> m ()+siftDown keys vals size i k v =+  if i >= (size `div` 2)+  then do UA.writeProtoArray keys i k+          A.writeProtoArray vals i v+  else do let n  = 2 * i + 1+              n' = n + 1+          kn  <- UA.readProtoArray keys n+          if n' >= size +            then if k <= kn+                 then do UA.writeProtoArray keys i k+                         A.writeProtoArray vals i v+                 else do vn <- A.readProtoArray vals n+                         UA.writeProtoArray keys i kn+                         A.writeProtoArray vals i vn+                         siftDown keys vals size n k v+            else do kn' <- UA.readProtoArray keys n'+                    let n''  = if kn > kn' then n' else n+                        kn'' = min kn' kn+                    if k <= kn''+                      then do UA.writeProtoArray keys i k+                              A.writeProtoArray vals i v+                      else do vn'' <- A.readProtoArray vals n''+                              UA.writeProtoArray keys i kn''+                              A.writeProtoArray vals i vn''+                              siftDown keys vals size n'' k v++-- | Test whether the priority queue is empty.+queueNull :: ProtoMonadComp m => PriorityQueue m a -> m Bool+queueNull pq =+  do size <- readProtoRef (pqSize pq)+     return $ size == 0++-- | Return the number of elements in the priority queue.+queueCount :: ProtoMonadComp m => PriorityQueue m a -> m Int+queueCount pq = readProtoRef (pqSize pq)++-- | Create a new priority queue.+newQueue :: ProtoMonadComp m => Session m -> m (PriorityQueue m a)+newQueue session =+  do keys        <- UA.newProtoArray_ session 11+     vals        <- A.newProtoArray_ session 11+     keyRef      <- newProtoRef session keys+     valRef      <- newProtoRef session vals+     sizeRef     <- newProtoRef session 0+     capacityRef <- newProtoRef session 11+     return PriorityQueue { pqSession = session,+                            pqKeys = keyRef, +                            pqVals = valRef, +                            pqSize = sizeRef,+                            pqCapacity = capacityRef }++-- | Enqueue a new element with the specified priority.+enqueue :: ProtoMonadComp m => PriorityQueue m a -> Double -> a -> m ()+enqueue pq k v =+  do i <- readProtoRef (pqSize pq)+     n <- readProtoRef (pqCapacity pq)+     when (i >= n - 1) $ increase pq+     writeProtoRef (pqSize pq) (i + 1)+     keys <- readProtoRef (pqKeys pq)+     vals <- readProtoRef (pqVals pq)+     siftUp keys vals i k v++-- | Dequeue the element with the minimal priority.+dequeue :: ProtoMonadComp m => PriorityQueue m a -> m ()+dequeue pq =+  do size <- readProtoRef (pqSize pq)+     when (size == 0) $ error "Empty priority queue: dequeue"+     let i = size - 1+     writeProtoRef (pqSize pq) i+     keys <- readProtoRef (pqKeys pq)+     vals <- readProtoRef (pqVals pq)+     k  <- UA.readProtoArray keys i+     v  <- A.readProtoArray vals i+     let k0 = 0.0+         v0 = undefined+     UA.writeProtoArray keys i k0+     A.writeProtoArray vals i v0+     siftDown keys vals i 0 k v++-- | Return the element with the minimal priority.+queueFront :: ProtoMonadComp m => PriorityQueue m a -> m (Double, a)+queueFront pq =+  do size <- readProtoRef (pqSize pq)+     when (size == 0) $ error "Empty priority queue: queueFront"+     keys <- readProtoRef (pqKeys pq)+     vals <- readProtoRef (pqVals pq)+     k <- UA.readProtoArray keys 0+     v <- A.readProtoArray vals 0+     return (k, v)

Simulation/Aivika/Trans/Process.hs view

@@ -1,82 +1,84 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Process
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Processor.hs view

@@ -1,474 +1,474 @@-
-{-# LANGUAGE FlexibleContexts #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Processor
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Processor/RoundRobbin.hs view

@@ -1,59 +1,59 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Processor.RoundRobbin
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module defines the 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- The module defines the 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

Simulation/Aivika/Trans/ProtoArray.hs view

@@ -1,82 +1,82 @@-
-{-# LANGUAGE TypeFamilies #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.ProtoArray
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- It defines a prototype of all mutable arrays.
---
-module Simulation.Aivika.Trans.ProtoArray
-       (ProtoArrayMonad(..)) where
-
-import Data.Array
-import Data.Array.IO.Safe
-
-import Simulation.Aivika.Trans.Session
-import Simulation.Aivika.Trans.ProtoRef
-
--- | A monad within which computation we can create and work with
--- the prototype of mutable arrays.
-class ProtoRefMonad m => ProtoArrayMonad m where
-  
-  -- | A prototype of mutable array.
-  data ProtoArray m :: * -> *
-
-  -- | Return the array size.
-  protoArrayCount :: ProtoArray m a -> m Int
-
-  -- | Create a new ptototype of mutable array by the specified session,
-  -- size and initial value.
-  newProtoArray :: Session m -> Int -> a -> m (ProtoArray m a)
-
-  -- | Create a new ptototype of mutable array by the specified session
-  -- and size with every element initialised to an undefined value.
-  newProtoArray_ :: Session m -> Int -> m (ProtoArray m a)
-
-  -- | Read an element from the mutable array.
-  readProtoArray :: ProtoArray m a -> Int -> m a
-
-  -- | Write the element in the mutable array.
-  writeProtoArray :: ProtoArray m a -> Int -> a -> m ()
-
-  -- | Return a list of the elements.
-  protoArrayToList :: ProtoArray m a -> m [a]
-
-  -- | Create an array by the specified list of elements.
-  protoArrayFromList :: [a] -> m (ProtoArray m a)
-
-  -- | Return the elements of the mutable array in an immutable array.
-  freezeProtoArray :: ProtoArray m a -> m (Array Int a)
-
-instance ProtoArrayMonad IO where
-
-  newtype ProtoArray IO a = ProtoArray (IOArray Int a)
-
-  {-# SPECIALISE INLINE protoArrayCount :: ProtoArray IO a -> IO Int #-}
-  protoArrayCount (ProtoArray a) = do { (0, n') <- getBounds a; return $ n' + 1 }
-
-  {-# SPECIALISE INLINE newProtoArray :: Session IO -> Int -> a -> IO (ProtoArray IO a) #-}
-  newProtoArray s n a = fmap ProtoArray $ newArray (0, n - 1) a
-
-  {-# SPECIALISE INLINE newProtoArray_ :: Session IO -> Int -> IO (ProtoArray IO a) #-}
-  newProtoArray_ s n = fmap ProtoArray $ newArray_ (0, n - 1)
-
-  {-# SPECIALISE INLINE readProtoArray :: ProtoArray IO a -> Int -> IO a #-}
-  readProtoArray (ProtoArray a) = readArray a
-
-  {-# SPECIALISE INLINE writeProtoArray :: ProtoArray IO a -> Int -> a -> IO () #-}
-  writeProtoArray (ProtoArray a) = writeArray a
-
-  {-# SPECIALISE INLINE protoArrayToList :: ProtoArray IO a -> IO [a] #-}
-  protoArrayToList (ProtoArray a) = getElems a
-
-  {-# SPECIALISE INLINE protoArrayFromList :: [a] -> IO (ProtoArray IO a) #-}
-  protoArrayFromList xs = fmap ProtoArray $ newListArray (0, length xs - 1) xs
-
-  {-# SPECIALISE INLINE freezeProtoArray :: ProtoArray IO a -> IO (Array Int a) #-}
-  freezeProtoArray (ProtoArray a) = freeze a
++{-# LANGUAGE TypeFamilies #-}++-- |+-- Module     : Simulation.Aivika.Trans.ProtoArray+-- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- It defines a prototype of all mutable arrays.+--+module Simulation.Aivika.Trans.ProtoArray+       (ProtoArrayMonad(..)) where++import Data.Array+import Data.Array.IO.Safe++import Simulation.Aivika.Trans.Session+import Simulation.Aivika.Trans.ProtoRef++-- | A monad within which computation we can create and work with+-- the prototype of mutable arrays.+class ProtoRefMonad m => ProtoArrayMonad m where+  +  -- | A prototype of mutable array.+  data ProtoArray m :: * -> *++  -- | Return the array size.+  protoArrayCount :: ProtoArray m a -> m Int++  -- | Create a new ptototype of mutable array by the specified session,+  -- size and initial value.+  newProtoArray :: Session m -> Int -> a -> m (ProtoArray m a)++  -- | Create a new ptototype of mutable array by the specified session+  -- and size with every element initialised to an undefined value.+  newProtoArray_ :: Session m -> Int -> m (ProtoArray m a)++  -- | Read an element from the mutable array.+  readProtoArray :: ProtoArray m a -> Int -> m a++  -- | Write the element in the mutable array.+  writeProtoArray :: ProtoArray m a -> Int -> a -> m ()++  -- | Return a list of the elements.+  protoArrayToList :: ProtoArray m a -> m [a]++  -- | Create an array by the specified list of elements.+  protoArrayFromList :: [a] -> m (ProtoArray m a)++  -- | Return the elements of the mutable array in an immutable array.+  freezeProtoArray :: ProtoArray m a -> m (Array Int a)++instance ProtoArrayMonad IO where++  newtype ProtoArray IO a = ProtoArray (IOArray Int a)++  {-# SPECIALISE INLINE protoArrayCount :: ProtoArray IO a -> IO Int #-}+  protoArrayCount (ProtoArray a) = do { (0, n') <- getBounds a; return $ n' + 1 }++  {-# SPECIALISE INLINE newProtoArray :: Session IO -> Int -> a -> IO (ProtoArray IO a) #-}+  newProtoArray s n a = fmap ProtoArray $ newArray (0, n - 1) a++  {-# SPECIALISE INLINE newProtoArray_ :: Session IO -> Int -> IO (ProtoArray IO a) #-}+  newProtoArray_ s n = fmap ProtoArray $ newArray_ (0, n - 1)++  {-# SPECIALISE INLINE readProtoArray :: ProtoArray IO a -> Int -> IO a #-}+  readProtoArray (ProtoArray a) = readArray a++  {-# SPECIALISE INLINE writeProtoArray :: ProtoArray IO a -> Int -> a -> IO () #-}+  writeProtoArray (ProtoArray a) = writeArray a++  {-# SPECIALISE INLINE protoArrayToList :: ProtoArray IO a -> IO [a] #-}+  protoArrayToList (ProtoArray a) = getElems a++  {-# SPECIALISE INLINE protoArrayFromList :: [a] -> IO (ProtoArray IO a) #-}+  protoArrayFromList xs = fmap ProtoArray $ newListArray (0, length xs - 1) xs++  {-# SPECIALISE INLINE freezeProtoArray :: ProtoArray IO a -> IO (Array Int a) #-}+  freezeProtoArray (ProtoArray a) = freeze a

Simulation/Aivika/Trans/ProtoArray/Unboxed.hs view

@@ -1,98 +1,98 @@-
-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.ProtoArray.Unboxed
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- It defines a prototype of all mutable unboxed arrays.
---
-module Simulation.Aivika.Trans.ProtoArray.Unboxed
-       (ProtoArrayMonad(..)) where
-
-import Data.Array
-import Data.Array.IO.Safe
-
-import Simulation.Aivika.Trans.Session
-import Simulation.Aivika.Trans.ProtoRef
-
--- | A monad within which computation we can create and work with
--- the prototype of mutable unboxed arrays.
-class ProtoRefMonad m => ProtoArrayMonad m a where
-  
-  -- | A prototype of mutable unboxed array.
-  data ProtoArray m :: * -> *
-
-  -- | Return the array size.
-  protoArrayCount :: ProtoArray m a -> m Int
-
-  -- | Create a new ptototype of mutable array by the specified session,
-  -- size and initial value.
-  newProtoArray :: Session m -> Int -> a -> m (ProtoArray m a)
-
-  -- | Create a new ptototype of mutable array by the specified session
-  -- and size with every element initialised to an undefined value.
-  newProtoArray_ :: Session m -> Int -> m (ProtoArray m a)
-
-  -- | Read an element from the mutable array.
-  readProtoArray :: ProtoArray m a -> Int -> m a
-
-  -- | Write the element in the mutable array.
-  writeProtoArray :: ProtoArray m a -> Int -> a -> m ()
-
-  -- | Return a list of the elements.
-  protoArrayToList :: ProtoArray m a -> m [a]
-
-  -- | Create an array by the specified list of elements.
-  protoArrayFromList :: [a] -> m (ProtoArray m a)
-
-  -- | Return the elements of the mutable array in an immutable array.
-  freezeProtoArray :: ProtoArray m a -> m (Array Int a)
-
-instance MArray IOUArray a IO => ProtoArrayMonad IO a where
-
-  newtype ProtoArray IO a = ProtoArray (IOUArray Int a)
-
-  {-# SPECIALISE INLINE protoArrayCount :: MArray IOUArray Double IO => ProtoArray IO Double -> IO Int #-}
-  {-# SPECIALISE INLINE protoArrayCount :: MArray IOUArray Float IO => ProtoArray IO Float -> IO Int #-}
-  {-# SPECIALISE INLINE protoArrayCount :: MArray IOUArray Int IO => ProtoArray IO Int -> IO Int #-}
-  protoArrayCount (ProtoArray a) = do { (0, n') <- getBounds a; return $ n' + 1 }
-
-  {-# SPECIALISE INLINE newProtoArray :: MArray IOUArray Double IO => Session IO -> Int -> Double -> IO (ProtoArray IO Double) #-}
-  {-# SPECIALISE INLINE newProtoArray :: MArray IOUArray Float IO => Session IO -> Int -> Float -> IO (ProtoArray IO Float) #-}
-  {-# SPECIALISE INLINE newProtoArray :: MArray IOUArray Int IO => Session IO -> Int -> Int -> IO (ProtoArray IO Int) #-}
-  newProtoArray s n a = fmap ProtoArray $ newArray (0, n - 1) a
-
-  {-# SPECIALISE INLINE newProtoArray_ :: MArray IOUArray Double IO => Session IO -> Int -> IO (ProtoArray IO Double) #-}
-  {-# SPECIALISE INLINE newProtoArray_ :: MArray IOUArray Float IO => Session IO -> Int -> IO (ProtoArray IO Float) #-}
-  {-# SPECIALISE INLINE newProtoArray_ :: MArray IOUArray Int IO => Session IO -> Int -> IO (ProtoArray IO Int) #-}
-  newProtoArray_ s n = fmap ProtoArray $ newArray_ (0, n - 1)
-
-  {-# SPECIALISE INLINE readProtoArray :: MArray IOUArray Double IO => ProtoArray IO Double -> Int -> IO Double #-}
-  {-# SPECIALISE INLINE readProtoArray :: MArray IOUArray Float IO => ProtoArray IO Float -> Int -> IO Float #-}
-  {-# SPECIALISE INLINE readProtoArray :: MArray IOUArray Int IO => ProtoArray IO Int -> Int -> IO Int #-}
-  readProtoArray (ProtoArray a) = readArray a
-
-  {-# SPECIALISE INLINE writeProtoArray :: MArray IOUArray Double IO => ProtoArray IO Double -> Int -> Double -> IO () #-}
-  {-# SPECIALISE INLINE writeProtoArray :: MArray IOUArray Float IO => ProtoArray IO Float -> Int -> Float -> IO () #-}
-  {-# SPECIALISE INLINE writeProtoArray :: MArray IOUArray Int IO => ProtoArray IO Int -> Int -> Int -> IO () #-}
-  writeProtoArray (ProtoArray a) = writeArray a
-
-  {-# SPECIALISE INLINE protoArrayToList :: MArray IOUArray Double IO => ProtoArray IO Double -> IO [Double] #-}
-  {-# SPECIALISE INLINE protoArrayToList :: MArray IOUArray Float IO => ProtoArray IO Float -> IO [Float] #-}
-  {-# SPECIALISE INLINE protoArrayToList :: MArray IOUArray Int IO => ProtoArray IO Int -> IO [Int] #-}
-  protoArrayToList (ProtoArray a) = getElems a
-
-  {-# SPECIALISE INLINE protoArrayFromList :: MArray IOUArray Double IO => [Double] -> IO (ProtoArray IO Double) #-}
-  {-# SPECIALISE INLINE protoArrayFromList :: MArray IOUArray Float IO => [Float] -> IO (ProtoArray IO Float) #-}
-  {-# SPECIALISE INLINE protoArrayFromList :: MArray IOUArray Int IO => [Int] -> IO (ProtoArray IO Int) #-}
-  protoArrayFromList xs = fmap ProtoArray $ newListArray (0, length xs - 1) xs
-
-  {-# SPECIALISE INLINE freezeProtoArray :: MArray IOUArray Double IO => ProtoArray IO Double -> IO (Array Int Double) #-}
-  {-# SPECIALISE INLINE freezeProtoArray :: MArray IOUArray Float IO => ProtoArray IO Float -> IO (Array Int Float) #-}
-  {-# SPECIALISE INLINE freezeProtoArray :: MArray IOUArray Int IO => ProtoArray IO Int -> IO (Array Int Int) #-}
-  freezeProtoArray (ProtoArray a) = freeze a
++{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.Trans.ProtoArray.Unboxed+-- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- It defines a prototype of all mutable unboxed arrays.+--+module Simulation.Aivika.Trans.ProtoArray.Unboxed+       (ProtoArrayMonad(..)) where++import Data.Array+import Data.Array.IO.Safe++import Simulation.Aivika.Trans.Session+import Simulation.Aivika.Trans.ProtoRef++-- | A monad within which computation we can create and work with+-- the prototype of mutable unboxed arrays.+class ProtoRefMonad m => ProtoArrayMonad m a where+  +  -- | A prototype of mutable unboxed array.+  data ProtoArray m :: * -> *++  -- | Return the array size.+  protoArrayCount :: ProtoArray m a -> m Int++  -- | Create a new ptototype of mutable array by the specified session,+  -- size and initial value.+  newProtoArray :: Session m -> Int -> a -> m (ProtoArray m a)++  -- | Create a new ptototype of mutable array by the specified session+  -- and size with every element initialised to an undefined value.+  newProtoArray_ :: Session m -> Int -> m (ProtoArray m a)++  -- | Read an element from the mutable array.+  readProtoArray :: ProtoArray m a -> Int -> m a++  -- | Write the element in the mutable array.+  writeProtoArray :: ProtoArray m a -> Int -> a -> m ()++  -- | Return a list of the elements.+  protoArrayToList :: ProtoArray m a -> m [a]++  -- | Create an array by the specified list of elements.+  protoArrayFromList :: [a] -> m (ProtoArray m a)++  -- | Return the elements of the mutable array in an immutable array.+  freezeProtoArray :: ProtoArray m a -> m (Array Int a)++instance MArray IOUArray a IO => ProtoArrayMonad IO a where++  newtype ProtoArray IO a = ProtoArray (IOUArray Int a)++  {-# SPECIALISE INLINE protoArrayCount :: MArray IOUArray Double IO => ProtoArray IO Double -> IO Int #-}+  {-# SPECIALISE INLINE protoArrayCount :: MArray IOUArray Float IO => ProtoArray IO Float -> IO Int #-}+  {-# SPECIALISE INLINE protoArrayCount :: MArray IOUArray Int IO => ProtoArray IO Int -> IO Int #-}+  protoArrayCount (ProtoArray a) = do { (0, n') <- getBounds a; return $ n' + 1 }++  {-# SPECIALISE INLINE newProtoArray :: MArray IOUArray Double IO => Session IO -> Int -> Double -> IO (ProtoArray IO Double) #-}+  {-# SPECIALISE INLINE newProtoArray :: MArray IOUArray Float IO => Session IO -> Int -> Float -> IO (ProtoArray IO Float) #-}+  {-# SPECIALISE INLINE newProtoArray :: MArray IOUArray Int IO => Session IO -> Int -> Int -> IO (ProtoArray IO Int) #-}+  newProtoArray s n a = fmap ProtoArray $ newArray (0, n - 1) a++  {-# SPECIALISE INLINE newProtoArray_ :: MArray IOUArray Double IO => Session IO -> Int -> IO (ProtoArray IO Double) #-}+  {-# SPECIALISE INLINE newProtoArray_ :: MArray IOUArray Float IO => Session IO -> Int -> IO (ProtoArray IO Float) #-}+  {-# SPECIALISE INLINE newProtoArray_ :: MArray IOUArray Int IO => Session IO -> Int -> IO (ProtoArray IO Int) #-}+  newProtoArray_ s n = fmap ProtoArray $ newArray_ (0, n - 1)++  {-# SPECIALISE INLINE readProtoArray :: MArray IOUArray Double IO => ProtoArray IO Double -> Int -> IO Double #-}+  {-# SPECIALISE INLINE readProtoArray :: MArray IOUArray Float IO => ProtoArray IO Float -> Int -> IO Float #-}+  {-# SPECIALISE INLINE readProtoArray :: MArray IOUArray Int IO => ProtoArray IO Int -> Int -> IO Int #-}+  readProtoArray (ProtoArray a) = readArray a++  {-# SPECIALISE INLINE writeProtoArray :: MArray IOUArray Double IO => ProtoArray IO Double -> Int -> Double -> IO () #-}+  {-# SPECIALISE INLINE writeProtoArray :: MArray IOUArray Float IO => ProtoArray IO Float -> Int -> Float -> IO () #-}+  {-# SPECIALISE INLINE writeProtoArray :: MArray IOUArray Int IO => ProtoArray IO Int -> Int -> Int -> IO () #-}+  writeProtoArray (ProtoArray a) = writeArray a++  {-# SPECIALISE INLINE protoArrayToList :: MArray IOUArray Double IO => ProtoArray IO Double -> IO [Double] #-}+  {-# SPECIALISE INLINE protoArrayToList :: MArray IOUArray Float IO => ProtoArray IO Float -> IO [Float] #-}+  {-# SPECIALISE INLINE protoArrayToList :: MArray IOUArray Int IO => ProtoArray IO Int -> IO [Int] #-}+  protoArrayToList (ProtoArray a) = getElems a++  {-# SPECIALISE INLINE protoArrayFromList :: MArray IOUArray Double IO => [Double] -> IO (ProtoArray IO Double) #-}+  {-# SPECIALISE INLINE protoArrayFromList :: MArray IOUArray Float IO => [Float] -> IO (ProtoArray IO Float) #-}+  {-# SPECIALISE INLINE protoArrayFromList :: MArray IOUArray Int IO => [Int] -> IO (ProtoArray IO Int) #-}+  protoArrayFromList xs = fmap ProtoArray $ newListArray (0, length xs - 1) xs++  {-# SPECIALISE INLINE freezeProtoArray :: MArray IOUArray Double IO => ProtoArray IO Double -> IO (Array Int Double) #-}+  {-# SPECIALISE INLINE freezeProtoArray :: MArray IOUArray Float IO => ProtoArray IO Float -> IO (Array Int Float) #-}+  {-# SPECIALISE INLINE freezeProtoArray :: MArray IOUArray Int IO => ProtoArray IO Int -> IO (Array Int Int) #-}+  freezeProtoArray (ProtoArray a) = freeze a

Simulation/Aivika/Trans/ProtoRef.hs view

@@ -1,61 +1,61 @@-
-{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleInstances #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.ProtoRef
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- It defines a prototype of mutable references.
---
-module Simulation.Aivika.Trans.ProtoRef
-       (ProtoRefMonad(..),
-        ProtoRef(..)) where
-
-import Data.IORef
-
-import Simulation.Aivika.Trans.Session
-
--- | A monad within which computation we can create and work with
--- the prototype of mutable reference.
-class (Functor m, Monad m) => ProtoRefMonad m where
-  
-  -- | A prototype of mutable reference.
-  data ProtoRef m :: * -> *
-
-  -- | Create a new ptototype of mutable reference by the specified session and initial value.
-  newProtoRef :: Session m -> a -> m (ProtoRef m a)
-
-  -- | Read the contents of the prototype of mutable reference.
-  readProtoRef :: ProtoRef m a -> m a
-
-  -- | Write a new value in the prototype of mutable reference.
-  writeProtoRef :: ProtoRef m a -> a -> m ()
-
-  -- | Modify a value stored in the prototype of mutable reference.
-  modifyProtoRef :: ProtoRef m a -> (a -> a) -> m ()
-
-  -- | A strict version of 'modifyProtoRef'.
-  modifyProtoRef' :: ProtoRef m a -> (a -> a) -> m ()
-
-instance ProtoRefMonad IO where
-
-  newtype ProtoRef IO a = ProtoRef (IORef a)
-
-  {-# SPECIALIZE INLINE newProtoRef :: Session IO -> a -> IO (ProtoRef IO a) #-}
-  newProtoRef session = fmap ProtoRef . newIORef
-
-  {-# SPECIALIZE INLINE readProtoRef :: ProtoRef IO a -> IO a #-}
-  readProtoRef (ProtoRef x) = readIORef x
-
-  {-# SPECIALIZE INLINE writeProtoRef :: ProtoRef IO a -> a -> IO () #-}
-  writeProtoRef (ProtoRef x) = writeIORef x
-
-  {-# SPECIALIZE INLINE modifyProtoRef :: ProtoRef IO a -> (a -> a) -> IO () #-}
-  modifyProtoRef (ProtoRef x) = modifyIORef x
-
-  {-# SPECIALIZE INLINE modifyProtoRef' :: ProtoRef IO a -> (a -> a) -> IO () #-}
-  modifyProtoRef' (ProtoRef x) = modifyIORef' x
++{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleInstances #-}++-- |+-- Module     : Simulation.Aivika.Trans.ProtoRef+-- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- It defines a prototype of mutable references.+--+module Simulation.Aivika.Trans.ProtoRef+       (ProtoRefMonad(..),+        ProtoRef(..)) where++import Data.IORef++import Simulation.Aivika.Trans.Session++-- | A monad within which computation we can create and work with+-- the prototype of mutable reference.+class (Functor m, Monad m) => ProtoRefMonad m where+  +  -- | A prototype of mutable reference.+  data ProtoRef m :: * -> *++  -- | Create a new ptototype of mutable reference by the specified session and initial value.+  newProtoRef :: Session m -> a -> m (ProtoRef m a)++  -- | Read the contents of the prototype of mutable reference.+  readProtoRef :: ProtoRef m a -> m a++  -- | Write a new value in the prototype of mutable reference.+  writeProtoRef :: ProtoRef m a -> a -> m ()++  -- | Modify a value stored in the prototype of mutable reference.+  modifyProtoRef :: ProtoRef m a -> (a -> a) -> m ()++  -- | A strict version of 'modifyProtoRef'.+  modifyProtoRef' :: ProtoRef m a -> (a -> a) -> m ()++instance ProtoRefMonad IO where++  newtype ProtoRef IO a = ProtoRef (IORef a)++  {-# SPECIALIZE INLINE newProtoRef :: Session IO -> a -> IO (ProtoRef IO a) #-}+  newProtoRef session = fmap ProtoRef . newIORef++  {-# SPECIALIZE INLINE readProtoRef :: ProtoRef IO a -> IO a #-}+  readProtoRef (ProtoRef x) = readIORef x++  {-# SPECIALIZE INLINE writeProtoRef :: ProtoRef IO a -> a -> IO () #-}+  writeProtoRef (ProtoRef x) = writeIORef x++  {-# SPECIALIZE INLINE modifyProtoRef :: ProtoRef IO a -> (a -> a) -> IO () #-}+  modifyProtoRef (ProtoRef x) = modifyIORef x++  {-# SPECIALIZE INLINE modifyProtoRef' :: ProtoRef IO a -> (a -> a) -> IO () #-}+  modifyProtoRef' (ProtoRef x) = modifyIORef' x

Simulation/Aivika/Trans/Queue.hs view

@@ -1,1122 +1,1122 @@-
-{-# LANGUAGE FlexibleContexts #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Queue
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines a 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines a 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)

Simulation/Aivika/Trans/Queue/Infinite.hs view

@@ -1,649 +1,648 @@-
-{-# LANGUAGE FlexibleContexts #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Queue.Infinite
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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)

Simulation/Aivika/Trans/QueueStrategy.hs view

@@ -1,202 +1,202 @@-
-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, FunctionalDependencies, UndecidableInstances #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.QueueStrategy
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines the 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines the 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

Simulation/Aivika/Trans/Ref.hs view

@@ -1,76 +1,76 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Ref
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Ref/Plain.hs view

@@ -1,60 +1,60 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Ref.Plain
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines a plain and more fast version of an updatable reference
--- that depends on the event queue but that doesn't supply with the signal notification.
---
-module Simulation.Aivika.Trans.Ref.Plain
-       (Ref,
-        newRef,
-        readRef,
-        writeRef,
-        modifyRef) where
-
-import Data.IORef
-
-import Control.Monad
-import Control.Monad.Trans
-
-import Simulation.Aivika.Trans.Session
-import Simulation.Aivika.Trans.ProtoRef
-import Simulation.Aivika.Trans.Comp
-import Simulation.Aivika.Trans.Internal.Specs
-import Simulation.Aivika.Trans.Internal.Simulation
-import Simulation.Aivika.Trans.Internal.Event
-
--- | The 'Ref' type represents a mutable variable similar to the 'IORef' variable 
--- but only dependent on the event queue, which allows synchronizing the reference
--- with the model explicitly through the 'Event' monad.
-newtype Ref m a = 
-  Ref { refValue :: ProtoRef m a }
-
--- | Create a new reference.
-newRef :: MonadComp m => a -> Simulation m (Ref m a)
-newRef a =
-  Simulation $ \r ->
-  do let s = runSession r
-     x <- newProtoRef s a
-     return Ref { refValue = x }
-     
--- | Read the value of a reference.
-readRef :: MonadComp m => Ref m a -> Event m a
-readRef r = Event $ \p -> readProtoRef (refValue r)
-
--- | Write a new value into the reference.
-writeRef :: MonadComp m => Ref m a -> a -> Event m ()
-writeRef r a = Event $ \p -> 
-  a `seq` writeProtoRef (refValue r) a
-
--- | Mutate the contents of the reference.
-modifyRef :: MonadComp m => Ref m a -> (a -> a) -> Event m ()
-modifyRef r f = Event $ \p -> 
-  do a <- readProtoRef (refValue r)
-     let b = f a
-     b `seq` writeProtoRef (refValue r) b
++-- |+-- Module     : Simulation.Aivika.Trans.Ref.Plain+-- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines a plain and more fast version of an updatable reference+-- that depends on the event queue but that doesn't supply with the signal notification.+--+module Simulation.Aivika.Trans.Ref.Plain+       (Ref,+        newRef,+        readRef,+        writeRef,+        modifyRef) where++import Data.IORef++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Trans.Session+import Simulation.Aivika.Trans.ProtoRef+import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Internal.Simulation+import Simulation.Aivika.Trans.Internal.Event++-- | The 'Ref' type represents a mutable variable similar to the 'IORef' variable +-- but only dependent on the event queue, which allows synchronizing the reference+-- with the model explicitly through the 'Event' monad.+newtype Ref m a = +  Ref { refValue :: ProtoRef m a }++-- | Create a new reference.+newRef :: MonadComp m => a -> Simulation m (Ref m a)+newRef a =+  Simulation $ \r ->+  do let s = runSession r+     x <- newProtoRef s a+     return Ref { refValue = x }+     +-- | Read the value of a reference.+readRef :: MonadComp m => Ref m a -> Event m a+readRef r = Event $ \p -> readProtoRef (refValue r)++-- | Write a new value into the reference.+writeRef :: MonadComp m => Ref m a -> a -> Event m ()+writeRef r a = Event $ \p -> +  a `seq` writeProtoRef (refValue r) a++-- | Mutate the contents of the reference.+modifyRef :: MonadComp m => Ref m a -> (a -> a) -> Event m ()+modifyRef r f = Event $ \p -> +  do a <- readProtoRef (refValue r)+     let b = f a+     b `seq` writeProtoRef (refValue r) b

Simulation/Aivika/Trans/Resource.hs view

@@ -1,347 +1,347 @@-
-{-# LANGUAGE FlexibleContexts #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Resource
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines the 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines the 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

Simulation/Aivika/Trans/Results.hs view

@@ -1,1890 +1,1939 @@-
-{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, UndecidableInstances, ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Results
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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)

Simulation/Aivika/Trans/Results/IO.hs view

@@ -1,485 +1,485 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Results.IO
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Results/Locale.hs view

@@ -1,340 +1,377 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Results.Locale
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module defines 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Server.hs view

@@ -1,516 +1,513 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Server
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- It 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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)

Simulation/Aivika/Trans/Session.hs view

@@ -1,56 +1,56 @@-
-{-# LANGUAGE TypeFamilies #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Session
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- It identifies a current simulation session usually associated with the current simulation run.
---
-module Simulation.Aivika.Trans.Session
-       (SessionMonad(..),
-        Session(..)) where
-
-import Data.IORef
-
--- | A monad within which computation we can create and work with a simulation session.
-class (Functor m, Monad m) => SessionMonad m where
-  
-  -- | A simulation session.
-  data Session m :: *
-
-  -- | A marker that exists with the session and which can be compared for equality.
-  data SessionMarker m :: *
-
-  -- | Create a new session.
-  newSession :: m (Session m)
-
-  -- | Create a new marker within the current session.
-  newSessionMarker :: Session m -> m (SessionMarker m)
-
-  -- | Compare two markers for equality.
-  equalSessionMarker :: SessionMarker m -> SessionMarker m -> Bool
-
-instance SessionMonad IO where
-
-  data Session IO = Session
-
-  newtype SessionMarker IO = SessionMarker (IORef ())
-
-  {-# SPECIALISE INLINE newSession :: IO (Session IO) #-}
-  newSession = return Session
-
-  {-# SPECIALISE INLINE newSessionMarker :: Session IO -> IO (SessionMarker IO) #-}
-  newSessionMarker session = fmap SessionMarker $ newIORef ()
-
-  {-# SPECIALISE INLINE equalSessionMarker :: SessionMarker IO -> SessionMarker IO -> Bool #-}
-  equalSessionMarker (SessionMarker x) (SessionMarker y) = x == y
-
-instance SessionMonad m => Eq (SessionMarker m) where
-
-  {-# INLINE (==) #-}
-  (==) = equalSessionMarker
++{-# LANGUAGE TypeFamilies #-}++-- |+-- Module     : Simulation.Aivika.Trans.Session+-- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- It identifies a current simulation session usually associated with the current simulation run.+--+module Simulation.Aivika.Trans.Session+       (SessionMonad(..),+        Session(..)) where++import Data.IORef++-- | A monad within which computation we can create and work with a simulation session.+class (Functor m, Monad m) => SessionMonad m where+  +  -- | A simulation session.+  data Session m :: *++  -- | A marker that exists with the session and which can be compared for equality.+  data SessionMarker m :: *++  -- | Create a new session.+  newSession :: m (Session m)++  -- | Create a new marker within the current session.+  newSessionMarker :: Session m -> m (SessionMarker m)++  -- | Compare two markers for equality.+  equalSessionMarker :: SessionMarker m -> SessionMarker m -> Bool++instance SessionMonad IO where++  data Session IO = Session++  newtype SessionMarker IO = SessionMarker (IORef ())++  {-# SPECIALISE INLINE newSession :: IO (Session IO) #-}+  newSession = return Session++  {-# SPECIALISE INLINE newSessionMarker :: Session IO -> IO (SessionMarker IO) #-}+  newSessionMarker session = fmap SessionMarker $ newIORef ()++  {-# SPECIALISE INLINE equalSessionMarker :: SessionMarker IO -> SessionMarker IO -> Bool #-}+  equalSessionMarker (SessionMarker x) (SessionMarker y) = x == y++instance SessionMonad m => Eq (SessionMarker m) where++  {-# INLINE (==) #-}+  (==) = equalSessionMarker

Simulation/Aivika/Trans/Signal.hs view

@@ -1,53 +1,53 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Signal
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines the signal which we can subscribe handlers to. 
--- These handlers can be disposed. The signal is triggered in the 
--- current time point actuating the corresponded computations from 
--- the handlers. 
---
-module Simulation.Aivika.Trans.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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines the signal which we can subscribe handlers to. +-- These handlers can be disposed. The signal is triggered in the +-- current time point actuating the corresponded computations from +-- the handlers. +--+module Simulation.Aivika.Trans.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

Simulation/Aivika/Trans/Simulation.hs view

@@ -1,26 +1,26 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Simulation
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module defines the '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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- The module defines the '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

Simulation/Aivika/Trans/Specs.hs view

@@ -1,25 +1,25 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Specs
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- It defines 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Statistics.hs view

@@ -1,32 +1,32 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Statistics
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Statistics/Accumulator.hs view

@@ -1,45 +1,45 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Statistics.Accumulator
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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 }

Simulation/Aivika/Trans/Stream.hs view

@@ -1,550 +1,550 @@-
-{-# LANGUAGE FlexibleContexts #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Stream
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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)

Simulation/Aivika/Trans/Stream/Random.hs view

@@ -1,162 +1,162 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Stream.Random
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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)

Simulation/Aivika/Trans/SystemDynamics.hs view

@@ -1,747 +1,820 @@-
-{-# LANGUAGE BangPatterns, RecursiveDo, FlexibleContexts #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.SystemDynamics
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Table.hs view

@@ -1,16 +1,16 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Table
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- It defines 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Task.hs view

@@ -1,173 +1,184 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Task
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The '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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Transform.hs view

@@ -1,130 +1,150 @@-
-{-# LANGUAGE RecursiveDo #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Transform
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The module defines 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Transform/Extra.hs view

@@ -1,58 +1,58 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Transform.Extra
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Transform/Memo.hs view

@@ -1,46 +1,46 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Transform.Memo
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Transform/Memo/Unboxed.hs view

@@ -1,42 +1,42 @@-
-{-# LANGUAGE FlexibleContexts #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Transform.Memo.Unboxed
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines the 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

Simulation/Aivika/Trans/Unboxed.hs view

@@ -1,45 +1,45 @@-
-{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Unboxed
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- The 'Unboxed' class allows creating unboxed arrays in monad 'IO'.
---
-
-module Simulation.Aivika.Trans.Unboxed
-       (Unboxed(..)) where
-
-import Simulation.Aivika.Trans.ProtoArray.Unboxed
-
-import Data.Array
-import Data.Int
-import Data.Word
-
--- | The type which values can be contained in an unboxed array.
-class ProtoArrayMonad m e => Unboxed m e
-
-instance Unboxed IO Bool
-instance Unboxed IO Char
-instance Unboxed IO Double
-instance Unboxed IO Float
-instance Unboxed IO Int
-instance Unboxed IO Int8
-instance Unboxed IO Int16
-instance Unboxed IO Int32
-instance Unboxed IO Word
-instance Unboxed IO Word8
-instance Unboxed IO Word16
-instance Unboxed IO Word32
-
-#ifndef __HASTE__
-
-instance Unboxed IO Int64
-instance Unboxed IO Word64
-
-#endif
++{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses #-}++-- |+-- Module     : Simulation.Aivika.Trans.Unboxed+-- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- The 'Unboxed' class allows creating unboxed arrays in monad 'IO'.+--++module Simulation.Aivika.Trans.Unboxed+       (Unboxed(..)) where++import Simulation.Aivika.Trans.ProtoArray.Unboxed++import Data.Array+import Data.Int+import Data.Word++-- | The type which values can be contained in an unboxed array.+class ProtoArrayMonad m e => Unboxed m e++instance Unboxed IO Bool+instance Unboxed IO Char+instance Unboxed IO Double+instance Unboxed IO Float+instance Unboxed IO Int+instance Unboxed IO Int8+instance Unboxed IO Int16+instance Unboxed IO Int32+instance Unboxed IO Word+instance Unboxed IO Word8+instance Unboxed IO Word16+instance Unboxed IO Word32++#ifndef __HASTE__++instance Unboxed IO Int64+instance Unboxed IO Word64++#endif

Simulation/Aivika/Trans/Var.hs view

@@ -1,190 +1,190 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Var
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- This module defines a 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- This module defines a 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

Simulation/Aivika/Trans/Var/Unboxed.hs view

@@ -1,190 +1,190 @@-
--- |
--- Module     : Simulation.Aivika.Trans.Var.Unboxed
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- 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 <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- 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

Simulation/Aivika/Trans/Vector.hs view

@@ -1,199 +1,199 @@-
-{-# LANGUAGE TypeFamilies #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Vector
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- It defines a prototype of mutable vectors.
---
-module Simulation.Aivika.Trans.Vector
-       (Vector,
-        newVector, 
-        copyVector,
-        vectorCount, 
-        appendVector, 
-        readVector, 
-        writeVector,
-        vectorBinarySearch,
-        vectorInsert,
-        vectorDeleteAt,
-        vectorIndex,
-        freezeVector) where 
-
-import Data.Array
-
-import Control.Monad
-
-import Simulation.Aivika.Trans.Session
-import Simulation.Aivika.Trans.ProtoRef
-import Simulation.Aivika.Trans.ProtoArray
-
--- | A prototype of mutable vector.
-data Vector m a =
-    Vector { vectorSession  :: Session m,
-             vectorArrayRef :: ProtoRef m (ProtoArray m a),
-             vectorCountRef :: ProtoRef m Int, 
-             vectorCapacityRef :: ProtoRef m Int }
-
--- | Create a new vector within the specified simulation session.
-newVector :: ProtoArrayMonad m => Session m -> m (Vector m a)
-newVector session = 
-  do array <- newProtoArray_ session 4
-     arrayRef <- newProtoRef session array
-     countRef <- newProtoRef session 0
-     capacityRef <- newProtoRef session 4
-     return Vector { vectorSession  = session,
-                     vectorArrayRef = arrayRef,
-                     vectorCountRef = countRef,
-                     vectorCapacityRef = capacityRef }
-
--- | Copy the vector.
-copyVector :: ProtoArrayMonad m => Vector m a -> m (Vector m a)
-copyVector vector =
-  do let session = vectorSession vector
-     array <- readProtoRef (vectorArrayRef vector)
-     count <- readProtoRef (vectorCountRef vector)
-     array' <- newProtoArray_ session count
-     arrayRef' <- newProtoRef session array'
-     countRef' <- newProtoRef session count
-     capacityRef' <- newProtoRef session count
-     forM_ [0 .. count - 1] $ \i ->
-       do x <- readProtoArray array i
-          writeProtoArray array' i x
-     return Vector { vectorSession  = session,
-                     vectorArrayRef = arrayRef',
-                     vectorCountRef = countRef',
-                     vectorCapacityRef = capacityRef' }
-       
--- | Ensure that the vector has the specified capacity.
-vectorEnsureCapacity :: ProtoArrayMonad m => Vector m a -> Int -> m ()
-vectorEnsureCapacity vector capacity =
-  do capacity' <- readProtoRef (vectorCapacityRef vector)
-     when (capacity' < capacity) $
-       do array' <- readProtoRef (vectorArrayRef vector)
-          count' <- readProtoRef (vectorCountRef vector)
-          let capacity'' = max (2 * capacity') capacity
-              session    = vectorSession vector
-          array'' <- newProtoArray_ session capacity''
-          forM_ [0 .. count' - 1] $ \i ->
-            do x <- readProtoArray array' i
-               writeProtoArray array'' i x
-          writeProtoRef (vectorArrayRef vector) array''
-          writeProtoRef (vectorCapacityRef vector) capacity''
-
--- | Return the element count.
-vectorCount :: ProtoArrayMonad m => Vector m a -> m Int
-vectorCount vector = readProtoRef (vectorCountRef vector)
-
--- | Add the specified element to the end of the vector.
-appendVector :: ProtoArrayMonad m => Vector m a -> a -> m ()          
-appendVector vector item =
-  do count <- readProtoRef (vectorCountRef vector)
-     vectorEnsureCapacity vector (count + 1)
-     array <- readProtoRef (vectorArrayRef vector)
-     writeProtoArray array count item
-     writeProtoRef (vectorCountRef vector) (count + 1)
-
--- | Read a value from the vector, where indices are started from 0.
-readVector :: ProtoArrayMonad m => Vector m a -> Int -> m a
-readVector vector index =
-  do array <- readProtoRef (vectorArrayRef vector)
-     readProtoArray array index
-
--- | Set an array item at the specified index which is started from 0.
-writeVector :: ProtoArrayMonad m => Vector m a -> Int -> a -> m ()
-writeVector vector index item =
-  do array <- readProtoRef (vectorArrayRef vector)
-     writeProtoArray array index item
-
--- | Return the index of the specified element using binary search; otherwise, 
--- a negated insertion index minus one: 0 -> -0 - 1, ..., i -> -i - 1, ....
-vectorBinarySearch :: (ProtoArrayMonad m, Ord a) => Vector m a -> a -> m Int
-vectorBinarySearch vector item =
-  do array <- readProtoRef (vectorArrayRef vector)
-     count <- readProtoRef (vectorCountRef vector)
-     vectorBinarySearch' array item 0 (count - 1)
-
--- | Return the index of the specified element using binary search
--- within the specified range; otherwise, a negated insertion index minus one.
-vectorBinarySearchWithin :: (ProtoArrayMonad m, Ord a) => Vector m a -> a -> Int -> Int -> m Int
-vectorBinarySearchWithin vector item left right =
-  do array <- readProtoRef (vectorArrayRef vector)
-     vectorBinarySearch' array item left right
-
--- | Return the elements of the vector in an immutable array.
-freezeVector :: ProtoArrayMonad m => Vector m a -> m (Array Int a)
-freezeVector vector =
-  do array <- readProtoRef (vectorArrayRef vector)
-     freezeProtoArray array
-
--- | Insert the element in the vector at the specified index.
-vectorInsert :: ProtoArrayMonad m => Vector m a -> Int -> a -> m ()
-vectorInsert vector index item =
-  do count <- readProtoRef (vectorCountRef vector)
-     when (index < 0) $
-       error $
-       "Index cannot be " ++
-       "negative: vectorInsert."
-     when (index > count) $
-       error $
-       "Index cannot be greater " ++
-       "than the count: vectorInsert."
-     vectorEnsureCapacity vector (count + 1)
-     array <- readProtoRef (vectorArrayRef vector)
-     forM_ [count, count - 1 .. index + 1] $ \i ->
-       do x <- readProtoArray array (i - 1)
-          writeProtoArray array i x
-     writeProtoArray array index item
-     writeProtoRef (vectorCountRef vector) (count + 1)
-
--- | Delete the element at the specified index.
-vectorDeleteAt :: ProtoArrayMonad m => Vector m a -> Int -> m ()
-vectorDeleteAt vector index =
-  do count <- readProtoRef (vectorCountRef vector)
-     when (index < 0) $
-       error $
-       "Index cannot be " ++
-       "negative: vectorDeleteAt."
-     when (index >= count) $
-       error $
-       "Index must be less " ++
-       "than the count: vectorDeleteAt."
-     array <- readProtoRef (vectorArrayRef vector)
-     forM_ [index, index + 1 .. count - 2] $ \i ->
-       do x <- readProtoArray array (i + 1)
-          writeProtoArray array i x
-     writeProtoArray array (count - 1) undefined
-     writeProtoRef (vectorCountRef vector) (count - 1)
-
--- | Return the index of the item or -1.
-vectorIndex :: (ProtoArrayMonad m, Eq a) => Vector m a -> a -> m Int
-vectorIndex vector item =
-  do count <- readProtoRef (vectorCountRef vector)
-     array <- readProtoRef (vectorArrayRef vector)
-     let loop index =
-           if index >= count
-           then return $ -1
-           else do x <- readProtoArray array index
-                   if item == x
-                     then return index
-                     else loop $ index + 1
-     loop 0
-
-vectorBinarySearch' :: (ProtoArrayMonad m, Ord a) => ProtoArray m a -> a -> Int -> Int -> m Int
-vectorBinarySearch' array item left right =
-  if left > right 
-  then return $ - (right + 1) - 1
-  else
-    do let index = (left + right) `div` 2
-       curr <- readProtoArray array index
-       if item < curr 
-         then vectorBinarySearch' array item left (index - 1)
-         else if item == curr
-              then return index
-              else vectorBinarySearch' array item (index + 1) right
++{-# LANGUAGE TypeFamilies #-}++-- |+-- Module     : Simulation.Aivika.Trans.Vector+-- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- It defines a prototype of mutable vectors.+--+module Simulation.Aivika.Trans.Vector+       (Vector,+        newVector, +        copyVector,+        vectorCount, +        appendVector, +        readVector, +        writeVector,+        vectorBinarySearch,+        vectorInsert,+        vectorDeleteAt,+        vectorIndex,+        freezeVector) where ++import Data.Array++import Control.Monad++import Simulation.Aivika.Trans.Session+import Simulation.Aivika.Trans.ProtoRef+import Simulation.Aivika.Trans.ProtoArray++-- | A prototype of mutable vector.+data Vector m a =+    Vector { vectorSession  :: Session m,+             vectorArrayRef :: ProtoRef m (ProtoArray m a),+             vectorCountRef :: ProtoRef m Int, +             vectorCapacityRef :: ProtoRef m Int }++-- | Create a new vector within the specified simulation session.+newVector :: ProtoArrayMonad m => Session m -> m (Vector m a)+newVector session = +  do array <- newProtoArray_ session 4+     arrayRef <- newProtoRef session array+     countRef <- newProtoRef session 0+     capacityRef <- newProtoRef session 4+     return Vector { vectorSession  = session,+                     vectorArrayRef = arrayRef,+                     vectorCountRef = countRef,+                     vectorCapacityRef = capacityRef }++-- | Copy the vector.+copyVector :: ProtoArrayMonad m => Vector m a -> m (Vector m a)+copyVector vector =+  do let session = vectorSession vector+     array <- readProtoRef (vectorArrayRef vector)+     count <- readProtoRef (vectorCountRef vector)+     array' <- newProtoArray_ session count+     arrayRef' <- newProtoRef session array'+     countRef' <- newProtoRef session count+     capacityRef' <- newProtoRef session count+     forM_ [0 .. count - 1] $ \i ->+       do x <- readProtoArray array i+          writeProtoArray array' i x+     return Vector { vectorSession  = session,+                     vectorArrayRef = arrayRef',+                     vectorCountRef = countRef',+                     vectorCapacityRef = capacityRef' }+       +-- | Ensure that the vector has the specified capacity.+vectorEnsureCapacity :: ProtoArrayMonad m => Vector m a -> Int -> m ()+vectorEnsureCapacity vector capacity =+  do capacity' <- readProtoRef (vectorCapacityRef vector)+     when (capacity' < capacity) $+       do array' <- readProtoRef (vectorArrayRef vector)+          count' <- readProtoRef (vectorCountRef vector)+          let capacity'' = max (2 * capacity') capacity+              session    = vectorSession vector+          array'' <- newProtoArray_ session capacity''+          forM_ [0 .. count' - 1] $ \i ->+            do x <- readProtoArray array' i+               writeProtoArray array'' i x+          writeProtoRef (vectorArrayRef vector) array''+          writeProtoRef (vectorCapacityRef vector) capacity''++-- | Return the element count.+vectorCount :: ProtoArrayMonad m => Vector m a -> m Int+vectorCount vector = readProtoRef (vectorCountRef vector)++-- | Add the specified element to the end of the vector.+appendVector :: ProtoArrayMonad m => Vector m a -> a -> m ()          +appendVector vector item =+  do count <- readProtoRef (vectorCountRef vector)+     vectorEnsureCapacity vector (count + 1)+     array <- readProtoRef (vectorArrayRef vector)+     writeProtoArray array count item+     writeProtoRef (vectorCountRef vector) (count + 1)++-- | Read a value from the vector, where indices are started from 0.+readVector :: ProtoArrayMonad m => Vector m a -> Int -> m a+readVector vector index =+  do array <- readProtoRef (vectorArrayRef vector)+     readProtoArray array index++-- | Set an array item at the specified index which is started from 0.+writeVector :: ProtoArrayMonad m => Vector m a -> Int -> a -> m ()+writeVector vector index item =+  do array <- readProtoRef (vectorArrayRef vector)+     writeProtoArray array index item++-- | Return the index of the specified element using binary search; otherwise, +-- a negated insertion index minus one: 0 -> -0 - 1, ..., i -> -i - 1, ....+vectorBinarySearch :: (ProtoArrayMonad m, Ord a) => Vector m a -> a -> m Int+vectorBinarySearch vector item =+  do array <- readProtoRef (vectorArrayRef vector)+     count <- readProtoRef (vectorCountRef vector)+     vectorBinarySearch' array item 0 (count - 1)++-- | Return the index of the specified element using binary search+-- within the specified range; otherwise, a negated insertion index minus one.+vectorBinarySearchWithin :: (ProtoArrayMonad m, Ord a) => Vector m a -> a -> Int -> Int -> m Int+vectorBinarySearchWithin vector item left right =+  do array <- readProtoRef (vectorArrayRef vector)+     vectorBinarySearch' array item left right++-- | Return the elements of the vector in an immutable array.+freezeVector :: ProtoArrayMonad m => Vector m a -> m (Array Int a)+freezeVector vector =+  do array <- readProtoRef (vectorArrayRef vector)+     freezeProtoArray array++-- | Insert the element in the vector at the specified index.+vectorInsert :: ProtoArrayMonad m => Vector m a -> Int -> a -> m ()+vectorInsert vector index item =+  do count <- readProtoRef (vectorCountRef vector)+     when (index < 0) $+       error $+       "Index cannot be " +++       "negative: vectorInsert."+     when (index > count) $+       error $+       "Index cannot be greater " +++       "than the count: vectorInsert."+     vectorEnsureCapacity vector (count + 1)+     array <- readProtoRef (vectorArrayRef vector)+     forM_ [count, count - 1 .. index + 1] $ \i ->+       do x <- readProtoArray array (i - 1)+          writeProtoArray array i x+     writeProtoArray array index item+     writeProtoRef (vectorCountRef vector) (count + 1)++-- | Delete the element at the specified index.+vectorDeleteAt :: ProtoArrayMonad m => Vector m a -> Int -> m ()+vectorDeleteAt vector index =+  do count <- readProtoRef (vectorCountRef vector)+     when (index < 0) $+       error $+       "Index cannot be " +++       "negative: vectorDeleteAt."+     when (index >= count) $+       error $+       "Index must be less " +++       "than the count: vectorDeleteAt."+     array <- readProtoRef (vectorArrayRef vector)+     forM_ [index, index + 1 .. count - 2] $ \i ->+       do x <- readProtoArray array (i + 1)+          writeProtoArray array i x+     writeProtoArray array (count - 1) undefined+     writeProtoRef (vectorCountRef vector) (count - 1)++-- | Return the index of the item or -1.+vectorIndex :: (ProtoArrayMonad m, Eq a) => Vector m a -> a -> m Int+vectorIndex vector item =+  do count <- readProtoRef (vectorCountRef vector)+     array <- readProtoRef (vectorArrayRef vector)+     let loop index =+           if index >= count+           then return $ -1+           else do x <- readProtoArray array index+                   if item == x+                     then return index+                     else loop $ index + 1+     loop 0++vectorBinarySearch' :: (ProtoArrayMonad m, Ord a) => ProtoArray m a -> a -> Int -> Int -> m Int+vectorBinarySearch' array item left right =+  if left > right +  then return $ - (right + 1) - 1+  else+    do let index = (left + right) `div` 2+       curr <- readProtoArray array index+       if item < curr +         then vectorBinarySearch' array item left (index - 1)+         else if item == curr+              then return index+              else vectorBinarySearch' array item (index + 1) right

Simulation/Aivika/Trans/Vector/Unboxed.hs view

@@ -1,199 +1,199 @@-
-{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
-
--- |
--- Module     : Simulation.Aivika.Trans.Vector.Unboxed
--- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>
--- License    : BSD3
--- Maintainer : David Sorokin <david.sorokin@gmail.com>
--- Stability  : experimental
--- Tested with: GHC 7.8.3
---
--- It defines a prototype of mutable unboxed vectors.
---
-module Simulation.Aivika.Trans.Vector.Unboxed
-       (Vector,
-        newVector, 
-        copyVector,
-        vectorCount, 
-        appendVector, 
-        readVector, 
-        writeVector,
-        vectorBinarySearch,
-        vectorInsert,
-        vectorDeleteAt,
-        vectorIndex,
-        freezeVector) where 
-
-import Data.Array
-
-import Control.Monad
-
-import Simulation.Aivika.Trans.Session
-import Simulation.Aivika.Trans.ProtoRef
-import Simulation.Aivika.Trans.ProtoArray.Unboxed
-
--- | A prototype of mutable unboxed vector.
-data Vector m a =
-    Vector { vectorSession  :: Session m,
-             vectorArrayRef :: ProtoRef m (ProtoArray m a),
-             vectorCountRef :: ProtoRef m Int, 
-             vectorCapacityRef :: ProtoRef m Int }
-
--- | Create a new vector within the specified simulation session.
-newVector :: ProtoArrayMonad m a => Session m -> m (Vector m a)
-newVector session = 
-  do array <- newProtoArray_ session 4
-     arrayRef <- newProtoRef session array
-     countRef <- newProtoRef session 0
-     capacityRef <- newProtoRef session 4
-     return Vector { vectorSession  = session,
-                     vectorArrayRef = arrayRef,
-                     vectorCountRef = countRef,
-                     vectorCapacityRef = capacityRef }
-
--- | Copy the vector.
-copyVector :: ProtoArrayMonad m a => Vector m a -> m (Vector m a)
-copyVector vector =
-  do let session = vectorSession vector
-     array <- readProtoRef (vectorArrayRef vector)
-     count <- readProtoRef (vectorCountRef vector)
-     array' <- newProtoArray_ session count
-     arrayRef' <- newProtoRef session array'
-     countRef' <- newProtoRef session count
-     capacityRef' <- newProtoRef session count
-     forM_ [0 .. count - 1] $ \i ->
-       do x <- readProtoArray array i
-          writeProtoArray array' i x
-     return Vector { vectorSession  = session,
-                     vectorArrayRef = arrayRef',
-                     vectorCountRef = countRef',
-                     vectorCapacityRef = capacityRef' }
-       
--- | Ensure that the vector has the specified capacity.
-vectorEnsureCapacity :: ProtoArrayMonad m a => Vector m a -> Int -> m ()
-vectorEnsureCapacity vector capacity =
-  do capacity' <- readProtoRef (vectorCapacityRef vector)
-     when (capacity' < capacity) $
-       do array' <- readProtoRef (vectorArrayRef vector)
-          count' <- readProtoRef (vectorCountRef vector)
-          let capacity'' = max (2 * capacity') capacity
-              session    = vectorSession vector
-          array'' <- newProtoArray_ session capacity''
-          forM_ [0 .. count' - 1] $ \i ->
-            do x <- readProtoArray array' i
-               writeProtoArray array'' i x
-          writeProtoRef (vectorArrayRef vector) array''
-          writeProtoRef (vectorCapacityRef vector) capacity''
-
--- | Return the element count.
-vectorCount :: ProtoArrayMonad m a => Vector m a -> m Int
-vectorCount vector = readProtoRef (vectorCountRef vector)
-
--- | Add the specified element to the end of the vector.
-appendVector :: ProtoArrayMonad m a => Vector m a -> a -> m ()          
-appendVector vector item =
-  do count <- readProtoRef (vectorCountRef vector)
-     vectorEnsureCapacity vector (count + 1)
-     array <- readProtoRef (vectorArrayRef vector)
-     writeProtoArray array count item
-     writeProtoRef (vectorCountRef vector) (count + 1)
-
--- | Read a value from the vector, where indices are started from 0.
-readVector :: ProtoArrayMonad m a => Vector m a -> Int -> m a
-readVector vector index =
-  do array <- readProtoRef (vectorArrayRef vector)
-     readProtoArray array index
-
--- | Set an array item at the specified index which is started from 0.
-writeVector :: ProtoArrayMonad m a => Vector m a -> Int -> a -> m ()
-writeVector vector index item =
-  do array <- readProtoRef (vectorArrayRef vector)
-     writeProtoArray array index item
-
--- | Return the index of the specified element using binary search; otherwise, 
--- a negated insertion index minus one: 0 -> -0 - 1, ..., i -> -i - 1, ....
-vectorBinarySearch :: (ProtoArrayMonad m a, Ord a) => Vector m a -> a -> m Int
-vectorBinarySearch vector item =
-  do array <- readProtoRef (vectorArrayRef vector)
-     count <- readProtoRef (vectorCountRef vector)
-     vectorBinarySearch' array item 0 (count - 1)
-
--- | Return the index of the specified element using binary search
--- within the specified range; otherwise, a negated insertion index minus one.
-vectorBinarySearchWithin :: (ProtoArrayMonad m a, Ord a) => Vector m a -> a -> Int -> Int -> m Int
-vectorBinarySearchWithin vector item left right =
-  do array <- readProtoRef (vectorArrayRef vector)
-     vectorBinarySearch' array item left right
-
--- | Return the elements of the vector in an immutable array.
-freezeVector :: ProtoArrayMonad m a => Vector m a -> m (Array Int a)
-freezeVector vector =
-  do array <- readProtoRef (vectorArrayRef vector)
-     freezeProtoArray array
-
--- | Insert the element in the vector at the specified index.
-vectorInsert :: ProtoArrayMonad m a => Vector m a -> Int -> a -> m ()
-vectorInsert vector index item =
-  do count <- readProtoRef (vectorCountRef vector)
-     when (index < 0) $
-       error $
-       "Index cannot be " ++
-       "negative: vectorInsert."
-     when (index > count) $
-       error $
-       "Index cannot be greater " ++
-       "than the count: vectorInsert."
-     vectorEnsureCapacity vector (count + 1)
-     array <- readProtoRef (vectorArrayRef vector)
-     forM_ [count, count - 1 .. index + 1] $ \i ->
-       do x <- readProtoArray array (i - 1)
-          writeProtoArray array i x
-     writeProtoArray array index item
-     writeProtoRef (vectorCountRef vector) (count + 1)
-
--- | Delete the element at the specified index.
-vectorDeleteAt :: ProtoArrayMonad m a => Vector m a -> Int -> m ()
-vectorDeleteAt vector index =
-  do count <- readProtoRef (vectorCountRef vector)
-     when (index < 0) $
-       error $
-       "Index cannot be " ++
-       "negative: vectorDeleteAt."
-     when (index >= count) $
-       error $
-       "Index must be less " ++
-       "than the count: vectorDeleteAt."
-     array <- readProtoRef (vectorArrayRef vector)
-     forM_ [index, index + 1 .. count - 2] $ \i ->
-       do x <- readProtoArray array (i + 1)
-          writeProtoArray array i x
-     writeProtoArray array (count - 1) undefined
-     writeProtoRef (vectorCountRef vector) (count - 1)
-
--- | Return the index of the item or -1.
-vectorIndex :: (ProtoArrayMonad m a, Eq a) => Vector m a -> a -> m Int
-vectorIndex vector item =
-  do count <- readProtoRef (vectorCountRef vector)
-     array <- readProtoRef (vectorArrayRef vector)
-     let loop index =
-           if index >= count
-           then return $ -1
-           else do x <- readProtoArray array index
-                   if item == x
-                     then return index
-                     else loop $ index + 1
-     loop 0
-
-vectorBinarySearch' :: (ProtoArrayMonad m a, Ord a) => ProtoArray m a -> a -> Int -> Int -> m Int
-vectorBinarySearch' array item left right =
-  if left > right 
-  then return $ - (right + 1) - 1
-  else
-    do let index = (left + right) `div` 2
-       curr <- readProtoArray array index
-       if item < curr 
-         then vectorBinarySearch' array item left (index - 1)
-         else if item == curr
-              then return index
-              else vectorBinarySearch' array item (index + 1) right
++{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.Trans.Vector.Unboxed+-- Copyright  : Copyright (c) 2009-2014, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 7.8.3+--+-- It defines a prototype of mutable unboxed vectors.+--+module Simulation.Aivika.Trans.Vector.Unboxed+       (Vector,+        newVector, +        copyVector,+        vectorCount, +        appendVector, +        readVector, +        writeVector,+        vectorBinarySearch,+        vectorInsert,+        vectorDeleteAt,+        vectorIndex,+        freezeVector) where ++import Data.Array++import Control.Monad++import Simulation.Aivika.Trans.Session+import Simulation.Aivika.Trans.ProtoRef+import Simulation.Aivika.Trans.ProtoArray.Unboxed++-- | A prototype of mutable unboxed vector.+data Vector m a =+    Vector { vectorSession  :: Session m,+             vectorArrayRef :: ProtoRef m (ProtoArray m a),+             vectorCountRef :: ProtoRef m Int, +             vectorCapacityRef :: ProtoRef m Int }++-- | Create a new vector within the specified simulation session.+newVector :: ProtoArrayMonad m a => Session m -> m (Vector m a)+newVector session = +  do array <- newProtoArray_ session 4+     arrayRef <- newProtoRef session array+     countRef <- newProtoRef session 0+     capacityRef <- newProtoRef session 4+     return Vector { vectorSession  = session,+                     vectorArrayRef = arrayRef,+                     vectorCountRef = countRef,+                     vectorCapacityRef = capacityRef }++-- | Copy the vector.+copyVector :: ProtoArrayMonad m a => Vector m a -> m (Vector m a)+copyVector vector =+  do let session = vectorSession vector+     array <- readProtoRef (vectorArrayRef vector)+     count <- readProtoRef (vectorCountRef vector)+     array' <- newProtoArray_ session count+     arrayRef' <- newProtoRef session array'+     countRef' <- newProtoRef session count+     capacityRef' <- newProtoRef session count+     forM_ [0 .. count - 1] $ \i ->+       do x <- readProtoArray array i+          writeProtoArray array' i x+     return Vector { vectorSession  = session,+                     vectorArrayRef = arrayRef',+                     vectorCountRef = countRef',+                     vectorCapacityRef = capacityRef' }+       +-- | Ensure that the vector has the specified capacity.+vectorEnsureCapacity :: ProtoArrayMonad m a => Vector m a -> Int -> m ()+vectorEnsureCapacity vector capacity =+  do capacity' <- readProtoRef (vectorCapacityRef vector)+     when (capacity' < capacity) $+       do array' <- readProtoRef (vectorArrayRef vector)+          count' <- readProtoRef (vectorCountRef vector)+          let capacity'' = max (2 * capacity') capacity+              session    = vectorSession vector+          array'' <- newProtoArray_ session capacity''+          forM_ [0 .. count' - 1] $ \i ->+            do x <- readProtoArray array' i+               writeProtoArray array'' i x+          writeProtoRef (vectorArrayRef vector) array''+          writeProtoRef (vectorCapacityRef vector) capacity''++-- | Return the element count.+vectorCount :: ProtoArrayMonad m a => Vector m a -> m Int+vectorCount vector = readProtoRef (vectorCountRef vector)++-- | Add the specified element to the end of the vector.+appendVector :: ProtoArrayMonad m a => Vector m a -> a -> m ()          +appendVector vector item =+  do count <- readProtoRef (vectorCountRef vector)+     vectorEnsureCapacity vector (count + 1)+     array <- readProtoRef (vectorArrayRef vector)+     writeProtoArray array count item+     writeProtoRef (vectorCountRef vector) (count + 1)++-- | Read a value from the vector, where indices are started from 0.+readVector :: ProtoArrayMonad m a => Vector m a -> Int -> m a+readVector vector index =+  do array <- readProtoRef (vectorArrayRef vector)+     readProtoArray array index++-- | Set an array item at the specified index which is started from 0.+writeVector :: ProtoArrayMonad m a => Vector m a -> Int -> a -> m ()+writeVector vector index item =+  do array <- readProtoRef (vectorArrayRef vector)+     writeProtoArray array index item++-- | Return the index of the specified element using binary search; otherwise, +-- a negated insertion index minus one: 0 -> -0 - 1, ..., i -> -i - 1, ....+vectorBinarySearch :: (ProtoArrayMonad m a, Ord a) => Vector m a -> a -> m Int+vectorBinarySearch vector item =+  do array <- readProtoRef (vectorArrayRef vector)+     count <- readProtoRef (vectorCountRef vector)+     vectorBinarySearch' array item 0 (count - 1)++-- | Return the index of the specified element using binary search+-- within the specified range; otherwise, a negated insertion index minus one.+vectorBinarySearchWithin :: (ProtoArrayMonad m a, Ord a) => Vector m a -> a -> Int -> Int -> m Int+vectorBinarySearchWithin vector item left right =+  do array <- readProtoRef (vectorArrayRef vector)+     vectorBinarySearch' array item left right++-- | Return the elements of the vector in an immutable array.+freezeVector :: ProtoArrayMonad m a => Vector m a -> m (Array Int a)+freezeVector vector =+  do array <- readProtoRef (vectorArrayRef vector)+     freezeProtoArray array++-- | Insert the element in the vector at the specified index.+vectorInsert :: ProtoArrayMonad m a => Vector m a -> Int -> a -> m ()+vectorInsert vector index item =+  do count <- readProtoRef (vectorCountRef vector)+     when (index < 0) $+       error $+       "Index cannot be " +++       "negative: vectorInsert."+     when (index > count) $+       error $+       "Index cannot be greater " +++       "than the count: vectorInsert."+     vectorEnsureCapacity vector (count + 1)+     array <- readProtoRef (vectorArrayRef vector)+     forM_ [count, count - 1 .. index + 1] $ \i ->+       do x <- readProtoArray array (i - 1)+          writeProtoArray array i x+     writeProtoArray array index item+     writeProtoRef (vectorCountRef vector) (count + 1)++-- | Delete the element at the specified index.+vectorDeleteAt :: ProtoArrayMonad m a => Vector m a -> Int -> m ()+vectorDeleteAt vector index =+  do count <- readProtoRef (vectorCountRef vector)+     when (index < 0) $+       error $+       "Index cannot be " +++       "negative: vectorDeleteAt."+     when (index >= count) $+       error $+       "Index must be less " +++       "than the count: vectorDeleteAt."+     array <- readProtoRef (vectorArrayRef vector)+     forM_ [index, index + 1 .. count - 2] $ \i ->+       do x <- readProtoArray array (i + 1)+          writeProtoArray array i x+     writeProtoArray array (count - 1) undefined+     writeProtoRef (vectorCountRef vector) (count - 1)++-- | Return the index of the item or -1.+vectorIndex :: (ProtoArrayMonad m a, Eq a) => Vector m a -> a -> m Int+vectorIndex vector item =+  do count <- readProtoRef (vectorCountRef vector)+     array <- readProtoRef (vectorArrayRef vector)+     let loop index =+           if index >= count+           then return $ -1+           else do x <- readProtoArray array index+                   if item == x+                     then return index+                     else loop $ index + 1+     loop 0++vectorBinarySearch' :: (ProtoArrayMonad m a, Ord a) => ProtoArray m a -> a -> Int -> Int -> m Int+vectorBinarySearch' array item left right =+  if left > right +  then return $ - (right + 1) - 1+  else+    do let index = (left + right) `div` 2+       curr <- readProtoArray array index+       if item < curr +         then vectorBinarySearch' array item left (index - 1)+         else if item == curr+              then return index+              else vectorBinarySearch' array item (index + 1) right

aivika-transformers.cabal view

@@ -1,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] <http://hackage.haskell.org/package/aivika>
-    .
-category:        Simulation
-license:         BSD3
-license-file:    LICENSE
-copyright:       (c) 2009-2014. David Sorokin <david.sorokin@gmail.com>
-author:          David Sorokin
-maintainer:      David Sorokin <david.sorokin@gmail.com>
-homepage:        http://github.com/dsorokin/aivika
-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] <http://hackage.haskell.org/package/aivika>+    .+category:        Simulation+license:         BSD3+license-file:    LICENSE+copyright:       (c) 2009-2014. David Sorokin <david.sorokin@gmail.com>+author:          David Sorokin+maintainer:      David Sorokin <david.sorokin@gmail.com>+homepage:        http://github.com/dsorokin/aivika-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

examples/BassDiffusion.hs view

@@ -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

examples/ChemicalReaction.hs view

@@ -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

examples/ChemicalReactionCircuit.hs view

@@ -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

examples/FishBank.hs view

@@ -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

examples/Furnace.hs view

@@ -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

examples/InspectionAdjustmentStations.hs view

@@ -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

examples/MachRep1.hs view

@@ -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

examples/MachRep1EventDriven.hs view

@@ -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

examples/MachRep1TimeDriven.hs view

@@ -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

examples/MachRep2.hs view

@@ -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

examples/MachRep3.hs view

@@ -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

examples/TimeOut.hs view

@@ -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

examples/TimeOutInt.hs view

@@ -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

examples/TimeOutWait.hs view

@@ -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

examples/WorkStationsInSeries.hs view

@@ -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