aivika 1.4 → 2.0

raw patch · 79 files changed

+16566/−16256 lines, 79 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 +85/−81
• Simulation/Aivika/Agent.hs +252/−252
• Simulation/Aivika/Arrival.hs +77/−77
• Simulation/Aivika/Circuit.hs +379/−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/−0
• Simulation/Aivika/Dynamics/Fold.hs +0/−82
• Simulation/Aivika/Dynamics/Interpolate.hs +0/−58
• Simulation/Aivika/Dynamics/Memo.hs +159/−127
• 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/−712
• Simulation/Aivika/Internal/Dynamics.hs +214/−216
• Simulation/Aivika/Internal/Event.hs +409/−411
• Simulation/Aivika/Internal/Parameter.hs +261/−262
• Simulation/Aivika/Internal/Process.hs +630/−627
• Simulation/Aivika/Internal/Signal.hs +380/−380
• Simulation/Aivika/Internal/Simulation.hs +161/−163
• Simulation/Aivika/Internal/Specs.hs +223/−223
• Simulation/Aivika/Net.hs +242/−242
• Simulation/Aivika/Parameter.hs +38/−38
• Simulation/Aivika/Parameter/Random.hs +123/−123
• Simulation/Aivika/PriorityQueue.hs +163/−161
• Simulation/Aivika/Process.hs +82/−82
• Simulation/Aivika/Processor.hs +458/−458
• Simulation/Aivika/Processor/RoundRobbin.hs +58/−58
• Simulation/Aivika/Queue.hs +1097/−1103
• Simulation/Aivika/Queue/Infinite.hs +636/−642
• Simulation/Aivika/QueueStrategy.hs +187/−178
• Simulation/Aivika/Ref.hs +69/−69
• Simulation/Aivika/Ref/Light.hs +0/−53
• Simulation/Aivika/Ref/Plain.hs +53/−0
• Simulation/Aivika/Resource.hs +335/−336
• Simulation/Aivika/Results.hs +1884/−1841
• Simulation/Aivika/Results/IO.hs +476/−476
• Simulation/Aivika/Results/Locale.hs +340/−339
• Simulation/Aivika/Server.hs +510/−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 +708/−708
• Simulation/Aivika/Table.hs +64/−64
• Simulation/Aivika/Task.hs +168/−168
• Simulation/Aivika/Transform.hs +126/−30
• Simulation/Aivika/Transform/Extra.hs +54/−0
• Simulation/Aivika/Transform/Memo.hs +45/−0
• Simulation/Aivika/Transform/Memo/Unboxed.hs +41/−0
• Simulation/Aivika/Unboxed.hs +48/−48
• Simulation/Aivika/Var.hs +188/−150
• Simulation/Aivika/Var/Unboxed.hs +188/−157
• Simulation/Aivika/Vector.hs +183/−183
• Simulation/Aivika/Vector/Unboxed.hs +186/−186
• aivika.cabal +203/−200
• 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/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,81 +1,85 @@---- |--- 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.Interpolate,-        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.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.Interpolate-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.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.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

