aivika 2.0 → 2.1

raw patch · 78 files changed

+17454/−16566 lines, 78 filessetup-changedPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• LICENSE +30/−30
• Setup.lhs +3/−3
• Simulation/Aivika.hs +87/−85
• Simulation/Aivika/Activity.hs +369/−0
• Simulation/Aivika/Agent.hs +252/−252
• Simulation/Aivika/Arrival.hs +77/−77
• Simulation/Aivika/Circuit.hs +494/−379
• Simulation/Aivika/Cont.hs +19/−19
• Simulation/Aivika/DoubleLinkedList.hs +165/−165
• Simulation/Aivika/Dynamics.hs +31/−31
• Simulation/Aivika/Dynamics/Extra.hs +109/−109
• Simulation/Aivika/Dynamics/Memo.hs +159/−159
• Simulation/Aivika/Dynamics/Memo/Unboxed.hs +102/−102
• Simulation/Aivika/Dynamics/Random.hs +132/−132
• Simulation/Aivika/Event.hs +44/−44
• Simulation/Aivika/Generator.hs +220/−220
• Simulation/Aivika/Internal/Arrival.hs +39/−39
• Simulation/Aivika/Internal/Cont.hs +671/−671
• Simulation/Aivika/Internal/Dynamics.hs +214/−214
• Simulation/Aivika/Internal/Event.hs +399/−409
• Simulation/Aivika/Internal/Parameter.hs +261/−261
• Simulation/Aivika/Internal/Process.hs +643/−630
• Simulation/Aivika/Internal/Signal.hs +380/−380
• Simulation/Aivika/Internal/Simulation.hs +161/−161
• Simulation/Aivika/Internal/Specs.hs +223/−223
• Simulation/Aivika/Net.hs +249/−242
• Simulation/Aivika/Parameter.hs +38/−38
• Simulation/Aivika/Parameter/Random.hs +123/−123
• Simulation/Aivika/PriorityQueue.hs +163/−163
• Simulation/Aivika/Process.hs +84/−82
• Simulation/Aivika/Processor.hs +458/−458
• Simulation/Aivika/Processor/RoundRobbin.hs +58/−58
• Simulation/Aivika/Queue.hs +1097/−1097
• Simulation/Aivika/Queue/Infinite.hs +636/−636
• Simulation/Aivika/QueueStrategy.hs +187/−187
• Simulation/Aivika/Ref.hs +69/−69
• Simulation/Aivika/Ref/Plain.hs +53/−53
• Simulation/Aivika/Resource.hs +335/−335
• Simulation/Aivika/Results.hs +1931/−1884
• Simulation/Aivika/Results/IO.hs +476/−476
• Simulation/Aivika/Results/Locale.hs +377/−340
• Simulation/Aivika/Server.hs +507/−510
• Simulation/Aivika/Signal.hs +53/−53
• Simulation/Aivika/Simulation.hs +25/−25
• Simulation/Aivika/Specs.hs +25/−25
• Simulation/Aivika/Statistics.hs +417/−417
• Simulation/Aivika/Statistics/Accumulator.hs +44/−44
• Simulation/Aivika/Stream.hs +534/−534
• Simulation/Aivika/Stream/Random.hs +153/−153
• Simulation/Aivika/SystemDynamics.hs +777/−708
• Simulation/Aivika/Table.hs +64/−64
• Simulation/Aivika/Task.hs +179/−168
• Simulation/Aivika/Transform.hs +145/−126
• Simulation/Aivika/Transform/Extra.hs +54/−54
• Simulation/Aivika/Transform/Memo.hs +45/−45
• Simulation/Aivika/Transform/Memo/Unboxed.hs +41/−41
• Simulation/Aivika/Unboxed.hs +48/−48
• Simulation/Aivika/Var.hs +188/−188
• Simulation/Aivika/Var/Unboxed.hs +188/−188
• Simulation/Aivika/Vector.hs +183/−183
• Simulation/Aivika/Vector/Unboxed.hs +186/−186
• aivika.cabal +205/−203
• examples/BassDiffusion.hs +104/−104
• examples/ChemicalReaction.hs +30/−30
• examples/ChemicalReactionCircuit.hs +43/−43
• examples/FishBank.hs +60/−60
• examples/Furnace.hs +323/−323
• examples/InspectionAdjustmentStations.hs +161/−161
• examples/MachRep1.hs +67/−67
• examples/MachRep1EventDriven.hs +81/−81
• examples/MachRep1TimeDriven.hs +118/−118
• examples/MachRep2.hs +104/−104
• examples/MachRep3.hs +94/−94
• examples/QuarryOperations.hs +208/−0
• examples/TimeOut.hs +96/−96
• examples/TimeOutInt.hs +77/−77
• examples/TimeOutWait.hs +70/−70
• examples/WorkStationsInSeries.hs +139/−139

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

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

@@ -1,85 +1,87 @@-
--- |
--- Module     : Simulation.Aivika
--- 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.
---
-module Simulation.Aivika
-       (-- * Modules
-        module Simulation.Aivika.Agent,
-        module Simulation.Aivika.Arrival,
-        module Simulation.Aivika.Circuit,
-        module Simulation.Aivika.Cont,
-        module Simulation.Aivika.Dynamics,
-        module Simulation.Aivika.Dynamics.Extra,
-        module Simulation.Aivika.Dynamics.Memo.Unboxed,
-        module Simulation.Aivika.Dynamics.Random,
-        module Simulation.Aivika.Event,
-        module Simulation.Aivika.Generator,
-        module Simulation.Aivika.Net,
-        module Simulation.Aivika.Parameter,
-        module Simulation.Aivika.Parameter.Random,
-        module Simulation.Aivika.Process,
-        module Simulation.Aivika.Processor,
-        module Simulation.Aivika.Processor.RoundRobbin,
-        module Simulation.Aivika.QueueStrategy,
-        module Simulation.Aivika.Ref,
-        module Simulation.Aivika.Resource,
-        module Simulation.Aivika.Results,
-        module Simulation.Aivika.Results.Locale,
-        module Simulation.Aivika.Results.IO,
-        module Simulation.Aivika.Server,
-        module Simulation.Aivika.Signal,
-        module Simulation.Aivika.Simulation,
-        module Simulation.Aivika.Specs,
-        module Simulation.Aivika.Statistics,
-        module Simulation.Aivika.Statistics.Accumulator,
-        module Simulation.Aivika.Stream,
-        module Simulation.Aivika.Stream.Random,
-        module Simulation.Aivika.Task,
-        module Simulation.Aivika.Transform,
-        module Simulation.Aivika.Transform.Extra,
-        module Simulation.Aivika.Transform.Memo.Unboxed,
-        module Simulation.Aivika.Var.Unboxed) where
-
-import Simulation.Aivika.Agent
-import Simulation.Aivika.Arrival
-import Simulation.Aivika.Circuit
-import Simulation.Aivika.Cont
-import Simulation.Aivika.Dynamics
-import Simulation.Aivika.Dynamics.Extra
-import Simulation.Aivika.Dynamics.Memo.Unboxed
-import Simulation.Aivika.Dynamics.Random
-import Simulation.Aivika.Event
-import Simulation.Aivika.Generator
-import Simulation.Aivika.Net
-import Simulation.Aivika.Parameter
-import Simulation.Aivika.Parameter.Random
-import Simulation.Aivika.Process
-import Simulation.Aivika.Processor
-import Simulation.Aivika.Processor.RoundRobbin
-import Simulation.Aivika.QueueStrategy
-import Simulation.Aivika.Ref
-import Simulation.Aivika.Resource
-import Simulation.Aivika.Results
-import Simulation.Aivika.Results.Locale
-import Simulation.Aivika.Results.IO
-import Simulation.Aivika.Server
-import Simulation.Aivika.Signal
-import Simulation.Aivika.Simulation
-import Simulation.Aivika.Specs
-import Simulation.Aivika.Statistics
-import Simulation.Aivika.Statistics.Accumulator
-import Simulation.Aivika.Stream
-import Simulation.Aivika.Stream.Random
-import Simulation.Aivika.Task
-import Simulation.Aivika.Transform
-import Simulation.Aivika.Transform.Extra
-import Simulation.Aivika.Transform.Memo.Unboxed
-import Simulation.Aivika.Var.Unboxed
++-- |+-- Module     : Simulation.Aivika+-- 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.+--+module Simulation.Aivika+       (-- * Modules+        module Simulation.Aivika.Activity,+        module Simulation.Aivika.Agent,+        module Simulation.Aivika.Arrival,+        module Simulation.Aivika.Circuit,+        module Simulation.Aivika.Cont,+        module Simulation.Aivika.Dynamics,+        module Simulation.Aivika.Dynamics.Extra,+        module Simulation.Aivika.Dynamics.Memo.Unboxed,+        module Simulation.Aivika.Dynamics.Random,+        module Simulation.Aivika.Event,+        module Simulation.Aivika.Generator,+        module Simulation.Aivika.Net,+        module Simulation.Aivika.Parameter,+        module Simulation.Aivika.Parameter.Random,+        module Simulation.Aivika.Process,+        module Simulation.Aivika.Processor,+        module Simulation.Aivika.Processor.RoundRobbin,+        module Simulation.Aivika.QueueStrategy,+        module Simulation.Aivika.Ref,+        module Simulation.Aivika.Resource,+        module Simulation.Aivika.Results,+        module Simulation.Aivika.Results.Locale,+        module Simulation.Aivika.Results.IO,+        module Simulation.Aivika.Server,+        module Simulation.Aivika.Signal,+        module Simulation.Aivika.Simulation,+        module Simulation.Aivika.Specs,+        module Simulation.Aivika.Statistics,+        module Simulation.Aivika.Statistics.Accumulator,+        module Simulation.Aivika.Stream,+        module Simulation.Aivika.Stream.Random,+        module Simulation.Aivika.Task,+        module Simulation.Aivika.Transform,+        module Simulation.Aivika.Transform.Extra,+        module Simulation.Aivika.Transform.Memo.Unboxed,+        module Simulation.Aivika.Var.Unboxed) where++import Simulation.Aivika.Activity+import Simulation.Aivika.Agent+import Simulation.Aivika.Arrival+import Simulation.Aivika.Circuit+import Simulation.Aivika.Cont+import Simulation.Aivika.Dynamics+import Simulation.Aivika.Dynamics.Extra+import Simulation.Aivika.Dynamics.Memo.Unboxed+import Simulation.Aivika.Dynamics.Random+import Simulation.Aivika.Event+import Simulation.Aivika.Generator+import Simulation.Aivika.Net+import Simulation.Aivika.Parameter+import Simulation.Aivika.Parameter.Random+import Simulation.Aivika.Process+import Simulation.Aivika.Processor+import Simulation.Aivika.Processor.RoundRobbin+import Simulation.Aivika.QueueStrategy+import Simulation.Aivika.Ref+import Simulation.Aivika.Resource+import Simulation.Aivika.Results+import Simulation.Aivika.Results.Locale+import Simulation.Aivika.Results.IO+import Simulation.Aivika.Server+import Simulation.Aivika.Signal+import Simulation.Aivika.Simulation+import Simulation.Aivika.Specs+import Simulation.Aivika.Statistics+import Simulation.Aivika.Statistics.Accumulator+import Simulation.Aivika.Stream+import Simulation.Aivika.Stream.Random+import Simulation.Aivika.Task+import Simulation.Aivika.Transform+import Simulation.Aivika.Transform.Extra+import Simulation.Aivika.Transform.Memo.Unboxed+import Simulation.Aivika.Var.Unboxed