@@ -1,252 +1,252 @@---- |--- Module     : Simulation.Aivika.Agent--- Copyright  : Copyright (c) 2009-2013, 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, while the state remains 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,379 @@--{-# 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-       (-- * Circuit Arrow-        Circuit(..),-        -- * Circuit Primitives-        arrCircuit,-        accumCircuit,-        -- * Arrival Circuit-        arrivalCircuit,-        -- * Delaying Circuit-        delayCircuit,-        -- * Time Circuit-        timeCircuit,-        -- * Conditional Computation-        (<?<),-        (>?>),-        filterCircuit,-        filterCircuitM,-        neverCircuit,-        -- * Converting to Signals and Processors-        circuitSignaling,-        circuitProcessor,-        -- * Integrals and Difference Equations-        integCircuit,-        sumCircuit,-        -- * 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(..),
+        -- * 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

@@ -1,19 +1,19 @@---- |--- Module     : Simulation.Aivika.Cont--- Copyright  : Copyright (c) 2009-2013, 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-2013, 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-2013, 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

@@ -0,0 +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

@@ -1,82 +0,0 @@---- |--- Module     : Simulation.Aivika.Dynamics.Fold--- Copyright  : Copyright (c) 2009-2013, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.6.3------ This module defines the fold functions that allows traversing the values of--- any 'Dynamics' computation in the integration time points.----module Simulation.Aivika.Dynamics.Fold-       (foldDynamics1,-        foldDynamics) where--import Data.IORef-import Control.Monad-import Control.Monad.Trans--import Simulation.Aivika.Internal.Specs-import Simulation.Aivika.Internal.Simulation-import Simulation.Aivika.Internal.Dynamics-import Simulation.Aivika.Dynamics.Memo------- Fold------- | Like the standard 'foldl1' function but applied to values in --- the integration time points. The accumulator values are transformed--- according to the first argument, which should be either function --- 'memo0Dynamics' or its unboxed version.-foldDynamics1 :: (Dynamics a -> Simulation (Dynamics a))-                 -> (a -> a -> a) -                 -> Dynamics a -                 -> Simulation (Dynamics a)-foldDynamics1 tr f (Dynamics m) =-  do r <- liftIO $ newIORef m-     let z = Dynamics $ \p ->-           case pointIteration p of-             0 -> -               m p-             n -> do -               let sc = pointSpecs p-                   ty = basicTime sc (n - 1) 0-                   py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 }-               y <- readIORef r-               s <- y py-               x <- m p-               return $! f s x-     y@(Dynamics m) <- tr z-     liftIO $ writeIORef r m-     return y---- | Like the standard 'foldl' function but applied to values in --- the integration time points. The accumulator values are transformed--- according to the first argument, which should be either function--- 'memo0Dynamics' or its unboxed version.-foldDynamics :: (Dynamics a -> Simulation (Dynamics a))-                -> (a -> b -> a) -                -> a-                -> Dynamics b -                -> Simulation (Dynamics a)-foldDynamics tr f acc (Dynamics m) =-  do r <- liftIO $ newIORef $ const $ return acc-     let z = Dynamics $ \p ->-           case pointIteration p of-             0 -> do-               x <- m p-               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 }-               y <- readIORef r-               s <- y py-               x <- m p-               return $! f s x-     y@(Dynamics m) <- tr z-     liftIO $ writeIORef r m-     return y

@@ -1,58 +0,0 @@---- |--- Module     : Simulation.Aivika.Dynamics.Interpolate--- Copyright  : Copyright (c) 2009-2013, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.6.3------ This module defines interpolation functions.--- These functions complement the memoization.-----module Simulation.Aivika.Dynamics.Interpolate-       (initDynamics,-        discreteDynamics,-        interpolateDynamics) where--import Simulation.Aivika.Internal.Specs-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 }

@@ -1,127 +1,159 @@---- |--- Module     : Simulation.Aivika.Dynamics.Memo--- Copyright  : Copyright (c) 2009-2013, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.6.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) 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.Interpolate---- | 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+
+-- |
+-- 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-2013, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.6.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.Interpolate-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-2013, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.6.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-     generatorUniform 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-     generatorUniformInt 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-     generatorNormal 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-     generatorExponential 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-     generatorErlang 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-     generatorPoisson 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-     generatorBinomial 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-2013, 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-2013, 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 { generatorUniform :: Double -> Double -> IO Double,-              -- ^ Generate an uniform random number-              -- with the specified minimum and maximum.-              generatorUniformInt :: Int -> Int -> IO Int,-              -- ^ Generate an uniform integer random number-              -- with the specified minimum and maximum.-              generatorNormal :: Double -> Double -> IO Double,-              -- ^ Generate the normal random number-              -- with the specified mean and deviation.-              generatorExponential :: Double -> IO Double,-              -- ^ Generate the random number distributed exponentially-              -- with the specified mean (the reciprocal of the rate).-              generatorErlang :: Double -> Int -> IO Double,-              -- ^ Generate the Erlang random number-              -- with the specified scale (the reciprocal of the rate) and integer shape.-              generatorPoisson :: Double -> IO Int,-              -- ^ Generate the Poisson random number-              -- with the specified mean.-              generatorBinomial :: 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.-generateUniform :: IO Double-                   -- ^ the generator-                   -> Double-                   -- ^ minimum-                   -> Double-                   -- ^ maximum-                   -> IO Double-generateUniform g min max =-  do x <- g-     return $ min + x * (max - min)---- | Generate the uniform random number with the specified minimum and maximum.-generateUniformInt :: IO Double-                      -- ^ the generator-                      -> Int-                      -- ^ minimum-                      -> Int-                      -- ^ maximum-                      -> IO Int-generateUniformInt 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.-newNormalGenerator :: IO Double-                      -- ^ the generator-                      -> IO (IO Double)-newNormalGenerator 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.-generateExponential :: IO Double-                       -- ^ the generator-                       -> Double-                       -- ^ the mean-                       -> IO Double-generateExponential g mu =-  do x <- g-     return (- log x * mu)---- | Return the Erlang random number.-generateErlang :: IO Double-                  -- ^ the generator-                  -> Double-                  -- ^ the scale-                  -> Int-                  -- ^ the shape-                  -> IO Double-generateErlang 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.-generatePoisson :: IO Double-                   -- ^ the generator-                   -> Double-                   -- ^ the mean-                   -> IO Int-generatePoisson 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. -generateBinomial :: IO Double-                    -- ^ the generator-                    -> Double -                    -- ^ the probability-                    -> Int-                    -- ^ the number of trials-                    -> IO Int-generateBinomial 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 <- newNormalGenerator g1-     let g3 mu nu =-           do x <- g2-              return $ mu + nu * x-     return Generator { generatorUniform = generateUniform g1,-                        generatorUniformInt = generateUniformInt g1,-                        generatorNormal = g3,-                        generatorExponential = generateExponential g1,-                        generatorErlang = generateErlang g1,-                        generatorPoisson = generatePoisson g1,-                        generatorBinomial = generateBinomial 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.6.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,712 +1,671 @@---- |--- Module     : Simulation.Aivika.Internal.Cont--- Copyright  : Copyright (c) 2009-2013, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.6.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 qualified Control.Exception as C-import Control.Exception (IOException, throw)--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 :: IOException -> 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 m k = ---   Cont $ \c -> ---   if (contCatchFlag . contAux $ c) ---   then bindWithCatch m k c---   else bindWithoutCatch m k c-  -bindC :: Cont a -> (a -> Cont b) -> Cont b-{-# INLINE bindC #-}-bindC m k = -  Cont $ bindWithoutCatch m k  -- Another version is not tail recursive!-  -bindWithoutCatch :: Cont a -> (a -> Cont b) -> ContParams b -> Event ()-{-# INLINE bindWithoutCatch #-}-bindWithoutCatch (Cont m) k 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 }---- -- It is not tail recursive!--- bindWithCatch :: Cont a -> (a -> Cont b) -> ContParams b -> Event ()--- {-# NOINLINE bindWithCatch #-}--- bindWithCatch (Cont m) k c = ---   Event $ \p ->---   do z <- contCanceled c---      if z ---        then cancelCont p c---        else invokeEvent p $ m $ ---             let cont a = catchEvent ---                          (invokeCont c (k a))---                          (contECont $ contAux c)---             in c { contCont = cont }---- Like "bindWithoutCatch (return a) k"-callWithoutCatch :: (a -> Cont b) -> a -> ContParams b -> Event ()-callWithoutCatch k a c =-  Event $ \p ->-  do z <- contCanceled c-     if z -       then cancelCont p c-       else invokeEvent p $ invokeCont c (k a)---- -- Like "bindWithCatch (return a) k" but it is not tail recursive!--- callWithCatch :: (a -> Cont b) -> a -> ContParams b -> Event ()--- callWithCatch k a c =---   Event $ \p ->---   do z <- contCanceled c---      if z ---        then cancelCont p c---        else invokeEvent p $ catchEvent ---             (invokeCont c (k a))---             (contECont $ contAux c)---- | Exception handling within 'Cont' computations.-catchCont :: Cont a -> (IOException -> Cont a) -> Cont a-catchCont m h = -  Cont $ \c ->-  catchWithCatch m h (c { contAux = (contAux c) { contCatchFlag = True } })-  -catchWithCatch :: Cont a -> (IOException -> Cont a) -> ContParams a -> Event ()-catchWithCatch (Cont m) h c =-  Event $ \p -> -  do z <- contCanceled c-     if z -       then cancelCont p c-       else invokeEvent p $ m $-            -- let econt e = callWithCatch h e c   -- not tail recursive!-            let econt e = callWithoutCatch h e c-            in c { contAux = (contAux c) { contECont = econt } }-               --- | A computation with finalization part.-finallyCont :: Cont a -> Cont b -> Cont a-finallyCont m m' = -  Cont $ \c -> -  finallyWithCatch m m' (c { contAux = (contAux c) { contCatchFlag = True } })-  -finallyWithCatch :: Cont a -> Cont b -> ContParams a -> Event ()               -finallyWithCatch (Cont m) (Cont m') c =-  Event $ \p ->-  do 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 reasons, the standard 'throw' function per se is not handled --- properly within 'Cont' computations, altough it will be still handled --- if it will be hidden under the 'liftIO' function. The problem arises --- namely with the @throw@ function, not 'IO' computations.-throwCont :: IOException -> Cont a-throwCont e = liftIO $ throw e---- | 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 -           -> (IOError -> 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-               C.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 -> IOException -> 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,216 +1,214 @@--{-# LANGUAGE RecursiveDo #-}---- |--- Module     : Simulation.Aivika.Internal.Dynamics--- Copyright  : Copyright (c) 2009-2013, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.6.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 qualified Control.Exception as C-import Control.Exception (IOException, throw, finally)--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 :: Dynamics a -> (IOException -> Dynamics a) -> Dynamics a-catchDynamics (Dynamics m) h =-  Dynamics $ \p -> -  C.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 ->-  C.finally (m p) (m' p)---- | Like the standard 'throw' function.-throwDynamics :: IOException -> 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,411 +1,409 @@--{-# LANGUAGE RecursiveDo #-}---- |--- Module     : Simulation.Aivika.Internal.Event--- Copyright  : Copyright (c) 2009-2013, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.6.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 qualified Control.Exception as C-import Control.Exception (IOException, throw, finally)--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 :: Event a -> (IOException -> Event a) -> Event a-catchEvent (Event m) h =-  Event $ \p -> -  C.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 ->-  C.finally (m p) (m' p)---- | Like the standard 'throw' function.-throwEvent :: IOException -> 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.
+--
+-- 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

@@ -1,262 +1,261 @@--{-# LANGUAGE RecursiveDo #-}---- |--- Module     : Simulation.Aivika.Internal.Parameter--- Copyright  : Copyright (c) 2009-2013, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.6.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 qualified Control.Exception as C-import Control.Exception (IOException, throw, finally)-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 :: Parameter a -> (IOException -> Parameter a) -> Parameter a-catchParameter (Parameter m) h =-  Parameter $ \r -> -  C.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 ->-  C.finally (m r) (m' r)---- | Like the standard 'throw' function.-throwParameter :: IOException -> 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,627 +1,630 @@---- |--- Module     : Simulation.Aivika.Internal.Process--- Copyright  : Copyright (c) 2009-2013, David Sorokin <david.sorokin@gmail.com>--- License    : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- Stability  : experimental--- Tested with: GHC 7.6.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 (IOException, throw)-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."---- | 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 :: Process a -> (IOException -> 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 reasons, the standard 'throw' function per se is not handled --- properly within 'Process' computations, although it will be still --- handled if it will be hidden under the 'liftIO' function. The problem --- arises namely with the @throw@ function, not 'IO' computations.-throwProcess :: IOException -> 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 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,
+        -- * 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"