@@ -0,0 +1,369 @@++-- |+-- Module     : Simulation.Aivika.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.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.IORef+import Data.Monoid++import Control.Monad.Trans+import Control.Arrow++import Simulation.Aivika.Simulation+import Simulation.Aivika.Dynamics+import Simulation.Aivika.Internal.Event+import Simulation.Aivika.Internal.Signal+import Simulation.Aivika.Resource+import Simulation.Aivika.Cont+import Simulation.Aivika.Process+import Simulation.Aivika.Net+import Simulation.Aivika.Server+import Simulation.Aivika.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 s a b =+  Activity { activityInitState :: s,+             -- ^ The initial state of the activity.+             activityStateRef :: IORef s,+             -- ^ The current state of the activity.+             activityProcess :: s -> a -> Process (s, b),+             -- ^ Provide @b@ by specified @a@.+             activityTotalUtilisationTimeRef :: IORef Double,+             -- ^ The counted total time of utilising the activity.+             activityTotalIdleTimeRef :: IORef Double,+             -- ^ The counted total time, when the activity was idle.+             activityUtilisationTimeRef :: IORef (SamplingStats Double),+             -- ^ The statistics for the utilisation time.+             activityIdleTimeRef :: IORef (SamplingStats Double),+             -- ^ The statistics for the time, when the activity was idle.+             activityUtilisingSource :: SignalSource a,+             -- ^ A signal raised when starting to utilise the activity.+             activityUtilisedSource :: SignalSource (a, b)+             -- ^ A signal raised when the activity has been utilised.+           }++-- | Create a new activity that can provide output @b@ by input @a@.+newActivity :: (a -> Process b)+               -- ^ provide an output by the specified input+               -> Simulation (Activity () 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 :: (s -> a -> Process (s, b))+                    -- ^ provide a new state and output by the specified +                    -- old state and input+                    -> s+                    -- ^ the initial state+                    -> Simulation (Activity s a b)+newStateActivity provide state =+  do r0 <- liftIO $ newIORef state+     r1 <- liftIO $ newIORef 0+     r2 <- liftIO $ newIORef 0+     r3 <- liftIO $ newIORef emptySamplingStats+     r4 <- liftIO $ newIORef 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 :: Activity s a b -> Net 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' ->+                  liftIO $+                  do modifyIORef' (activityTotalIdleTimeRef act) (+ (t0 - t'))+                     modifyIORef' (activityIdleTimeRef act) $+                       addSamplingStats (t0 - t')+              triggerSignal (activityUtilisingSource act) a+         -- utilise the activity+         (s', b) <- activityProcess act s a+         t1 <- liftDynamics time+         liftEvent $+           do liftIO $+                do writeIORef (activityStateRef act) $! s'+                   modifyIORef' (activityTotalUtilisationTimeRef act) (+ (t1 - t0))+                   modifyIORef' (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 :: Activity s a b -> Event s+activityState act =+  Event $ \p -> readIORef (activityStateRef act)+  +-- | Signal when the 'activityState' property value has changed.+activityStateChanged :: Activity s a b -> Signal s+activityStateChanged act =+  mapSignalM (const $ activityState act) (activityStateChanged_ act)+  +-- | Signal when the 'activityState' property value has changed.+activityStateChanged_ :: Activity s a b -> Signal ()+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 :: Activity s a b -> Event Double+activityTotalUtilisationTime act =+  Event $ \p -> readIORef (activityTotalUtilisationTimeRef act)+  +-- | Signal when the 'activityTotalUtilisationTime' property value has changed.+activityTotalUtilisationTimeChanged :: Activity s a b -> Signal Double+activityTotalUtilisationTimeChanged act =+  mapSignalM (const $ activityTotalUtilisationTime act) (activityTotalUtilisationTimeChanged_ act)+  +-- | Signal when the 'activityTotalUtilisationTime' property value has changed.+activityTotalUtilisationTimeChanged_ :: Activity s a b -> Signal ()+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 :: Activity s a b -> Event Double+activityTotalIdleTime act =+  Event $ \p -> readIORef (activityTotalIdleTimeRef act)+  +-- | Signal when the 'activityTotalIdleTime' property value has changed.+activityTotalIdleTimeChanged :: Activity s a b -> Signal Double+activityTotalIdleTimeChanged act =+  mapSignalM (const $ activityTotalIdleTime act) (activityTotalIdleTimeChanged_ act)+  +-- | Signal when the 'activityTotalIdleTime' property value has changed.+activityTotalIdleTimeChanged_ :: Activity s a b -> Signal ()+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 :: Activity s a b -> Event (SamplingStats Double)+activityUtilisationTime act =+  Event $ \p -> readIORef (activityUtilisationTimeRef act)+  +-- | Signal when the 'activityUtilisationTime' property value has changed.+activityUtilisationTimeChanged :: Activity s a b -> Signal (SamplingStats Double)+activityUtilisationTimeChanged act =+  mapSignalM (const $ activityUtilisationTime act) (activityUtilisationTimeChanged_ act)+  +-- | Signal when the 'activityUtilisationTime' property value has changed.+activityUtilisationTimeChanged_ :: Activity s a b -> Signal ()+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 :: Activity s a b -> Event (SamplingStats Double)+activityIdleTime act =+  Event $ \p -> readIORef (activityIdleTimeRef act)+  +-- | Signal when the 'activityIdleTime' property value has changed.+activityIdleTimeChanged :: Activity s a b -> Signal (SamplingStats Double)+activityIdleTimeChanged act =+  mapSignalM (const $ activityIdleTime act) (activityIdleTimeChanged_ act)+  +-- | Signal when the 'activityIdleTime' property value has changed.+activityIdleTimeChanged_ :: Activity s a b -> Signal ()+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 :: Activity s a b -> Event Double+activityUtilisationFactor act =+  Event $ \p ->+  do x1 <- readIORef (activityTotalUtilisationTimeRef act)+     x2 <- readIORef (activityTotalIdleTimeRef act)+     return (x1 / (x1 + x2))+  +-- | Signal when the 'activityUtilisationFactor' property value has changed.+activityUtilisationFactorChanged :: Activity s a b -> Signal Double+activityUtilisationFactorChanged act =+  mapSignalM (const $ activityUtilisationFactor act) (activityUtilisationFactorChanged_ act)+  +-- | Signal when the 'activityUtilisationFactor' property value has changed.+activityUtilisationFactorChanged_ :: Activity s a b -> Signal ()+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 :: Activity s a b -> Event Double+activityIdleFactor act =+  Event $ \p ->+  do x1 <- readIORef (activityTotalUtilisationTimeRef act)+     x2 <- readIORef (activityTotalIdleTimeRef act)+     return (x2 / (x1 + x2))+  +-- | Signal when the 'activityIdleFactor' property value has changed.+activityIdleFactorChanged :: Activity s a b -> Signal Double+activityIdleFactorChanged act =+  mapSignalM (const $ activityIdleFactor act) (activityIdleFactorChanged_ act)+  +-- | Signal when the 'activityIdleFactor' property value has changed.+activityIdleFactorChanged_ :: Activity s a b -> Signal ()+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 s a b -> Signal a+activityUtilising = publishSignal . activityUtilisingSource++-- | Raised when the activity has been utilised after the current task is processed.+activityUtilised :: Activity s a b -> Signal (a, b)+activityUtilised = publishSignal . activityUtilisedSource++-- | Signal whenever any property of the activity changes.+activityChanged_ :: Activity s a b -> Signal ()+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 :: Activity s a b -> Int -> Event ShowS+activitySummary act indent =+  Event $ \p ->+  do tx1 <- readIORef (activityTotalUtilisationTimeRef act)+     tx2 <- readIORef (activityTotalIdleTimeRef act)+     let xf1 = tx1 / (tx1 + tx2)+         xf2 = tx2 / (tx1 + tx2)+     xs1 <- readIORef (activityUtilisationTimeRef act)+     xs2 <- readIORef (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)

@@ -1,252 +1,252 @@-
--- |
--- Module     : Simulation.Aivika.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.Agent
-       (Agent,
-        AgentState,
-        newAgent,
-        newState,
-        newSubstate,
-        selectedState,
-        selectedStateChanged,
-        selectedStateChanged_,
-        selectState,
-        stateAgent,
-        stateParent,
-        addTimeout,
-        addTimer,
-        setStateActivation,
-        setStateDeactivation,
-        setStateTransition) where
-
-import Data.IORef
-import Control.Monad
-
-import Simulation.Aivika.Internal.Specs
-import Simulation.Aivika.Internal.Simulation
-import Simulation.Aivika.Internal.Event
-import Simulation.Aivika.Internal.Signal
-
---
--- Agent-based Modeling
---
-
--- | Represents an agent.
-data Agent = Agent { agentModeRef            :: IORef AgentMode,
-                     agentStateRef           :: IORef (Maybe AgentState), 
-                     agentStateChangedSource :: SignalSource (Maybe AgentState) }
-
--- | Represents the agent state.
-data AgentState = AgentState { stateAgent         :: Agent,
-                               -- ^ Return the corresponded agent.
-                               stateParent        :: Maybe AgentState,
-                               -- ^ Return the parent state or 'Nothing'.
-                               stateActivateRef   :: IORef (Event ()),
-                               stateDeactivateRef :: IORef (Event ()),
-                               stateTransitRef    :: IORef (Event (Maybe AgentState)),
-                               stateVersionRef    :: IORef Int }
-                  
-data AgentMode = CreationMode
-               | TransientMode
-               | ProcessingMode
-                      
-instance Eq Agent where
-  x == y = agentStateRef x == agentStateRef y      -- unique references
-  
-instance Eq AgentState where
-  x == y = stateVersionRef x == stateVersionRef y  -- unique references
-
-fullPath :: AgentState -> [AgentState] -> [AgentState]
-fullPath st acc =
-  case stateParent st of
-    Nothing  -> st : acc
-    Just st' -> fullPath st' (st : acc)
-
-partitionPath :: [AgentState] -> [AgentState] -> ([AgentState], [AgentState])
-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 :: Maybe AgentState -> AgentState -> ([AgentState], [AgentState])
-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 :: Maybe AgentState -> AgentState -> Event ()
-traversePath source target =
-  let (path1, path2) = findPath source target
-      agent = stateAgent target
-      activate st p   = invokeEvent p =<< readIORef (stateActivateRef st)
-      deactivate st p = invokeEvent p =<< readIORef (stateDeactivateRef st)
-      transit st p    = invokeEvent p =<< readIORef (stateTransitRef st)
-      continue st p   = invokeEvent p $ traversePath (Just target) st
-  in Event $ \p ->
-       unless (null path1 && null path2) $
-       do writeIORef (agentModeRef agent) TransientMode
-          forM_ path1 $ \st ->
-            do writeIORef (agentStateRef agent) (Just st)
-               deactivate st p
-               -- it makes all timeout and timer handlers outdated
-               modifyIORef (stateVersionRef st) (1 +)
-          forM_ path2 $ \st ->
-            do writeIORef (agentStateRef agent) (Just st)
-               activate st p
-          st' <- transit target p
-          case st' of
-            Nothing ->
-              do writeIORef (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 :: AgentState -> Double -> Event () -> Event ()
-addTimeout st dt action =
-  Event $ \p ->
-  do v <- readIORef (stateVersionRef st)
-     let m1 = Event $ \p ->
-           do v' <- readIORef (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 :: AgentState -> Event Double -> Event () -> Event ()
-addTimer st dt action =
-  Event $ \p ->
-  do v <- readIORef (stateVersionRef st)
-     let m1 = Event $ \p ->
-           do v' <- readIORef (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 :: Agent -> Simulation AgentState
-newState agent =
-  Simulation $ \r ->
-  do aref <- newIORef $ return ()
-     dref <- newIORef $ return ()
-     tref <- newIORef $ return Nothing
-     vref <- newIORef 0
-     return AgentState { stateAgent = agent,
-                         stateParent = Nothing,
-                         stateActivateRef = aref,
-                         stateDeactivateRef = dref,
-                         stateTransitRef = tref,
-                         stateVersionRef = vref }
-
--- | Create a child state.
-newSubstate :: AgentState -> Simulation AgentState
-newSubstate parent =
-  Simulation $ \r ->
-  do let agent = stateAgent parent 
-     aref <- newIORef $ return ()
-     dref <- newIORef $ return ()
-     tref <- newIORef $ return Nothing
-     vref <- newIORef 0
-     return AgentState { stateAgent = agent,
-                         stateParent = Just parent,
-                         stateActivateRef= aref,
-                         stateDeactivateRef = dref,
-                         stateTransitRef = tref,
-                         stateVersionRef = vref }
-
--- | Create an agent.
-newAgent :: Simulation Agent
-newAgent =
-  Simulation $ \r ->
-  do modeRef  <- newIORef CreationMode
-     stateRef <- newIORef Nothing
-     stateChangedSource <- invokeSimulation r newSignalSource
-     return Agent { agentModeRef = modeRef,
-                    agentStateRef = stateRef, 
-                    agentStateChangedSource = stateChangedSource }
-
--- | Return the selected active state.
-selectedState :: Agent -> Event (Maybe AgentState)
-selectedState agent =
-  Event $ \p -> readIORef (agentStateRef agent)
-                   
--- | Select the state. The activation and selection are repeated while
--- there is the transition state defined by 'setStateTransition'.
-selectState :: AgentState -> Event ()
-selectState st =
-  Event $ \p ->
-  do let agent = stateAgent st
-     mode <- readIORef (agentModeRef agent)
-     case mode of
-       CreationMode ->
-         do x0 <- readIORef (agentStateRef agent)
-            invokeEvent p $ traversePath x0 st
-       TransientMode ->
-         error $
-         "Use the setStateTransition function to define " ++
-         "the transition state: activateState."
-       ProcessingMode ->
-         do x0 @ (Just st0) <- readIORef (agentStateRef agent)
-            invokeEvent p $ traversePath x0 st
-
--- | Set the activation computation for the specified state.
-setStateActivation :: AgentState -> Event () -> Simulation ()
-setStateActivation st action =
-  Simulation $ \r ->
-  writeIORef (stateActivateRef st) action
-  
--- | Set the deactivation computation for the specified state.
-setStateDeactivation :: AgentState -> Event () -> Simulation ()
-setStateDeactivation st action =
-  Simulation $ \r ->
-  writeIORef (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 :: AgentState -> Event (Maybe AgentState) -> Simulation ()
-setStateTransition st action =
-  Simulation $ \r ->
-  writeIORef (stateTransitRef st) action
-  
--- | Trigger the signal when the agent state changes.
-triggerAgentStateChanged :: Point -> Agent -> IO ()
-triggerAgentStateChanged p agent =
-  do st <- readIORef (agentStateRef agent)
-     invokeEvent p $ triggerSignal (agentStateChangedSource agent) st
-
--- | Return a signal that notifies about every change of the selected state.
-selectedStateChanged :: Agent -> Signal (Maybe AgentState)
-selectedStateChanged agent =
-  publishSignal (agentStateChangedSource agent)
-
--- | Return a signal that notifies about every change of the selected state.
-selectedStateChanged_ :: Agent -> Signal ()
-selectedStateChanged_ agent =
-  mapSignal (const ()) $ selectedStateChanged agent
++-- |+-- Module     : Simulation.Aivika.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.Agent+       (Agent,+        AgentState,+        newAgent,+        newState,+        newSubstate,+        selectedState,+        selectedStateChanged,+        selectedStateChanged_,+        selectState,+        stateAgent,+        stateParent,+        addTimeout,+        addTimer,+        setStateActivation,+        setStateDeactivation,+        setStateTransition) where++import Data.IORef+import Control.Monad++import Simulation.Aivika.Internal.Specs+import Simulation.Aivika.Internal.Simulation+import Simulation.Aivika.Internal.Event+import Simulation.Aivika.Internal.Signal++--+-- Agent-based Modeling+--++-- | Represents an agent.+data Agent = Agent { agentModeRef            :: IORef AgentMode,+                     agentStateRef           :: IORef (Maybe AgentState), +                     agentStateChangedSource :: SignalSource (Maybe AgentState) }++-- | Represents the agent state.+data AgentState = AgentState { stateAgent         :: Agent,+                               -- ^ Return the corresponded agent.+                               stateParent        :: Maybe AgentState,+                               -- ^ Return the parent state or 'Nothing'.+                               stateActivateRef   :: IORef (Event ()),+                               stateDeactivateRef :: IORef (Event ()),+                               stateTransitRef    :: IORef (Event (Maybe AgentState)),+                               stateVersionRef    :: IORef Int }+                  +data AgentMode = CreationMode+               | TransientMode+               | ProcessingMode+                      +instance Eq Agent where+  x == y = agentStateRef x == agentStateRef y      -- unique references+  +instance Eq AgentState where+  x == y = stateVersionRef x == stateVersionRef y  -- unique references++fullPath :: AgentState -> [AgentState] -> [AgentState]+fullPath st acc =+  case stateParent st of+    Nothing  -> st : acc+    Just st' -> fullPath st' (st : acc)++partitionPath :: [AgentState] -> [AgentState] -> ([AgentState], [AgentState])+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 :: Maybe AgentState -> AgentState -> ([AgentState], [AgentState])+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 :: Maybe AgentState -> AgentState -> Event ()+traversePath source target =+  let (path1, path2) = findPath source target+      agent = stateAgent target+      activate st p   = invokeEvent p =<< readIORef (stateActivateRef st)+      deactivate st p = invokeEvent p =<< readIORef (stateDeactivateRef st)+      transit st p    = invokeEvent p =<< readIORef (stateTransitRef st)+      continue st p   = invokeEvent p $ traversePath (Just target) st+  in Event $ \p ->+       unless (null path1 && null path2) $+       do writeIORef (agentModeRef agent) TransientMode+          forM_ path1 $ \st ->+            do writeIORef (agentStateRef agent) (Just st)+               deactivate st p+               -- it makes all timeout and timer handlers outdated+               modifyIORef (stateVersionRef st) (1 +)+          forM_ path2 $ \st ->+            do writeIORef (agentStateRef agent) (Just st)+               activate st p+          st' <- transit target p+          case st' of+            Nothing ->+              do writeIORef (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 :: AgentState -> Double -> Event () -> Event ()+addTimeout st dt action =+  Event $ \p ->+  do v <- readIORef (stateVersionRef st)+     let m1 = Event $ \p ->+           do v' <- readIORef (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 :: AgentState -> Event Double -> Event () -> Event ()+addTimer st dt action =+  Event $ \p ->+  do v <- readIORef (stateVersionRef st)+     let m1 = Event $ \p ->+           do v' <- readIORef (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 :: Agent -> Simulation AgentState+newState agent =+  Simulation $ \r ->+  do aref <- newIORef $ return ()+     dref <- newIORef $ return ()+     tref <- newIORef $ return Nothing+     vref <- newIORef 0+     return AgentState { stateAgent = agent,+                         stateParent = Nothing,+                         stateActivateRef = aref,+                         stateDeactivateRef = dref,+                         stateTransitRef = tref,+                         stateVersionRef = vref }++-- | Create a child state.+newSubstate :: AgentState -> Simulation AgentState+newSubstate parent =+  Simulation $ \r ->+  do let agent = stateAgent parent +     aref <- newIORef $ return ()+     dref <- newIORef $ return ()+     tref <- newIORef $ return Nothing+     vref <- newIORef 0+     return AgentState { stateAgent = agent,+                         stateParent = Just parent,+                         stateActivateRef= aref,+                         stateDeactivateRef = dref,+                         stateTransitRef = tref,+                         stateVersionRef = vref }++-- | Create an agent.+newAgent :: Simulation Agent+newAgent =+  Simulation $ \r ->+  do modeRef  <- newIORef CreationMode+     stateRef <- newIORef Nothing+     stateChangedSource <- invokeSimulation r newSignalSource+     return Agent { agentModeRef = modeRef,+                    agentStateRef = stateRef, +                    agentStateChangedSource = stateChangedSource }++-- | Return the selected active state.+selectedState :: Agent -> Event (Maybe AgentState)+selectedState agent =+  Event $ \p -> readIORef (agentStateRef agent)+                   +-- | Select the state. The activation and selection are repeated while+-- there is the transition state defined by 'setStateTransition'.+selectState :: AgentState -> Event ()+selectState st =+  Event $ \p ->+  do let agent = stateAgent st+     mode <- readIORef (agentModeRef agent)+     case mode of+       CreationMode ->+         do x0 <- readIORef (agentStateRef agent)+            invokeEvent p $ traversePath x0 st+       TransientMode ->+         error $+         "Use the setStateTransition function to define " +++         "the transition state: activateState."+       ProcessingMode ->+         do x0 @ (Just st0) <- readIORef (agentStateRef agent)+            invokeEvent p $ traversePath x0 st++-- | Set the activation computation for the specified state.+setStateActivation :: AgentState -> Event () -> Simulation ()+setStateActivation st action =+  Simulation $ \r ->+  writeIORef (stateActivateRef st) action+  +-- | Set the deactivation computation for the specified state.+setStateDeactivation :: AgentState -> Event () -> Simulation ()+setStateDeactivation st action =+  Simulation $ \r ->+  writeIORef (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 :: AgentState -> Event (Maybe AgentState) -> Simulation ()+setStateTransition st action =+  Simulation $ \r ->+  writeIORef (stateTransitRef st) action+  +-- | Trigger the signal when the agent state changes.+triggerAgentStateChanged :: Point -> Agent -> IO ()+triggerAgentStateChanged p agent =+  do st <- readIORef (agentStateRef agent)+     invokeEvent p $ triggerSignal (agentStateChangedSource agent) st++-- | Return a signal that notifies about every change of the selected state.+selectedStateChanged :: Agent -> Signal (Maybe AgentState)+selectedStateChanged agent =+  publishSignal (agentStateChangedSource agent)++-- | Return a signal that notifies about every change of the selected state.+selectedStateChanged_ :: Agent -> Signal ()+selectedStateChanged_ agent =+  mapSignal (const ()) $ selectedStateChanged agent

@@ -1,77 +1,77 @@-
--- |
--- Module     : Simulation.Aivika.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.Arrival
-       (Arrival(..),
-        ArrivalTimer,
-        newArrivalTimer,
-        arrivalTimerProcessor,
-        arrivalProcessingTime,
-        arrivalProcessingTimeChanged,
-        arrivalProcessingTimeChanged_) where
-
-import Control.Monad
-import Control.Monad.Trans
-
-import Simulation.Aivika.Simulation
-import Simulation.Aivika.Dynamics
-import Simulation.Aivika.Event
-import Simulation.Aivika.Processor
-import Simulation.Aivika.Stream
-import Simulation.Aivika.Statistics
-import Simulation.Aivika.Ref
-import Simulation.Aivika.Signal
-import Simulation.Aivika.Internal.Arrival
-
--- | Accumulates the statistics about that how long the arrived events are processed.
-data ArrivalTimer =
-  ArrivalTimer { arrivalProcessingTimeRef :: Ref (SamplingStats Double),
-                 arrivalProcessingTimeChangedSource :: SignalSource () }
-
--- | Create a new timer that measures how long the arrived events are processed.
-newArrivalTimer :: Simulation ArrivalTimer
-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 :: ArrivalTimer -> Event (SamplingStats Double)
-arrivalProcessingTime = readRef . arrivalProcessingTimeRef
-
--- | Return a signal raised when the the processing time statistics changes.
-arrivalProcessingTimeChanged :: ArrivalTimer -> Signal (SamplingStats Double)
-arrivalProcessingTimeChanged timer =
-  mapSignalM (const $ arrivalProcessingTime timer) (arrivalProcessingTimeChanged_ timer)
-
--- | Return a signal raised when the the processing time statistics changes.
-arrivalProcessingTimeChanged_ :: ArrivalTimer -> Signal ()
-arrivalProcessingTimeChanged_ timer =
-  publishSignal (arrivalProcessingTimeChangedSource timer)
-
--- | Return a processor that actually measures how much time has passed from
--- the time of arriving the events.
-arrivalTimerProcessor :: ArrivalTimer -> Processor (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.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.Arrival+       (Arrival(..),+        ArrivalTimer,+        newArrivalTimer,+        arrivalTimerProcessor,+        arrivalProcessingTime,+        arrivalProcessingTimeChanged,+        arrivalProcessingTimeChanged_) where++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Simulation+import Simulation.Aivika.Dynamics+import Simulation.Aivika.Event+import Simulation.Aivika.Processor+import Simulation.Aivika.Stream+import Simulation.Aivika.Statistics+import Simulation.Aivika.Ref+import Simulation.Aivika.Signal+import Simulation.Aivika.Internal.Arrival++-- | Accumulates the statistics about that how long the arrived events are processed.+data ArrivalTimer =+  ArrivalTimer { arrivalProcessingTimeRef :: Ref (SamplingStats Double),+                 arrivalProcessingTimeChangedSource :: SignalSource () }++-- | Create a new timer that measures how long the arrived events are processed.+newArrivalTimer :: Simulation ArrivalTimer+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 :: ArrivalTimer -> Event (SamplingStats Double)+arrivalProcessingTime = readRef . arrivalProcessingTimeRef++-- | Return a signal raised when the the processing time statistics changes.+arrivalProcessingTimeChanged :: ArrivalTimer -> Signal (SamplingStats Double)+arrivalProcessingTimeChanged timer =+  mapSignalM (const $ arrivalProcessingTime timer) (arrivalProcessingTimeChanged_ timer)++-- | Return a signal raised when the the processing time statistics changes.+arrivalProcessingTimeChanged_ :: ArrivalTimer -> Signal ()+arrivalProcessingTimeChanged_ timer =+  publishSignal (arrivalProcessingTimeChangedSource timer)++-- | Return a processor that actually measures how much time has passed from+-- the time of arriving the events.+arrivalTimerProcessor :: ArrivalTimer -> Processor (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)

@@ -1,379 +1,494 @@-
-{-# LANGUAGE RecursiveDo, Arrows #-}
-
--- |
--- Module     : Simulation.Aivika.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.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 Data.IORef
-
-import Simulation.Aivika.Internal.Arrival
-import Simulation.Aivika.Internal.Specs
-import Simulation.Aivika.Internal.Simulation
-import Simulation.Aivika.Internal.Dynamics
-import Simulation.Aivika.Internal.Event
-import Simulation.Aivika.Dynamics.Memo
-import Simulation.Aivika.Transform
-import Simulation.Aivika.SystemDynamics
-import Simulation.Aivika.Signal
-import Simulation.Aivika.Stream
-import Simulation.Aivika.Processor
-
--- | Represents a circuit synchronized with the event queue.
--- Besides, it allows creating the recursive links with help of
--- the proc-notation.
---
-newtype Circuit a b =
-  Circuit { runCircuit :: a -> Event (b, Circuit a b)
-            -- ^ Run the circuit.
-          }
-
-instance C.Category Circuit 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 Arrow Circuit 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 ArrowLoop Circuit where
-
-  loop (Circuit f) =
-    Circuit $ \b ->
-    Event $ \p ->
-    do rec ((c, d), cir) <- invokeEvent p (f (b, d))
-       return (c, loop cir)
-
-instance ArrowChoice Circuit 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 :: Circuit a b -> Signal a -> Signal b
-circuitSignaling (Circuit cir) sa =
-  Signal { handleSignal = \f ->
-            Event $ \p ->
-            do r <- newIORef cir
-               invokeEvent p $
-                 handleSignal sa $ \a ->
-                 Event $ \p ->
-                 do cir <- readIORef r
-                    (b, Circuit cir') <- invokeEvent p (cir a)
-                    writeIORef r cir'
-                    invokeEvent p (f b) }
-
--- | Transform the circuit to a processor.
-circuitProcessor :: Circuit a b -> Processor 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 :: (a -> Event b) -> Circuit 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 :: (acc -> a -> Event (acc, b)) -> acc -> Circuit 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 :: Circuit 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 :: a -> Circuit a a
-delayCircuit a0 =
-  Circuit $ \a ->
-  return (a0, delayCircuit a)
-
--- | A circuit that returns the current modeling time.
-timeCircuit :: Circuit a Double
-timeCircuit =
-  Circuit $ \a ->
-  Event $ \p ->
-  return (pointTime p, timeCircuit)
-
--- | Like '>>>' but processes only the represented events.
-(>?>) :: Circuit a (Maybe b)
-         -- ^ whether there is an event
-         -> Circuit b c
-         -- ^ process the event if it presents
-         -> Circuit a (Maybe c)
-         -- ^ the resulting circuit that processes only the represented events
-whether >?> process =
-  Circuit $ \a ->
-  Event $ \p ->
-  do (b, whether') <- invokeEvent p (runCircuit whether a)
-     case b of
-       Nothing ->
-         return (Nothing, whether' >?> process)
-       Just b  ->
-         do (c, process') <- invokeEvent p (runCircuit process b)
-            return (Just c, whether' >?> process')
-
--- | Like '<<<' but processes only the represented events.
-(<?<) :: Circuit b c
-         -- ^ process the event if it presents
-         -> Circuit a (Maybe b)
-         -- ^ whether there is an event
-         -> Circuit 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 :: (a -> Bool) -> Circuit a b -> Circuit 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 :: (a -> Event Bool) -> Circuit a b -> Circuit 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 :: Circuit 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 :: Double
-                -- ^ the initial value
-                -> Circuit 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 :: Num a =>
-              a
-              -- ^ the initial value
-              -> Circuit 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 :: Circuit a b -> Transform a b
-circuitTransform cir = Transform start
-  where
-    start m =
-      Simulation $ \r ->
-      do ref <- newIORef cir
-         invokeSimulation r $
-           memo0Dynamics (next ref m)
-    next ref m =
-      Dynamics $ \p ->
-      do a <- invokeDynamics p m
-         cir <- readIORef ref
-         (b, cir') <-
-           invokeDynamics p $
-           runEvent (runCircuit cir a)
-         writeIORef ref cir'
-         return b
++{-# LANGUAGE RecursiveDo, Arrows #-}++-- |+-- Module     : Simulation.Aivika.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.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 Data.IORef++import Simulation.Aivika.Internal.Arrival+import Simulation.Aivika.Internal.Specs+import Simulation.Aivika.Internal.Simulation+import Simulation.Aivika.Internal.Dynamics+import Simulation.Aivika.Internal.Event+import Simulation.Aivika.Dynamics.Memo+import Simulation.Aivika.Transform+import Simulation.Aivika.SystemDynamics+import Simulation.Aivika.Signal+import Simulation.Aivika.Stream+import Simulation.Aivika.Process+import Simulation.Aivika.Processor+import Simulation.Aivika.Task++-- | Represents a circuit synchronized with the event queue.+-- Besides, it allows creating the recursive links with help of+-- the proc-notation.+--+newtype Circuit a b =+  Circuit { runCircuit :: a -> Event (b, Circuit a b)+            -- ^ Run the circuit.+          }++instance C.Category Circuit 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 Arrow Circuit 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 ArrowLoop Circuit where++  loop (Circuit f) =+    Circuit $ \b ->+    Event $ \p ->+    do rec ((c, d), cir) <- invokeEvent p (f (b, d))+       return (c, loop cir)++instance ArrowChoice Circuit 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 :: Circuit a b -> Signal a -> Signal b+circuitSignaling (Circuit cir) sa =+  Signal { handleSignal = \f ->+            Event $ \p ->+            do r <- newIORef cir+               invokeEvent p $+                 handleSignal sa $ \a ->+                 Event $ \p ->+                 do cir <- readIORef r+                    (b, Circuit cir') <- invokeEvent p (cir a)+                    writeIORef r cir'+                    invokeEvent p (f b) }++-- | Transform the circuit to a processor.+circuitProcessor :: Circuit a b -> Processor 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 :: (a -> Event b) -> Circuit 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 :: (acc -> a -> Event (acc, b)) -> acc -> Circuit 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 :: Circuit 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 :: a -> Circuit a a+delayCircuit a0 =+  Circuit $ \a ->+  return (a0, delayCircuit a)++-- | A circuit that returns the current modeling time.+timeCircuit :: Circuit a Double+timeCircuit =+  Circuit $ \a ->+  Event $ \p ->+  return (pointTime p, timeCircuit)++-- | Like '>>>' but processes only the represented events.+(>?>) :: Circuit a (Maybe b)+         -- ^ whether there is an event+         -> Circuit b c+         -- ^ process the event if it presents+         -> Circuit a (Maybe c)+         -- ^ the resulting circuit that processes only the represented events+whether >?> process =+  Circuit $ \a ->+  Event $ \p ->+  do (b, whether') <- invokeEvent p (runCircuit whether a)+     case b of+       Nothing ->+         return (Nothing, whether' >?> process)+       Just b  ->+         do (c, process') <- invokeEvent p (runCircuit process b)+            return (Just c, whether' >?> process')++-- | Like '<<<' but processes only the represented events.+(<?<) :: Circuit b c+         -- ^ process the event if it presents+         -> Circuit a (Maybe b)+         -- ^ whether there is an event+         -> Circuit 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 :: (a -> Bool) -> Circuit a b -> Circuit 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 :: (a -> Event Bool) -> Circuit a b -> Circuit 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 :: Circuit 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 :: Double+                -- ^ the initial value+                -> Circuit 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 :: Double+                      -- ^ the initial value+                      -> Circuit (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 :: Num a =>+              a+              -- ^ the initial value+              -> Circuit 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 :: Num a =>+                    a+                    -- ^ the initial value+                    -> Circuit (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 :: Circuit a b -> Transform a b+circuitTransform cir = Transform start+  where+    start m =+      Simulation $ \r ->+      do ref <- newIORef cir+         invokeSimulation r $+           memo0Dynamics (next ref m)+    next ref m =+      Dynamics $ \p ->+      do a <- invokeDynamics p m+         cir <- readIORef ref+         (b, cir') <-+           invokeDynamics p $+           runEvent (runCircuit cir a)+         writeIORef ref cir'+         return b++-- | Iterate the circuit in the specified time points.+iterateCircuitInPoints_ :: [Point] -> Circuit a a -> a -> Event ()+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 :: [Point] -> Circuit a a -> a -> Event (Task 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_ :: Circuit a a -> a -> Event ()+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_ :: [Double] -> Circuit a a -> a -> Event ()+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 :: Circuit a a -> a -> Event (Task 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 :: [Double] -> Circuit a a -> a -> Event (Task a)+iterateCircuitInTimes ts cir a =+  Event $ \p ->+  do let ps = map (pointAt $ pointRun p) ts+     invokeEvent p $ +       iterateCircuitInPoints ps cir a 

@@ -1,19 +1,19 @@-
--- |
--- Module     : Simulation.Aivika.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.Cont
-       (ContCancellation(..),
-        Cont) where
-
-import Simulation.Aivika.Internal.Event
-import Simulation.Aivika.Internal.Cont
++-- |+-- Module     : Simulation.Aivika.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.Cont+       (ContCancellation(..),+        Cont) where++import Simulation.Aivika.Internal.Event+import Simulation.Aivika.Internal.Cont

@@ -1,165 +1,165 @@-
--- |
--- Module     : Simulation.Aivika.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.DoubleLinkedList 
-       (DoubleLinkedList, 
-        listNull, 
-        listCount,
-        newList, 
-        listInsertFirst,
-        listAddLast,
-        listRemoveFirst,
-        listRemoveLast,
-        listFirst,
-        listLast) where 
-
-import Data.IORef
-import Control.Monad
-
--- | A cell of the double-linked list.
-data DoubleLinkedItem a = 
-  DoubleLinkedItem { itemVal  :: a,
-                     itemPrev :: IORef (Maybe (DoubleLinkedItem a)),
-                     itemNext :: IORef (Maybe (DoubleLinkedItem a)) }
-  
--- | The 'DoubleLinkedList' type represents an imperative double-linked list.
-data DoubleLinkedList a =  
-  DoubleLinkedList { listHead :: IORef (Maybe (DoubleLinkedItem a)),
-                     listTail :: IORef (Maybe (DoubleLinkedItem a)), 
-                     listSize :: IORef Int }
-
--- | Test whether the list is empty.
-listNull :: DoubleLinkedList a -> IO Bool
-listNull x =
-  do head <- readIORef (listHead x) 
-     case head of
-       Nothing -> return True
-       Just _  -> return False
-    
--- | Return the number of elements in the list.
-listCount :: DoubleLinkedList a -> IO Int
-listCount x = readIORef (listSize x)
-
--- | Create a new list.
-newList :: IO (DoubleLinkedList a)
-newList =
-  do head <- newIORef Nothing 
-     tail <- newIORef Nothing
-     size <- newIORef 0
-     return DoubleLinkedList { listHead = head,
-                               listTail = tail,
-                               listSize = size }
-
--- | Insert a new element in the beginning.
-listInsertFirst :: DoubleLinkedList a -> a -> IO ()
-listInsertFirst x v =
-  do size <- readIORef (listSize x)
-     writeIORef (listSize x) (size + 1)
-     head <- readIORef (listHead x)
-     case head of
-       Nothing ->
-         do prev <- newIORef Nothing
-            next <- newIORef Nothing
-            let item = Just DoubleLinkedItem { itemVal = v, 
-                                               itemPrev = prev, 
-                                               itemNext = next }
-            writeIORef (listHead x) item
-            writeIORef (listTail x) item
-       Just h ->
-         do prev <- newIORef Nothing
-            next <- newIORef head
-            let item = Just DoubleLinkedItem { itemVal = v,
-                                               itemPrev = prev,
-                                               itemNext = next }
-            writeIORef (itemPrev h) item
-            writeIORef (listHead x) item
-
--- | Add a new element to the end.
-listAddLast :: DoubleLinkedList a -> a -> IO ()
-listAddLast x v =
-  do size <- readIORef (listSize x)
-     writeIORef (listSize x) (size + 1)
-     tail <- readIORef (listTail x)
-     case tail of
-       Nothing ->
-         do prev <- newIORef Nothing
-            next <- newIORef Nothing
-            let item = Just DoubleLinkedItem { itemVal = v, 
-                                               itemPrev = prev, 
-                                               itemNext = next }
-            writeIORef (listHead x) item
-            writeIORef (listTail x) item
-       Just t ->
-         do prev <- newIORef tail
-            next <- newIORef Nothing
-            let item = Just DoubleLinkedItem { itemVal = v,
-                                               itemPrev = prev,
-                                               itemNext = next }
-            writeIORef (itemNext t) item
-            writeIORef (listTail x) item
-
--- | Remove the first element.
-listRemoveFirst :: DoubleLinkedList a -> IO ()
-listRemoveFirst x =
-  do head <- readIORef (listHead x) 
-     case head of
-       Nothing ->
-         error "Empty list: listRemoveFirst"
-       Just h ->
-         do size  <- readIORef (listSize x)
-            writeIORef (listSize x) (size - 1)
-            head' <- readIORef (itemNext h)
-            case head' of
-              Nothing ->
-                do writeIORef (listHead x) Nothing
-                   writeIORef (listTail x) Nothing
-              Just h' ->
-                do writeIORef (itemPrev h') Nothing
-                   writeIORef (listHead x) head'
-
--- | Remove the last element.
-listRemoveLast :: DoubleLinkedList a -> IO ()
-listRemoveLast x =
-  do tail <- readIORef (listTail x) 
-     case tail of
-       Nothing ->
-         error "Empty list: listRemoveLast"
-       Just t ->
-         do size  <- readIORef (listSize x)
-            writeIORef (listSize x) (size - 1)
-            tail' <- readIORef (itemPrev t)
-            case tail' of
-              Nothing ->
-                do writeIORef (listHead x) Nothing
-                   writeIORef (listTail x) Nothing
-              Just t' ->
-                do writeIORef (itemNext t') Nothing
-                   writeIORef (listTail x) tail'
-
--- | Return the first element.
-listFirst :: DoubleLinkedList a -> IO a
-listFirst x =
-  do head <- readIORef (listHead x)
-     case head of
-       Nothing ->
-         error "Empty list: listFirst"
-       Just h ->
-         return $ itemVal h
-
--- | Return the last element.
-listLast :: DoubleLinkedList a -> IO a
-listLast x =
-  do tail <- readIORef (listTail x)
-     case tail of
-       Nothing ->
-         error "Empty list: listLast"
-       Just t ->
-         return $ itemVal t
++-- |+-- Module     : Simulation.Aivika.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.DoubleLinkedList +       (DoubleLinkedList, +        listNull, +        listCount,+        newList, +        listInsertFirst,+        listAddLast,+        listRemoveFirst,+        listRemoveLast,+        listFirst,+        listLast) where ++import Data.IORef+import Control.Monad++-- | A cell of the double-linked list.+data DoubleLinkedItem a = +  DoubleLinkedItem { itemVal  :: a,+                     itemPrev :: IORef (Maybe (DoubleLinkedItem a)),+                     itemNext :: IORef (Maybe (DoubleLinkedItem a)) }+  +-- | The 'DoubleLinkedList' type represents an imperative double-linked list.+data DoubleLinkedList a =  +  DoubleLinkedList { listHead :: IORef (Maybe (DoubleLinkedItem a)),+                     listTail :: IORef (Maybe (DoubleLinkedItem a)), +                     listSize :: IORef Int }++-- | Test whether the list is empty.+listNull :: DoubleLinkedList a -> IO Bool+listNull x =+  do head <- readIORef (listHead x) +     case head of+       Nothing -> return True+       Just _  -> return False+    +-- | Return the number of elements in the list.+listCount :: DoubleLinkedList a -> IO Int+listCount x = readIORef (listSize x)++-- | Create a new list.+newList :: IO (DoubleLinkedList a)+newList =+  do head <- newIORef Nothing +     tail <- newIORef Nothing+     size <- newIORef 0+     return DoubleLinkedList { listHead = head,+                               listTail = tail,+                               listSize = size }++-- | Insert a new element in the beginning.+listInsertFirst :: DoubleLinkedList a -> a -> IO ()+listInsertFirst x v =+  do size <- readIORef (listSize x)+     writeIORef (listSize x) (size + 1)+     head <- readIORef (listHead x)+     case head of+       Nothing ->+         do prev <- newIORef Nothing+            next <- newIORef Nothing+            let item = Just DoubleLinkedItem { itemVal = v, +                                               itemPrev = prev, +                                               itemNext = next }+            writeIORef (listHead x) item+            writeIORef (listTail x) item+       Just h ->+         do prev <- newIORef Nothing+            next <- newIORef head+            let item = Just DoubleLinkedItem { itemVal = v,+                                               itemPrev = prev,+                                               itemNext = next }+            writeIORef (itemPrev h) item+            writeIORef (listHead x) item++-- | Add a new element to the end.+listAddLast :: DoubleLinkedList a -> a -> IO ()+listAddLast x v =+  do size <- readIORef (listSize x)+     writeIORef (listSize x) (size + 1)+     tail <- readIORef (listTail x)+     case tail of+       Nothing ->+         do prev <- newIORef Nothing+            next <- newIORef Nothing+            let item = Just DoubleLinkedItem { itemVal = v, +                                               itemPrev = prev, +                                               itemNext = next }+            writeIORef (listHead x) item+            writeIORef (listTail x) item+       Just t ->+         do prev <- newIORef tail+            next <- newIORef Nothing+            let item = Just DoubleLinkedItem { itemVal = v,+                                               itemPrev = prev,+                                               itemNext = next }+            writeIORef (itemNext t) item+            writeIORef (listTail x) item++-- | Remove the first element.+listRemoveFirst :: DoubleLinkedList a -> IO ()+listRemoveFirst x =+  do head <- readIORef (listHead x) +     case head of+       Nothing ->+         error "Empty list: listRemoveFirst"+       Just h ->+         do size  <- readIORef (listSize x)+            writeIORef (listSize x) (size - 1)+            head' <- readIORef (itemNext h)+            case head' of+              Nothing ->+                do writeIORef (listHead x) Nothing+                   writeIORef (listTail x) Nothing+              Just h' ->+                do writeIORef (itemPrev h') Nothing+                   writeIORef (listHead x) head'++-- | Remove the last element.+listRemoveLast :: DoubleLinkedList a -> IO ()+listRemoveLast x =+  do tail <- readIORef (listTail x) +     case tail of+       Nothing ->+         error "Empty list: listRemoveLast"+       Just t ->+         do size  <- readIORef (listSize x)+            writeIORef (listSize x) (size - 1)+            tail' <- readIORef (itemPrev t)+            case tail' of+              Nothing ->+                do writeIORef (listHead x) Nothing+                   writeIORef (listTail x) Nothing+              Just t' ->+                do writeIORef (itemNext t') Nothing+                   writeIORef (listTail x) tail'++-- | Return the first element.+listFirst :: DoubleLinkedList a -> IO a+listFirst x =+  do head <- readIORef (listHead x)+     case head of+       Nothing ->+         error "Empty list: listFirst"+       Just h ->+         return $ itemVal h++-- | Return the last element.+listLast :: DoubleLinkedList a -> IO a+listLast x =+  do tail <- readIORef (listTail x)+     case tail of+       Nothing ->+         error "Empty list: listLast"+       Just t ->+         return $ itemVal t

@@ -1,31 +1,31 @@-
--- |
--- Module     : Simulation.Aivika.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 representing a time varying polymorphic function. 
---
-module Simulation.Aivika.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.Internal.Dynamics
++-- |+-- Module     : Simulation.Aivika.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 representing a time varying polymorphic function. +--+module Simulation.Aivika.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.Internal.Dynamics

@@ -1,109 +1,109 @@-
-{-# LANGUAGE RecursiveDo #-}
-
--- |
--- Module     : Simulation.Aivika.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.Dynamics.Extra
-       (-- * Interpolation
-        initDynamics,
-        discreteDynamics,
-        interpolateDynamics,
-        -- * Scans
-        scanDynamics,
-        scan1Dynamics) where
-
-import Simulation.Aivika.Internal.Specs
-import Simulation.Aivika.Internal.Simulation
-import Simulation.Aivika.Internal.Dynamics
-
--- | Return the initial value.
-initDynamics :: Dynamics a -> Dynamics 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 a -> Dynamics 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 a -> Dynamics 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 :: (a -> a -> a)
-                 -> (Dynamics a -> Simulation (Dynamics a))
-                 -> (Dynamics a -> Simulation (Dynamics 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 :: (a -> b -> a)
-                -> a
-                -> (Dynamics a -> Simulation (Dynamics a))
-                -> (Dynamics b -> Simulation (Dynamics 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.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.Dynamics.Extra+       (-- * Interpolation+        initDynamics,+        discreteDynamics,+        interpolateDynamics,+        -- * Scans+        scanDynamics,+        scan1Dynamics) where++import Simulation.Aivika.Internal.Specs+import Simulation.Aivika.Internal.Simulation+import Simulation.Aivika.Internal.Dynamics++-- | Return the initial value.+initDynamics :: Dynamics a -> Dynamics 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 a -> Dynamics 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 a -> Dynamics 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 :: (a -> a -> a)+                 -> (Dynamics a -> Simulation (Dynamics a))+                 -> (Dynamics a -> Simulation (Dynamics 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 :: (a -> b -> a)+                -> a+                -> (Dynamics a -> Simulation (Dynamics a))+                -> (Dynamics b -> Simulation (Dynamics 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

@@ -1,159 +1,159 @@-
--- |
--- Module     : Simulation.Aivika.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.Dynamics.Memo
-       (memoDynamics,
-        memo0Dynamics,
-        iterateDynamics,
-        unzipDynamics,
-        unzip0Dynamics) where
-
-import Data.Array
-import Data.Array.IO.Safe
-import Data.IORef
-import Control.Monad
-
-import Simulation.Aivika.Internal.Specs
-import Simulation.Aivika.Internal.Parameter
-import Simulation.Aivika.Internal.Simulation
-import Simulation.Aivika.Internal.Dynamics
-import Simulation.Aivika.Dynamics.Extra
-
--- | Create a boxed array with default values.
-newBoxedArray_ :: Ix i => (i, i) -> IO (IOArray i e)
-newBoxedArray_ = newArray_
-
--- | Memoize and order the computation in the integration time points using 
--- the interpolation that knows of the Runge-Kutta method. The values are
--- calculated sequentially starting from 'starttime'.
-memoDynamics :: Dynamics e -> Simulation (Dynamics e)
-{-# INLINE memoDynamics #-}
-memoDynamics (Dynamics m) = 
-  Simulation $ \r ->
-  do let sc = runSpecs r
-         (phl, phu) = integPhaseBnds sc
-         (nl, nu)   = integIterationBnds sc
-     arr   <- newBoxedArray_ ((phl, nl), (phu, nu))
-     nref  <- newIORef 0
-     phref <- newIORef 0
-     let r p = 
-           do let sc  = pointSpecs p
-                  n   = pointIteration p
-                  ph  = pointPhase p
-                  phu = integPhaseHiBnd sc 
-                  loop n' ph' = 
-                    if (n' > n) || ((n' == n) && (ph' > ph)) 
-                    then 
-                      readArray arr (ph, n)
-                    else 
-                      let p' = p { pointIteration = n', pointPhase = ph',
-                                   pointTime = basicTime sc n' ph' }
-                      in do a <- m p'
-                            a `seq` writeArray arr (ph', n') a
-                            if ph' >= phu 
-                              then do writeIORef phref 0
-                                      writeIORef nref (n' + 1)
-                                      loop (n' + 1) 0
-                              else do writeIORef phref (ph' + 1)
-                                      loop n' (ph' + 1)
-              n'  <- readIORef nref
-              ph' <- readIORef 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 :: Dynamics e -> Simulation (Dynamics e)
-{-# INLINE memo0Dynamics #-}
-memo0Dynamics (Dynamics m) = 
-  Simulation $ \r ->
-  do let sc   = runSpecs r
-         bnds = integIterationBnds sc
-     arr  <- newBoxedArray_ bnds
-     nref <- newIORef 0
-     let r p =
-           do let sc = pointSpecs p
-                  n  = pointIteration p
-                  loop n' = 
-                    if n' > n
-                    then 
-                      readArray arr n
-                    else 
-                      let p' = p { pointIteration = n', pointPhase = 0,
-                                   pointTime = basicTime sc n' 0 }
-                      in do a <- m p'
-                            a `seq` writeArray arr n' a
-                            writeIORef nref (n' + 1)
-                            loop (n' + 1)
-              n' <- readIORef 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 :: Dynamics () -> Simulation (Dynamics ())
-{-# INLINE iterateDynamics #-}
-iterateDynamics (Dynamics m) = 
-  Simulation $ \r ->
-  do let sc = runSpecs r
-     nref <- newIORef 0
-     let r p =
-           do let sc = pointSpecs p
-                  n  = pointIteration p
-                  loop n' = 
-                    unless (n' > n) $
-                    let p' = p { pointIteration = n', pointPhase = 0,
-                                 pointTime = basicTime sc n' 0 }
-                    in do a <- m p'
-                          a `seq` writeIORef nref (n' + 1)
-                          loop (n' + 1)
-              n' <- readIORef nref
-              loop n'
-     return $ discreteDynamics $ Dynamics r
-
--- | Memoize and unzip the computation of pairs, applying the 'memoDynamics' function.
-unzipDynamics :: Dynamics (a, b) -> Simulation (Dynamics a, Dynamics 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 :: Dynamics (a, b) -> Simulation (Dynamics a, Dynamics 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.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.Dynamics.Memo+       (memoDynamics,+        memo0Dynamics,+        iterateDynamics,+        unzipDynamics,+        unzip0Dynamics) where++import Data.Array+import Data.Array.IO.Safe+import Data.IORef+import Control.Monad++import Simulation.Aivika.Internal.Specs+import Simulation.Aivika.Internal.Parameter+import Simulation.Aivika.Internal.Simulation+import Simulation.Aivika.Internal.Dynamics+import Simulation.Aivika.Dynamics.Extra++-- | Create a boxed array with default values.+newBoxedArray_ :: Ix i => (i, i) -> IO (IOArray i e)+newBoxedArray_ = newArray_++-- | Memoize and order the computation in the integration time points using +-- the interpolation that knows of the Runge-Kutta method. The values are+-- calculated sequentially starting from 'starttime'.+memoDynamics :: Dynamics e -> Simulation (Dynamics e)+{-# INLINE memoDynamics #-}+memoDynamics (Dynamics m) = +  Simulation $ \r ->+  do let sc = runSpecs r+         (phl, phu) = integPhaseBnds sc+         (nl, nu)   = integIterationBnds sc+     arr   <- newBoxedArray_ ((phl, nl), (phu, nu))+     nref  <- newIORef 0+     phref <- newIORef 0+     let r p = +           do let sc  = pointSpecs p+                  n   = pointIteration p+                  ph  = pointPhase p+                  phu = integPhaseHiBnd sc +                  loop n' ph' = +                    if (n' > n) || ((n' == n) && (ph' > ph)) +                    then +                      readArray arr (ph, n)+                    else +                      let p' = p { pointIteration = n', pointPhase = ph',+                                   pointTime = basicTime sc n' ph' }+                      in do a <- m p'+                            a `seq` writeArray arr (ph', n') a+                            if ph' >= phu +                              then do writeIORef phref 0+                                      writeIORef nref (n' + 1)+                                      loop (n' + 1) 0+                              else do writeIORef phref (ph' + 1)+                                      loop n' (ph' + 1)+              n'  <- readIORef nref+              ph' <- readIORef 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 :: Dynamics e -> Simulation (Dynamics e)+{-# INLINE memo0Dynamics #-}+memo0Dynamics (Dynamics m) = +  Simulation $ \r ->+  do let sc   = runSpecs r+         bnds = integIterationBnds sc+     arr  <- newBoxedArray_ bnds+     nref <- newIORef 0+     let r p =+           do let sc = pointSpecs p+                  n  = pointIteration p+                  loop n' = +                    if n' > n+                    then +                      readArray arr n+                    else +                      let p' = p { pointIteration = n', pointPhase = 0,+                                   pointTime = basicTime sc n' 0 }+                      in do a <- m p'+                            a `seq` writeArray arr n' a+                            writeIORef nref (n' + 1)+                            loop (n' + 1)+              n' <- readIORef 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 :: Dynamics () -> Simulation (Dynamics ())+{-# INLINE iterateDynamics #-}+iterateDynamics (Dynamics m) = +  Simulation $ \r ->+  do let sc = runSpecs r+     nref <- newIORef 0+     let r p =+           do let sc = pointSpecs p+                  n  = pointIteration p+                  loop n' = +                    unless (n' > n) $+                    let p' = p { pointIteration = n', pointPhase = 0,+                                 pointTime = basicTime sc n' 0 }+                    in do a <- m p'+                          a `seq` writeIORef nref (n' + 1)+                          loop (n' + 1)+              n' <- readIORef nref+              loop n'+     return $ discreteDynamics $ Dynamics r++-- | Memoize and unzip the computation of pairs, applying the 'memoDynamics' function.+unzipDynamics :: Dynamics (a, b) -> Simulation (Dynamics a, Dynamics 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 :: Dynamics (a, b) -> Simulation (Dynamics a, Dynamics 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)

@@ -1,102 +1,102 @@-
-{-# LANGUAGE FlexibleContexts #-}
-
--- |
--- Module     : Simulation.Aivika.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 'Dynamics'
--- computations, which values are cached in the integration time points. Then
--- these values are interpolated in all other time points.
---
-
-module Simulation.Aivika.Dynamics.Memo.Unboxed
-       (memoDynamics,
-        memo0Dynamics) where
-
-import Data.Array
-import Data.Array.IO.Safe
-import Data.IORef
-import Control.Monad
-
-import Simulation.Aivika.Internal.Specs
-import Simulation.Aivika.Internal.Parameter
-import Simulation.Aivika.Internal.Simulation
-import Simulation.Aivika.Internal.Dynamics
-import Simulation.Aivika.Dynamics.Extra
-import Simulation.Aivika.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 e => Dynamics e -> Simulation (Dynamics e)
-{-# INLINE memoDynamics #-}
-memoDynamics (Dynamics m) = 
-  Simulation $ \r ->
-  do let sc = runSpecs r
-         (phl, phu) = integPhaseBnds sc
-         (nl, nu)   = integIterationBnds sc
-     arr   <- newUnboxedArray_ ((phl, nl), (phu, nu))
-     nref  <- newIORef 0
-     phref <- newIORef 0
-     let r p =
-           do let sc  = pointSpecs p
-                  n   = pointIteration p
-                  ph  = pointPhase p
-                  phu = integPhaseHiBnd sc 
-                  loop n' ph' = 
-                    if (n' > n) || ((n' == n) && (ph' > ph)) 
-                    then 
-                      readArray arr (ph, n)
-                    else 
-                      let p' = p { pointIteration = n', 
-                                   pointPhase = ph',
-                                   pointTime = basicTime sc n' ph' }
-                      in do a <- m p'
-                            a `seq` writeArray arr (ph', n') a
-                            if ph' >= phu 
-                              then do writeIORef phref 0
-                                      writeIORef nref (n' + 1)
-                                      loop (n' + 1) 0
-                              else do writeIORef phref (ph' + 1)
-                                      loop n' (ph' + 1)
-              n'  <- readIORef nref
-              ph' <- readIORef 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 e => Dynamics e -> Simulation (Dynamics e)
-{-# INLINE memo0Dynamics #-}
-memo0Dynamics (Dynamics m) = 
-  Simulation $ \r ->
-  do let sc   = runSpecs r
-         bnds = integIterationBnds sc
-     arr  <- newUnboxedArray_ bnds
-     nref <- newIORef 0
-     let r p =
-           do let sc = pointSpecs p
-                  n  = pointIteration p
-                  loop n' = 
-                    if n' > n
-                    then 
-                      readArray arr n
-                    else 
-                      let p' = p { pointIteration = n', pointPhase = 0,
-                                   pointTime = basicTime sc n' 0 }
-                      in do a <- m p'
-                            a `seq` writeArray arr n' a
-                            writeIORef nref (n' + 1)
-                            loop (n' + 1)
-              n' <- readIORef nref
-              loop n'
-     return $ discreteDynamics $ Dynamics r
++{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module     : Simulation.Aivika.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 'Dynamics'+-- computations, which values are cached in the integration time points. Then+-- these values are interpolated in all other time points.+--++module Simulation.Aivika.Dynamics.Memo.Unboxed+       (memoDynamics,+        memo0Dynamics) where++import Data.Array+import Data.Array.IO.Safe+import Data.IORef+import Control.Monad++import Simulation.Aivika.Internal.Specs+import Simulation.Aivika.Internal.Parameter+import Simulation.Aivika.Internal.Simulation+import Simulation.Aivika.Internal.Dynamics+import Simulation.Aivika.Dynamics.Extra+import Simulation.Aivika.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 e => Dynamics e -> Simulation (Dynamics e)+{-# INLINE memoDynamics #-}+memoDynamics (Dynamics m) = +  Simulation $ \r ->+  do let sc = runSpecs r+         (phl, phu) = integPhaseBnds sc+         (nl, nu)   = integIterationBnds sc+     arr   <- newUnboxedArray_ ((phl, nl), (phu, nu))+     nref  <- newIORef 0+     phref <- newIORef 0+     let r p =+           do let sc  = pointSpecs p+                  n   = pointIteration p+                  ph  = pointPhase p+                  phu = integPhaseHiBnd sc +                  loop n' ph' = +                    if (n' > n) || ((n' == n) && (ph' > ph)) +                    then +                      readArray arr (ph, n)+                    else +                      let p' = p { pointIteration = n', +                                   pointPhase = ph',+                                   pointTime = basicTime sc n' ph' }+                      in do a <- m p'+                            a `seq` writeArray arr (ph', n') a+                            if ph' >= phu +                              then do writeIORef phref 0+                                      writeIORef nref (n' + 1)+                                      loop (n' + 1) 0+                              else do writeIORef phref (ph' + 1)+                                      loop n' (ph' + 1)+              n'  <- readIORef nref+              ph' <- readIORef 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 e => Dynamics e -> Simulation (Dynamics e)+{-# INLINE memo0Dynamics #-}+memo0Dynamics (Dynamics m) = +  Simulation $ \r ->+  do let sc   = runSpecs r+         bnds = integIterationBnds sc+     arr  <- newUnboxedArray_ bnds+     nref <- newIORef 0+     let r p =+           do let sc = pointSpecs p+                  n  = pointIteration p+                  loop n' = +                    if n' > n+                    then +                      readArray arr n+                    else +                      let p' = p { pointIteration = n', pointPhase = 0,+                                   pointTime = basicTime sc n' 0 }+                      in do a <- m p'+                            a `seq` writeArray arr n' a+                            writeIORef nref (n' + 1)+                            loop (n' + 1)+              n' <- readIORef nref+              loop n'+     return $ discreteDynamics $ Dynamics r

@@ -1,132 +1,132 @@-
--- |
--- Module     : Simulation.Aivika.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.Dynamics.Random
-       (memoRandomUniformDynamics,
-        memoRandomUniformIntDynamics,
-        memoRandomNormalDynamics,
-        memoRandomExponentialDynamics,
-        memoRandomErlangDynamics,
-        memoRandomPoissonDynamics,
-        memoRandomBinomialDynamics) where
-
-import System.Random
-
-import Control.Monad.Trans
-
-import Simulation.Aivika.Generator
-import Simulation.Aivika.Internal.Specs
-import Simulation.Aivika.Internal.Parameter
-import Simulation.Aivika.Internal.Simulation
-import Simulation.Aivika.Internal.Dynamics
-import Simulation.Aivika.Dynamics.Memo.Unboxed
-
--- | Computation that generates random numbers distributed uniformly and
--- memoizes them in the integration time points.
-memoRandomUniformDynamics :: Dynamics Double     -- ^ minimum
-                             -> Dynamics Double  -- ^ maximum
-                             -> Simulation (Dynamics 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 :: Dynamics Int     -- ^ minimum
-                                -> Dynamics Int  -- ^ maximum
-                                -> Simulation (Dynamics 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 :: Dynamics Double     -- ^ mean
-                            -> Dynamics Double  -- ^ deviation
-                            -> Simulation (Dynamics 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 :: Dynamics Double
-                                 -- ^ the mean (the reciprocal of the rate)
-                                 -> Simulation (Dynamics 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 :: Dynamics Double
-                            -- ^ the scale (the reciprocal of the rate)
-                            -> Dynamics Int
-                            -- ^ the shape
-                            -> Simulation (Dynamics 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 :: Dynamics Double
-                             -- ^ the mean
-                             -> Simulation (Dynamics 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 :: Dynamics Double  -- ^ the probability
-                              -> Dynamics Int  -- ^ the number of trials
-                              -> Simulation (Dynamics 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.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.Dynamics.Random+       (memoRandomUniformDynamics,+        memoRandomUniformIntDynamics,+        memoRandomNormalDynamics,+        memoRandomExponentialDynamics,+        memoRandomErlangDynamics,+        memoRandomPoissonDynamics,+        memoRandomBinomialDynamics) where++import System.Random++import Control.Monad.Trans++import Simulation.Aivika.Generator+import Simulation.Aivika.Internal.Specs+import Simulation.Aivika.Internal.Parameter+import Simulation.Aivika.Internal.Simulation+import Simulation.Aivika.Internal.Dynamics+import Simulation.Aivika.Dynamics.Memo.Unboxed++-- | Computation that generates random numbers distributed uniformly and+-- memoizes them in the integration time points.+memoRandomUniformDynamics :: Dynamics Double     -- ^ minimum+                             -> Dynamics Double  -- ^ maximum+                             -> Simulation (Dynamics 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 :: Dynamics Int     -- ^ minimum+                                -> Dynamics Int  -- ^ maximum+                                -> Simulation (Dynamics 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 :: Dynamics Double     -- ^ mean+                            -> Dynamics Double  -- ^ deviation+                            -> Simulation (Dynamics 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 :: Dynamics Double+                                 -- ^ the mean (the reciprocal of the rate)+                                 -> Simulation (Dynamics 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 :: Dynamics Double+                            -- ^ the scale (the reciprocal of the rate)+                            -> Dynamics Int+                            -- ^ the shape+                            -> Simulation (Dynamics 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 :: Dynamics Double+                             -- ^ the mean+                             -> Simulation (Dynamics 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 :: Dynamics Double  -- ^ the probability+                              -> Dynamics Int  -- ^ the number of trials+                              -> Simulation (Dynamics 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'

@@ -1,44 +1,44 @@-
--- |
--- Module     : Simulation.Aivika.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.Event
-       (-- * Event Monad
-        Event,
-        EventLift(..),
-        EventProcessing(..),
-        runEvent,
-        runEventWith,
-        runEventInStartTime,
-        runEventInStopTime,
-        -- * Event Queue
-        enqueueEvent,
-        enqueueEventWithCancellation,
-        enqueueEventWithTimes,
-        enqueueEventWithIntegTimes,
-        yieldEvent,
-        eventQueueCount,
-        -- * Cancelling Event
-        EventCancellation,
-        cancelEvent,
-        eventCancelled,
-        eventFinished,
-        -- * Error Handling
-        catchEvent,
-        finallyEvent,
-        throwEvent,
-        -- * Memoization
-        memoEvent,
-        memoEventInTime,
-        -- * Disposable
-        DisposableEvent(..)) where
-
-import Simulation.Aivika.Internal.Event
++-- |+-- Module     : Simulation.Aivika.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.Event+       (-- * Event Monad+        Event,+        EventLift(..),+        EventProcessing(..),+        runEvent,+        runEventWith,+        runEventInStartTime,+        runEventInStopTime,+        -- * Event Queue+        enqueueEvent,+        enqueueEventWithCancellation,+        enqueueEventWithTimes,+        enqueueEventWithIntegTimes,+        yieldEvent,+        eventQueueCount,+        -- * Cancelling Event+        EventCancellation,+        cancelEvent,+        eventCancelled,+        eventFinished,+        -- * Error Handling+        catchEvent,+        finallyEvent,+        throwEvent,+        -- * Memoization+        memoEvent,+        memoEventInTime,+        -- * Disposable+        DisposableEvent(..)) where++import Simulation.Aivika.Internal.Event

@@ -1,220 +1,220 @@-
--- |
--- Module     : Simulation.Aivika.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 type class of the random number generator.
---
-module Simulation.Aivika.Generator 
-       (Generator(..),
-        GeneratorType(..),
-        newGenerator,
-        newRandomGenerator) where
-
-import System.Random
-import Data.IORef
-
--- | Defines a random number generator.
-data Generator =
-  Generator { generateUniform :: Double -> Double -> IO Double,
-              -- ^ Generate an uniform random number
-              -- with the specified minimum and maximum.
-              generateUniformInt :: Int -> Int -> IO Int,
-              -- ^ Generate an uniform integer random number
-              -- with the specified minimum and maximum.
-              generateNormal :: Double -> Double -> IO Double,
-              -- ^ Generate the normal random number
-              -- with the specified mean and deviation.
-              generateExponential :: Double -> IO Double,
-              -- ^ Generate the random number distributed exponentially
-              -- with the specified mean (the reciprocal of the rate).
-              generateErlang :: Double -> Int -> IO Double,
-              -- ^ Generate the Erlang random number
-              -- with the specified scale (the reciprocal of the rate) and integer shape.
-              generatePoisson :: Double -> IO Int,
-              -- ^ Generate the Poisson random number
-              -- with the specified mean.
-              generateBinomial :: Double -> Int -> IO Int
-              -- ^ Generate the binomial random number
-              -- with the specified probability and number of trials.
-            }
-
--- | Generate the 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 the 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'))
-
--- | 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
-
--- | Defines a type of the random number generator.
-data GeneratorType = SimpleGenerator
-                     -- ^ The simple random number generator.
-                   | SimpleGeneratorWithSeed Int
-                     -- ^ The simple random number generator with the specified seed.
-                   | CustomGenerator (IO Generator)
-                     -- ^ The custom random number generator.
-                   | CustomGenerator01 (IO Double)
-                     -- ^ The custom random number generator by the specified uniform
-                     -- generator of numbers from 0 to 1.
-
--- | Create a new random number generator by the specified type.
-newGenerator :: GeneratorType -> IO Generator
-newGenerator tp =
-  case tp of
-    SimpleGenerator ->
-      newStdGen >>= newRandomGenerator
-    SimpleGeneratorWithSeed x ->
-      newRandomGenerator $ mkStdGen x
-    CustomGenerator g ->
-      g
-    CustomGenerator01 g ->
-      newRandomGenerator01 g
-
--- | Create a new random generator by the specified standard generator.
-newRandomGenerator :: RandomGen g => g -> IO Generator
-newRandomGenerator g =
-  do r <- newIORef g
-     let g1 = do g <- readIORef r
-                 let (x, g') = random g
-                 writeIORef r g'
-                 return x
-     newRandomGenerator01 g1
-
--- | Create a new random generator by the specified uniform generator of numbers from 0 to 1.
-newRandomGenerator01 :: IO Double -> IO Generator
-newRandomGenerator01 g =
-  do let g1 = g
-     g2 <- newNormalGenerator01 g1
-     let g3 mu nu =
-           do x <- g2
-              return $ mu + nu * x
-     return Generator { generateUniform = generateUniform01 g1,
-                        generateUniformInt = generateUniformInt01 g1,
-                        generateNormal = g3,
-                        generateExponential = generateExponential01 g1,
-                        generateErlang = generateErlang01 g1,
-                        generatePoisson = generatePoisson01 g1,
-                        generateBinomial = generateBinomial01 g1 }
++-- |+-- Module     : Simulation.Aivika.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 type class of the random number generator.+--+module Simulation.Aivika.Generator +       (Generator(..),+        GeneratorType(..),+        newGenerator,+        newRandomGenerator) where++import System.Random+import Data.IORef++-- | Defines a random number generator.+data Generator =+  Generator { generateUniform :: Double -> Double -> IO Double,+              -- ^ Generate an uniform random number+              -- with the specified minimum and maximum.+              generateUniformInt :: Int -> Int -> IO Int,+              -- ^ Generate an uniform integer random number+              -- with the specified minimum and maximum.+              generateNormal :: Double -> Double -> IO Double,+              -- ^ Generate the normal random number+              -- with the specified mean and deviation.+              generateExponential :: Double -> IO Double,+              -- ^ Generate the random number distributed exponentially+              -- with the specified mean (the reciprocal of the rate).+              generateErlang :: Double -> Int -> IO Double,+              -- ^ Generate the Erlang random number+              -- with the specified scale (the reciprocal of the rate) and integer shape.+              generatePoisson :: Double -> IO Int,+              -- ^ Generate the Poisson random number+              -- with the specified mean.+              generateBinomial :: Double -> Int -> IO Int+              -- ^ Generate the binomial random number+              -- with the specified probability and number of trials.+            }++-- | Generate the 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 the 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'))++-- | 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++-- | Defines a type of the random number generator.+data GeneratorType = SimpleGenerator+                     -- ^ The simple random number generator.+                   | SimpleGeneratorWithSeed Int+                     -- ^ The simple random number generator with the specified seed.+                   | CustomGenerator (IO Generator)+                     -- ^ The custom random number generator.+                   | CustomGenerator01 (IO Double)+                     -- ^ The custom random number generator by the specified uniform+                     -- generator of numbers from 0 to 1.++-- | Create a new random number generator by the specified type.+newGenerator :: GeneratorType -> IO Generator+newGenerator tp =+  case tp of+    SimpleGenerator ->+      newStdGen >>= newRandomGenerator+    SimpleGeneratorWithSeed x ->+      newRandomGenerator $ mkStdGen x+    CustomGenerator g ->+      g+    CustomGenerator01 g ->+      newRandomGenerator01 g++-- | Create a new random generator by the specified standard generator.+newRandomGenerator :: RandomGen g => g -> IO Generator+newRandomGenerator g =+  do r <- newIORef g+     let g1 = do g <- readIORef r+                 let (x, g') = random g+                 writeIORef r g'+                 return x+     newRandomGenerator01 g1++-- | Create a new random generator by the specified uniform generator of numbers from 0 to 1.+newRandomGenerator01 :: IO Double -> IO Generator+newRandomGenerator01 g =+  do let g1 = g+     g2 <- newNormalGenerator01 g1+     let g3 mu nu =+           do x <- g2+              return $ mu + nu * x+     return Generator { generateUniform = generateUniform01 g1,+                        generateUniformInt = generateUniformInt01 g1,+                        generateNormal = g3,+                        generateExponential = generateExponential01 g1,+                        generateErlang = generateErlang01 g1,+                        generatePoisson = generatePoisson01 g1,+                        generateBinomial = generateBinomial01 g1 }

@@ -1,39 +1,39 @@-
--- |
--- Module     : Simulation.Aivika.Internal.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.Internal.Arrival
-       (Arrival(..)) where
-
-import Simulation.Aivika.Event
-
--- | It defines when an event has arrived, usually generated by some random stream.
---
--- Such events should arrive one by one without time lag in the following sense
--- that the model should start awaiting the next event exactly in that time
--- when the previous event has arrived.
---
--- Another use case is a situation when the actual event is not synchronized with
--- the 'Event' computation, being synchronized with the event queue, nevertheless.
--- Then the arrival is used for providing the additional information about the time
--- at which the event had been actually arrived.
-data Arrival a =
-  Arrival { arrivalValue :: a,
-            -- ^ the data we received with the event
-            arrivalTime :: Double,
-            -- ^ the simulation time at which the event has arrived
-            arrivalDelay :: Maybe Double
-            -- ^ the delay time which has passed from the time of
-            -- arriving the previous event
-          } deriving (Eq, Ord, Show)
++-- |+-- Module     : Simulation.Aivika.Internal.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.Internal.Arrival+       (Arrival(..)) where++import Simulation.Aivika.Event++-- | It defines when an event has arrived, usually generated by some random stream.+--+-- Such events should arrive one by one without time lag in the following sense+-- that the model should start awaiting the next event exactly in that time+-- when the previous event has arrived.+--+-- Another use case is a situation when the actual event is not synchronized with+-- the 'Event' computation, being synchronized with the event queue, nevertheless.+-- Then the arrival is used for providing the additional information about the time+-- at which the event had been actually arrived.+data Arrival a =+  Arrival { arrivalValue :: a,+            -- ^ the data we received with the event+            arrivalTime :: Double,+            -- ^ the simulation time at which the event has arrived+            arrivalDelay :: Maybe Double+            -- ^ the delay time which has passed from the time of+            -- arriving the previous event+          } deriving (Eq, Ord, Show)

@@ -1,671 +1,671 @@-
--- |
--- Module     : Simulation.Aivika.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.Internal.Cont
-       (ContCancellation(..),
-        ContCancellationSource,
-        Cont(..),
-        ContParams,
-        newContCancellationSource,
-        contCancellationInitiated,
-        contCancellationInitiate,
-        contCancellationInitiating,
-        contCancellationBind,
-        contCancellationConnect,
-        invokeCont,
-        runCont,
-        rerunCont,
-        spawnCont,
-        contParallel,
-        contParallel_,
-        catchCont,
-        finallyCont,
-        throwCont,
-        resumeCont,
-        resumeECont,
-        contCanceled,
-        contFreeze,
-        contAwait) where
-
-import Data.IORef
-import Data.Array
-import Data.Array.IO.Safe
-import Data.Monoid
-
-import Control.Exception
-import Control.Monad
-import Control.Monad.Trans
-import Control.Applicative
-
-import Simulation.Aivika.Internal.Specs
-import Simulation.Aivika.Internal.Parameter
-import Simulation.Aivika.Internal.Simulation
-import Simulation.Aivika.Internal.Dynamics
-import Simulation.Aivika.Internal.Event
-import Simulation.Aivika.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 =
-  ContCancellationSource { contCancellationInitiatedRef :: IORef Bool,
-                           contCancellationActivatedRef :: IORef Bool,
-                           contCancellationInitiatingSource :: SignalSource ()
-                         }
-
--- | Create the cancellation source.
-newContCancellationSource :: Simulation ContCancellationSource
-newContCancellationSource =
-  Simulation $ \r ->
-  do r1 <- newIORef False
-     r2 <- newIORef False
-     s  <- invokeSimulation r newSignalSource
-     return ContCancellationSource { contCancellationInitiatedRef = r1,
-                                     contCancellationActivatedRef = r2,
-                                     contCancellationInitiatingSource = s
-                                   }
-
--- | Signal when the cancellation is intiating.
-contCancellationInitiating :: ContCancellationSource -> Signal ()
-contCancellationInitiating =
-  publishSignal . contCancellationInitiatingSource
-
--- | Whether the cancellation was initiated.
-contCancellationInitiated :: ContCancellationSource -> Event Bool
-contCancellationInitiated x =
-  Event $ \p -> readIORef (contCancellationInitiatedRef x)
-
--- | Whether the cancellation was activated.
-contCancellationActivated :: ContCancellationSource -> IO Bool
-contCancellationActivated =
-  readIORef . contCancellationActivatedRef
-
--- | Deactivate the cancellation.
-contCancellationDeactivate :: ContCancellationSource -> IO ()
-contCancellationDeactivate x =
-  writeIORef (contCancellationActivatedRef x) False
-
--- | If the main computation is cancelled then all the nested ones will be cancelled too.
-contCancellationBind :: ContCancellationSource -> [ContCancellationSource] -> Event DisposableEvent
-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 :: ContCancellationSource
-                           -- ^ the parent
-                           -> ContCancellation
-                           -- ^ how to connect
-                           -> ContCancellationSource
-                           -- ^ the child
-                           -> Event DisposableEvent
-                           -- ^ 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 :: ContCancellationSource -> Event ()
-contCancellationInitiate x =
-  Event $ \p ->
-  do f <- readIORef (contCancellationInitiatedRef x)
-     unless f $
-       do writeIORef (contCancellationInitiatedRef x) True
-          writeIORef (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 a = Cont (ContParams a -> Event ())
-
--- | The continuation parameters.
-data ContParams a = 
-  ContParams { contCont :: a -> Event (), 
-               contAux  :: ContParamsAux }
-
--- | The auxiliary continuation parameters.
-data ContParamsAux =
-  ContParamsAux { contECont :: SomeException -> Event (),
-                  contCCont :: () -> Event (),
-                  contCancelSource :: ContCancellationSource,
-                  contCancelFlag :: IO Bool,
-                  contCatchFlag  :: Bool }
-
-instance Monad Cont where
-  return  = returnC
-  m >>= k = bindC m k
-
-instance ParameterLift Cont where
-  liftParameter = liftPC
-
-instance SimulationLift Cont where
-  liftSimulation = liftSC
-
-instance DynamicsLift Cont where
-  liftDynamics = liftDC
-
-instance EventLift Cont where
-  liftEvent = liftEC
-
-instance Functor Cont where
-  fmap = liftM
-
-instance Applicative Cont where
-  pure = return
-  (<*>) = ap
-
-instance MonadIO Cont where
-  liftIO = liftIOC 
-
--- | Invoke the computation.
-invokeCont :: ContParams a -> Cont a -> Event ()
-{-# INLINE invokeCont #-}
-invokeCont p (Cont m) = m p
-
--- | Cancel the computation.
-cancelCont :: Point -> ContParams a -> IO ()
-{-# NOINLINE cancelCont #-}
-cancelCont p c =
-  do contCancellationDeactivate (contCancelSource $ contAux c)
-     invokeEvent p $ (contCCont $ contAux c) ()
-
-returnC :: a -> Cont a
-{-# INLINE returnC #-}
-returnC a = 
-  Cont $ \c ->
-  Event $ \p ->
-  do z <- contCanceled c
-     if z 
-       then cancelCont p c
-       else invokeEvent p $ contCont c a
-                          
-bindC :: Cont a -> (a -> Cont b) -> Cont b
-{-# INLINE bindC #-}
-bindC (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 }
-
--- | Like @return a >>= k@.
-callCont :: (a -> Cont b) -> a -> ContParams b -> Event ()
-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 :: Exception e => Cont a -> (e -> Cont a) -> Cont 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 :: Cont a -> Cont b -> Cont 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 :: IOException -> Cont a
-throwCont = liftIO . throw
-
--- | Run the 'Cont' computation with the specified cancelation source 
--- and flag indicating whether to catch exceptions from the beginning.
-runCont :: Cont a
-           -- ^ the computation to run
-           -> (a -> Event ())
-           -- ^ the main branch 
-           -> (SomeException -> Event ())
-           -- ^ the branch for handing exceptions
-           -> (() -> Event ())
-           -- ^ the branch for cancellation
-           -> ContCancellationSource
-           -- ^ the cancellation source
-           -> Bool
-           -- ^ whether to support the exception handling from the beginning
-           -> Event ()
-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 } }
-
--- | Lift the 'Parameter' computation.
-liftPC :: Parameter a -> Cont a
-liftPC (Parameter m) = 
-  Cont $ \c ->
-  Event $ \p ->
-  if contCatchFlag . contAux $ c
-  then liftIOWithCatch (m $ pointRun p) p c
-  else liftIOWithoutCatch (m $ pointRun p) p c
-
--- | Lift the 'Simulation' computation.
-liftSC :: Simulation a -> Cont a
-liftSC (Simulation m) = 
-  Cont $ \c ->
-  Event $ \p ->
-  if contCatchFlag . contAux $ c
-  then liftIOWithCatch (m $ pointRun p) p c
-  else liftIOWithoutCatch (m $ pointRun p) p c
-     
--- | Lift the 'Dynamics' computation.
-liftDC :: Dynamics a -> Cont a
-liftDC (Dynamics m) =
-  Cont $ \c ->
-  Event $ \p ->
-  if contCatchFlag . contAux $ c
-  then liftIOWithCatch (m p) p c
-  else liftIOWithoutCatch (m p) p c
-     
--- | Lift the 'Event' computation.
-liftEC :: Event a -> Cont a
-liftEC (Event m) =
-  Cont $ \c ->
-  Event $ \p ->
-  if contCatchFlag . contAux $ c
-  then liftIOWithCatch (m p) p c
-  else liftIOWithoutCatch (m p) p c
-     
--- | Lift the IO computation.
-liftIOC :: IO a -> Cont a
-liftIOC m =
-  Cont $ \c ->
-  Event $ \p ->
-  if contCatchFlag . contAux $ c
-  then liftIOWithCatch m p c
-  else liftIOWithoutCatch m p c
-  
-liftIOWithoutCatch :: IO a -> Point -> ContParams a -> IO ()
-{-# INLINE liftIOWithoutCatch #-}
-liftIOWithoutCatch m p c =
-  do z <- contCanceled c
-     if z
-       then cancelCont p c
-       else do a <- m
-               invokeEvent p $ contCont c a
-
-liftIOWithCatch :: IO a -> Point -> ContParams a -> IO ()
-{-# NOINLINE liftIOWithCatch #-}
-liftIOWithCatch m p c =
-  do z <- contCanceled c
-     if z
-       then cancelCont p c
-       else do aref <- newIORef undefined
-               eref <- newIORef Nothing
-               catch (m >>= writeIORef aref) 
-                 (writeIORef eref . Just)
-               e <- readIORef eref
-               case e of
-                 Nothing -> 
-                   do a <- readIORef 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 :: ContParams a -> a -> Event ()
-{-# 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 :: ContParams a -> SomeException -> Event ()
-{-# 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 a -> IO 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 :: [(Cont a, ContCancellationSource)]
-                -- ^ the list of:
-                -- the nested computation,
-                -- the cancellation source
-                -> Cont [a]
-contParallel xs =
-  Cont $ \c ->
-  Event $ \p ->
-  do let n = length xs
-         worker =
-           do results   <- newArray_ (1, n) :: IO (IOArray Int a)
-              counter   <- newIORef 0
-              catchRef  <- newIORef Nothing
-              hs <- invokeEvent p $
-                    contCancellationBind (contCancelSource $ contAux c) $
-                    map snd xs
-              let propagate =
-                    Event $ \p ->
-                    do n' <- readIORef counter
-                       when (n' == n) $
-                         do invokeEvent p $ disposeEvent hs  -- unbind the cancellation sources
-                            f1 <- contCanceled c
-                            f2 <- readIORef catchRef
-                            case (f1, f2) of
-                              (False, Nothing) ->
-                                do rs <- getElems results
-                                   invokeEvent p $ resumeCont c rs
-                              (False, Just e) ->
-                                invokeEvent p $ resumeECont c e
-                              (True, _) ->
-                                cancelCont p c
-                  cont i a =
-                    Event $ \p ->
-                    do modifyIORef counter (+ 1)
-                       writeArray results i a
-                       invokeEvent p propagate
-                  econt e =
-                    Event $ \p ->
-                    do modifyIORef counter (+ 1)
-                       r <- readIORef catchRef
-                       case r of
-                         Nothing -> writeIORef catchRef $ Just e
-                         Just e' -> return ()  -- ignore the next error
-                       invokeEvent p propagate
-                  ccont e =
-                    Event $ \p ->
-                    do modifyIORef counter (+ 1)
-                       -- the main computation was automatically canceled
-                       invokeEvent p propagate
-              forM_ (zip [1..n] 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_ :: [(Cont a, ContCancellationSource)]
-                 -- ^ the list of:
-                 -- the nested computation,
-                 -- the cancellation source
-                 -> Cont ()
-contParallel_ xs =
-  Cont $ \c ->
-  Event $ \p ->
-  do let n = length xs
-         worker =
-           do counter   <- newIORef 0
-              catchRef  <- newIORef Nothing
-              hs <- invokeEvent p $
-                    contCancellationBind (contCancelSource $ contAux c) $
-                    map snd xs
-              let propagate =
-                    Event $ \p ->
-                    do n' <- readIORef counter
-                       when (n' == n) $
-                         do invokeEvent p $ disposeEvent hs  -- unbind the cancellation sources
-                            f1 <- contCanceled c
-                            f2 <- readIORef 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 modifyIORef counter (+ 1)
-                       -- ignore the result
-                       invokeEvent p propagate
-                  econt e =
-                    Event $ \p ->
-                    do modifyIORef counter (+ 1)
-                       r <- readIORef catchRef
-                       case r of
-                         Nothing -> writeIORef catchRef $ Just e
-                         Just e' -> return ()  -- ignore the next error
-                       invokeEvent p propagate
-                  ccont e =
-                    Event $ \p ->
-                    do modifyIORef counter (+ 1)
-                       -- the main computation was automatically canceled
-                       invokeEvent p propagate
-              forM_ (zip [1..n] 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 :: Cont a -> ContCancellationSource -> Cont 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 :: ContCancellation -> Cont () -> ContCancellationSource -> Cont ()
-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 :: ContParams a -> Event (Event (Maybe (ContParams a)))
-contFreeze c =
-  Event $ \p ->
-  do rh <- newIORef Nothing
-     rc <- newIORef $ Just c
-     h <- invokeEvent p $
-          handleSignal (contCancellationInitiating $
-                        contCancelSource $
-                        contAux c) $ \a ->
-          Event $ \p ->
-          do h <- readIORef rh
-             case h of
-               Nothing ->
-                 error "The handler was lost: contFreeze."
-               Just h ->
-                 do invokeEvent p $ disposeEvent h
-                    c <- readIORef rc
-                    case c of
-                      Nothing -> return ()
-                      Just c  ->
-                        do writeIORef rc Nothing
-                           invokeEvent p $
-                             enqueueEvent (pointTime p) $
-                             Event $ \p ->
-                             do z <- contCanceled c
-                                when z $ cancelCont p c
-     writeIORef rh (Just h)
-     return $
-       Event $ \p ->
-       do invokeEvent p $ disposeEvent h
-          c <- readIORef rc
-          writeIORef rc Nothing
-          return c
-     
--- | Await the signal.
-contAwait :: Signal a -> Cont a
-contAwait signal =
-  Cont $ \c ->
-  Event $ \p ->
-  do c <- invokeEvent p $ contFreeze c
-     r <- newIORef Nothing
-     h <- invokeEvent p $
-          handleSignal signal $ 
-          \a -> Event $ 
-                \p -> do x <- readIORef 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
-     writeIORef r $ Just h          
++-- |+-- Module     : Simulation.Aivika.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.Internal.Cont+       (ContCancellation(..),+        ContCancellationSource,+        Cont(..),+        ContParams,+        newContCancellationSource,+        contCancellationInitiated,+        contCancellationInitiate,+        contCancellationInitiating,+        contCancellationBind,+        contCancellationConnect,+        invokeCont,+        runCont,+        rerunCont,+        spawnCont,+        contParallel,+        contParallel_,+        catchCont,+        finallyCont,+        throwCont,+        resumeCont,+        resumeECont,+        contCanceled,+        contFreeze,+        contAwait) where++import Data.IORef+import Data.Array+import Data.Array.IO.Safe+import Data.Monoid++import Control.Exception+import Control.Monad+import Control.Monad.Trans+import Control.Applicative++import Simulation.Aivika.Internal.Specs+import Simulation.Aivika.Internal.Parameter+import Simulation.Aivika.Internal.Simulation+import Simulation.Aivika.Internal.Dynamics+import Simulation.Aivika.Internal.Event+import Simulation.Aivika.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 =+  ContCancellationSource { contCancellationInitiatedRef :: IORef Bool,+                           contCancellationActivatedRef :: IORef Bool,+                           contCancellationInitiatingSource :: SignalSource ()+                         }++-- | Create the cancellation source.+newContCancellationSource :: Simulation ContCancellationSource+newContCancellationSource =+  Simulation $ \r ->+  do r1 <- newIORef False+     r2 <- newIORef False+     s  <- invokeSimulation r newSignalSource+     return ContCancellationSource { contCancellationInitiatedRef = r1,+                                     contCancellationActivatedRef = r2,+                                     contCancellationInitiatingSource = s+                                   }++-- | Signal when the cancellation is intiating.+contCancellationInitiating :: ContCancellationSource -> Signal ()+contCancellationInitiating =+  publishSignal . contCancellationInitiatingSource++-- | Whether the cancellation was initiated.+contCancellationInitiated :: ContCancellationSource -> Event Bool+contCancellationInitiated x =+  Event $ \p -> readIORef (contCancellationInitiatedRef x)++-- | Whether the cancellation was activated.+contCancellationActivated :: ContCancellationSource -> IO Bool+contCancellationActivated =+  readIORef . contCancellationActivatedRef++-- | Deactivate the cancellation.+contCancellationDeactivate :: ContCancellationSource -> IO ()+contCancellationDeactivate x =+  writeIORef (contCancellationActivatedRef x) False++-- | If the main computation is cancelled then all the nested ones will be cancelled too.+contCancellationBind :: ContCancellationSource -> [ContCancellationSource] -> Event DisposableEvent+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 :: ContCancellationSource+                           -- ^ the parent+                           -> ContCancellation+                           -- ^ how to connect+                           -> ContCancellationSource+                           -- ^ the child+                           -> Event DisposableEvent+                           -- ^ 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 :: ContCancellationSource -> Event ()+contCancellationInitiate x =+  Event $ \p ->+  do f <- readIORef (contCancellationInitiatedRef x)+     unless f $+       do writeIORef (contCancellationInitiatedRef x) True+          writeIORef (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 a = Cont (ContParams a -> Event ())++-- | The continuation parameters.+data ContParams a = +  ContParams { contCont :: a -> Event (), +               contAux  :: ContParamsAux }++-- | The auxiliary continuation parameters.+data ContParamsAux =+  ContParamsAux { contECont :: SomeException -> Event (),+                  contCCont :: () -> Event (),+                  contCancelSource :: ContCancellationSource,+                  contCancelFlag :: IO Bool,+                  contCatchFlag  :: Bool }++instance Monad Cont where+  return  = returnC+  m >>= k = bindC m k++instance ParameterLift Cont where+  liftParameter = liftPC++instance SimulationLift Cont where+  liftSimulation = liftSC++instance DynamicsLift Cont where+  liftDynamics = liftDC++instance EventLift Cont where+  liftEvent = liftEC++instance Functor Cont where+  fmap = liftM++instance Applicative Cont where+  pure = return+  (<*>) = ap++instance MonadIO Cont where+  liftIO = liftIOC ++-- | Invoke the computation.+invokeCont :: ContParams a -> Cont a -> Event ()+{-# INLINE invokeCont #-}+invokeCont p (Cont m) = m p++-- | Cancel the computation.+cancelCont :: Point -> ContParams a -> IO ()+{-# NOINLINE cancelCont #-}+cancelCont p c =+  do contCancellationDeactivate (contCancelSource $ contAux c)+     invokeEvent p $ (contCCont $ contAux c) ()++returnC :: a -> Cont a+{-# INLINE returnC #-}+returnC a = +  Cont $ \c ->+  Event $ \p ->+  do z <- contCanceled c+     if z +       then cancelCont p c+       else invokeEvent p $ contCont c a+                          +bindC :: Cont a -> (a -> Cont b) -> Cont b+{-# INLINE bindC #-}+bindC (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 }++-- | Like @return a >>= k@.+callCont :: (a -> Cont b) -> a -> ContParams b -> Event ()+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 :: Exception e => Cont a -> (e -> Cont a) -> Cont 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 :: Cont a -> Cont b -> Cont 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 :: IOException -> Cont a+throwCont = liftIO . throw++-- | Run the 'Cont' computation with the specified cancelation source +-- and flag indicating whether to catch exceptions from the beginning.+runCont :: Cont a+           -- ^ the computation to run+           -> (a -> Event ())+           -- ^ the main branch +           -> (SomeException -> Event ())+           -- ^ the branch for handing exceptions+           -> (() -> Event ())+           -- ^ the branch for cancellation+           -> ContCancellationSource+           -- ^ the cancellation source+           -> Bool+           -- ^ whether to support the exception handling from the beginning+           -> Event ()+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 } }++-- | Lift the 'Parameter' computation.+liftPC :: Parameter a -> Cont a+liftPC (Parameter m) = +  Cont $ \c ->+  Event $ \p ->+  if contCatchFlag . contAux $ c+  then liftIOWithCatch (m $ pointRun p) p c+  else liftIOWithoutCatch (m $ pointRun p) p c++-- | Lift the 'Simulation' computation.+liftSC :: Simulation a -> Cont a+liftSC (Simulation m) = +  Cont $ \c ->+  Event $ \p ->+  if contCatchFlag . contAux $ c+  then liftIOWithCatch (m $ pointRun p) p c+  else liftIOWithoutCatch (m $ pointRun p) p c+     +-- | Lift the 'Dynamics' computation.+liftDC :: Dynamics a -> Cont a+liftDC (Dynamics m) =+  Cont $ \c ->+  Event $ \p ->+  if contCatchFlag . contAux $ c+  then liftIOWithCatch (m p) p c+  else liftIOWithoutCatch (m p) p c+     +-- | Lift the 'Event' computation.+liftEC :: Event a -> Cont a+liftEC (Event m) =+  Cont $ \c ->+  Event $ \p ->+  if contCatchFlag . contAux $ c+  then liftIOWithCatch (m p) p c+  else liftIOWithoutCatch (m p) p c+     +-- | Lift the IO computation.+liftIOC :: IO a -> Cont a+liftIOC m =+  Cont $ \c ->+  Event $ \p ->+  if contCatchFlag . contAux $ c+  then liftIOWithCatch m p c+  else liftIOWithoutCatch m p c+  +liftIOWithoutCatch :: IO a -> Point -> ContParams a -> IO ()+{-# INLINE liftIOWithoutCatch #-}+liftIOWithoutCatch m p c =+  do z <- contCanceled c+     if z+       then cancelCont p c+       else do a <- m+               invokeEvent p $ contCont c a++liftIOWithCatch :: IO a -> Point -> ContParams a -> IO ()+{-# NOINLINE liftIOWithCatch #-}+liftIOWithCatch m p c =+  do z <- contCanceled c+     if z+       then cancelCont p c+       else do aref <- newIORef undefined+               eref <- newIORef Nothing+               catch (m >>= writeIORef aref) +                 (writeIORef eref . Just)+               e <- readIORef eref+               case e of+                 Nothing -> +                   do a <- readIORef 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 :: ContParams a -> a -> Event ()+{-# 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 :: ContParams a -> SomeException -> Event ()+{-# 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 a -> IO 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 :: [(Cont a, ContCancellationSource)]+                -- ^ the list of:+                -- the nested computation,+                -- the cancellation source+                -> Cont [a]+contParallel xs =+  Cont $ \c ->+  Event $ \p ->+  do let n = length xs+         worker =+           do results   <- newArray_ (1, n) :: IO (IOArray Int a)+              counter   <- newIORef 0+              catchRef  <- newIORef Nothing+              hs <- invokeEvent p $+                    contCancellationBind (contCancelSource $ contAux c) $+                    map snd xs+              let propagate =+                    Event $ \p ->+                    do n' <- readIORef counter+                       when (n' == n) $+                         do invokeEvent p $ disposeEvent hs  -- unbind the cancellation sources+                            f1 <- contCanceled c+                            f2 <- readIORef catchRef+                            case (f1, f2) of+                              (False, Nothing) ->+                                do rs <- getElems results+                                   invokeEvent p $ resumeCont c rs+                              (False, Just e) ->+                                invokeEvent p $ resumeECont c e+                              (True, _) ->+                                cancelCont p c+                  cont i a =+                    Event $ \p ->+                    do modifyIORef counter (+ 1)+                       writeArray results i a+                       invokeEvent p propagate+                  econt e =+                    Event $ \p ->+                    do modifyIORef counter (+ 1)+                       r <- readIORef catchRef+                       case r of+                         Nothing -> writeIORef catchRef $ Just e+                         Just e' -> return ()  -- ignore the next error+                       invokeEvent p propagate+                  ccont e =+                    Event $ \p ->+                    do modifyIORef counter (+ 1)+                       -- the main computation was automatically canceled+                       invokeEvent p propagate+              forM_ (zip [1..n] 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_ :: [(Cont a, ContCancellationSource)]+                 -- ^ the list of:+                 -- the nested computation,+                 -- the cancellation source+                 -> Cont ()+contParallel_ xs =+  Cont $ \c ->+  Event $ \p ->+  do let n = length xs+         worker =+           do counter   <- newIORef 0+              catchRef  <- newIORef Nothing+              hs <- invokeEvent p $+                    contCancellationBind (contCancelSource $ contAux c) $+                    map snd xs+              let propagate =+                    Event $ \p ->+                    do n' <- readIORef counter+                       when (n' == n) $+                         do invokeEvent p $ disposeEvent hs  -- unbind the cancellation sources+                            f1 <- contCanceled c+                            f2 <- readIORef 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 modifyIORef counter (+ 1)+                       -- ignore the result+                       invokeEvent p propagate+                  econt e =+                    Event $ \p ->+                    do modifyIORef counter (+ 1)+                       r <- readIORef catchRef+                       case r of+                         Nothing -> writeIORef catchRef $ Just e+                         Just e' -> return ()  -- ignore the next error+                       invokeEvent p propagate+                  ccont e =+                    Event $ \p ->+                    do modifyIORef counter (+ 1)+                       -- the main computation was automatically canceled+                       invokeEvent p propagate+              forM_ (zip [1..n] 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 :: Cont a -> ContCancellationSource -> Cont 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 :: ContCancellation -> Cont () -> ContCancellationSource -> Cont ()+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 :: ContParams a -> Event (Event (Maybe (ContParams a)))+contFreeze c =+  Event $ \p ->+  do rh <- newIORef Nothing+     rc <- newIORef $ Just c+     h <- invokeEvent p $+          handleSignal (contCancellationInitiating $+                        contCancelSource $+                        contAux c) $ \a ->+          Event $ \p ->+          do h <- readIORef rh+             case h of+               Nothing ->+                 error "The handler was lost: contFreeze."+               Just h ->+                 do invokeEvent p $ disposeEvent h+                    c <- readIORef rc+                    case c of+                      Nothing -> return ()+                      Just c  ->+                        do writeIORef rc Nothing+                           invokeEvent p $+                             enqueueEvent (pointTime p) $+                             Event $ \p ->+                             do z <- contCanceled c+                                when z $ cancelCont p c+     writeIORef rh (Just h)+     return $+       Event $ \p ->+       do invokeEvent p $ disposeEvent h+          c <- readIORef rc+          writeIORef rc Nothing+          return c+     +-- | Await the signal.+contAwait :: Signal a -> Cont a+contAwait signal =+  Cont $ \c ->+  Event $ \p ->+  do c <- invokeEvent p $ contFreeze c+     r <- newIORef Nothing+     h <- invokeEvent p $+          handleSignal signal $ +          \a -> Event $ +                \p -> do x <- readIORef 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+     writeIORef r $ Just h          

@@ -1,214 +1,214 @@-
-{-# LANGUAGE RecursiveDo #-}
-
--- |
--- Module     : Simulation.Aivika.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 representing a time varying polymorphic function. 
---
-module Simulation.Aivika.Internal.Dynamics
-       (-- * Dynamics
-        Dynamics(..),
-        DynamicsLift(..),
-        invokeDynamics,
-        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.Internal.Specs
-import Simulation.Aivika.Internal.Parameter
-import Simulation.Aivika.Internal.Simulation
-
--- | A value in the 'Dynamics' monad represents a polymorphic time varying function.
-newtype Dynamics a = Dynamics (Point -> IO a)
-
-instance Monad Dynamics where
-  return  = returnD
-  m >>= k = bindD m k
-
-returnD :: a -> Dynamics a
-{-# INLINE returnD #-}
-returnD a = Dynamics (\p -> return a)
-
-bindD :: Dynamics a -> (a -> Dynamics b) -> Dynamics b
-{-# INLINE bindD #-}
-bindD (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 a -> Simulation a
-runDynamicsInStartTime (Dynamics m) =
-  Simulation $ m . integStartPoint
-
--- | Run the 'Dynamics' computation in the final time point.
-runDynamicsInStopTime :: Dynamics a -> Simulation a
-runDynamicsInStopTime (Dynamics m) =
-  Simulation $ m . integStopPoint
-
--- | Run the 'Dynamics' computation in all integration time points.
-runDynamicsInIntegTimes :: Dynamics a -> Simulation [IO a]
-runDynamicsInIntegTimes (Dynamics m) =
-  Simulation $ return . map m . integPoints
-
--- | Run the 'Dynamics' computation in the specified time point.
-runDynamicsInTime :: Double -> Dynamics a -> Simulation a
-runDynamicsInTime t (Dynamics m) =
-  Simulation $ \r -> m $ pointAt r t
-
--- | Run the 'Dynamics' computation in the specified time points.
-runDynamicsInTimes :: [Double] -> Dynamics a -> Simulation [IO a]
-runDynamicsInTimes ts (Dynamics m) =
-  Simulation $ \r -> return $ map (m . pointAt r) ts 
-
-instance Functor Dynamics where
-  fmap = liftMD
-
-instance Applicative Dynamics where
-  pure = return
-  (<*>) = ap
-
-instance Eq (Dynamics a) where
-  x == y = error "Can't compare dynamics." 
-
-instance Show (Dynamics a) where
-  showsPrec _ x = showString "<< Dynamics >>"
-
-liftMD :: (a -> b) -> Dynamics a -> Dynamics b
-{-# INLINE liftMD #-}
-liftMD f (Dynamics x) =
-  Dynamics $ \p -> do { a <- x p; return $ f a }
-
-liftM2D :: (a -> b -> c) -> Dynamics a -> Dynamics b -> Dynamics 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) => Num (Dynamics a) where
-  x + y = liftM2D (+) x y
-  x - y = liftM2D (-) x y
-  x * y = liftM2D (*) x y
-  negate = liftMD negate
-  abs = liftMD abs
-  signum = liftMD signum
-  fromInteger i = return $ fromInteger i
-
-instance (Fractional a) => Fractional (Dynamics a) where
-  x / y = liftM2D (/) x y
-  recip = liftMD recip
-  fromRational t = return $ fromRational t
-
-instance (Floating a) => Floating (Dynamics a) where
-  pi = return pi
-  exp = liftMD exp
-  log = liftMD log
-  sqrt = liftMD sqrt
-  x ** y = liftM2D (**) x y
-  sin = liftMD sin
-  cos = liftMD cos
-  tan = liftMD tan
-  asin = liftMD asin
-  acos = liftMD acos
-  atan = liftMD atan
-  sinh = liftMD sinh
-  cosh = liftMD cosh
-  tanh = liftMD tanh
-  asinh = liftMD asinh
-  acosh = liftMD acosh
-  atanh = liftMD atanh
-
-instance MonadIO Dynamics where
-  liftIO m = Dynamics $ const m
-
-instance ParameterLift Dynamics where
-  liftParameter = liftDP
-
-instance SimulationLift Dynamics where
-  liftSimulation = liftDS
-    
-liftDP :: Parameter a -> Dynamics a
-{-# INLINE liftDP #-}
-liftDP (Parameter m) =
-  Dynamics $ \p -> m $ pointRun p
-    
-liftDS :: Simulation a -> Dynamics a
-{-# INLINE liftDS #-}
-liftDS (Simulation m) =
-  Dynamics $ \p -> m $ pointRun p
-
--- | A type class to lift the 'Dynamics' computations to other computations.
-class DynamicsLift m where
-  
-  -- | Lift the specified 'Dynamics' computation to another computation.
-  liftDynamics :: Dynamics a -> m a
-
-instance DynamicsLift Dynamics where
-  liftDynamics = id
-  
--- | Exception handling within 'Dynamics' computations.
-catchDynamics :: Exception e => Dynamics a -> (e -> Dynamics a) -> Dynamics a
-catchDynamics (Dynamics m) h =
-  Dynamics $ \p -> 
-  catch (m p) $ \e ->
-  let Dynamics m' = h e in m' p
-                           
--- | A computation with finalization part like the 'finally' function.
-finallyDynamics :: Dynamics a -> Dynamics b -> Dynamics a
-finallyDynamics (Dynamics m) (Dynamics m') =
-  Dynamics $ \p ->
-  finally (m p) (m' p)
-
--- | Like the standard 'throw' function.
-throwDynamics :: Exception e => e -> Dynamics a
-throwDynamics = throw
-
--- | Invoke the 'Dynamics' computation.
-invokeDynamics :: Point -> Dynamics a -> IO a
-{-# INLINE invokeDynamics #-}
-invokeDynamics p (Dynamics m) = m p
-
-instance MonadFix Dynamics where
-  mfix f = 
-    Dynamics $ \p ->
-    do { rec { a <- invokeDynamics p (f a) }; return a }
-
--- | Computation that returns the current simulation time.
-time :: Dynamics Double
-time = Dynamics $ return . pointTime 
-
--- | Whether the current time is an integration time.
-isTimeInteg :: Dynamics Bool
-isTimeInteg = Dynamics $ \p -> return $ pointPhase p >= 0
-
--- | Return the integration iteration closest to the current simulation time.
-integIteration :: Dynamics Int
-integIteration = Dynamics $ return . pointIteration
-
--- | Return the integration phase for the current simulation time.
--- It is @(-1)@ for non-integration time points.
-integPhase :: Dynamics Int
-integPhase = Dynamics $ return . pointPhase
++{-# LANGUAGE RecursiveDo #-}++-- |+-- Module     : Simulation.Aivika.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 representing a time varying polymorphic function. +--+module Simulation.Aivika.Internal.Dynamics+       (-- * Dynamics+        Dynamics(..),+        DynamicsLift(..),+        invokeDynamics,+        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.Internal.Specs+import Simulation.Aivika.Internal.Parameter+import Simulation.Aivika.Internal.Simulation++-- | A value in the 'Dynamics' monad represents a polymorphic time varying function.+newtype Dynamics a = Dynamics (Point -> IO a)++instance Monad Dynamics where+  return  = returnD+  m >>= k = bindD m k++returnD :: a -> Dynamics a+{-# INLINE returnD #-}+returnD a = Dynamics (\p -> return a)++bindD :: Dynamics a -> (a -> Dynamics b) -> Dynamics b+{-# INLINE bindD #-}+bindD (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 a -> Simulation a+runDynamicsInStartTime (Dynamics m) =+  Simulation $ m . integStartPoint++-- | Run the 'Dynamics' computation in the final time point.+runDynamicsInStopTime :: Dynamics a -> Simulation a+runDynamicsInStopTime (Dynamics m) =+  Simulation $ m . integStopPoint++-- | Run the 'Dynamics' computation in all integration time points.+runDynamicsInIntegTimes :: Dynamics a -> Simulation [IO a]+runDynamicsInIntegTimes (Dynamics m) =+  Simulation $ return . map m . integPoints++-- | Run the 'Dynamics' computation in the specified time point.+runDynamicsInTime :: Double -> Dynamics a -> Simulation a+runDynamicsInTime t (Dynamics m) =+  Simulation $ \r -> m $ pointAt r t++-- | Run the 'Dynamics' computation in the specified time points.+runDynamicsInTimes :: [Double] -> Dynamics a -> Simulation [IO a]+runDynamicsInTimes ts (Dynamics m) =+  Simulation $ \r -> return $ map (m . pointAt r) ts ++instance Functor Dynamics where+  fmap = liftMD++instance Applicative Dynamics where+  pure = return+  (<*>) = ap++instance Eq (Dynamics a) where+  x == y = error "Can't compare dynamics." ++instance Show (Dynamics a) where+  showsPrec _ x = showString "<< Dynamics >>"++liftMD :: (a -> b) -> Dynamics a -> Dynamics b+{-# INLINE liftMD #-}+liftMD f (Dynamics x) =+  Dynamics $ \p -> do { a <- x p; return $ f a }++liftM2D :: (a -> b -> c) -> Dynamics a -> Dynamics b -> Dynamics 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) => Num (Dynamics a) where+  x + y = liftM2D (+) x y+  x - y = liftM2D (-) x y+  x * y = liftM2D (*) x y+  negate = liftMD negate+  abs = liftMD abs+  signum = liftMD signum+  fromInteger i = return $ fromInteger i++instance (Fractional a) => Fractional (Dynamics a) where+  x / y = liftM2D (/) x y+  recip = liftMD recip+  fromRational t = return $ fromRational t++instance (Floating a) => Floating (Dynamics a) where+  pi = return pi+  exp = liftMD exp+  log = liftMD log+  sqrt = liftMD sqrt+  x ** y = liftM2D (**) x y+  sin = liftMD sin+  cos = liftMD cos+  tan = liftMD tan+  asin = liftMD asin+  acos = liftMD acos+  atan = liftMD atan+  sinh = liftMD sinh+  cosh = liftMD cosh+  tanh = liftMD tanh+  asinh = liftMD asinh+  acosh = liftMD acosh+  atanh = liftMD atanh++instance MonadIO Dynamics where+  liftIO m = Dynamics $ const m++instance ParameterLift Dynamics where+  liftParameter = liftDP++instance SimulationLift Dynamics where+  liftSimulation = liftDS+    +liftDP :: Parameter a -> Dynamics a+{-# INLINE liftDP #-}+liftDP (Parameter m) =+  Dynamics $ \p -> m $ pointRun p+    +liftDS :: Simulation a -> Dynamics a+{-# INLINE liftDS #-}+liftDS (Simulation m) =+  Dynamics $ \p -> m $ pointRun p++-- | A type class to lift the 'Dynamics' computations to other computations.+class DynamicsLift m where+  +  -- | Lift the specified 'Dynamics' computation to another computation.+  liftDynamics :: Dynamics a -> m a++instance DynamicsLift Dynamics where+  liftDynamics = id+  +-- | Exception handling within 'Dynamics' computations.+catchDynamics :: Exception e => Dynamics a -> (e -> Dynamics a) -> Dynamics a+catchDynamics (Dynamics m) h =+  Dynamics $ \p -> +  catch (m p) $ \e ->+  let Dynamics m' = h e in m' p+                           +-- | A computation with finalization part like the 'finally' function.+finallyDynamics :: Dynamics a -> Dynamics b -> Dynamics a+finallyDynamics (Dynamics m) (Dynamics m') =+  Dynamics $ \p ->+  finally (m p) (m' p)++-- | Like the standard 'throw' function.+throwDynamics :: Exception e => e -> Dynamics a+throwDynamics = throw++-- | Invoke the 'Dynamics' computation.+invokeDynamics :: Point -> Dynamics a -> IO a+{-# INLINE invokeDynamics #-}+invokeDynamics p (Dynamics m) = m p++instance MonadFix Dynamics where+  mfix f = +    Dynamics $ \p ->+    do { rec { a <- invokeDynamics p (f a) }; return a }++-- | Computation that returns the current simulation time.+time :: Dynamics Double+time = Dynamics $ return . pointTime ++-- | Whether the current time is an integration time.+isTimeInteg :: Dynamics Bool+isTimeInteg = Dynamics $ \p -> return $ pointPhase p >= 0++-- | Return the integration iteration closest to the current simulation time.+integIteration :: Dynamics Int+integIteration = Dynamics $ return . pointIteration++-- | Return the integration phase for the current simulation time.+-- It is @(-1)@ for non-integration time points.+integPhase :: Dynamics Int+integPhase = Dynamics $ return . pointPhase

@@ -1,409 +1,399 @@-
-{-# LANGUAGE RecursiveDo #-}
-
--- |
--- Module     : Simulation.Aivika.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 which is very similar to the 'Dynamics'
--- monad but only now the computation is strongly synchronized with the event queue.
---
-module Simulation.Aivika.Internal.Event
-       (-- * Event Monad
-        Event(..),
-        EventLift(..),
-        EventProcessing(..),
-        invokeEvent,
-        runEvent,
-        runEventWith,
-        runEventInStartTime,
-        runEventInStopTime,
-        -- * Event Queue
-        enqueueEvent,
-        enqueueEventWithCancellation,
-        enqueueEventWithTimes,
-        enqueueEventWithPoints,
-        enqueueEventWithIntegTimes,
-        yieldEvent,
-        eventQueueCount,
-        -- * Cancelling Event
-        EventCancellation,
-        cancelEvent,
-        eventCancelled,
-        eventFinished,
-        -- * Error Handling
-        catchEvent,
-        finallyEvent,
-        throwEvent,
-        -- * Memoization
-        memoEvent,
-        memoEventInTime,
-        -- * Disposable
-        DisposableEvent(..)) where
-
-import Data.IORef
-import Data.Monoid
-
-import Control.Exception
-import Control.Monad
-import Control.Monad.Trans
-import Control.Monad.Fix
-import Control.Applicative
-
-import qualified Simulation.Aivika.PriorityQueue as PQ
-
-import Simulation.Aivika.Internal.Specs
-import Simulation.Aivika.Internal.Parameter
-import Simulation.Aivika.Internal.Simulation
-import Simulation.Aivika.Internal.Dynamics
-
--- | A value in the 'Event' monad represents a polymorphic time varying function
--- which is strongly synchronized with the event queue.
-newtype Event a = Event (Point -> IO a)
-
-instance Monad Event where
-  return  = returnE
-  m >>= k = bindE m k
-
-returnE :: a -> Event a
-{-# INLINE returnE #-}
-returnE a = Event (\p -> return a)
-
-bindE :: Event a -> (a -> Event b) -> Event b
-{-# INLINE bindE #-}
-bindE (Event m) k = 
-  Event $ \p -> 
-  do a <- m p
-     let Event m' = k a
-     m' p
-
-instance Functor Event where
-  fmap = liftME
-
-instance Applicative Event where
-  pure = return
-  (<*>) = ap
-
-liftME :: (a -> b) -> Event a -> Event b
-{-# INLINE liftME #-}
-liftME f (Event x) =
-  Event $ \p -> do { a <- x p; return $ f a }
-
-instance MonadIO Event where
-  liftIO m = Event $ const m
-
-instance ParameterLift Event where
-  liftParameter = liftPS
-
-instance SimulationLift Event where
-  liftSimulation = liftES
-
-instance DynamicsLift Event where
-  liftDynamics = liftDS
-    
-liftPS :: Parameter a -> Event a
-{-# INLINE liftPS #-}
-liftPS (Parameter m) =
-  Event $ \p -> m $ pointRun p
-    
-liftES :: Simulation a -> Event a
-{-# INLINE liftES #-}
-liftES (Simulation m) =
-  Event $ \p -> m $ pointRun p
-
-liftDS :: Dynamics a -> Event a
-{-# INLINE liftDS #-}
-liftDS (Dynamics m) =
-  Event m
-
--- | A type class to lift the 'Event' computation to other computations.
-class EventLift m where
-  
-  -- | Lift the specified 'Event' computation to another computation.
-  liftEvent :: Event a -> m a
-
-instance EventLift Event where
-  liftEvent = id
-  
--- | Exception handling within 'Event' computations.
-catchEvent :: Exception e => Event a -> (e -> Event a) -> Event a
-catchEvent (Event m) h =
-  Event $ \p -> 
-  catch (m p) $ \e ->
-  let Event m' = h e in m' p
-                           
--- | A computation with finalization part like the 'finally' function.
-finallyEvent :: Event a -> Event b -> Event a
-finallyEvent (Event m) (Event m') =
-  Event $ \p ->
-  finally (m p) (m' p)
-
--- | Like the standard 'throw' function.
-throwEvent :: Exception e => e -> Event a
-throwEvent = throw
-
--- | Invoke the 'Event' computation.
-invokeEvent :: Point -> Event a -> IO a
-{-# INLINE invokeEvent #-}
-invokeEvent p (Event m) = m p
-
-instance MonadFix Event where
-  mfix f = 
-    Event $ \p ->
-    do { rec { a <- invokeEvent p (f a) }; return a }
-
--- | 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)
-
--- | 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 () -> Event ()
-enqueueEvent t (Event m) =
-  Event $ \p ->
-  let pq = queuePQ $ runEventQueue $ pointRun p
-  in PQ.enqueue pq t m
-
--- | Process the pending events.
-processPendingEventsCore :: Bool -> Dynamics ()
-processPendingEventsCore includingCurrentEvents = Dynamics r where
-  r p =
-    do let q = runEventQueue $ pointRun p
-           f = queueBusy q
-       f' <- readIORef f
-       unless f' $
-         do writeIORef f True
-            call q p
-            writeIORef 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' <- readIORef t
-            when (t2 < t') $ 
-              error "The time value is too small: processPendingEventsCore"
-            when ((t2 < pointTime p) ||
-                  (includingCurrentEvents && (t2 == pointTime p))) $
-              do writeIORef 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 ()
-processPendingEvents includingCurrentEvents = Dynamics r where
-  r p =
-    do let q = runEventQueue $ pointRun p
-           t = queueTime q
-       t' <- readIORef t
-       if pointTime p < t'
-         then error $
-              "The current time is less than " ++
-              "the time in the queue: processPendingEvents"
-         else invokeDynamics p m
-  m = processPendingEventsCore includingCurrentEvents
-
--- | A memoized value.
-processEventsIncludingCurrent = processPendingEvents True
-
--- | A memoized value.
-processEventsIncludingEarlier = processPendingEvents False
-
--- | A memoized value.
-processEventsIncludingCurrentCore = processPendingEventsCore True
-
--- | A memoized value.
-processEventsIncludingEarlierCore = processPendingEventsCore True
-
--- | Process the events.
-processEvents :: EventProcessing -> Dynamics ()
-processEvents CurrentEvents = processEventsIncludingCurrent
-processEvents EarlierEvents = processEventsIncludingEarlier
-processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore
-processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore
-
--- | Run the 'Event' computation in the current simulation time
--- within the 'Dynamics' computation involving all pending
--- 'CurrentEvents' in the processing too.
-runEvent :: Event a -> Dynamics a
-runEvent = runEventWith CurrentEvents
-
--- | Run the 'Event' computation in the current simulation time
--- within the 'Dynamics' computation specifying what pending events 
--- should be involved in the processing.
-runEventWith :: EventProcessing -> Event a -> Dynamics a
-runEventWith processing (Event e) =
-  Dynamics $ \p ->
-  do invokeDynamics p $ processEvents processing
-     e p
-
--- | Run the 'Event' computation in the start time involving all
--- pending 'CurrentEvents' in the processing too.
-runEventInStartTime :: Event a -> Simulation a
-runEventInStartTime = runDynamicsInStartTime . runEvent
-
--- | Run the 'Event' computation in the stop time involving all
--- pending 'CurrentEvents' in the processing too.
-runEventInStopTime :: Event a -> Simulation a
-runEventInStopTime = runDynamicsInStopTime . runEvent
-
--- | Return the number of pending events that should
--- be yet actuated.
-eventQueueCount :: Event Int
-eventQueueCount =
-  Event $ PQ.queueCount . queuePQ . runEventQueue . pointRun
-
--- | Actuate the event handler in the specified time points.
-enqueueEventWithTimes :: [Double] -> Event () -> Event ()
-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 :: [Point] -> Event () -> Event ()
-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 :: Event () -> Event ()
-enqueueEventWithIntegTimes e =
-  Event $ \p ->
-  let points = integPoints $ pointRun p
-  in invokeEvent p $ enqueueEventWithPoints points e
-
--- | It allows cancelling the event.
-data EventCancellation =
-  EventCancellation { cancelEvent   :: Event (),
-                      -- ^ Cancel the event.
-                      eventCancelled :: Event Bool,
-                      -- ^ Test whether the event was cancelled.
-                      eventFinished :: Event Bool
-                      -- ^ Test whether the event was processed and finished.
-                    }
-
--- | Enqueue the event with an ability to cancel it.
-enqueueEventWithCancellation :: Double -> Event () -> Event EventCancellation
-enqueueEventWithCancellation t e =
-  Event $ \p ->
-  do cancelledRef <- newIORef False
-     cancellableRef <- newIORef True
-     finishedRef <- newIORef False
-     let cancel =
-           Event $ \p ->
-           do x <- readIORef cancellableRef
-              when x $
-                writeIORef cancelledRef True
-         cancelled =
-           Event $ \p -> readIORef cancelledRef
-         finished =
-           Event $ \p -> readIORef finishedRef
-     invokeEvent p $
-       enqueueEvent t $
-       Event $ \p ->
-       do writeIORef cancellableRef False
-          x <- readIORef cancelledRef
-          unless x $
-            do invokeEvent p e
-               writeIORef finishedRef True
-     return EventCancellation { cancelEvent   = cancel,
-                                eventCancelled = cancelled,
-                                eventFinished = finished }
-
--- | Memoize the 'Event' computation, always returning the same value
--- within a simulation run.
-memoEvent :: Event a -> Simulation (Event a)
-memoEvent m =
-  do ref <- liftIO $ newIORef Nothing
-     return $ Event $ \p ->
-       do x <- readIORef ref
-          case x of
-            Just v -> return v
-            Nothing ->
-              do v <- invokeEvent p m
-                 writeIORef 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 :: Event a -> Simulation (Event a)
-memoEventInTime m =
-  do ref <- liftIO $ newIORef Nothing
-     return $ Event $ \p ->
-       do x <- readIORef ref
-          case x of
-            Just (t, v) | t == pointTime p ->
-              return v
-            _ ->
-              do v <- invokeEvent p m
-                 writeIORef ref (Just (pointTime p, v))
-                 return v
-
--- | Enqueue the event which must be actuated with the current modeling time but later.
-yieldEvent :: Event () -> Event ()
-yieldEvent m =
-  Event $ \p ->
-  invokeEvent p $
-  enqueueEvent (pointTime p) m
-
--- | Defines a computation disposing some entity.
-newtype DisposableEvent =
-  DisposableEvent { disposeEvent :: Event ()
-                    -- ^ Dispose something within the 'Event' computation.
-                  }
-
-instance Monoid DisposableEvent where
-
-  mempty = DisposableEvent $ return ()
-  mappend (DisposableEvent x) (DisposableEvent y) = DisposableEvent $ x >> y
++{-# LANGUAGE RecursiveDo #-}++-- |+-- Module     : Simulation.Aivika.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 which is very similar to the 'Dynamics'+-- monad but only now the computation is strongly synchronized with the event queue.+--+module Simulation.Aivika.Internal.Event+       (-- * Event Monad+        Event(..),+        EventLift(..),+        EventProcessing(..),+        invokeEvent,+        runEvent,+        runEventWith,+        runEventInStartTime,+        runEventInStopTime,+        -- * Event Queue+        enqueueEvent,+        enqueueEventWithCancellation,+        enqueueEventWithTimes,+        enqueueEventWithPoints,+        enqueueEventWithIntegTimes,+        yieldEvent,+        eventQueueCount,+        -- * Cancelling Event+        EventCancellation,+        cancelEvent,+        eventCancelled,+        eventFinished,+        -- * Error Handling+        catchEvent,+        finallyEvent,+        throwEvent,+        -- * Memoization+        memoEvent,+        memoEventInTime,+        -- * Disposable+        DisposableEvent(..)) where++import Data.IORef+import Data.Monoid++import Control.Exception+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Fix+import Control.Applicative++import qualified Simulation.Aivika.PriorityQueue as PQ++import Simulation.Aivika.Internal.Specs+import Simulation.Aivika.Internal.Parameter+import Simulation.Aivika.Internal.Simulation+import Simulation.Aivika.Internal.Dynamics++-- | A value in the 'Event' monad represents a polymorphic time varying function+-- which is strongly synchronized with the event queue.+newtype Event a = Event (Point -> IO a)++instance Monad Event where+  return  = returnE+  m >>= k = bindE m k++returnE :: a -> Event a+{-# INLINE returnE #-}+returnE a = Event (\p -> return a)++bindE :: Event a -> (a -> Event b) -> Event b+{-# INLINE bindE #-}+bindE (Event m) k = +  Event $ \p -> +  do a <- m p+     let Event m' = k a+     m' p++instance Functor Event where+  fmap = liftME++instance Applicative Event where+  pure = return+  (<*>) = ap++liftME :: (a -> b) -> Event a -> Event b+{-# INLINE liftME #-}+liftME f (Event x) =+  Event $ \p -> do { a <- x p; return $ f a }++instance MonadIO Event where+  liftIO m = Event $ const m++instance ParameterLift Event where+  liftParameter = liftPS++instance SimulationLift Event where+  liftSimulation = liftES++instance DynamicsLift Event where+  liftDynamics = liftDS+    +liftPS :: Parameter a -> Event a+{-# INLINE liftPS #-}+liftPS (Parameter m) =+  Event $ \p -> m $ pointRun p+    +liftES :: Simulation a -> Event a+{-# INLINE liftES #-}+liftES (Simulation m) =+  Event $ \p -> m $ pointRun p++liftDS :: Dynamics a -> Event a+{-# INLINE liftDS #-}+liftDS (Dynamics m) =+  Event m++-- | A type class to lift the 'Event' computation to other computations.+class EventLift m where+  +  -- | Lift the specified 'Event' computation to another computation.+  liftEvent :: Event a -> m a++instance EventLift Event where+  liftEvent = id+  +-- | Exception handling within 'Event' computations.+catchEvent :: Exception e => Event a -> (e -> Event a) -> Event a+catchEvent (Event m) h =+  Event $ \p -> +  catch (m p) $ \e ->+  let Event m' = h e in m' p+                           +-- | A computation with finalization part like the 'finally' function.+finallyEvent :: Event a -> Event b -> Event a+finallyEvent (Event m) (Event m') =+  Event $ \p ->+  finally (m p) (m' p)++-- | Like the standard 'throw' function.+throwEvent :: Exception e => e -> Event a+throwEvent = throw++-- | Invoke the 'Event' computation.+invokeEvent :: Point -> Event a -> IO a+{-# INLINE invokeEvent #-}+invokeEvent p (Event m) = m p++instance MonadFix Event where+  mfix f = +    Event $ \p ->+    do { rec { a <- invokeEvent p (f a) }; return a }++-- | 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)++-- | Enqueue the event which must be actuated at the specified time.+enqueueEvent :: Double -> Event () -> Event ()+enqueueEvent t (Event m) =+  Event $ \p ->+  let pq = queuePQ $ runEventQueue $ pointRun p+  in PQ.enqueue pq t m++-- | Process the pending events.+processPendingEventsCore :: Bool -> Dynamics ()+processPendingEventsCore includingCurrentEvents = Dynamics r where+  r p =+    do let q = runEventQueue $ pointRun p+           f = queueBusy q+       f' <- readIORef f+       unless f' $+         do writeIORef f True+            call q p+            writeIORef 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' <- readIORef t+            when (t2 < t') $ +              error "The time value is too small: processPendingEventsCore"+            when ((t2 < pointTime p) ||+                  (includingCurrentEvents && (t2 == pointTime p))) $+              do writeIORef 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 ()+processPendingEvents includingCurrentEvents = Dynamics r where+  r p =+    do let q = runEventQueue $ pointRun p+           t = queueTime q+       t' <- readIORef t+       if pointTime p < t'+         then error $+              "The current time is less than " +++              "the time in the queue: processPendingEvents"+         else invokeDynamics p m+  m = processPendingEventsCore includingCurrentEvents++-- | A memoized value.+processEventsIncludingCurrent = processPendingEvents True++-- | A memoized value.+processEventsIncludingEarlier = processPendingEvents False++-- | A memoized value.+processEventsIncludingCurrentCore = processPendingEventsCore True++-- | A memoized value.+processEventsIncludingEarlierCore = processPendingEventsCore True++-- | Process the events.+processEvents :: EventProcessing -> Dynamics ()+processEvents CurrentEvents = processEventsIncludingCurrent+processEvents EarlierEvents = processEventsIncludingEarlier+processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore+processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore++-- | Run the 'Event' computation in the current simulation time+-- within the 'Dynamics' computation involving all pending+-- 'CurrentEvents' in the processing too.+runEvent :: Event a -> Dynamics a+runEvent = runEventWith CurrentEvents++-- | Run the 'Event' computation in the current simulation time+-- within the 'Dynamics' computation specifying what pending events +-- should be involved in the processing.+runEventWith :: EventProcessing -> Event a -> Dynamics a+runEventWith processing (Event e) =+  Dynamics $ \p ->+  do invokeDynamics p $ processEvents processing+     e p++-- | Run the 'Event' computation in the start time involving all+-- pending 'CurrentEvents' in the processing too.+runEventInStartTime :: Event a -> Simulation a+runEventInStartTime = runDynamicsInStartTime . runEvent++-- | Run the 'Event' computation in the stop time involving all+-- pending 'CurrentEvents' in the processing too.+runEventInStopTime :: Event a -> Simulation a+runEventInStopTime = runDynamicsInStopTime . runEvent++-- | Return the number of pending events that should+-- be yet actuated.+eventQueueCount :: Event Int+eventQueueCount =+  Event $ PQ.queueCount . queuePQ . runEventQueue . pointRun++-- | Actuate the event handler in the specified time points.+enqueueEventWithTimes :: [Double] -> Event () -> Event ()+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 :: [Point] -> Event () -> Event ()+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 :: Event () -> Event ()+enqueueEventWithIntegTimes e =+  Event $ \p ->+  let points = integPoints $ pointRun p+  in invokeEvent p $ enqueueEventWithPoints points e++-- | It allows cancelling the event.+data EventCancellation =+  EventCancellation { cancelEvent   :: Event (),+                      -- ^ Cancel the event.+                      eventCancelled :: Event Bool,+                      -- ^ Test whether the event was cancelled.+                      eventFinished :: Event Bool+                      -- ^ Test whether the event was processed and finished.+                    }++-- | Enqueue the event with an ability to cancel it.+enqueueEventWithCancellation :: Double -> Event () -> Event EventCancellation+enqueueEventWithCancellation t e =+  Event $ \p ->+  do cancelledRef <- newIORef False+     cancellableRef <- newIORef True+     finishedRef <- newIORef False+     let cancel =+           Event $ \p ->+           do x <- readIORef cancellableRef+              when x $+                writeIORef cancelledRef True+         cancelled =+           Event $ \p -> readIORef cancelledRef+         finished =+           Event $ \p -> readIORef finishedRef+     invokeEvent p $+       enqueueEvent t $+       Event $ \p ->+       do writeIORef cancellableRef False+          x <- readIORef cancelledRef+          unless x $+            do invokeEvent p e+               writeIORef finishedRef True+     return EventCancellation { cancelEvent   = cancel,+                                eventCancelled = cancelled,+                                eventFinished = finished }++-- | Memoize the 'Event' computation, always returning the same value+-- within a simulation run.+memoEvent :: Event a -> Simulation (Event a)+memoEvent m =+  do ref <- liftIO $ newIORef Nothing+     return $ Event $ \p ->+       do x <- readIORef ref+          case x of+            Just v -> return v+            Nothing ->+              do v <- invokeEvent p m+                 writeIORef 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 :: Event a -> Simulation (Event a)+memoEventInTime m =+  do ref <- liftIO $ newIORef Nothing+     return $ Event $ \p ->+       do x <- readIORef ref+          case x of+            Just (t, v) | t == pointTime p ->+              return v+            _ ->+              do v <- invokeEvent p m+                 writeIORef ref (Just (pointTime p, v))+                 return v++-- | Enqueue the event which must be actuated with the current modeling time but later.+yieldEvent :: Event () -> Event ()+yieldEvent m =+  Event $ \p ->+  invokeEvent p $+  enqueueEvent (pointTime p) m++-- | Defines a computation disposing some entity.+newtype DisposableEvent =+  DisposableEvent { disposeEvent :: Event ()+                    -- ^ Dispose something within the 'Event' computation.+                  }++instance Monoid DisposableEvent where++  mempty = DisposableEvent $ return ()+  mappend (DisposableEvent x) (DisposableEvent y) = DisposableEvent $ x >> y

@@ -1,261 +1,261 @@-
-{-# LANGUAGE RecursiveDo #-}
-
--- |
--- Module     : Simulation.Aivika.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 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.Internal.Parameter
-       (-- * Parameter
-        Parameter(..),
-        ParameterLift(..),
-        invokeParameter,
-        runParameter,
-        runParameters,
-        -- * Error Handling
-        catchParameter,
-        finallyParameter,
-        throwParameter,
-        -- * Predefined Parameters
-        simulationIndex,
-        simulationCount,
-        simulationSpecs,
-        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.Generator
-import Simulation.Aivika.Internal.Specs
-
--- | 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 a = Parameter (Run -> IO a)
-
-instance Monad Parameter where
-  return  = returnP
-  m >>= k = bindP m k
-
-returnP :: a -> Parameter a
-{-# INLINE returnP #-}
-returnP a = Parameter (\r -> return a)
-
-bindP :: Parameter a -> (a -> Parameter b) -> Parameter b
-{-# INLINE bindP #-}
-bindP (Parameter m) k = 
-  Parameter $ \r -> 
-  do a <- m r
-     let Parameter m' = k a
-     m' r
-
--- | Run the parameter using the specified specs.
-runParameter :: Parameter a -> Specs -> IO a
-runParameter (Parameter m) sc =
-  do q <- newEventQueue sc
-     g <- newGenerator $ spcGeneratorType sc
-     m Run { runSpecs = sc,
-             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 :: Parameter a -> Specs -> Int -> [IO a]
-runParameters (Parameter m) sc runs = map f [1 .. runs]
-  where f i = do q <- newEventQueue sc
-                 g <- newGenerator $ spcGeneratorType sc
-                 m Run { runSpecs = sc,
-                         runIndex = i,
-                         runCount = runs,
-                         runEventQueue = q,
-                         runGenerator = g }
-
--- | Return the run index for the current simulation.
-simulationIndex :: Parameter Int
-simulationIndex = Parameter $ return . runIndex
-
--- | Return the number of simulations currently run.
-simulationCount :: Parameter Int
-simulationCount = Parameter $ return . runCount
-
--- | Return the simulation specs.
-simulationSpecs :: Parameter Specs
-simulationSpecs = Parameter $ return . runSpecs
-
--- | Return the random number generator for the simulation run.
-generatorParameter :: Parameter Generator
-generatorParameter = Parameter $ return . runGenerator
-
-instance Functor Parameter where
-  fmap = liftMP
-
-instance Applicative Parameter where
-  pure = return
-  (<*>) = ap
-
-instance Eq (Parameter a) where
-  x == y = error "Can't compare parameters." 
-
-instance Show (Parameter a) where
-  showsPrec _ x = showString "<< Parameter >>"
-
-liftMP :: (a -> b) -> Parameter a -> Parameter b
-{-# INLINE liftMP #-}
-liftMP f (Parameter x) =
-  Parameter $ \r -> do { a <- x r; return $ f a }
-
-liftM2P :: (a -> b -> c) -> Parameter a -> Parameter b -> Parameter 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) => Num (Parameter a) where
-  x + y = liftM2P (+) x y
-  x - y = liftM2P (-) x y
-  x * y = liftM2P (*) x y
-  negate = liftMP negate
-  abs = liftMP abs
-  signum = liftMP signum
-  fromInteger i = return $ fromInteger i
-
-instance (Fractional a) => Fractional (Parameter a) where
-  x / y = liftM2P (/) x y
-  recip = liftMP recip
-  fromRational t = return $ fromRational t
-
-instance (Floating a) => Floating (Parameter a) where
-  pi = return pi
-  exp = liftMP exp
-  log = liftMP log
-  sqrt = liftMP sqrt
-  x ** y = liftM2P (**) x y
-  sin = liftMP sin
-  cos = liftMP cos
-  tan = liftMP tan
-  asin = liftMP asin
-  acos = liftMP acos
-  atan = liftMP atan
-  sinh = liftMP sinh
-  cosh = liftMP cosh
-  tanh = liftMP tanh
-  asinh = liftMP asinh
-  acosh = liftMP acosh
-  atanh = liftMP atanh
-
-instance MonadIO Parameter where
-  liftIO m = Parameter $ const m
-
--- | A type class to lift the parameters to other computations.
-class ParameterLift m where
-  
-  -- | Lift the specified 'Parameter' computation to another computation.
-  liftParameter :: Parameter a -> m a
-
-instance ParameterLift Parameter where
-  liftParameter = id
-    
--- | Exception handling within 'Parameter' computations.
-catchParameter :: Exception e => Parameter a -> (e -> Parameter a) -> Parameter a
-catchParameter (Parameter m) h =
-  Parameter $ \r -> 
-  catch (m r) $ \e ->
-  let Parameter m' = h e in m' r
-                           
--- | A computation with finalization part like the 'finally' function.
-finallyParameter :: Parameter a -> Parameter b -> Parameter a
-finallyParameter (Parameter m) (Parameter m') =
-  Parameter $ \r ->
-  finally (m r) (m' r)
-
--- | Like the standard 'throw' function.
-throwParameter :: Exception e => e -> Parameter a
-throwParameter = throw
-
--- | Invoke the 'Parameter' computation.
-invokeParameter :: Run -> Parameter a -> IO a
-{-# INLINE invokeParameter #-}
-invokeParameter r (Parameter m) = m r
-
-instance MonadFix Parameter where
-  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 a -> IO (Parameter 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 :: Array Int a -> Parameter 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 :: Parameter Double
-starttime =
-  Parameter $ return . spcStartTime . runSpecs
-
--- | Computation that returns the final simulation time.
-stoptime :: Parameter Double
-stoptime =
-  Parameter $ return . spcStopTime . runSpecs
-
--- | Computation that returns the integration time step.
-dt :: Parameter Double
-dt =
-  Parameter $ return . spcDT . runSpecs
++{-# LANGUAGE RecursiveDo #-}++-- |+-- Module     : Simulation.Aivika.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 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.Internal.Parameter+       (-- * Parameter+        Parameter(..),+        ParameterLift(..),+        invokeParameter,+        runParameter,+        runParameters,+        -- * Error Handling+        catchParameter,+        finallyParameter,+        throwParameter,+        -- * Predefined Parameters+        simulationIndex,+        simulationCount,+        simulationSpecs,+        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.Generator+import Simulation.Aivika.Internal.Specs++-- | 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 a = Parameter (Run -> IO a)++instance Monad Parameter where+  return  = returnP+  m >>= k = bindP m k++returnP :: a -> Parameter a+{-# INLINE returnP #-}+returnP a = Parameter (\r -> return a)++bindP :: Parameter a -> (a -> Parameter b) -> Parameter b+{-# INLINE bindP #-}+bindP (Parameter m) k = +  Parameter $ \r -> +  do a <- m r+     let Parameter m' = k a+     m' r++-- | Run the parameter using the specified specs.+runParameter :: Parameter a -> Specs -> IO a+runParameter (Parameter m) sc =+  do q <- newEventQueue sc+     g <- newGenerator $ spcGeneratorType sc+     m Run { runSpecs = sc,+             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 :: Parameter a -> Specs -> Int -> [IO a]+runParameters (Parameter m) sc runs = map f [1 .. runs]+  where f i = do q <- newEventQueue sc+                 g <- newGenerator $ spcGeneratorType sc+                 m Run { runSpecs = sc,+                         runIndex = i,+                         runCount = runs,+                         runEventQueue = q,+                         runGenerator = g }++-- | Return the run index for the current simulation.+simulationIndex :: Parameter Int+simulationIndex = Parameter $ return . runIndex++-- | Return the number of simulations currently run.+simulationCount :: Parameter Int+simulationCount = Parameter $ return . runCount++-- | Return the simulation specs.+simulationSpecs :: Parameter Specs+simulationSpecs = Parameter $ return . runSpecs++-- | Return the random number generator for the simulation run.+generatorParameter :: Parameter Generator+generatorParameter = Parameter $ return . runGenerator++instance Functor Parameter where+  fmap = liftMP++instance Applicative Parameter where+  pure = return+  (<*>) = ap++instance Eq (Parameter a) where+  x == y = error "Can't compare parameters." ++instance Show (Parameter a) where+  showsPrec _ x = showString "<< Parameter >>"++liftMP :: (a -> b) -> Parameter a -> Parameter b+{-# INLINE liftMP #-}+liftMP f (Parameter x) =+  Parameter $ \r -> do { a <- x r; return $ f a }++liftM2P :: (a -> b -> c) -> Parameter a -> Parameter b -> Parameter 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) => Num (Parameter a) where+  x + y = liftM2P (+) x y+  x - y = liftM2P (-) x y+  x * y = liftM2P (*) x y+  negate = liftMP negate+  abs = liftMP abs+  signum = liftMP signum+  fromInteger i = return $ fromInteger i++instance (Fractional a) => Fractional (Parameter a) where+  x / y = liftM2P (/) x y+  recip = liftMP recip+  fromRational t = return $ fromRational t++instance (Floating a) => Floating (Parameter a) where+  pi = return pi+  exp = liftMP exp+  log = liftMP log+  sqrt = liftMP sqrt+  x ** y = liftM2P (**) x y+  sin = liftMP sin+  cos = liftMP cos+  tan = liftMP tan+  asin = liftMP asin+  acos = liftMP acos+  atan = liftMP atan+  sinh = liftMP sinh+  cosh = liftMP cosh+  tanh = liftMP tanh+  asinh = liftMP asinh+  acosh = liftMP acosh+  atanh = liftMP atanh++instance MonadIO Parameter where+  liftIO m = Parameter $ const m++-- | A type class to lift the parameters to other computations.+class ParameterLift m where+  +  -- | Lift the specified 'Parameter' computation to another computation.+  liftParameter :: Parameter a -> m a++instance ParameterLift Parameter where+  liftParameter = id+    +-- | Exception handling within 'Parameter' computations.+catchParameter :: Exception e => Parameter a -> (e -> Parameter a) -> Parameter a+catchParameter (Parameter m) h =+  Parameter $ \r -> +  catch (m r) $ \e ->+  let Parameter m' = h e in m' r+                           +-- | A computation with finalization part like the 'finally' function.+finallyParameter :: Parameter a -> Parameter b -> Parameter a+finallyParameter (Parameter m) (Parameter m') =+  Parameter $ \r ->+  finally (m r) (m' r)++-- | Like the standard 'throw' function.+throwParameter :: Exception e => e -> Parameter a+throwParameter = throw++-- | Invoke the 'Parameter' computation.+invokeParameter :: Run -> Parameter a -> IO a+{-# INLINE invokeParameter #-}+invokeParameter r (Parameter m) = m r++instance MonadFix Parameter where+  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 a -> IO (Parameter 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 :: Array Int a -> Parameter 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 :: Parameter Double+starttime =+  Parameter $ return . spcStartTime . runSpecs++-- | Computation that returns the final simulation time.+stoptime :: Parameter Double+stoptime =+  Parameter $ return . spcStopTime . runSpecs++-- | Computation that returns the integration time step.+dt :: Parameter Double+dt =+  Parameter $ return . spcDT . runSpecs

@@ -1,630 +1,643 @@-
--- |
--- Module     : Simulation.Aivika.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.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 Data.IORef
-
-import Control.Exception
-import Control.Monad
-import Control.Monad.Trans
-import Control.Applicative
-
-import Simulation.Aivika.Internal.Specs
-import Simulation.Aivika.Internal.Parameter
-import Simulation.Aivika.Internal.Simulation
-import Simulation.Aivika.Internal.Dynamics
-import Simulation.Aivika.Internal.Event
-import Simulation.Aivika.Internal.Cont
-import Simulation.Aivika.Internal.Signal
-
--- | Represents a process identifier.
-data ProcessId = 
-  ProcessId { processStarted :: IORef Bool,
-              processReactCont     :: IORef (Maybe (ContParams ())), 
-              processCancelSource  :: ContCancellationSource,
-              processInterruptRef  :: IORef Bool, 
-              processInterruptCont :: IORef (Maybe (ContParams ())), 
-              processInterruptVersion :: IORef Int }
-
--- | Specifies a discontinuous process that can suspend at any time
--- and then resume later.
-newtype Process a = Process (ProcessId -> Cont a)
-
--- | A type class to lift the 'Process' computation to other computations.
-class ProcessLift m where
-  
-  -- | Lift the specified 'Process' computation to another computation.
-  liftProcess :: Process a -> m a
-
-instance ProcessLift Process where
-  liftProcess = id
-
--- | Invoke the process computation.
-invokeProcess :: ProcessId -> Process a -> Cont a
-{-# INLINE invokeProcess #-}
-invokeProcess pid (Process m) = m pid
-
--- | Hold the process for the specified time period.
-holdProcess :: Double -> Process ()
-holdProcess dt =
-  Process $ \pid ->
-  Cont $ \c ->
-  Event $ \p ->
-  do let x = processInterruptCont pid
-     writeIORef x $ Just c
-     writeIORef (processInterruptRef pid) False
-     v <- readIORef (processInterruptVersion pid)
-     invokeEvent p $
-       enqueueEvent (pointTime p + dt) $
-       Event $ \p ->
-       do v' <- readIORef (processInterruptVersion pid)
-          when (v == v') $ 
-            do writeIORef x Nothing
-               invokeEvent p $ resumeCont c ()
-
--- | Interrupt a process with the specified identifier if the process
--- is held by computation 'holdProcess'.
-interruptProcess :: ProcessId -> Event ()
-interruptProcess pid =
-  Event $ \p ->
-  do let x = processInterruptCont pid
-     a <- readIORef x
-     case a of
-       Nothing -> return ()
-       Just c ->
-         do writeIORef x Nothing
-            writeIORef (processInterruptRef pid) True
-            modifyIORef (processInterruptVersion pid) $ (+) 1
-            invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c ()
-            
--- | Test whether the process with the specified identifier was interrupted.
-processInterrupted :: ProcessId -> Event Bool
-processInterrupted pid =
-  Event $ \p ->
-  readIORef (processInterruptRef pid)
-
--- | Passivate the process.
-passivateProcess :: Process ()
-passivateProcess =
-  Process $ \pid ->
-  Cont $ \c ->
-  Event $ \p ->
-  do let x = processReactCont pid
-     a <- readIORef x
-     case a of
-       Nothing -> writeIORef x $ Just c
-       Just _  -> error "Cannot passivate the process twice: passivateProcess"
-
--- | Test whether the process with the specified identifier is passivated.
-processPassive :: ProcessId -> Event Bool
-processPassive pid =
-  Event $ \p ->
-  do let x = processReactCont pid
-     a <- readIORef x
-     return $ isJust a
-
--- | Reactivate a process with the specified identifier.
-reactivateProcess :: ProcessId -> Event ()
-reactivateProcess pid =
-  Event $ \p ->
-  do let x = processReactCont pid
-     a <- readIORef x
-     case a of
-       Nothing -> 
-         return ()
-       Just c ->
-         do writeIORef x Nothing
-            invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c ()
-
--- | Prepare the processes identifier for running.
-processIdPrepare :: ProcessId -> Event ()
-processIdPrepare pid =
-  Event $ \p ->
-  do y <- readIORef (processStarted pid)
-     if y
-       then error $
-            "Another process with the specified identifier " ++
-            "has been started already: processIdPrepare"
-       else writeIORef (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 :: Process () -> Event ()
-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 :: ProcessId -> Process () -> Event ()
-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 :: Process () -> Simulation ()
-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 :: ProcessId -> Process () -> Simulation ()
-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 :: Process () -> Simulation ()
-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 :: ProcessId -> Process () -> Simulation ()
-runProcessInStopTimeUsingId pid p =
-  runEventInStopTime $ runProcessUsingId pid p
-
--- | Enqueue the process that will be then started at the specified time
--- from the event queue.
-enqueueProcess :: Double -> Process () -> Event ()
-enqueueProcess t p =
-  enqueueEvent t $ runProcess p
-
--- | Enqueue the process that will be then started at the specified time
--- from the event queue.
-enqueueProcessUsingId :: Double -> ProcessId -> Process () -> Event ()
-enqueueProcessUsingId t pid p =
-  enqueueEvent t $ runProcessUsingId pid p
-
--- | Return the current process identifier.
-processId :: Process ProcessId
-processId = Process return
-
--- | Create a new process identifier.
-newProcessId :: Simulation ProcessId
-newProcessId =
-  do x <- liftIO $ newIORef Nothing
-     y <- liftIO $ newIORef False
-     c <- newContCancellationSource
-     i <- liftIO $ newIORef False
-     z <- liftIO $ newIORef Nothing
-     v <- liftIO $ newIORef 0
-     return ProcessId { processStarted = y,
-                        processReactCont     = x, 
-                        processCancelSource  = c, 
-                        processInterruptRef  = i,
-                        processInterruptCont = z, 
-                        processInterruptVersion = v }
-
--- | Cancel a process with the specified identifier, interrupting it if needed.
-cancelProcessWithId :: ProcessId -> Event ()
-cancelProcessWithId pid = contCancellationInitiate (processCancelSource pid)
-
--- | The process cancels itself.
-cancelProcess :: Process 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 :: ProcessId -> Event Bool
-processCancelled pid = contCancellationInitiated (processCancelSource pid)
-
--- | Return a signal that notifies about cancelling the process with 
--- the specified identifier.
-processCancelling :: ProcessId -> Signal ()
-processCancelling pid = contCancellationInitiating (processCancelSource pid)
-
--- | Register a handler that will be invoked in case of cancelling the current process.
-whenCancellingProcess :: Event () -> Process ()
-whenCancellingProcess h =
-  Process $ \pid ->
-  liftEvent $
-  handleSignal_ (processCancelling pid) $ \() -> h
-
-instance Eq ProcessId where
-  x == y = processReactCont x == processReactCont y    -- for the references are unique
-
-instance Monad Process where
-  return  = returnP
-  m >>= k = bindP m k
-
-instance Functor Process where
-  fmap = liftM
-
-instance Applicative Process where
-  pure = return
-  (<*>) = ap
-
-instance ParameterLift Process where
-  liftParameter = liftPP
-
-instance SimulationLift Process where
-  liftSimulation = liftSP
-  
-instance DynamicsLift Process where
-  liftDynamics = liftDP
-  
-instance EventLift Process where
-  liftEvent = liftEP
-  
-instance MonadIO Process where
-  liftIO = liftIOP
-  
-returnP :: a -> Process a
-{-# INLINE returnP #-}
-returnP a = Process $ \pid -> return a
-
-bindP :: Process a -> (a -> Process b) -> Process b
-{-# INLINE bindP #-}
-bindP (Process m) k = 
-  Process $ \pid -> 
-  do a <- m pid
-     let Process m' = k a
-     m' pid
-
-liftPP :: Parameter a -> Process a
-{-# INLINE liftPP #-}
-liftPP m = Process $ \pid -> liftParameter m
-
-liftSP :: Simulation a -> Process a
-{-# INLINE liftSP #-}
-liftSP m = Process $ \pid -> liftSimulation m
-
-liftDP :: Dynamics a -> Process a
-{-# INLINE liftDP #-}
-liftDP m = Process $ \pid -> liftDynamics m
-
-liftEP :: Event a -> Process a
-{-# INLINE liftEP #-}
-liftEP m = Process $ \pid -> liftEvent m
-
-liftIOP :: IO a -> Process a
-{-# INLINE liftIOP #-}
-liftIOP m = Process $ \pid -> liftIO m
-
--- | Exception handling within 'Process' computations.
-catchProcess :: Exception e => Process a -> (e -> Process a) -> Process 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 :: Process a -> Process b -> Process 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 :: Exception e => e -> Process 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 :: [Process a] -> Process [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 :: [(ProcessId, Process a)] -> Process [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_ :: [Process a] -> Process ()
-processParallel_ xs =
-  liftSimulation (processParallelCreateIds xs) >>= processParallelUsingIds_ 
-
--- | Like 'processParallelUsingIds' but ignores the result.
-processParallelUsingIds_ :: [(ProcessId, Process a)] -> Process ()
-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 :: [Process a] -> Simulation [(ProcessId, Process a)]
-processParallelCreateIds xs =
-  do pids <- liftSimulation $ forM xs $ const newProcessId
-     return $ zip pids xs
-
--- | Prepare the processes for parallel execution.
-processParallelPrepare :: [(ProcessId, Process a)] -> Event ()
-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 :: ProcessId -> Process a -> Process 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 :: ContCancellation -> Process () -> Process ()
-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 :: ContCancellation -> ProcessId -> Process () -> Process ()
-spawnProcessUsingId cancellation pid x =
-  Process $ \pid' ->
-  do liftEvent $ processIdPrepare pid
-     spawnCont cancellation (invokeProcess pid x) (processCancelSource pid)
-
--- | Await the signal.
-processAwait :: Signal a -> Process 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 :: Process a -> Simulation (Process a)
-memoProcess x =
-  do started  <- liftIO $ newIORef False
-     computed <- newSignalSource
-     value    <- liftIO $ newIORef Nothing
-     let result =
-           do Just x <- liftIO $ readIORef value
-              case x of
-                MemoComputed a -> return a
-                MemoError e    -> throwProcess e
-                MemoCancelled  -> cancelProcess
-     return $
-       do v <- liftIO $ readIORef value
-          case v of
-            Just _ -> result
-            Nothing ->
-              do f <- liftIO $ readIORef started
-                 case f of
-                   True ->
-                     do processAwait $ publishSignal computed
-                        result
-                   False ->
-                     do liftIO $ writeIORef started True
-                        r <- liftIO $ newIORef MemoCancelled
-                        finallyProcess
-                          (catchProcess
-                           (do a <- x    -- compute only once!
-                               liftIO $ writeIORef r (MemoComputed a))
-                           (\e ->
-                             liftIO $ writeIORef r (MemoError e)))
-                          (liftEvent $
-                           do liftIO $
-                                do x <- readIORef r
-                                   writeIORef value (Just x)
-                              triggerSignal computed ())
-                        result
-
--- | Zip two parallel processes waiting for the both.
-zipProcessParallel :: Process a -> Process b -> Process (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 :: Process a -> Process b -> Process c -> Process (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 :: Process (a, b) -> Simulation (Process a, Process 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 :: Double -> Process a -> Process (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 :: Double -> ProcessId -> Process a -> Process (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 r <- liftIO $ newIORef Nothing
-          finallyProcess
-            (catchProcess
-             (do a <- p
-                 liftIO $ writeIORef r $ Just (Right a))
-             (\e ->
-               liftIO $ writeIORef r $ Just (Left e)))
-            (liftEvent $
-             do x <- liftIO $ readIORef 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 :: Process ()
-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 :: Process 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.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.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 Data.IORef++import Control.Exception+import Control.Monad+import Control.Monad.Trans+import Control.Applicative++import Simulation.Aivika.Internal.Specs+import Simulation.Aivika.Internal.Parameter+import Simulation.Aivika.Internal.Simulation+import Simulation.Aivika.Internal.Dynamics+import Simulation.Aivika.Internal.Event+import Simulation.Aivika.Internal.Cont+import Simulation.Aivika.Internal.Signal++-- | Represents a process identifier.+data ProcessId = +  ProcessId { processStarted :: IORef Bool,+              processReactCont     :: IORef (Maybe (ContParams ())), +              processCancelSource  :: ContCancellationSource,+              processInterruptRef  :: IORef Bool, +              processInterruptCont :: IORef (Maybe (ContParams ())), +              processInterruptVersion :: IORef Int }++-- | Specifies a discontinuous process that can suspend at any time+-- and then resume later.+newtype Process a = Process (ProcessId -> Cont a)++-- | A type class to lift the 'Process' computation to other computations.+class ProcessLift m where+  +  -- | Lift the specified 'Process' computation to another computation.+  liftProcess :: Process a -> m a++instance ProcessLift Process where+  liftProcess = id++-- | Invoke the process computation.+invokeProcess :: ProcessId -> Process a -> Cont a+{-# INLINE invokeProcess #-}+invokeProcess pid (Process m) = m pid++-- | Hold the process for the specified time period.+holdProcess :: Double -> Process ()+holdProcess dt =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do let x = processInterruptCont pid+     writeIORef x $ Just c+     writeIORef (processInterruptRef pid) False+     v <- readIORef (processInterruptVersion pid)+     invokeEvent p $+       enqueueEvent (pointTime p + dt) $+       Event $ \p ->+       do v' <- readIORef (processInterruptVersion pid)+          when (v == v') $ +            do writeIORef x Nothing+               invokeEvent p $ resumeCont c ()++-- | Interrupt a process with the specified identifier if the process+-- is held by computation 'holdProcess'.+interruptProcess :: ProcessId -> Event ()+interruptProcess pid =+  Event $ \p ->+  do let x = processInterruptCont pid+     a <- readIORef x+     case a of+       Nothing -> return ()+       Just c ->+         do writeIORef x Nothing+            writeIORef (processInterruptRef pid) True+            modifyIORef (processInterruptVersion pid) $ (+) 1+            invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c ()+            +-- | Test whether the process with the specified identifier was interrupted.+processInterrupted :: ProcessId -> Event Bool+processInterrupted pid =+  Event $ \p ->+  readIORef (processInterruptRef pid)++-- | Passivate the process.+passivateProcess :: Process ()+passivateProcess =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do let x = processReactCont pid+     a <- readIORef x+     case a of+       Nothing -> writeIORef x $ Just c+       Just _  -> error "Cannot passivate the process twice: passivateProcess"++-- | Test whether the process with the specified identifier is passivated.+processPassive :: ProcessId -> Event Bool+processPassive pid =+  Event $ \p ->+  do let x = processReactCont pid+     a <- readIORef x+     return $ isJust a++-- | Reactivate a process with the specified identifier.+reactivateProcess :: ProcessId -> Event ()+reactivateProcess pid =+  Event $ \p ->+  do let x = processReactCont pid+     a <- readIORef x+     case a of+       Nothing -> +         return ()+       Just c ->+         do writeIORef x Nothing+            invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c ()++-- | Prepare the processes identifier for running.+processIdPrepare :: ProcessId -> Event ()+processIdPrepare pid =+  Event $ \p ->+  do y <- readIORef (processStarted pid)+     if y+       then error $+            "Another process with the specified identifier " +++            "has been started already: processIdPrepare"+       else writeIORef (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 :: Process () -> Event ()+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 :: ProcessId -> Process () -> Event ()+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 :: Process () -> Simulation ()+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 :: ProcessId -> Process () -> Simulation ()+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 :: Process () -> Simulation ()+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 :: ProcessId -> Process () -> Simulation ()+runProcessInStopTimeUsingId pid p =+  runEventInStopTime $ runProcessUsingId pid p++-- | Enqueue the process that will be then started at the specified time+-- from the event queue.+enqueueProcess :: Double -> Process () -> Event ()+enqueueProcess t p =+  enqueueEvent t $ runProcess p++-- | Enqueue the process that will be then started at the specified time+-- from the event queue.+enqueueProcessUsingId :: Double -> ProcessId -> Process () -> Event ()+enqueueProcessUsingId t pid p =+  enqueueEvent t $ runProcessUsingId pid p++-- | Return the current process identifier.+processId :: Process ProcessId+processId = Process return++-- | Create a new process identifier.+newProcessId :: Simulation ProcessId+newProcessId =+  do x <- liftIO $ newIORef Nothing+     y <- liftIO $ newIORef False+     c <- newContCancellationSource+     i <- liftIO $ newIORef False+     z <- liftIO $ newIORef Nothing+     v <- liftIO $ newIORef 0+     return ProcessId { processStarted = y,+                        processReactCont     = x, +                        processCancelSource  = c, +                        processInterruptRef  = i,+                        processInterruptCont = z, +                        processInterruptVersion = v }++-- | Cancel a process with the specified identifier, interrupting it if needed.+cancelProcessWithId :: ProcessId -> Event ()+cancelProcessWithId pid = contCancellationInitiate (processCancelSource pid)++-- | The process cancels itself.+cancelProcess :: Process 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 :: ProcessId -> Event Bool+processCancelled pid = contCancellationInitiated (processCancelSource pid)++-- | Return a signal that notifies about cancelling the process with +-- the specified identifier.+processCancelling :: ProcessId -> Signal ()+processCancelling pid = contCancellationInitiating (processCancelSource pid)++-- | Register a handler that will be invoked in case of cancelling the current process.+whenCancellingProcess :: Event () -> Process ()+whenCancellingProcess h =+  Process $ \pid ->+  liftEvent $+  handleSignal_ (processCancelling pid) $ \() -> h++instance Eq ProcessId where+  x == y = processReactCont x == processReactCont y    -- for the references are unique++instance Monad Process where+  return  = returnP+  m >>= k = bindP m k++instance Functor Process where+  fmap = liftM++instance Applicative Process where+  pure = return+  (<*>) = ap++instance ParameterLift Process where+  liftParameter = liftPP++instance SimulationLift Process where+  liftSimulation = liftSP+  +instance DynamicsLift Process where+  liftDynamics = liftDP+  +instance EventLift Process where+  liftEvent = liftEP+  +instance MonadIO Process where+  liftIO = liftIOP+  +returnP :: a -> Process a+{-# INLINE returnP #-}+returnP a = Process $ \pid -> return a++bindP :: Process a -> (a -> Process b) -> Process b+{-# INLINE bindP #-}+bindP (Process m) k = +  Process $ \pid -> +  do a <- m pid+     let Process m' = k a+     m' pid++liftPP :: Parameter a -> Process a+{-# INLINE liftPP #-}+liftPP m = Process $ \pid -> liftParameter m++liftSP :: Simulation a -> Process a+{-# INLINE liftSP #-}+liftSP m = Process $ \pid -> liftSimulation m++liftDP :: Dynamics a -> Process a+{-# INLINE liftDP #-}+liftDP m = Process $ \pid -> liftDynamics m++liftEP :: Event a -> Process a+{-# INLINE liftEP #-}+liftEP m = Process $ \pid -> liftEvent m++liftIOP :: IO a -> Process a+{-# INLINE liftIOP #-}+liftIOP m = Process $ \pid -> liftIO m++-- | Exception handling within 'Process' computations.+catchProcess :: Exception e => Process a -> (e -> Process a) -> Process 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 :: Process a -> Process b -> Process 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 :: Exception e => e -> Process 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 :: [Process a] -> Process [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 :: [(ProcessId, Process a)] -> Process [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_ :: [Process a] -> Process ()+processParallel_ xs =+  liftSimulation (processParallelCreateIds xs) >>= processParallelUsingIds_ ++-- | Like 'processParallelUsingIds' but ignores the result.+processParallelUsingIds_ :: [(ProcessId, Process a)] -> Process ()+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 :: [Process a] -> Simulation [(ProcessId, Process a)]+processParallelCreateIds xs =+  do pids <- liftSimulation $ forM xs $ const newProcessId+     return $ zip pids xs++-- | Prepare the processes for parallel execution.+processParallelPrepare :: [(ProcessId, Process a)] -> Event ()+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 :: ProcessId -> Process a -> Process 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 :: Process () -> Process ()+spawnProcess = spawnProcessWith CancelTogether++-- | Spawn the child process with the specified process identifier.+-- In case of cancelling one of the processes, other process will+-- be cancelled too.+spawnProcessUsingId :: ProcessId -> Process () -> Process ()+spawnProcessUsingId = spawnProcessUsingIdWith CancelTogether++-- | Spawn the child process specifying how the child and parent processes+-- should be cancelled in case of need.+spawnProcessWith :: ContCancellation -> Process () -> Process ()+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 :: ContCancellation -> ProcessId -> Process () -> Process ()+spawnProcessUsingIdWith cancellation pid x =+  Process $ \pid' ->+  do liftEvent $ processIdPrepare pid+     spawnCont cancellation (invokeProcess pid x) (processCancelSource pid)++-- | Await the signal.+processAwait :: Signal a -> Process 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 :: Process a -> Simulation (Process a)+memoProcess x =+  do started  <- liftIO $ newIORef False+     computed <- newSignalSource+     value    <- liftIO $ newIORef Nothing+     let result =+           do Just x <- liftIO $ readIORef value+              case x of+                MemoComputed a -> return a+                MemoError e    -> throwProcess e+                MemoCancelled  -> cancelProcess+     return $+       do v <- liftIO $ readIORef value+          case v of+            Just _ -> result+            Nothing ->+              do f <- liftIO $ readIORef started+                 case f of+                   True ->+                     do processAwait $ publishSignal computed+                        result+                   False ->+                     do liftIO $ writeIORef started True+                        r <- liftIO $ newIORef MemoCancelled+                        finallyProcess+                          (catchProcess+                           (do a <- x    -- compute only once!+                               liftIO $ writeIORef r (MemoComputed a))+                           (\e ->+                             liftIO $ writeIORef r (MemoError e)))+                          (liftEvent $+                           do liftIO $+                                do x <- readIORef r+                                   writeIORef value (Just x)+                              triggerSignal computed ())+                        result++-- | Zip two parallel processes waiting for the both.+zipProcessParallel :: Process a -> Process b -> Process (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 :: Process a -> Process b -> Process c -> Process (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 :: Process (a, b) -> Simulation (Process a, Process 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 :: Double -> Process a -> Process (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 :: Double -> ProcessId -> Process a -> Process (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 r <- liftIO $ newIORef Nothing+          finallyProcess+            (catchProcess+             (do a <- p+                 liftIO $ writeIORef r $ Just (Right a))+             (\e ->+               liftIO $ writeIORef r $ Just (Left e)))+            (liftEvent $+             do x <- liftIO $ readIORef 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 :: Process ()+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 :: Process a+neverProcess =+  Process $ \pid ->+  Cont $ \c ->+  let signal = processCancelling pid+  in handleSignal_ signal $ \_ ->+     resumeCont c $ error "It must never be computed: neverProcess"