diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (c) 2009, 2010, 2011, 2012, 2013, 2014 David Sorokin - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. +Copyright (c) 2009, 2010, 2011, 2012, 2013, 2014 David Sorokin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,3 +1,3 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/Simulation/Aivika.hs b/Simulation/Aivika.hs --- a/Simulation/Aivika.hs +++ b/Simulation/Aivika.hs @@ -1,81 +1,85 @@ - --- | --- Module : Simulation.Aivika --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module re-exports the most part of the library functionality. --- But there are modules that must be imported explicitly. --- -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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module re-exports the most part of the library functionality. +-- But there are modules that must be imported explicitly. +-- +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 diff --git a/Simulation/Aivika/Agent.hs b/Simulation/Aivika/Agent.hs --- a/Simulation/Aivika/Agent.hs +++ b/Simulation/Aivika/Agent.hs @@ -1,252 +1,252 @@ - --- | --- Module : Simulation.Aivika.Agent --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module introduces basic entities for the agent-based modeling. --- -module Simulation.Aivika.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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module introduces basic entities for the agent-based modeling. +-- +module Simulation.Aivika.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 diff --git a/Simulation/Aivika/Arrival.hs b/Simulation/Aivika/Arrival.hs --- a/Simulation/Aivika/Arrival.hs +++ b/Simulation/Aivika/Arrival.hs @@ -1,77 +1,77 @@ - --- | --- Module : Simulation.Aivika.Arrival --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines the types and functions for working with the events --- that can represent something that arrive from outside the model, or --- represent other things which computation is delayed and hence is not synchronized. --- --- Therefore, the additional information is provided about the time and delay of arrival. - -module Simulation.Aivika.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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the types and functions for working with the events +-- that can represent something that arrive from outside the model, or +-- represent other things which computation is delayed and hence is not synchronized. +-- +-- Therefore, the additional information is provided about the time and delay of arrival. + +module Simulation.Aivika.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) diff --git a/Simulation/Aivika/Circuit.hs b/Simulation/Aivika/Circuit.hs --- a/Simulation/Aivika/Circuit.hs +++ b/Simulation/Aivika/Circuit.hs @@ -1,379 +1,379 @@ - -{-# LANGUAGE RecursiveDo, Arrows #-} - --- | --- Module : Simulation.Aivika.Circuit --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It represents a circuit synchronized with the event queue. --- Also it allows creating the recursive links with help of --- the proc-notation. --- --- The implementation is based on the . --- -module Simulation.Aivika.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 a (Maybe b) - -- ^ whether there is an event - -> Circuit a (Maybe c) - -- ^ the resulting circuit that processes only the represented events -(?>) - --- | Filter the circuit, calculating only those parts of the circuit that satisfy --- the specified predicate. -filterCircuit :: (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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It represents a circuit synchronized with the event queue. +-- Also it allows creating the recursive links with help of +-- the proc-notation. +-- +-- The implementation is based on the . +-- +module Simulation.Aivika.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 a (Maybe b) + -- ^ whether there is an event + -> Circuit a (Maybe c) + -- ^ the resulting circuit that processes only the represented events +(?>) + +-- | Filter the circuit, calculating only those parts of the circuit that satisfy +-- the specified predicate. +filterCircuit :: (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 diff --git a/Simulation/Aivika/Cont.hs b/Simulation/Aivika/Cont.hs --- a/Simulation/Aivika/Cont.hs +++ b/Simulation/Aivika/Cont.hs @@ -1,19 +1,19 @@ - --- | --- Module : Simulation.Aivika.Cont --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The 'Cont' monad is a variation of the standard Cont monad --- and F# async workflow, where the result of applying --- the continuations is the 'Event' computation. --- -module Simulation.Aivika.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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The 'Cont' monad is a variation of the standard Cont monad +-- and F# async workflow, where the result of applying +-- the continuations is the 'Event' computation. +-- +module Simulation.Aivika.Cont + (ContCancellation(..), + Cont) where + +import Simulation.Aivika.Internal.Event +import Simulation.Aivika.Internal.Cont diff --git a/Simulation/Aivika/DoubleLinkedList.hs b/Simulation/Aivika/DoubleLinkedList.hs --- a/Simulation/Aivika/DoubleLinkedList.hs +++ b/Simulation/Aivika/DoubleLinkedList.hs @@ -1,165 +1,165 @@ - --- | --- Module : Simulation.Aivika.DoubleLinkedList --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Dynamics.hs b/Simulation/Aivika/Dynamics.hs --- a/Simulation/Aivika/Dynamics.hs +++ b/Simulation/Aivika/Dynamics.hs @@ -1,31 +1,31 @@ - --- | --- Module : Simulation.Aivika.Dynamics --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Dynamics/Extra.hs b/Simulation/Aivika/Dynamics/Extra.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Dynamics/Extra.hs @@ -0,0 +1,109 @@ + +{-# LANGUAGE RecursiveDo #-} + +-- | +-- Module : Simulation.Aivika.Dynamics.Extra +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines auxiliary functions such as interpolation ones +-- that complement the memoization, for example. There are scan functions too. +-- + +module Simulation.Aivika.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 diff --git a/Simulation/Aivika/Dynamics/Fold.hs b/Simulation/Aivika/Dynamics/Fold.hs deleted file mode 100644 --- a/Simulation/Aivika/Dynamics/Fold.hs +++ /dev/null @@ -1,82 +0,0 @@ - --- | --- Module : Simulation.Aivika.Dynamics.Fold --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 diff --git a/Simulation/Aivika/Dynamics/Interpolate.hs b/Simulation/Aivika/Dynamics/Interpolate.hs deleted file mode 100644 --- a/Simulation/Aivika/Dynamics/Interpolate.hs +++ /dev/null @@ -1,58 +0,0 @@ - --- | --- Module : Simulation.Aivika.Dynamics.Interpolate --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 } diff --git a/Simulation/Aivika/Dynamics/Memo.hs b/Simulation/Aivika/Dynamics/Memo.hs --- a/Simulation/Aivika/Dynamics/Memo.hs +++ b/Simulation/Aivika/Dynamics/Memo.hs @@ -1,127 +1,159 @@ - --- | --- Module : Simulation.Aivika.Dynamics.Memo --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines memo functions. The memoization creates such 'Dynamics' +-- computations, which values are cached in the integration time points. Then +-- these values are interpolated in all other time points. +-- + +module Simulation.Aivika.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) diff --git a/Simulation/Aivika/Dynamics/Memo/Unboxed.hs b/Simulation/Aivika/Dynamics/Memo/Unboxed.hs --- a/Simulation/Aivika/Dynamics/Memo/Unboxed.hs +++ b/Simulation/Aivika/Dynamics/Memo/Unboxed.hs @@ -1,102 +1,102 @@ - -{-# LANGUAGE FlexibleContexts #-} - --- | --- Module : Simulation.Aivika.Dynamics.Memo.Unboxed --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Dynamics/Random.hs b/Simulation/Aivika/Dynamics/Random.hs --- a/Simulation/Aivika/Dynamics/Random.hs +++ b/Simulation/Aivika/Dynamics/Random.hs @@ -1,132 +1,132 @@ - --- | --- Module : Simulation.Aivika.Dynamics.Random --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the random functions that always return the same values +-- in the integration time points within a single simulation run. The values +-- for another simulation run will be regenerated anew. +-- +-- For example, the computations returned by these functions can be used in +-- the equations of System Dynamics. +-- +-- Also it is worth noting that the values are generated in a strong order starting +-- from 'starttime' with step 'dt'. This is how the 'memo0Dynamics' function +-- actually works. +-- + +module Simulation.Aivika.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' diff --git a/Simulation/Aivika/Event.hs b/Simulation/Aivika/Event.hs --- a/Simulation/Aivika/Event.hs +++ b/Simulation/Aivika/Event.hs @@ -1,44 +1,44 @@ - --- | --- Module : Simulation.Aivika.Event --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines the 'Event' monad which is very similar to the 'Dynamics' --- monad but only now the computation is strongly synchronized with the event queue. --- -module Simulation.Aivika.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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the 'Event' monad which is very similar to the 'Dynamics' +-- monad but only now the computation is strongly synchronized with the event queue. +-- +module Simulation.Aivika.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 diff --git a/Simulation/Aivika/Generator.hs b/Simulation/Aivika/Generator.hs --- a/Simulation/Aivika/Generator.hs +++ b/Simulation/Aivika/Generator.hs @@ -1,220 +1,220 @@ - --- | --- Module : Simulation.Aivika.Generator --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/Internal/Arrival.hs b/Simulation/Aivika/Internal/Arrival.hs --- a/Simulation/Aivika/Internal/Arrival.hs +++ b/Simulation/Aivika/Internal/Arrival.hs @@ -1,39 +1,39 @@ - --- | --- Module : Simulation.Aivika.Internal.Arrival --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the types and functions for working with the events +-- that can represent something that arrive from outside the model, or +-- represent other things which computation is delayed and hence is not synchronized. +-- +-- Therefore, the additional information is provided about the time and delay of arrival. + +module Simulation.Aivika.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) diff --git a/Simulation/Aivika/Internal/Cont.hs b/Simulation/Aivika/Internal/Cont.hs --- a/Simulation/Aivika/Internal/Cont.hs +++ b/Simulation/Aivika/Internal/Cont.hs @@ -1,712 +1,671 @@ - --- | --- Module : Simulation.Aivika.Internal.Cont --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The 'Cont' monad is a variation of the standard Cont monad +-- and F# async workflow, where the result of applying +-- the continuations is the 'Event' computation. +-- +module Simulation.Aivika.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 diff --git a/Simulation/Aivika/Internal/Dynamics.hs b/Simulation/Aivika/Internal/Dynamics.hs --- a/Simulation/Aivika/Internal/Dynamics.hs +++ b/Simulation/Aivika/Internal/Dynamics.hs @@ -1,216 +1,214 @@ - -{-# LANGUAGE RecursiveDo #-} - --- | --- Module : Simulation.Aivika.Internal.Dynamics --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Internal/Event.hs b/Simulation/Aivika/Internal/Event.hs --- a/Simulation/Aivika/Internal/Event.hs +++ b/Simulation/Aivika/Internal/Event.hs @@ -1,411 +1,409 @@ - -{-# LANGUAGE RecursiveDo #-} - --- | --- Module : Simulation.Aivika.Internal.Event --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the 'Event' monad which is very similar to the 'Dynamics' +-- monad but only now the computation is strongly synchronized with the event queue. +-- +module Simulation.Aivika.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 diff --git a/Simulation/Aivika/Internal/Parameter.hs b/Simulation/Aivika/Internal/Parameter.hs --- a/Simulation/Aivika/Internal/Parameter.hs +++ b/Simulation/Aivika/Internal/Parameter.hs @@ -1,262 +1,261 @@ - -{-# LANGUAGE RecursiveDo #-} - --- | --- Module : Simulation.Aivika.Internal.Parameter --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Internal/Process.hs b/Simulation/Aivika/Internal/Process.hs --- a/Simulation/Aivika/Internal/Process.hs +++ b/Simulation/Aivika/Internal/Process.hs @@ -1,627 +1,630 @@ - --- | --- Module : Simulation.Aivika.Internal.Process --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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 +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- A value in the 'Process' monad represents a discontinuous process that +-- can suspend in any simulation time point and then resume later in the same +-- or another time point. +-- +-- The process of this type can involve the 'Event', 'Dynamics' and 'Simulation' +-- computations. Moreover, a value in the @Process@ monad can be run within +-- the @Event@ computation. +-- +-- A value of the 'ProcessId' type is just an identifier of such a process. +-- +module Simulation.Aivika.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" diff --git a/Simulation/Aivika/Internal/Signal.hs b/Simulation/Aivika/Internal/Signal.hs --- a/Simulation/Aivika/Internal/Signal.hs +++ b/Simulation/Aivika/Internal/Signal.hs @@ -1,380 +1,380 @@ - --- | --- Module : Simulation.Aivika.Internal.Signal --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- This module defines the signal which we can subscribe handlers to. --- These handlers can be disposed. The signal is triggered in the --- current time point actuating the corresponded computations from --- the handlers. --- - -module Simulation.Aivika.Internal.Signal - (-- * Handling and Triggering Signal - Signal(..), - handleSignal_, - SignalSource, - newSignalSource, - publishSignal, - triggerSignal, - -- * Useful Combinators - mapSignal, - mapSignalM, - apSignal, - filterSignal, - filterSignalM, - emptySignal, - merge2Signals, - merge3Signals, - merge4Signals, - merge5Signals, - -- * Signal Arriving - arrivalSignal, - -- * Creating Signal in Time Points - newSignalInTimes, - newSignalInIntegTimes, - newSignalInStartTime, - newSignalInStopTime, - -- * Signal History - SignalHistory, - signalHistorySignal, - newSignalHistory, - newSignalHistoryStartingWith, - readSignalHistory, - -- * Signalable Computations - Signalable(..), - signalableChanged, - emptySignalable, - appendSignalable) where - -import Data.IORef -import Data.Monoid -import Data.List -import Data.Array - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Internal.Specs -import Simulation.Aivika.Internal.Parameter -import Simulation.Aivika.Internal.Simulation -import Simulation.Aivika.Internal.Event -import Simulation.Aivika.Internal.Arrival - -import qualified Simulation.Aivika.Vector as V -import qualified Simulation.Aivika.Vector.Unboxed as UV - --- | The signal source that can publish its signal. -data SignalSource a = - SignalSource { publishSignal :: Signal a, - -- ^ Publish the signal. - triggerSignal :: a -> Event () - -- ^ Trigger the signal actuating - -- all its handlers at the current - -- simulation time point. - } - --- | The signal that can have disposable handlers. -data Signal a = - Signal { handleSignal :: (a -> Event ()) -> Event DisposableEvent - -- ^ Subscribe the handler to the specified - -- signal and return a nested computation - -- within a disposable object that, being applied, - -- unsubscribes the handler from this signal. - } - --- | The queue of signal handlers. -data SignalHandlerQueue a = - SignalHandlerQueue { queueList :: IORef [SignalHandler a] } - --- | It contains the information about the disposable queue handler. -data SignalHandler a = - SignalHandler { handlerComp :: a -> Event (), - handlerRef :: IORef () } - -instance Eq (SignalHandler a) where - x == y = (handlerRef x) == (handlerRef y) - --- | Subscribe the handler to the specified signal forever. --- To subscribe the disposable handlers, use function 'handleSignal'. -handleSignal_ :: Signal a -> (a -> Event ()) -> Event () -handleSignal_ signal h = - do x <- handleSignal signal h - return () - --- | Create a new signal source. -newSignalSource :: Simulation (SignalSource a) -newSignalSource = - Simulation $ \r -> - do list <- newIORef [] - let queue = SignalHandlerQueue { queueList = list } - signal = Signal { handleSignal = handle } - source = SignalSource { publishSignal = signal, - triggerSignal = trigger } - handle h = - Event $ \p -> - do x <- enqueueSignalHandler queue h - return $ - DisposableEvent $ - Event $ \p -> dequeueSignalHandler queue x - trigger a = - Event $ \p -> triggerSignalHandlers queue a p - return source - --- | Trigger all next signal handlers. -triggerSignalHandlers :: SignalHandlerQueue a -> a -> Point -> IO () -{-# INLINE triggerSignalHandlers #-} -triggerSignalHandlers q a p = - do hs <- readIORef (queueList q) - forM_ hs $ \h -> - invokeEvent p $ handlerComp h a - --- | Enqueue the handler and return its representative in the queue. -enqueueSignalHandler :: SignalHandlerQueue a -> (a -> Event ()) -> IO (SignalHandler a) -{-# INLINE enqueueSignalHandler #-} -enqueueSignalHandler q h = - do r <- newIORef () - let handler = SignalHandler { handlerComp = h, - handlerRef = r } - modifyIORef (queueList q) (handler :) - return handler - --- | Dequeue the handler representative. -dequeueSignalHandler :: SignalHandlerQueue a -> SignalHandler a -> IO () -{-# INLINE dequeueSignalHandler #-} -dequeueSignalHandler q h = - modifyIORef (queueList q) (delete h) - -instance Functor Signal where - fmap = mapSignal - -instance Monoid (Signal a) where - - mempty = emptySignal - - mappend = merge2Signals - - mconcat [] = emptySignal - mconcat [x1] = x1 - mconcat [x1, x2] = merge2Signals x1 x2 - mconcat [x1, x2, x3] = merge3Signals x1 x2 x3 - mconcat [x1, x2, x3, x4] = merge4Signals x1 x2 x3 x4 - mconcat [x1, x2, x3, x4, x5] = merge5Signals x1 x2 x3 x4 x5 - mconcat (x1 : x2 : x3 : x4 : x5 : xs) = - mconcat $ merge5Signals x1 x2 x3 x4 x5 : xs - --- | Map the signal according the specified function. -mapSignal :: (a -> b) -> Signal a -> Signal b -mapSignal f m = - Signal { handleSignal = \h -> - handleSignal m $ h . f } - --- | Filter only those signal values that satisfy to --- the specified predicate. -filterSignal :: (a -> Bool) -> Signal a -> Signal a -filterSignal p m = - Signal { handleSignal = \h -> - handleSignal m $ \a -> - when (p a) $ h a } - --- | Filter only those signal values that satisfy to --- the specified predicate. -filterSignalM :: (a -> Event Bool) -> Signal a -> Signal a -filterSignalM p m = - Signal { handleSignal = \h -> - handleSignal m $ \a -> - do x <- p a - when x $ h a } - --- | Merge two signals. -merge2Signals :: Signal a -> Signal a -> Signal a -merge2Signals m1 m2 = - Signal { handleSignal = \h -> - do x1 <- handleSignal m1 h - x2 <- handleSignal m2 h - return $ x1 <> x2 } - --- | Merge three signals. -merge3Signals :: Signal a -> Signal a -> Signal a -> Signal a -merge3Signals m1 m2 m3 = - Signal { handleSignal = \h -> - do x1 <- handleSignal m1 h - x2 <- handleSignal m2 h - x3 <- handleSignal m3 h - return $ x1 <> x2 <> x3 } - --- | Merge four signals. -merge4Signals :: Signal a -> Signal a -> Signal a -> - Signal a -> Signal a -merge4Signals m1 m2 m3 m4 = - Signal { handleSignal = \h -> - do x1 <- handleSignal m1 h - x2 <- handleSignal m2 h - x3 <- handleSignal m3 h - x4 <- handleSignal m4 h - return $ x1 <> x2 <> x3 <> x4 } - --- | Merge five signals. -merge5Signals :: Signal a -> Signal a -> Signal a -> - Signal a -> Signal a -> Signal a -merge5Signals m1 m2 m3 m4 m5 = - Signal { handleSignal = \h -> - do x1 <- handleSignal m1 h - x2 <- handleSignal m2 h - x3 <- handleSignal m3 h - x4 <- handleSignal m4 h - x5 <- handleSignal m5 h - return $ x1 <> x2 <> x3 <> x4 <> x5 } - --- | Compose the signal. -mapSignalM :: (a -> Event b) -> Signal a -> Signal b -mapSignalM f m = - Signal { handleSignal = \h -> - handleSignal m (f >=> h) } - --- | Transform the signal. -apSignal :: Event (a -> b) -> Signal a -> Signal b -apSignal f m = - Signal { handleSignal = \h -> - handleSignal m $ \a -> do { x <- f; h (x a) } } - --- | An empty signal which is never triggered. -emptySignal :: Signal a -emptySignal = - Signal { handleSignal = \h -> return mempty } - --- | Represents the history of the signal values. -data SignalHistory a = - SignalHistory { signalHistorySignal :: Signal a, - -- ^ The signal for which the history is created. - signalHistoryTimes :: UV.Vector Double, - signalHistoryValues :: V.Vector a } - --- | Create a history of the signal values. -newSignalHistory :: Signal a -> Event (SignalHistory a) -newSignalHistory = - newSignalHistoryStartingWith Nothing - --- | Create a history of the signal values starting with --- the optional initial value. -newSignalHistoryStartingWith :: Maybe a -> Signal a -> Event (SignalHistory a) -newSignalHistoryStartingWith init signal = - Event $ \p -> - do ts <- UV.newVector - xs <- V.newVector - case init of - Nothing -> return () - Just a -> - do UV.appendVector ts (pointTime p) - V.appendVector xs a - invokeEvent p $ - handleSignal_ signal $ \a -> - Event $ \p -> - do UV.appendVector ts (pointTime p) - V.appendVector xs a - return SignalHistory { signalHistorySignal = signal, - signalHistoryTimes = ts, - signalHistoryValues = xs } - --- | Read the history of signal values. -readSignalHistory :: SignalHistory a -> Event (Array Int Double, Array Int a) -readSignalHistory history = - do xs <- liftIO $ UV.freezeVector (signalHistoryTimes history) - ys <- liftIO $ V.freezeVector (signalHistoryValues history) - return (xs, ys) - --- | Trigger the signal with the current time. -triggerSignalWithCurrentTime :: SignalSource Double -> Event () -triggerSignalWithCurrentTime s = - Event $ \p -> invokeEvent p $ triggerSignal s (pointTime p) - --- | Return a signal that is triggered in the specified time points. -newSignalInTimes :: [Double] -> Event (Signal Double) -newSignalInTimes xs = - do s <- liftSimulation newSignalSource - enqueueEventWithTimes xs $ triggerSignalWithCurrentTime s - return $ publishSignal s - --- | Return a signal that is triggered in the integration time points. --- It should be called with help of 'runEventInStartTime'. -newSignalInIntegTimes :: Event (Signal Double) -newSignalInIntegTimes = - do s <- liftSimulation newSignalSource - enqueueEventWithIntegTimes $ triggerSignalWithCurrentTime s - return $ publishSignal s - --- | Return a signal that is triggered in the start time. --- It should be called with help of 'runEventInStartTime'. -newSignalInStartTime :: Event (Signal Double) -newSignalInStartTime = - do s <- liftSimulation newSignalSource - t <- liftParameter starttime - enqueueEvent t $ triggerSignalWithCurrentTime s - return $ publishSignal s - --- | Return a signal that is triggered in the final time. -newSignalInStopTime :: Event (Signal Double) -newSignalInStopTime = - do s <- liftSimulation newSignalSource - t <- liftParameter stoptime - enqueueEvent t $ triggerSignalWithCurrentTime s - return $ publishSignal s - --- | Describes a computation that also signals when changing its value. -data Signalable a = - Signalable { readSignalable :: Event a, - -- ^ Return a computation of the value. - signalableChanged_ :: Signal () - -- ^ Return a signal notifying that the value has changed - -- but without providing the information about the changed value. - } - --- | Return a signal notifying that the value has changed. -signalableChanged :: Signalable a -> Signal a -signalableChanged x = mapSignalM (const $ readSignalable x) $ signalableChanged_ x - -instance Functor Signalable where - fmap f x = x { readSignalable = fmap f (readSignalable x) } - -instance Monoid a => Monoid (Signalable a) where - - mempty = emptySignalable - mappend = appendSignalable - --- | Return an identity. -emptySignalable :: Monoid a => Signalable a -emptySignalable = - Signalable { readSignalable = return mempty, - signalableChanged_ = mempty } - --- | An associative operation. -appendSignalable :: Monoid a => Signalable a -> Signalable a -> Signalable a -appendSignalable m1 m2 = - Signalable { readSignalable = liftM2 (<>) (readSignalable m1) (readSignalable m2), - signalableChanged_ = (signalableChanged_ m1) <> (signalableChanged_ m2) } - --- | Transform a signal so that the resulting signal returns a sequence of arrivals --- saving the information about the time points at which the original signal was received. -arrivalSignal :: Signal a -> Signal (Arrival a) -arrivalSignal m = - Signal { handleSignal = \h -> - Event $ \p -> - do r <- newIORef Nothing - invokeEvent p $ - handleSignal m $ \a -> - Event $ \p -> - do t0 <- readIORef r - let t = pointTime p - writeIORef r (Just t) - invokeEvent p $ - h Arrival { arrivalValue = a, - arrivalTime = t, - arrivalDelay = - case t0 of - Nothing -> Nothing - Just t0 -> Just (t - t0) } - } + +-- | +-- Module : Simulation.Aivika.Internal.Signal +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the signal which we can subscribe handlers to. +-- These handlers can be disposed. The signal is triggered in the +-- current time point actuating the corresponded computations from +-- the handlers. +-- + +module Simulation.Aivika.Internal.Signal + (-- * Handling and Triggering Signal + Signal(..), + handleSignal_, + SignalSource, + newSignalSource, + publishSignal, + triggerSignal, + -- * Useful Combinators + mapSignal, + mapSignalM, + apSignal, + filterSignal, + filterSignalM, + emptySignal, + merge2Signals, + merge3Signals, + merge4Signals, + merge5Signals, + -- * Signal Arriving + arrivalSignal, + -- * Creating Signal in Time Points + newSignalInTimes, + newSignalInIntegTimes, + newSignalInStartTime, + newSignalInStopTime, + -- * Signal History + SignalHistory, + signalHistorySignal, + newSignalHistory, + newSignalHistoryStartingWith, + readSignalHistory, + -- * Signalable Computations + Signalable(..), + signalableChanged, + emptySignalable, + appendSignalable) where + +import Data.IORef +import Data.Monoid +import Data.List +import Data.Array + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Parameter +import Simulation.Aivika.Internal.Simulation +import Simulation.Aivika.Internal.Event +import Simulation.Aivika.Internal.Arrival + +import qualified Simulation.Aivika.Vector as V +import qualified Simulation.Aivika.Vector.Unboxed as UV + +-- | The signal source that can publish its signal. +data SignalSource a = + SignalSource { publishSignal :: Signal a, + -- ^ Publish the signal. + triggerSignal :: a -> Event () + -- ^ Trigger the signal actuating + -- all its handlers at the current + -- simulation time point. + } + +-- | The signal that can have disposable handlers. +data Signal a = + Signal { handleSignal :: (a -> Event ()) -> Event DisposableEvent + -- ^ Subscribe the handler to the specified + -- signal and return a nested computation + -- within a disposable object that, being applied, + -- unsubscribes the handler from this signal. + } + +-- | The queue of signal handlers. +data SignalHandlerQueue a = + SignalHandlerQueue { queueList :: IORef [SignalHandler a] } + +-- | It contains the information about the disposable queue handler. +data SignalHandler a = + SignalHandler { handlerComp :: a -> Event (), + handlerRef :: IORef () } + +instance Eq (SignalHandler a) where + x == y = (handlerRef x) == (handlerRef y) + +-- | Subscribe the handler to the specified signal forever. +-- To subscribe the disposable handlers, use function 'handleSignal'. +handleSignal_ :: Signal a -> (a -> Event ()) -> Event () +handleSignal_ signal h = + do x <- handleSignal signal h + return () + +-- | Create a new signal source. +newSignalSource :: Simulation (SignalSource a) +newSignalSource = + Simulation $ \r -> + do list <- newIORef [] + let queue = SignalHandlerQueue { queueList = list } + signal = Signal { handleSignal = handle } + source = SignalSource { publishSignal = signal, + triggerSignal = trigger } + handle h = + Event $ \p -> + do x <- enqueueSignalHandler queue h + return $ + DisposableEvent $ + Event $ \p -> dequeueSignalHandler queue x + trigger a = + Event $ \p -> triggerSignalHandlers queue a p + return source + +-- | Trigger all next signal handlers. +triggerSignalHandlers :: SignalHandlerQueue a -> a -> Point -> IO () +{-# INLINE triggerSignalHandlers #-} +triggerSignalHandlers q a p = + do hs <- readIORef (queueList q) + forM_ hs $ \h -> + invokeEvent p $ handlerComp h a + +-- | Enqueue the handler and return its representative in the queue. +enqueueSignalHandler :: SignalHandlerQueue a -> (a -> Event ()) -> IO (SignalHandler a) +{-# INLINE enqueueSignalHandler #-} +enqueueSignalHandler q h = + do r <- newIORef () + let handler = SignalHandler { handlerComp = h, + handlerRef = r } + modifyIORef (queueList q) (handler :) + return handler + +-- | Dequeue the handler representative. +dequeueSignalHandler :: SignalHandlerQueue a -> SignalHandler a -> IO () +{-# INLINE dequeueSignalHandler #-} +dequeueSignalHandler q h = + modifyIORef (queueList q) (delete h) + +instance Functor Signal where + fmap = mapSignal + +instance Monoid (Signal a) where + + mempty = emptySignal + + mappend = merge2Signals + + mconcat [] = emptySignal + mconcat [x1] = x1 + mconcat [x1, x2] = merge2Signals x1 x2 + mconcat [x1, x2, x3] = merge3Signals x1 x2 x3 + mconcat [x1, x2, x3, x4] = merge4Signals x1 x2 x3 x4 + mconcat [x1, x2, x3, x4, x5] = merge5Signals x1 x2 x3 x4 x5 + mconcat (x1 : x2 : x3 : x4 : x5 : xs) = + mconcat $ merge5Signals x1 x2 x3 x4 x5 : xs + +-- | Map the signal according the specified function. +mapSignal :: (a -> b) -> Signal a -> Signal b +mapSignal f m = + Signal { handleSignal = \h -> + handleSignal m $ h . f } + +-- | Filter only those signal values that satisfy to +-- the specified predicate. +filterSignal :: (a -> Bool) -> Signal a -> Signal a +filterSignal p m = + Signal { handleSignal = \h -> + handleSignal m $ \a -> + when (p a) $ h a } + +-- | Filter only those signal values that satisfy to +-- the specified predicate. +filterSignalM :: (a -> Event Bool) -> Signal a -> Signal a +filterSignalM p m = + Signal { handleSignal = \h -> + handleSignal m $ \a -> + do x <- p a + when x $ h a } + +-- | Merge two signals. +merge2Signals :: Signal a -> Signal a -> Signal a +merge2Signals m1 m2 = + Signal { handleSignal = \h -> + do x1 <- handleSignal m1 h + x2 <- handleSignal m2 h + return $ x1 <> x2 } + +-- | Merge three signals. +merge3Signals :: Signal a -> Signal a -> Signal a -> Signal a +merge3Signals m1 m2 m3 = + Signal { handleSignal = \h -> + do x1 <- handleSignal m1 h + x2 <- handleSignal m2 h + x3 <- handleSignal m3 h + return $ x1 <> x2 <> x3 } + +-- | Merge four signals. +merge4Signals :: Signal a -> Signal a -> Signal a -> + Signal a -> Signal a +merge4Signals m1 m2 m3 m4 = + Signal { handleSignal = \h -> + do x1 <- handleSignal m1 h + x2 <- handleSignal m2 h + x3 <- handleSignal m3 h + x4 <- handleSignal m4 h + return $ x1 <> x2 <> x3 <> x4 } + +-- | Merge five signals. +merge5Signals :: Signal a -> Signal a -> Signal a -> + Signal a -> Signal a -> Signal a +merge5Signals m1 m2 m3 m4 m5 = + Signal { handleSignal = \h -> + do x1 <- handleSignal m1 h + x2 <- handleSignal m2 h + x3 <- handleSignal m3 h + x4 <- handleSignal m4 h + x5 <- handleSignal m5 h + return $ x1 <> x2 <> x3 <> x4 <> x5 } + +-- | Compose the signal. +mapSignalM :: (a -> Event b) -> Signal a -> Signal b +mapSignalM f m = + Signal { handleSignal = \h -> + handleSignal m (f >=> h) } + +-- | Transform the signal. +apSignal :: Event (a -> b) -> Signal a -> Signal b +apSignal f m = + Signal { handleSignal = \h -> + handleSignal m $ \a -> do { x <- f; h (x a) } } + +-- | An empty signal which is never triggered. +emptySignal :: Signal a +emptySignal = + Signal { handleSignal = \h -> return mempty } + +-- | Represents the history of the signal values. +data SignalHistory a = + SignalHistory { signalHistorySignal :: Signal a, + -- ^ The signal for which the history is created. + signalHistoryTimes :: UV.Vector Double, + signalHistoryValues :: V.Vector a } + +-- | Create a history of the signal values. +newSignalHistory :: Signal a -> Event (SignalHistory a) +newSignalHistory = + newSignalHistoryStartingWith Nothing + +-- | Create a history of the signal values starting with +-- the optional initial value. +newSignalHistoryStartingWith :: Maybe a -> Signal a -> Event (SignalHistory a) +newSignalHistoryStartingWith init signal = + Event $ \p -> + do ts <- UV.newVector + xs <- V.newVector + case init of + Nothing -> return () + Just a -> + do UV.appendVector ts (pointTime p) + V.appendVector xs a + invokeEvent p $ + handleSignal_ signal $ \a -> + Event $ \p -> + do UV.appendVector ts (pointTime p) + V.appendVector xs a + return SignalHistory { signalHistorySignal = signal, + signalHistoryTimes = ts, + signalHistoryValues = xs } + +-- | Read the history of signal values. +readSignalHistory :: SignalHistory a -> Event (Array Int Double, Array Int a) +readSignalHistory history = + do xs <- liftIO $ UV.freezeVector (signalHistoryTimes history) + ys <- liftIO $ V.freezeVector (signalHistoryValues history) + return (xs, ys) + +-- | Trigger the signal with the current time. +triggerSignalWithCurrentTime :: SignalSource Double -> Event () +triggerSignalWithCurrentTime s = + Event $ \p -> invokeEvent p $ triggerSignal s (pointTime p) + +-- | Return a signal that is triggered in the specified time points. +newSignalInTimes :: [Double] -> Event (Signal Double) +newSignalInTimes xs = + do s <- liftSimulation newSignalSource + enqueueEventWithTimes xs $ triggerSignalWithCurrentTime s + return $ publishSignal s + +-- | Return a signal that is triggered in the integration time points. +-- It should be called with help of 'runEventInStartTime'. +newSignalInIntegTimes :: Event (Signal Double) +newSignalInIntegTimes = + do s <- liftSimulation newSignalSource + enqueueEventWithIntegTimes $ triggerSignalWithCurrentTime s + return $ publishSignal s + +-- | Return a signal that is triggered in the start time. +-- It should be called with help of 'runEventInStartTime'. +newSignalInStartTime :: Event (Signal Double) +newSignalInStartTime = + do s <- liftSimulation newSignalSource + t <- liftParameter starttime + enqueueEvent t $ triggerSignalWithCurrentTime s + return $ publishSignal s + +-- | Return a signal that is triggered in the final time. +newSignalInStopTime :: Event (Signal Double) +newSignalInStopTime = + do s <- liftSimulation newSignalSource + t <- liftParameter stoptime + enqueueEvent t $ triggerSignalWithCurrentTime s + return $ publishSignal s + +-- | Describes a computation that also signals when changing its value. +data Signalable a = + Signalable { readSignalable :: Event a, + -- ^ Return a computation of the value. + signalableChanged_ :: Signal () + -- ^ Return a signal notifying that the value has changed + -- but without providing the information about the changed value. + } + +-- | Return a signal notifying that the value has changed. +signalableChanged :: Signalable a -> Signal a +signalableChanged x = mapSignalM (const $ readSignalable x) $ signalableChanged_ x + +instance Functor Signalable where + fmap f x = x { readSignalable = fmap f (readSignalable x) } + +instance Monoid a => Monoid (Signalable a) where + + mempty = emptySignalable + mappend = appendSignalable + +-- | Return an identity. +emptySignalable :: Monoid a => Signalable a +emptySignalable = + Signalable { readSignalable = return mempty, + signalableChanged_ = mempty } + +-- | An associative operation. +appendSignalable :: Monoid a => Signalable a -> Signalable a -> Signalable a +appendSignalable m1 m2 = + Signalable { readSignalable = liftM2 (<>) (readSignalable m1) (readSignalable m2), + signalableChanged_ = (signalableChanged_ m1) <> (signalableChanged_ m2) } + +-- | Transform a signal so that the resulting signal returns a sequence of arrivals +-- saving the information about the time points at which the original signal was received. +arrivalSignal :: Signal a -> Signal (Arrival a) +arrivalSignal m = + Signal { handleSignal = \h -> + Event $ \p -> + do r <- newIORef Nothing + invokeEvent p $ + handleSignal m $ \a -> + Event $ \p -> + do t0 <- readIORef r + let t = pointTime p + writeIORef r (Just t) + invokeEvent p $ + h Arrival { arrivalValue = a, + arrivalTime = t, + arrivalDelay = + case t0 of + Nothing -> Nothing + Just t0 -> Just (t - t0) } + } diff --git a/Simulation/Aivika/Internal/Simulation.hs b/Simulation/Aivika/Internal/Simulation.hs --- a/Simulation/Aivika/Internal/Simulation.hs +++ b/Simulation/Aivika/Internal/Simulation.hs @@ -1,163 +1,161 @@ - -{-# LANGUAGE RecursiveDo #-} - --- | --- Module : Simulation.Aivika.Internal.Simulation --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- The module defines the 'Simulation' monad that represents a computation --- within the simulation run. --- -module Simulation.Aivika.Internal.Simulation - (-- * Simulation - Simulation(..), - SimulationLift(..), - invokeSimulation, - runSimulation, - runSimulations, - -- * Error Handling - catchSimulation, - finallySimulation, - throwSimulation, - -- * Utilities - simulationEventQueue, - -- * Memoization - memoSimulation) 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 Data.IORef - -import Simulation.Aivika.Generator -import Simulation.Aivika.Internal.Specs -import Simulation.Aivika.Internal.Parameter - --- | A value in the 'Simulation' monad represents a computation --- within the simulation run. -newtype Simulation a = Simulation (Run -> IO a) - -instance Monad Simulation where - return = returnS - m >>= k = bindS m k - -returnS :: a -> Simulation a -{-# INLINE returnS #-} -returnS a = Simulation (\r -> return a) - -bindS :: Simulation a -> (a -> Simulation b) -> Simulation b -{-# INLINE bindS #-} -bindS (Simulation m) k = - Simulation $ \r -> - do a <- m r - let Simulation m' = k a - m' r - --- | Run the simulation using the specified specs. -runSimulation :: Simulation a -> Specs -> IO a -runSimulation (Simulation 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 simulations using the specified specs, --- where each simulation is distinguished by its index 'simulationIndex'. -runSimulations :: Simulation a -> Specs -> Int -> [IO a] -runSimulations (Simulation 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 event queue. -simulationEventQueue :: Simulation EventQueue -simulationEventQueue = Simulation $ return . runEventQueue - -instance Functor Simulation where - fmap = liftMS - -instance Applicative Simulation where - pure = return - (<*>) = ap - -liftMS :: (a -> b) -> Simulation a -> Simulation b -{-# INLINE liftMS #-} -liftMS f (Simulation x) = - Simulation $ \r -> do { a <- x r; return $ f a } - -instance MonadIO Simulation where - liftIO m = Simulation $ const m - --- | A type class to lift the simulation computations to other computations. -class SimulationLift m where - - -- | Lift the specified 'Simulation' computation to another computation. - liftSimulation :: Simulation a -> m a - -instance SimulationLift Simulation where - liftSimulation = id - -instance ParameterLift Simulation where - liftParameter = liftPS - -liftPS :: Parameter a -> Simulation a -{-# INLINE liftPS #-} -liftPS (Parameter x) = - Simulation x - --- | Exception handling within 'Simulation' computations. -catchSimulation :: Simulation a -> (IOException -> Simulation a) -> Simulation a -catchSimulation (Simulation m) h = - Simulation $ \r -> - C.catch (m r) $ \e -> - let Simulation m' = h e in m' r - --- | A computation with finalization part like the 'finally' function. -finallySimulation :: Simulation a -> Simulation b -> Simulation a -finallySimulation (Simulation m) (Simulation m') = - Simulation $ \r -> - C.finally (m r) (m' r) - --- | Like the standard 'throw' function. -throwSimulation :: IOException -> Simulation a -throwSimulation = throw - --- | Invoke the 'Simulation' computation. -invokeSimulation :: Run -> Simulation a -> IO a -{-# INLINE invokeSimulation #-} -invokeSimulation r (Simulation m) = m r - -instance MonadFix Simulation where - mfix f = - Simulation $ \r -> - do { rec { a <- invokeSimulation r (f a) }; return a } - --- | Memoize the 'Simulation' computation, always returning the same value --- within a simulation run. -memoSimulation :: Simulation a -> Simulation (Simulation a) -memoSimulation m = - do ref <- liftIO $ newIORef Nothing - return $ Simulation $ \r -> - do x <- readIORef ref - case x of - Just v -> return v - Nothing -> - do v <- invokeSimulation r m - writeIORef ref (Just v) - return v + +{-# LANGUAGE RecursiveDo #-} + +-- | +-- Module : Simulation.Aivika.Internal.Simulation +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the 'Simulation' monad that represents a computation +-- within the simulation run. +-- +module Simulation.Aivika.Internal.Simulation + (-- * Simulation + Simulation(..), + SimulationLift(..), + invokeSimulation, + runSimulation, + runSimulations, + -- * Error Handling + catchSimulation, + finallySimulation, + throwSimulation, + -- * Utilities + simulationEventQueue, + -- * Memoization + memoSimulation) where + +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Fix +import Control.Applicative + +import Data.IORef + +import Simulation.Aivika.Generator +import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Parameter + +-- | A value in the 'Simulation' monad represents a computation +-- within the simulation run. +newtype Simulation a = Simulation (Run -> IO a) + +instance Monad Simulation where + return = returnS + m >>= k = bindS m k + +returnS :: a -> Simulation a +{-# INLINE returnS #-} +returnS a = Simulation (\r -> return a) + +bindS :: Simulation a -> (a -> Simulation b) -> Simulation b +{-# INLINE bindS #-} +bindS (Simulation m) k = + Simulation $ \r -> + do a <- m r + let Simulation m' = k a + m' r + +-- | Run the simulation using the specified specs. +runSimulation :: Simulation a -> Specs -> IO a +runSimulation (Simulation 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 simulations using the specified specs, +-- where each simulation is distinguished by its index 'simulationIndex'. +runSimulations :: Simulation a -> Specs -> Int -> [IO a] +runSimulations (Simulation 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 event queue. +simulationEventQueue :: Simulation EventQueue +simulationEventQueue = Simulation $ return . runEventQueue + +instance Functor Simulation where + fmap = liftMS + +instance Applicative Simulation where + pure = return + (<*>) = ap + +liftMS :: (a -> b) -> Simulation a -> Simulation b +{-# INLINE liftMS #-} +liftMS f (Simulation x) = + Simulation $ \r -> do { a <- x r; return $ f a } + +instance MonadIO Simulation where + liftIO m = Simulation $ const m + +-- | A type class to lift the simulation computations to other computations. +class SimulationLift m where + + -- | Lift the specified 'Simulation' computation to another computation. + liftSimulation :: Simulation a -> m a + +instance SimulationLift Simulation where + liftSimulation = id + +instance ParameterLift Simulation where + liftParameter = liftPS + +liftPS :: Parameter a -> Simulation a +{-# INLINE liftPS #-} +liftPS (Parameter x) = + Simulation x + +-- | Exception handling within 'Simulation' computations. +catchSimulation :: Exception e => Simulation a -> (e -> Simulation a) -> Simulation a +catchSimulation (Simulation m) h = + Simulation $ \r -> + catch (m r) $ \e -> + let Simulation m' = h e in m' r + +-- | A computation with finalization part like the 'finally' function. +finallySimulation :: Simulation a -> Simulation b -> Simulation a +finallySimulation (Simulation m) (Simulation m') = + Simulation $ \r -> + finally (m r) (m' r) + +-- | Like the standard 'throw' function. +throwSimulation :: Exception e => e -> Simulation a +throwSimulation = throw + +-- | Invoke the 'Simulation' computation. +invokeSimulation :: Run -> Simulation a -> IO a +{-# INLINE invokeSimulation #-} +invokeSimulation r (Simulation m) = m r + +instance MonadFix Simulation where + mfix f = + Simulation $ \r -> + do { rec { a <- invokeSimulation r (f a) }; return a } + +-- | Memoize the 'Simulation' computation, always returning the same value +-- within a simulation run. +memoSimulation :: Simulation a -> Simulation (Simulation a) +memoSimulation m = + do ref <- liftIO $ newIORef Nothing + return $ Simulation $ \r -> + do x <- readIORef ref + case x of + Just v -> return v + Nothing -> + do v <- invokeSimulation r m + writeIORef ref (Just v) + return v diff --git a/Simulation/Aivika/Internal/Specs.hs b/Simulation/Aivika/Internal/Specs.hs --- a/Simulation/Aivika/Internal/Specs.hs +++ b/Simulation/Aivika/Internal/Specs.hs @@ -1,223 +1,223 @@ - --- | --- Module : Simulation.Aivika.Internal.Specs --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- It defines the simulation specs and related stuff. -module Simulation.Aivika.Internal.Specs - (Specs(..), - Method(..), - Run(..), - Point(..), - EventQueue(..), - newEventQueue, - basicTime, - integIterationBnds, - integIterationHiBnd, - integIterationLoBnd, - integPhaseBnds, - integPhaseHiBnd, - integPhaseLoBnd, - integTimes, - integPoints, - integStartPoint, - integStopPoint, - pointAt) where - -import Data.IORef - -import Simulation.Aivika.Generator -import qualified Simulation.Aivika.PriorityQueue as PQ - --- | It defines the simulation specs. -data Specs = Specs { spcStartTime :: Double, -- ^ the start time - spcStopTime :: Double, -- ^ the stop time - spcDT :: Double, -- ^ the integration time step - spcMethod :: Method, -- ^ the integration method - spcGeneratorType :: GeneratorType - -- ^ the type of the random number generator - } - --- | It defines the integration method. -data Method = Euler -- ^ Euler's method - | RungeKutta2 -- ^ the 2nd order Runge-Kutta method - | RungeKutta4 -- ^ the 4th order Runge-Kutta method - deriving (Eq, Ord, Show) - --- | It indentifies the simulation run. -data Run = Run { runSpecs :: Specs, -- ^ the simulation specs - runIndex :: Int, -- ^ the current simulation run index - runCount :: Int, -- ^ the total number of runs in this experiment - runEventQueue :: EventQueue, -- ^ the event queue - runGenerator :: Generator -- ^ the random number generator - } - --- | It defines the simulation point appended with the additional information. -data Point = Point { pointSpecs :: Specs, -- ^ the simulation specs - pointRun :: Run, -- ^ the simulation run - pointTime :: Double, -- ^ the current time - pointIteration :: Int, -- ^ the current iteration - pointPhase :: Int -- ^ the current phase - } - --- | It represents the event queue. -data EventQueue = EventQueue { queuePQ :: PQ.PriorityQueue (Point -> IO ()), - -- ^ the underlying priority queue - queueBusy :: IORef Bool, - -- ^ whether the queue is currently processing events - queueTime :: IORef Double - -- ^ the actual time of the event queue - } - --- | Create a new event queue by the specified specs. -newEventQueue :: Specs -> IO EventQueue -newEventQueue specs = - do f <- newIORef False - t <- newIORef $ spcStartTime specs - pq <- PQ.newQueue - return EventQueue { queuePQ = pq, - queueBusy = f, - queueTime = t } - --- | Returns the integration iterations starting from zero. -integIterations :: Specs -> [Int] -integIterations sc = [i1 .. i2] where - i1 = integIterationLoBnd sc - i2 = integIterationHiBnd sc - --- | Returns the first and last integration iterations. -integIterationBnds :: Specs -> (Int, Int) -integIterationBnds sc = (i1, i2) where - i1 = integIterationLoBnd sc - i2 = integIterationHiBnd sc - --- | Returns the first integration iteration, i.e. zero. -integIterationLoBnd :: Specs -> Int -integIterationLoBnd sc = 0 - --- | Returns the last integration iteration. -integIterationHiBnd :: Specs -> Int -integIterationHiBnd sc = - let n = round ((spcStopTime sc - - spcStartTime sc) / spcDT sc) - in if n < 0 - then - error $ - "The iteration number in the stop time has a negative value. " ++ - "Either the simulation specs are incorrect, " ++ - "or a floating point overflow occurred, " ++ - "for example, when using a too small integration time step. " ++ - "You have to define this time step regardless of " ++ - "whether you actually use it or not, " ++ - "for Aivika allows combining the ordinary differential equations " ++ - "with the discrete event simulation within one model. " ++ - "So, if you are still using the 32-bit architecture and " ++ - "you do need a small integration time step " ++ - "for integrating the equations " ++ - "then you might think of using the 64-bit architecture. " ++ - "Although you could probably just forget " ++ - "to increase the time step " ++ - "after increasing the stop time: integIterationHiBnd" - else n - --- | Returns the phases for the specified simulation specs starting from zero. -integPhases :: Specs -> [Int] -integPhases sc = - case spcMethod sc of - Euler -> [0] - RungeKutta2 -> [0, 1] - RungeKutta4 -> [0, 1, 2, 3] - --- | Returns the first and last integration phases. -integPhaseBnds :: Specs -> (Int, Int) -integPhaseBnds sc = - case spcMethod sc of - Euler -> (0, 0) - RungeKutta2 -> (0, 1) - RungeKutta4 -> (0, 3) - --- | Returns the first integration phase, i.e. zero. -integPhaseLoBnd :: Specs -> Int -integPhaseLoBnd sc = 0 - --- | Returns the last integration phase, 0 for Euler's method, 1 for RK2 and 3 for RK4. -integPhaseHiBnd :: Specs -> Int -integPhaseHiBnd sc = - case spcMethod sc of - Euler -> 0 - RungeKutta2 -> 1 - RungeKutta4 -> 3 - --- | Returns a simulation time for the integration point specified by --- the specs, iteration and phase. -basicTime :: Specs -> Int -> Int -> Double -basicTime sc n ph = - if ph < 0 then - error "Incorrect phase: basicTime" - else - spcStartTime sc + n' * spcDT sc + delta (spcMethod sc) ph - where n' = fromIntegral n - delta Euler 0 = 0 - delta RungeKutta2 0 = 0 - delta RungeKutta2 1 = spcDT sc - delta RungeKutta4 0 = 0 - delta RungeKutta4 1 = spcDT sc / 2 - delta RungeKutta4 2 = spcDT sc / 2 - delta RungeKutta4 3 = spcDT sc - --- | Return the integration time values. -integTimes :: Specs -> [Double] -integTimes sc = map t [nl .. nu] - where (nl, nu) = integIterationBnds sc - t n = basicTime sc n 0 - --- | Return the integration time points. -integPoints :: Run -> [Point] -integPoints r = points - where sc = runSpecs r - (nl, nu) = integIterationBnds sc - points = map point [nl .. nu] - point n = Point { pointSpecs = sc, - pointRun = r, - pointTime = basicTime sc n 0, - pointIteration = n, - pointPhase = 0 } - --- | Return the start time point. -integStartPoint :: Run -> Point -integStartPoint r = point nl - where sc = runSpecs r - (nl, nu) = integIterationBnds sc - point n = Point { pointSpecs = sc, - pointRun = r, - pointTime = basicTime sc n 0, - pointIteration = n, - pointPhase = 0 } - --- | Return the stop time point. -integStopPoint :: Run -> Point -integStopPoint r = point nu - where sc = runSpecs r - (nl, nu) = integIterationBnds sc - point n = Point { pointSpecs = sc, - pointRun = r, - pointTime = basicTime sc n 0, - pointIteration = n, - pointPhase = 0 } - --- | Return the point at the specified time. -pointAt :: Run -> Double -> Point -pointAt r t = p - where sc = runSpecs r - t0 = spcStartTime sc - dt = spcDT sc - n = fromIntegral $ floor ((t - t0) / dt) - p = Point { pointSpecs = sc, - pointRun = r, - pointTime = t, - pointIteration = n, - pointPhase = -1 } + +-- | +-- Module : Simulation.Aivika.Internal.Specs +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It defines the simulation specs and related stuff. +module Simulation.Aivika.Internal.Specs + (Specs(..), + Method(..), + Run(..), + Point(..), + EventQueue(..), + newEventQueue, + basicTime, + integIterationBnds, + integIterationHiBnd, + integIterationLoBnd, + integPhaseBnds, + integPhaseHiBnd, + integPhaseLoBnd, + integTimes, + integPoints, + integStartPoint, + integStopPoint, + pointAt) where + +import Data.IORef + +import Simulation.Aivika.Generator +import qualified Simulation.Aivika.PriorityQueue as PQ + +-- | It defines the simulation specs. +data Specs = Specs { spcStartTime :: Double, -- ^ the start time + spcStopTime :: Double, -- ^ the stop time + spcDT :: Double, -- ^ the integration time step + spcMethod :: Method, -- ^ the integration method + spcGeneratorType :: GeneratorType + -- ^ the type of the random number generator + } + +-- | It defines the integration method. +data Method = Euler -- ^ Euler's method + | RungeKutta2 -- ^ the 2nd order Runge-Kutta method + | RungeKutta4 -- ^ the 4th order Runge-Kutta method + deriving (Eq, Ord, Show) + +-- | It indentifies the simulation run. +data Run = Run { runSpecs :: Specs, -- ^ the simulation specs + runIndex :: Int, -- ^ the current simulation run index + runCount :: Int, -- ^ the total number of runs in this experiment + runEventQueue :: EventQueue, -- ^ the event queue + runGenerator :: Generator -- ^ the random number generator + } + +-- | It defines the simulation point appended with the additional information. +data Point = Point { pointSpecs :: Specs, -- ^ the simulation specs + pointRun :: Run, -- ^ the simulation run + pointTime :: Double, -- ^ the current time + pointIteration :: Int, -- ^ the current iteration + pointPhase :: Int -- ^ the current phase + } + +-- | It represents the event queue. +data EventQueue = EventQueue { queuePQ :: PQ.PriorityQueue (Point -> IO ()), + -- ^ the underlying priority queue + queueBusy :: IORef Bool, + -- ^ whether the queue is currently processing events + queueTime :: IORef Double + -- ^ the actual time of the event queue + } + +-- | Create a new event queue by the specified specs. +newEventQueue :: Specs -> IO EventQueue +newEventQueue specs = + do f <- newIORef False + t <- newIORef $ spcStartTime specs + pq <- PQ.newQueue + return EventQueue { queuePQ = pq, + queueBusy = f, + queueTime = t } + +-- | Returns the integration iterations starting from zero. +integIterations :: Specs -> [Int] +integIterations sc = [i1 .. i2] where + i1 = integIterationLoBnd sc + i2 = integIterationHiBnd sc + +-- | Returns the first and last integration iterations. +integIterationBnds :: Specs -> (Int, Int) +integIterationBnds sc = (i1, i2) where + i1 = integIterationLoBnd sc + i2 = integIterationHiBnd sc + +-- | Returns the first integration iteration, i.e. zero. +integIterationLoBnd :: Specs -> Int +integIterationLoBnd sc = 0 + +-- | Returns the last integration iteration. +integIterationHiBnd :: Specs -> Int +integIterationHiBnd sc = + let n = round ((spcStopTime sc - + spcStartTime sc) / spcDT sc) + in if n < 0 + then + error $ + "The iteration number in the stop time has a negative value. " ++ + "Either the simulation specs are incorrect, " ++ + "or a floating point overflow occurred, " ++ + "for example, when using a too small integration time step. " ++ + "You have to define this time step regardless of " ++ + "whether you actually use it or not, " ++ + "for Aivika allows combining the ordinary differential equations " ++ + "with the discrete event simulation within one model. " ++ + "So, if you are still using the 32-bit architecture and " ++ + "you do need a small integration time step " ++ + "for integrating the equations " ++ + "then you might think of using the 64-bit architecture. " ++ + "Although you could probably just forget " ++ + "to increase the time step " ++ + "after increasing the stop time: integIterationHiBnd" + else n + +-- | Returns the phases for the specified simulation specs starting from zero. +integPhases :: Specs -> [Int] +integPhases sc = + case spcMethod sc of + Euler -> [0] + RungeKutta2 -> [0, 1] + RungeKutta4 -> [0, 1, 2, 3] + +-- | Returns the first and last integration phases. +integPhaseBnds :: Specs -> (Int, Int) +integPhaseBnds sc = + case spcMethod sc of + Euler -> (0, 0) + RungeKutta2 -> (0, 1) + RungeKutta4 -> (0, 3) + +-- | Returns the first integration phase, i.e. zero. +integPhaseLoBnd :: Specs -> Int +integPhaseLoBnd sc = 0 + +-- | Returns the last integration phase, 0 for Euler's method, 1 for RK2 and 3 for RK4. +integPhaseHiBnd :: Specs -> Int +integPhaseHiBnd sc = + case spcMethod sc of + Euler -> 0 + RungeKutta2 -> 1 + RungeKutta4 -> 3 + +-- | Returns a simulation time for the integration point specified by +-- the specs, iteration and phase. +basicTime :: Specs -> Int -> Int -> Double +basicTime sc n ph = + if ph < 0 then + error "Incorrect phase: basicTime" + else + spcStartTime sc + n' * spcDT sc + delta (spcMethod sc) ph + where n' = fromIntegral n + delta Euler 0 = 0 + delta RungeKutta2 0 = 0 + delta RungeKutta2 1 = spcDT sc + delta RungeKutta4 0 = 0 + delta RungeKutta4 1 = spcDT sc / 2 + delta RungeKutta4 2 = spcDT sc / 2 + delta RungeKutta4 3 = spcDT sc + +-- | Return the integration time values. +integTimes :: Specs -> [Double] +integTimes sc = map t [nl .. nu] + where (nl, nu) = integIterationBnds sc + t n = basicTime sc n 0 + +-- | Return the integration time points. +integPoints :: Run -> [Point] +integPoints r = points + where sc = runSpecs r + (nl, nu) = integIterationBnds sc + points = map point [nl .. nu] + point n = Point { pointSpecs = sc, + pointRun = r, + pointTime = basicTime sc n 0, + pointIteration = n, + pointPhase = 0 } + +-- | Return the start time point. +integStartPoint :: Run -> Point +integStartPoint r = point nl + where sc = runSpecs r + (nl, nu) = integIterationBnds sc + point n = Point { pointSpecs = sc, + pointRun = r, + pointTime = basicTime sc n 0, + pointIteration = n, + pointPhase = 0 } + +-- | Return the stop time point. +integStopPoint :: Run -> Point +integStopPoint r = point nu + where sc = runSpecs r + (nl, nu) = integIterationBnds sc + point n = Point { pointSpecs = sc, + pointRun = r, + pointTime = basicTime sc n 0, + pointIteration = n, + pointPhase = 0 } + +-- | Return the point at the specified time. +pointAt :: Run -> Double -> Point +pointAt r t = p + where sc = runSpecs r + t0 = spcStartTime sc + dt = spcDT sc + n = fromIntegral $ floor ((t - t0) / dt) + p = Point { pointSpecs = sc, + pointRun = r, + pointTime = t, + pointIteration = n, + pointPhase = -1 } diff --git a/Simulation/Aivika/Net.hs b/Simulation/Aivika/Net.hs --- a/Simulation/Aivika/Net.hs +++ b/Simulation/Aivika/Net.hs @@ -1,242 +1,242 @@ - --- | --- Module : Simulation.Aivika.Net --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines a 'Net' arrow that can be applied to modeling the queue networks --- like the 'Processor' arrow from another module. Only the former has a more efficient --- implementation of the 'Arrow' interface than the latter, although at the cost of --- some decreasing in generality. --- --- While the @Processor@ type is just a function that transforms the input 'Stream' into another, --- the @Net@ type is actually an automaton that has an implementation very similar to that one --- which the 'Circuit' type has, only the computations occur in the 'Process' monad. But unlike --- the @Circuit@ type, the @Net@ type doesn't allow declaring recursive definitions, being based on --- continuations. --- --- In a nutshell, the @Net@ type is an interchangeable alternative to the @Processor@ type --- with its weaknesses and strengths. The @Net@ arrow is useful for constructing computations --- with help of the proc-notation to be transformed then to the @Processor@ computations that --- are more general in nature and more easy-to-use but which computations created with help of --- the proc-notation are not so efficient. --- -module Simulation.Aivika.Net - (-- * Net Arrow - Net(..), - -- * Net Primitives - emptyNet, - arrNet, - accumNet, - -- * Specifying Identifier - netUsingId, - -- * Arrival Net - arrivalNet, - -- * Delaying Net - delayNet, - -- * Interchanging Nets with Processors - netProcessor, - processorNet) where - -import qualified Control.Category as C -import Control.Arrow -import Control.Monad.Trans - -import Data.IORef - -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Cont -import Simulation.Aivika.Process -import Simulation.Aivika.Stream -import Simulation.Aivika.QueueStrategy -import Simulation.Aivika.Resource -import Simulation.Aivika.Processor -import Simulation.Aivika.Ref -import Simulation.Aivika.Circuit -import Simulation.Aivika.Internal.Arrival - --- | Represents the net as an automaton working within the 'Process' computation. -newtype Net a b = - Net { runNet :: a -> Process (b, Net a b) - -- ^ Run the net. - } - -instance C.Category Net where - - id = Net $ \a -> return (a, C.id) - - (.) = dot - where - (Net g) `dot` (Net f) = - Net $ \a -> - do (b, p1) <- f a - (c, p2) <- g b - return (c, p2 `dot` p1) - -instance Arrow Net where - - arr f = Net $ \a -> return (f a, arr f) - - first (Net f) = - Net $ \(b, d) -> - do (c, p) <- f b - return ((c, d), first p) - - second (Net f) = - Net $ \(d, b) -> - do (c, p) <- f b - return ((d, c), second p) - - (Net f) *** (Net g) = - Net $ \(b, b') -> - do (c, p1) <- f b - (c', p2) <- g b' - return ((c, c'), p1 *** p2) - - (Net f) &&& (Net g) = - Net $ \b -> - do (c, p1) <- f b - (c', p2) <- g b - return ((c, c'), p1 &&& p2) - -instance ArrowChoice Net where - - left x@(Net f) = - Net $ \ebd -> - case ebd of - Left b -> - do (c, p) <- f b - return (Left c, left p) - Right d -> - return (Right d, left x) - - right x@(Net f) = - Net $ \edb -> - case edb of - Right b -> - do (c, p) <- f b - return (Right c, right p) - Left d -> - return (Left d, right x) - - x@(Net f) +++ y@(Net g) = - Net $ \ebb' -> - case ebb' of - Left b -> - do (c, p1) <- f b - return (Left c, p1 +++ y) - Right b' -> - do (c', p2) <- g b' - return (Right c', x +++ p2) - - x@(Net f) ||| y@(Net g) = - Net $ \ebc -> - case ebc of - Left b -> - do (d, p1) <- f b - return (d, p1 ||| y) - Right b' -> - do (d, p2) <- g b' - return (d, x ||| p2) - --- | A net that never finishes its work. -emptyNet :: Net a b -emptyNet = Net $ const neverProcess - --- | Create a simple net by the specified handling function --- that runs the discontinuous process for each input value to get an output. -arrNet :: (a -> Process b) -> Net a b -arrNet f = - let x = - Net $ \a -> - do b <- f a - return (b, x) - in x - --- | Accumulator that outputs a value determined by the supplied function. -accumNet :: (acc -> a -> Process (acc, b)) -> acc -> Net a b -accumNet f acc = - Net $ \a -> - do (acc', b) <- f acc a - return (b, accumNet f acc') - --- | Create a net that will use the specified process identifier. --- It can be useful to refer to the underlying 'Process' computation which --- can be passivated, interrupted, canceled and so on. See also the --- 'processUsingId' function for more details. -netUsingId :: ProcessId -> Net a b -> Net a b -netUsingId pid (Net f) = - Net $ processUsingId pid . f - --- | Transform the net to an equivalent processor (a rather cheap transformation). -netProcessor :: Net a b -> Processor a b -netProcessor = Processor . loop - where loop x as = - Cons $ - do (a, as') <- runStream as - (b, x') <- runNet x a - return (b, loop x' as') - --- | Transform the processor to a similar net (a more costly transformation). -processorNet :: Processor a b -> Net a b -processorNet x = - Net $ \a -> - do readingA <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - writingA <- liftSimulation $ newResourceWithMaxCount FCFS 1 (Just 1) - readingB <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - writingB <- liftSimulation $ newResourceWithMaxCount FCFS 1 (Just 1) - conting <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - refA <- liftIO $ newIORef Nothing - refB <- liftIO $ newIORef Nothing - let input = - do requestResource readingA - Just a <- liftIO $ readIORef refA - liftIO $ writeIORef refA Nothing - releaseResource writingA - return (a, Cons input) - consume bs = - do (b, bs') <- runStream bs - requestResource writingB - liftIO $ writeIORef refB (Just b) - releaseResource readingB - requestResource conting - consume bs' - loop a = - do requestResource writingA - liftIO $ writeIORef refA (Just a) - releaseResource readingA - requestResource readingB - Just b <- liftIO $ readIORef refB - liftIO $ writeIORef refB Nothing - releaseResource writingB - return (b, Net $ \a -> releaseResource conting >> loop a) - spawnProcess CancelTogether $ - consume $ runProcessor x (Cons input) - loop a - --- | A net that adds the information about the time points at which --- the values were received. -arrivalNet :: Net a (Arrival a) -arrivalNet = - let loop t0 = - Net $ \a -> - do t <- liftDynamics time - let b = Arrival { arrivalValue = a, - arrivalTime = t, - arrivalDelay = - case t0 of - Nothing -> Nothing - Just t0 -> Just (t - t0) } - return (b, loop $ Just t) - in loop Nothing - --- | Delay the input by one step using the specified initial value. -delayNet :: a -> Net a a -delayNet a0 = - Net $ \a -> - return (a0, delayNet a) + +-- | +-- Module : Simulation.Aivika.Net +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines a 'Net' arrow that can be applied to modeling the queue networks +-- like the 'Processor' arrow from another module. Only the former has a more efficient +-- implementation of the 'Arrow' interface than the latter, although at the cost of +-- some decreasing in generality. +-- +-- While the @Processor@ type is just a function that transforms the input 'Stream' into another, +-- the @Net@ type is actually an automaton that has an implementation very similar to that one +-- which the 'Circuit' type has, only the computations occur in the 'Process' monad. But unlike +-- the @Circuit@ type, the @Net@ type doesn't allow declaring recursive definitions, being based on +-- continuations. +-- +-- In a nutshell, the @Net@ type is an interchangeable alternative to the @Processor@ type +-- with its weaknesses and strengths. The @Net@ arrow is useful for constructing computations +-- with help of the proc-notation to be transformed then to the @Processor@ computations that +-- are more general in nature and more easy-to-use but which computations created with help of +-- the proc-notation are not so efficient. +-- +module Simulation.Aivika.Net + (-- * Net Arrow + Net(..), + -- * Net Primitives + emptyNet, + arrNet, + accumNet, + -- * Specifying Identifier + netUsingId, + -- * Arrival Net + arrivalNet, + -- * Delaying Net + delayNet, + -- * Interchanging Nets with Processors + netProcessor, + processorNet) where + +import qualified Control.Category as C +import Control.Arrow +import Control.Monad.Trans + +import Data.IORef + +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Event +import Simulation.Aivika.Cont +import Simulation.Aivika.Process +import Simulation.Aivika.Stream +import Simulation.Aivika.QueueStrategy +import Simulation.Aivika.Resource +import Simulation.Aivika.Processor +import Simulation.Aivika.Ref +import Simulation.Aivika.Circuit +import Simulation.Aivika.Internal.Arrival + +-- | Represents the net as an automaton working within the 'Process' computation. +newtype Net a b = + Net { runNet :: a -> Process (b, Net a b) + -- ^ Run the net. + } + +instance C.Category Net where + + id = Net $ \a -> return (a, C.id) + + (.) = dot + where + (Net g) `dot` (Net f) = + Net $ \a -> + do (b, p1) <- f a + (c, p2) <- g b + return (c, p2 `dot` p1) + +instance Arrow Net where + + arr f = Net $ \a -> return (f a, arr f) + + first (Net f) = + Net $ \(b, d) -> + do (c, p) <- f b + return ((c, d), first p) + + second (Net f) = + Net $ \(d, b) -> + do (c, p) <- f b + return ((d, c), second p) + + (Net f) *** (Net g) = + Net $ \(b, b') -> + do (c, p1) <- f b + (c', p2) <- g b' + return ((c, c'), p1 *** p2) + + (Net f) &&& (Net g) = + Net $ \b -> + do (c, p1) <- f b + (c', p2) <- g b + return ((c, c'), p1 &&& p2) + +instance ArrowChoice Net where + + left x@(Net f) = + Net $ \ebd -> + case ebd of + Left b -> + do (c, p) <- f b + return (Left c, left p) + Right d -> + return (Right d, left x) + + right x@(Net f) = + Net $ \edb -> + case edb of + Right b -> + do (c, p) <- f b + return (Right c, right p) + Left d -> + return (Left d, right x) + + x@(Net f) +++ y@(Net g) = + Net $ \ebb' -> + case ebb' of + Left b -> + do (c, p1) <- f b + return (Left c, p1 +++ y) + Right b' -> + do (c', p2) <- g b' + return (Right c', x +++ p2) + + x@(Net f) ||| y@(Net g) = + Net $ \ebc -> + case ebc of + Left b -> + do (d, p1) <- f b + return (d, p1 ||| y) + Right b' -> + do (d, p2) <- g b' + return (d, x ||| p2) + +-- | A net that never finishes its work. +emptyNet :: Net a b +emptyNet = Net $ const neverProcess + +-- | Create a simple net by the specified handling function +-- that runs the discontinuous process for each input value to get an output. +arrNet :: (a -> Process b) -> Net a b +arrNet f = + let x = + Net $ \a -> + do b <- f a + return (b, x) + in x + +-- | Accumulator that outputs a value determined by the supplied function. +accumNet :: (acc -> a -> Process (acc, b)) -> acc -> Net a b +accumNet f acc = + Net $ \a -> + do (acc', b) <- f acc a + return (b, accumNet f acc') + +-- | Create a net that will use the specified process identifier. +-- It can be useful to refer to the underlying 'Process' computation which +-- can be passivated, interrupted, canceled and so on. See also the +-- 'processUsingId' function for more details. +netUsingId :: ProcessId -> Net a b -> Net a b +netUsingId pid (Net f) = + Net $ processUsingId pid . f + +-- | Transform the net to an equivalent processor (a rather cheap transformation). +netProcessor :: Net a b -> Processor a b +netProcessor = Processor . loop + where loop x as = + Cons $ + do (a, as') <- runStream as + (b, x') <- runNet x a + return (b, loop x' as') + +-- | Transform the processor to a similar net (a more costly transformation). +processorNet :: Processor a b -> Net a b +processorNet x = + Net $ \a -> + do readingA <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + writingA <- liftSimulation $ newResourceWithMaxCount FCFS 1 (Just 1) + readingB <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + writingB <- liftSimulation $ newResourceWithMaxCount FCFS 1 (Just 1) + conting <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + refA <- liftIO $ newIORef Nothing + refB <- liftIO $ newIORef Nothing + let input = + do requestResource readingA + Just a <- liftIO $ readIORef refA + liftIO $ writeIORef refA Nothing + releaseResource writingA + return (a, Cons input) + consume bs = + do (b, bs') <- runStream bs + requestResource writingB + liftIO $ writeIORef refB (Just b) + releaseResource readingB + requestResource conting + consume bs' + loop a = + do requestResource writingA + liftIO $ writeIORef refA (Just a) + releaseResource readingA + requestResource readingB + Just b <- liftIO $ readIORef refB + liftIO $ writeIORef refB Nothing + releaseResource writingB + return (b, Net $ \a -> releaseResource conting >> loop a) + spawnProcess CancelTogether $ + consume $ runProcessor x (Cons input) + loop a + +-- | A net that adds the information about the time points at which +-- the values were received. +arrivalNet :: Net a (Arrival a) +arrivalNet = + let loop t0 = + Net $ \a -> + do t <- liftDynamics time + let b = Arrival { arrivalValue = a, + arrivalTime = t, + arrivalDelay = + case t0 of + Nothing -> Nothing + Just t0 -> Just (t - t0) } + return (b, loop $ Just t) + in loop Nothing + +-- | Delay the input by one step using the specified initial value. +delayNet :: a -> Net a a +delayNet a0 = + Net $ \a -> + return (a0, delayNet a) diff --git a/Simulation/Aivika/Parameter.hs b/Simulation/Aivika/Parameter.hs --- a/Simulation/Aivika/Parameter.hs +++ b/Simulation/Aivika/Parameter.hs @@ -1,38 +1,38 @@ --- | --- Module : Simulation.Aivika.Parameter --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- 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.Parameter - (-- * Parameter - Parameter, - ParameterLift(..), - runParameter, - runParameters, - -- * Error Handling - catchParameter, - finallyParameter, - throwParameter, - -- * Predefined Parameters - simulationIndex, - simulationCount, - simulationSpecs, - generatorParameter, - starttime, - stoptime, - dt, - -- * Memoization - memoParameter, - -- * Utilities - tableParameter) where - -import Simulation.Aivika.Internal.Parameter +-- | +-- Module : Simulation.Aivika.Parameter +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the 'Parameter' monad 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.Parameter + (-- * Parameter + Parameter, + ParameterLift(..), + runParameter, + runParameters, + -- * Error Handling + catchParameter, + finallyParameter, + throwParameter, + -- * Predefined Parameters + simulationIndex, + simulationCount, + simulationSpecs, + generatorParameter, + starttime, + stoptime, + dt, + -- * Memoization + memoParameter, + -- * Utilities + tableParameter) where + +import Simulation.Aivika.Internal.Parameter diff --git a/Simulation/Aivika/Parameter/Random.hs b/Simulation/Aivika/Parameter/Random.hs --- a/Simulation/Aivika/Parameter/Random.hs +++ b/Simulation/Aivika/Parameter/Random.hs @@ -1,123 +1,123 @@ - --- | --- Module : Simulation.Aivika.Parameter.Random --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- This module defines the random parameters of simulation experiments. --- --- To create a parameter that would return the same value within the simulation run, --- you should memoize the computation with help of 'memoParameter', which is important --- for the Monte-Carlo simulation. --- --- To create a random function that would return the same values in the integration --- time points within the simulation run, you should either lift the computation to --- the 'Dynamics' computation and then memoize it too but using the 'memo0Dynamics' --- function for that computation, or just take the predefined function that does --- namely this. - -module Simulation.Aivika.Parameter.Random - (randomUniform, - randomUniformInt, - randomNormal, - randomExponential, - randomErlang, - randomPoisson, - randomBinomial, - randomTrue, - randomFalse) 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.Dynamics -import Simulation.Aivika.Dynamics.Memo.Unboxed - --- | Computation that generates a new random number distributed uniformly. -randomUniform :: Double -- ^ minimum - -> Double -- ^ maximum - -> Parameter Double -randomUniform min max = - Parameter $ \r -> - let g = runGenerator r - in generatorUniform g min max - --- | Computation that generates a new random integer number distributed uniformly. -randomUniformInt :: Int -- ^ minimum - -> Int -- ^ maximum - -> Parameter Int -randomUniformInt min max = - Parameter $ \r -> - let g = runGenerator r - in generatorUniformInt g min max - --- | Computation that generates a new random number distributed normally. -randomNormal :: Double -- ^ mean - -> Double -- ^ deviation - -> Parameter Double -randomNormal mu nu = - Parameter $ \r -> - let g = runGenerator r - in generatorNormal g mu nu - --- | Computation that returns a new exponential random number with the specified mean --- (the reciprocal of the rate). -randomExponential :: Double - -- ^ the mean (the reciprocal of the rate) - -> Parameter Double -randomExponential mu = - Parameter $ \r -> - let g = runGenerator r - in generatorExponential g mu - --- | Computation that returns a new Erlang random number with the specified scale --- (the reciprocal of the rate) and integer shape. -randomErlang :: Double - -- ^ the scale (the reciprocal of the rate) - -> Int - -- ^ the shape - -> Parameter Double -randomErlang beta m = - Parameter $ \r -> - let g = runGenerator r - in generatorErlang g beta m - --- | Computation that returns a new Poisson random number with the specified mean. -randomPoisson :: Double - -- ^ the mean - -> Parameter Int -randomPoisson mu = - Parameter $ \r -> - let g = runGenerator r - in generatorPoisson g mu - --- | Computation that returns a new binomial random number with the specified --- probability and trials. -randomBinomial :: Double -- ^ the probability - -> Int -- ^ the number of trials - -> Parameter Int -randomBinomial prob trials = - Parameter $ \r -> - let g = runGenerator r - in generatorBinomial g prob trials - --- | Computation that returns 'True' in case of success. -randomTrue :: Double -- ^ the probability of the success - -> Parameter Bool -randomTrue p = - do x <- randomUniform 0 1 - return (x <= p) - --- | Computation that returns 'False' in case of success. -randomFalse :: Double -- ^ the probability of the success - -> Parameter Bool -randomFalse p = - do x <- randomUniform 0 1 - return (x > p) + +-- | +-- Module : Simulation.Aivika.Parameter.Random +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the random parameters of simulation experiments. +-- +-- To create a parameter that would return the same value within the simulation run, +-- you should memoize the computation with help of 'memoParameter', which is important +-- for the Monte-Carlo simulation. +-- +-- To create a random function that would return the same values in the integration +-- time points within the simulation run, you should either lift the computation to +-- the 'Dynamics' computation and then memoize it too but using the 'memo0Dynamics' +-- function for that computation, or just take the predefined function that does +-- namely this. + +module Simulation.Aivika.Parameter.Random + (randomUniform, + randomUniformInt, + randomNormal, + randomExponential, + randomErlang, + randomPoisson, + randomBinomial, + randomTrue, + randomFalse) 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.Dynamics +import Simulation.Aivika.Dynamics.Memo.Unboxed + +-- | Computation that generates a new random number distributed uniformly. +randomUniform :: Double -- ^ minimum + -> Double -- ^ maximum + -> Parameter Double +randomUniform min max = + Parameter $ \r -> + let g = runGenerator r + in generateUniform g min max + +-- | Computation that generates a new random integer number distributed uniformly. +randomUniformInt :: Int -- ^ minimum + -> Int -- ^ maximum + -> Parameter Int +randomUniformInt min max = + Parameter $ \r -> + let g = runGenerator r + in generateUniformInt g min max + +-- | Computation that generates a new random number distributed normally. +randomNormal :: Double -- ^ mean + -> Double -- ^ deviation + -> Parameter Double +randomNormal mu nu = + Parameter $ \r -> + let g = runGenerator r + in generateNormal g mu nu + +-- | Computation that returns a new exponential random number with the specified mean +-- (the reciprocal of the rate). +randomExponential :: Double + -- ^ the mean (the reciprocal of the rate) + -> Parameter Double +randomExponential mu = + Parameter $ \r -> + let g = runGenerator r + in generateExponential g mu + +-- | Computation that returns a new Erlang random number with the specified scale +-- (the reciprocal of the rate) and integer shape. +randomErlang :: Double + -- ^ the scale (the reciprocal of the rate) + -> Int + -- ^ the shape + -> Parameter Double +randomErlang beta m = + Parameter $ \r -> + let g = runGenerator r + in generateErlang g beta m + +-- | Computation that returns a new Poisson random number with the specified mean. +randomPoisson :: Double + -- ^ the mean + -> Parameter Int +randomPoisson mu = + Parameter $ \r -> + let g = runGenerator r + in generatePoisson g mu + +-- | Computation that returns a new binomial random number with the specified +-- probability and trials. +randomBinomial :: Double -- ^ the probability + -> Int -- ^ the number of trials + -> Parameter Int +randomBinomial prob trials = + Parameter $ \r -> + let g = runGenerator r + in generateBinomial g prob trials + +-- | Computation that returns 'True' in case of success. +randomTrue :: Double -- ^ the probability of the success + -> Parameter Bool +randomTrue p = + do x <- randomUniform 0 1 + return (x <= p) + +-- | Computation that returns 'False' in case of success. +randomFalse :: Double -- ^ the probability of the success + -> Parameter Bool +randomFalse p = + do x <- randomUniform 0 1 + return (x > p) diff --git a/Simulation/Aivika/PriorityQueue.hs b/Simulation/Aivika/PriorityQueue.hs --- a/Simulation/Aivika/PriorityQueue.hs +++ b/Simulation/Aivika/PriorityQueue.hs @@ -1,161 +1,163 @@ - --- | --- Module : Simulation.Aivika.PriorityQueue --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- An imperative heap-based priority queue. --- -module Simulation.Aivika.PriorityQueue - (PriorityQueue, - queueNull, - queueCount, - newQueue, - enqueue, - dequeue, - queueFront) where - -import Data.Array -import Data.Array.MArray.Safe -import Data.Array.IO.Safe -import Data.IORef -import Control.Monad - --- | The 'PriorityQueue' type represents an imperative heap-based --- priority queue. -data PriorityQueue a = - PriorityQueue { pqKeys :: IORef (IOUArray Int Double), - pqVals :: IORef (IOArray Int a), - pqSize :: IORef Int } - -increase :: PriorityQueue a -> Int -> IO () -increase pq capacity = - do let keyRef = pqKeys pq - valRef = pqVals pq - keys <- readIORef keyRef - vals <- readIORef valRef - (il, iu) <- getBounds keys - let len = (iu - il) + 1 - capacity' | len < 64 = max capacity ((len + 1) * 2) - | otherwise = max capacity ((len `div` 2) * 3) - il' = il - iu' = il + capacity' - 1 - keys' <- newArray_ (il', iu') - vals' <- newArray_ (il', iu') - mapM_ (\i -> do { k <- readArray keys i; writeArray keys' i k }) [il..iu] - mapM_ (\i -> do { v <- readArray vals i; writeArray vals' i v }) [il..iu] - writeIORef keyRef keys' - writeIORef valRef vals' - -siftUp :: IOUArray Int Double - -> IOArray Int a - -> Int -> Double -> a - -> IO () -siftUp keys vals i k v = - if i == 0 - then do writeArray keys i k - writeArray vals i v - else do let n = (i - 1) `div` 2 - kn <- readArray keys n - if k >= kn - then do writeArray keys i k - writeArray vals i v - else do vn <- readArray vals n - writeArray keys i kn - writeArray vals i vn - siftUp keys vals n k v - -siftDown :: IOUArray Int Double - -> IOArray Int a -> Int - -> Int -> Double -> a - -> IO () -siftDown keys vals size i k v = - if i >= (size `div` 2) - then do writeArray keys i k - writeArray vals i v - else do let n = 2 * i + 1 - n' = n + 1 - kn <- readArray keys n - if n' >= size - then if k <= kn - then do writeArray keys i k - writeArray vals i v - else do vn <- readArray vals n - writeArray keys i kn - writeArray vals i vn - siftDown keys vals size n k v - else do kn' <- readArray keys n' - let n'' = if kn > kn' then n' else n - kn'' = min kn' kn - if k <= kn'' - then do writeArray keys i k - writeArray vals i v - else do vn'' <- readArray vals n'' - writeArray keys i kn'' - writeArray vals i vn'' - siftDown keys vals size n'' k v - --- | Test whether the priority queue is empty. -queueNull :: PriorityQueue a -> IO Bool -queueNull pq = - do size <- readIORef (pqSize pq) - return $ size == 0 - --- | Return the number of elements in the priority queue. -queueCount :: PriorityQueue a -> IO Int -queueCount pq = readIORef (pqSize pq) - --- | Create a new priority queue. -newQueue :: IO (PriorityQueue a) -newQueue = - do keys <- newArray_ (0, 10) - vals <- newArray_ (0, 10) - keyRef <- newIORef keys - valRef <- newIORef vals - sizeRef <- newIORef 0 - return PriorityQueue { pqKeys = keyRef, - pqVals = valRef, - pqSize = sizeRef } - --- | Enqueue a new element with the specified priority. -enqueue :: PriorityQueue a -> Double -> a -> IO () -enqueue pq k v = - do i <- readIORef (pqSize pq) - keys <- readIORef (pqKeys pq) - (il, iu) <- getBounds keys - when (i >= iu - il) $ increase pq (i + 2) -- plus one element on the end - writeIORef (pqSize pq) (i + 1) - keys <- readIORef (pqKeys pq) -- it can be another! (side-effect) - vals <- readIORef (pqVals pq) - siftUp keys vals i k v - --- | Dequeue the element with the minimal priority. -dequeue :: PriorityQueue a -> IO () -dequeue pq = - do size <- readIORef (pqSize pq) - when (size == 0) $ error "Empty priority queue: dequeue" - let i = size - 1 - writeIORef (pqSize pq) i - keys <- readIORef (pqKeys pq) - vals <- readIORef (pqVals pq) - k <- readArray keys i - v <- readArray vals i - k0 <- readArray keys size - v0 <- readArray vals size - writeArray keys i k0 - writeArray vals i v0 - siftDown keys vals i 0 k v - --- | Return the element with the minimal priority. -queueFront :: PriorityQueue a -> IO (Double, a) -queueFront pq = - do size <- readIORef (pqSize pq) - when (size == 0) $ error "Empty priority queue: front" - keys <- readIORef (pqKeys pq) - vals <- readIORef (pqVals pq) - k <- readArray keys 0 - v <- readArray vals 0 - return (k, v) + +-- | +-- Module : Simulation.Aivika.PriorityQueue +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- An imperative heap-based priority queue. +-- +module Simulation.Aivika.PriorityQueue + (PriorityQueue, + queueNull, + queueCount, + newQueue, + enqueue, + dequeue, + queueFront) where + +import Data.Array +import Data.Array.MArray.Safe +import Data.Array.IO.Safe +import Data.IORef +import Control.Monad + +-- | The 'PriorityQueue' type represents an imperative heap-based +-- priority queue. +data PriorityQueue a = + PriorityQueue { pqKeys :: IORef (IOUArray Int Double), + pqVals :: IORef (IOArray Int a), + pqSize :: IORef Int } + +increase :: PriorityQueue a -> Int -> IO () +increase pq capacity = + do let keyRef = pqKeys pq + valRef = pqVals pq + keys <- readIORef keyRef + vals <- readIORef valRef + (il, iu) <- getBounds keys + let len = (iu - il) + 1 + capacity' | len < 64 = max capacity ((len + 1) * 2) + | otherwise = max capacity ((len `div` 2) * 3) + il' = il + iu' = il + capacity' - 1 + keys' <- newArray_ (il', iu') + vals' <- newArray_ (il', iu') + mapM_ (\i -> do { k <- readArray keys i; writeArray keys' i k }) [il..iu] + mapM_ (\i -> do { v <- readArray vals i; writeArray vals' i v }) [il..iu] + writeIORef keyRef keys' + writeIORef valRef vals' + +siftUp :: IOUArray Int Double + -> IOArray Int a + -> Int -> Double -> a + -> IO () +siftUp keys vals i k v = + if i == 0 + then do writeArray keys i k + writeArray vals i v + else do let n = (i - 1) `div` 2 + kn <- readArray keys n + if k >= kn + then do writeArray keys i k + writeArray vals i v + else do vn <- readArray vals n + writeArray keys i kn + writeArray vals i vn + siftUp keys vals n k v + +siftDown :: IOUArray Int Double + -> IOArray Int a -> Int + -> Int -> Double -> a + -> IO () +siftDown keys vals size i k v = + if i >= (size `div` 2) + then do writeArray keys i k + writeArray vals i v + else do let n = 2 * i + 1 + n' = n + 1 + kn <- readArray keys n + if n' >= size + then if k <= kn + then do writeArray keys i k + writeArray vals i v + else do vn <- readArray vals n + writeArray keys i kn + writeArray vals i vn + siftDown keys vals size n k v + else do kn' <- readArray keys n' + let n'' = if kn > kn' then n' else n + kn'' = min kn' kn + if k <= kn'' + then do writeArray keys i k + writeArray vals i v + else do vn'' <- readArray vals n'' + writeArray keys i kn'' + writeArray vals i vn'' + siftDown keys vals size n'' k v + +-- | Test whether the priority queue is empty. +queueNull :: PriorityQueue a -> IO Bool +queueNull pq = + do size <- readIORef (pqSize pq) + return $ size == 0 + +-- | Return the number of elements in the priority queue. +queueCount :: PriorityQueue a -> IO Int +queueCount pq = readIORef (pqSize pq) + +-- | Create a new priority queue. +newQueue :: IO (PriorityQueue a) +newQueue = + do keys <- newArray_ (0, 10) + vals <- newArray_ (0, 10) + keyRef <- newIORef keys + valRef <- newIORef vals + sizeRef <- newIORef 0 + return PriorityQueue { pqKeys = keyRef, + pqVals = valRef, + pqSize = sizeRef } + +-- | Enqueue a new element with the specified priority. +enqueue :: PriorityQueue a -> Double -> a -> IO () +enqueue pq k v = + do i <- readIORef (pqSize pq) + keys <- readIORef (pqKeys pq) + (il, iu) <- getBounds keys + when (i >= iu - il) $ increase pq (i + 2) -- plus one element on the end + writeIORef (pqSize pq) (i + 1) + keys <- readIORef (pqKeys pq) -- it can be another! (side-effect) + vals <- readIORef (pqVals pq) + siftUp keys vals i k v + +-- | Dequeue the element with the minimal priority. +dequeue :: PriorityQueue a -> IO () +dequeue pq = + do size <- readIORef (pqSize pq) + when (size == 0) $ error "Empty priority queue: dequeue" + let i = size - 1 + writeIORef (pqSize pq) i + keys <- readIORef (pqKeys pq) + vals <- readIORef (pqVals pq) + k <- readArray keys i + v <- readArray vals i + let k0 = 0.0 + v0 = undefined + -- k0 <- readArray keys size + -- v0 <- readArray vals size + writeArray keys i k0 + writeArray vals i v0 + siftDown keys vals i 0 k v + +-- | Return the element with the minimal priority. +queueFront :: PriorityQueue a -> IO (Double, a) +queueFront pq = + do size <- readIORef (pqSize pq) + when (size == 0) $ error "Empty priority queue: front" + keys <- readIORef (pqKeys pq) + vals <- readIORef (pqVals pq) + k <- readArray keys 0 + v <- readArray vals 0 + return (k, v) diff --git a/Simulation/Aivika/Process.hs b/Simulation/Aivika/Process.hs --- a/Simulation/Aivika/Process.hs +++ b/Simulation/Aivika/Process.hs @@ -1,82 +1,82 @@ - --- | --- Module : Simulation.Aivika.Process --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- A value in the 'Process' monad represents a discontinuous process that --- can suspend in any simulation time point and then resume later in the same --- or another time point. --- --- The process of this type can involve the 'Event', 'Dynamics' and 'Simulation' --- computations. Moreover, a value in the @Process@ monad can be run within --- the @Event@ computation. --- --- A value of the 'ProcessId' type is just an identifier of such a process. --- --- The characteristic property of the @Process@ type is function 'holdProcess' --- that suspends the current process for the specified time interval. --- -module Simulation.Aivika.Process - (-- * Process Monad - ProcessId, - Process, - ProcessLift(..), - -- * Running Process - runProcess, - runProcessUsingId, - runProcessInStartTime, - runProcessInStartTimeUsingId, - runProcessInStopTime, - runProcessInStopTimeUsingId, - -- * Spawning Processes - spawnProcess, - spawnProcessUsingId, - -- * Enqueueing Process - enqueueProcess, - enqueueProcessUsingId, - -- * Creating Process Identifier - newProcessId, - processId, - processUsingId, - -- * Holding, Interrupting, Passivating and Canceling Process - holdProcess, - interruptProcess, - processInterrupted, - passivateProcess, - processPassive, - reactivateProcess, - cancelProcessWithId, - cancelProcess, - processCancelled, - processCancelling, - whenCancellingProcess, - -- * Awaiting Signal - processAwait, - -- * Yield of Process - processYield, - -- * Process Timeout - timeoutProcess, - timeoutProcessUsingId, - -- * Parallelizing Processes - processParallel, - processParallelUsingIds, - processParallel_, - processParallelUsingIds_, - -- * Exception Handling - catchProcess, - finallyProcess, - throwProcess, - -- * Utilities - zipProcessParallel, - zip3ProcessParallel, - unzipProcess, - -- * Memoizing Process - memoProcess, - -- * Never Ending Process - neverProcess) where - -import Simulation.Aivika.Internal.Process + +-- | +-- Module : Simulation.Aivika.Process +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- A value in the 'Process' monad represents a discontinuous process that +-- can suspend in any simulation time point and then resume later in the same +-- or another time point. +-- +-- The process of this type can involve the 'Event', 'Dynamics' and 'Simulation' +-- computations. Moreover, a value in the @Process@ monad can be run within +-- the @Event@ computation. +-- +-- A value of the 'ProcessId' type is just an identifier of such a process. +-- +-- The characteristic property of the @Process@ type is function 'holdProcess' +-- that suspends the current process for the specified time interval. +-- +module Simulation.Aivika.Process + (-- * Process Monad + ProcessId, + Process, + ProcessLift(..), + -- * Running Process + runProcess, + runProcessUsingId, + runProcessInStartTime, + runProcessInStartTimeUsingId, + runProcessInStopTime, + runProcessInStopTimeUsingId, + -- * Spawning Processes + spawnProcess, + spawnProcessUsingId, + -- * Enqueueing Process + enqueueProcess, + enqueueProcessUsingId, + -- * Creating Process Identifier + newProcessId, + processId, + processUsingId, + -- * Holding, Interrupting, Passivating and Canceling Process + holdProcess, + interruptProcess, + processInterrupted, + passivateProcess, + processPassive, + reactivateProcess, + cancelProcessWithId, + cancelProcess, + processCancelled, + processCancelling, + whenCancellingProcess, + -- * Awaiting Signal + processAwait, + -- * Yield of Process + processYield, + -- * Process Timeout + timeoutProcess, + timeoutProcessUsingId, + -- * Parallelizing Processes + processParallel, + processParallelUsingIds, + processParallel_, + processParallelUsingIds_, + -- * Exception Handling + catchProcess, + finallyProcess, + throwProcess, + -- * Utilities + zipProcessParallel, + zip3ProcessParallel, + unzipProcess, + -- * Memoizing Process + memoProcess, + -- * Never Ending Process + neverProcess) where + +import Simulation.Aivika.Internal.Process diff --git a/Simulation/Aivika/Processor.hs b/Simulation/Aivika/Processor.hs --- a/Simulation/Aivika/Processor.hs +++ b/Simulation/Aivika/Processor.hs @@ -1,458 +1,458 @@ - --- | --- Module : Simulation.Aivika.Processor --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The processor of simulation data. --- -module Simulation.Aivika.Processor - (-- * Processor Type - Processor(..), - -- * Processor Primitives - emptyProcessor, - arrProcessor, - accumProcessor, - -- * Specifying Identifier - processorUsingId, - -- * Prefetch and Delay Processors - prefetchProcessor, - delayProcessor, - -- * Buffer Processor - bufferProcessor, - bufferProcessorLoop, - -- * Processing Queues - queueProcessor, - queueProcessorLoopMerging, - queueProcessorLoopSeq, - queueProcessorLoopParallel, - -- * Sequencing Processors - processorSeq, - -- * Parallelizing Processors - processorParallel, - processorQueuedParallel, - processorPrioritisingOutputParallel, - processorPrioritisingInputParallel, - processorPrioritisingInputOutputParallel, - -- * Arrival Processor - arrivalProcessor, - -- * Integrating with Signals - signalProcessor, - processorSignaling) where - -import qualified Control.Category as C -import Control.Arrow - -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Cont -import Simulation.Aivika.Process -import Simulation.Aivika.Stream -import Simulation.Aivika.QueueStrategy -import Simulation.Aivika.Signal -import Simulation.Aivika.Internal.Arrival - --- | Represents a processor of simulation data. -newtype Processor a b = - Processor { runProcessor :: Stream a -> Stream b - -- ^ Run the processor. - } - -instance C.Category Processor where - - id = Processor id - - Processor x . Processor y = Processor (x . y) - --- The implementation is based on article --- A New Notation for Arrows by Ross Paterson, --- although my streams are different and they --- already depend on the Process monad, --- while the pure streams were considered in the --- mentioned article. - -instance Arrow Processor where - - arr = Processor . mapStream - - first (Processor f) = - Processor $ \xys -> - Cons $ - do (xs, ys) <- liftSimulation $ unzipStream xys - runStream $ zipStreamSeq (f xs) ys - - second (Processor f) = - Processor $ \xys -> - Cons $ - do (xs, ys) <- liftSimulation $ unzipStream xys - runStream $ zipStreamSeq xs (f ys) - - Processor f *** Processor g = - Processor $ \xys -> - Cons $ - do (xs, ys) <- liftSimulation $ unzipStream xys - runStream $ zipStreamSeq (f xs) (g ys) - -instance ArrowChoice Processor where - - left (Processor f) = - Processor $ \xs -> - Cons $ - do ys <- liftSimulation $ memoStream xs - runStream $ replaceLeftStream ys (f $ leftStream ys) - - right (Processor f) = - Processor $ \xs -> - Cons $ - do ys <- liftSimulation $ memoStream xs - runStream $ replaceRightStream ys (f $ rightStream ys) - -instance ArrowZero Processor where - - zeroArrow = Processor $ const emptyStream - -instance ArrowPlus Processor where - - (Processor f) <+> (Processor g) = - Processor $ \xs -> - Cons $ - do [xs1, xs2] <- liftSimulation $ splitStream 2 xs - runStream $ mergeStreams (f xs1) (g xs2) - --- | A processor that never finishes its work producing an 'emptyStream'. -emptyProcessor :: Processor a b -emptyProcessor = Processor $ const emptyStream - --- | Create a simple processor by the specified handling function --- that runs the discontinuous process for each input value to get the output. -arrProcessor :: (a -> Process b) -> Processor a b -arrProcessor = Processor . mapStreamM - --- | Accumulator that outputs a value determined by the supplied function. -accumProcessor :: (acc -> a -> Process (acc, b)) -> acc -> Processor a b -accumProcessor f acc = - Processor $ \xs -> Cons $ loop xs acc where - loop xs acc = - do (a, xs') <- runStream xs - (acc', b) <- f acc a - return (b, Cons $ loop xs' acc') - --- | Create a processor that will use the specified process identifier. --- It can be useful to refer to the underlying 'Process' computation which --- can be passivated, interrupted, canceled and so on. See also the --- 'processUsingId' function for more details. -processorUsingId :: ProcessId -> Processor a b -> Processor a b -processorUsingId pid (Processor f) = - Processor $ Cons . processUsingId pid . runStream . f - --- | Launches the specified processors in parallel consuming the same input --- stream and producing a combined output stream. --- --- If you don't know what the enqueue strategies to apply, then --- you will probably need 'FCFS' for the both parameters, or --- function 'processorParallel' that does namely this. -processorQueuedParallel :: (EnqueueStrategy si qi, - EnqueueStrategy so qo) - => si - -- ^ the strategy applied for enqueuing the input data - -> so - -- ^ the strategy applied for enqueuing the output data - -> [Processor a b] - -- ^ the processors to parallelize - -> Processor a b - -- ^ the parallelized processor -processorQueuedParallel si so ps = - Processor $ \xs -> - Cons $ - do let n = length ps - input <- liftSimulation $ splitStreamQueueing si n xs - let results = flip map (zip input ps) $ \(input, p) -> - runProcessor p input - output = concatQueuedStreams so results - runStream output - --- | Launches the specified processors in parallel using priorities for combining the output. -processorPrioritisingOutputParallel :: (EnqueueStrategy si qi, - PriorityQueueStrategy so qo po) - => si - -- ^ the strategy applied for enqueuing the input data - -> so - -- ^ the strategy applied for enqueuing the output data - -> [Processor a (po, b)] - -- ^ the processors to parallelize - -> Processor a b - -- ^ the parallelized processor -processorPrioritisingOutputParallel si so ps = - Processor $ \xs -> - Cons $ - do let n = length ps - input <- liftSimulation $ splitStreamQueueing si n xs - let results = flip map (zip input ps) $ \(input, p) -> - runProcessor p input - output = concatPriorityStreams so results - runStream output - --- | Launches the specified processors in parallel using priorities for consuming the intput. -processorPrioritisingInputParallel :: (PriorityQueueStrategy si qi pi, - EnqueueStrategy so qo) - => si - -- ^ the strategy applied for enqueuing the input data - -> so - -- ^ the strategy applied for enqueuing the output data - -> [(Stream pi, Processor a b)] - -- ^ the streams of input priorities and the processors - -- to parallelize - -> Processor a b - -- ^ the parallelized processor -processorPrioritisingInputParallel si so ps = - Processor $ \xs -> - Cons $ - do input <- liftSimulation $ splitStreamPrioritising si (map fst ps) xs - let results = flip map (zip input ps) $ \(input, (_, p)) -> - runProcessor p input - output = concatQueuedStreams so results - runStream output - --- | Launches the specified processors in parallel using priorities for consuming --- the input and combining the output. -processorPrioritisingInputOutputParallel :: (PriorityQueueStrategy si qi pi, - PriorityQueueStrategy so qo po) - => si - -- ^ the strategy applied for enqueuing the input data - -> so - -- ^ the strategy applied for enqueuing the output data - -> [(Stream pi, Processor a (po, b))] - -- ^ the streams of input priorities and the processors - -- to parallelize - -> Processor a b - -- ^ the parallelized processor -processorPrioritisingInputOutputParallel si so ps = - Processor $ \xs -> - Cons $ - do input <- liftSimulation $ splitStreamPrioritising si (map fst ps) xs - let results = flip map (zip input ps) $ \(input, (_, p)) -> - runProcessor p input - output = concatPriorityStreams so results - runStream output - --- | Launches the processors in parallel consuming the same input stream and producing --- a combined output stream. This version applies the 'FCFS' strategy both for input --- and output, which suits the most part of uses cases. -processorParallel :: [Processor a b] -> Processor a b -processorParallel = processorQueuedParallel FCFS FCFS - --- | Launches the processors sequentially using the 'prefetchProcessor' between them --- to model an autonomous work of each of the processors specified. -processorSeq :: [Processor a a] -> Processor a a -processorSeq [] = emptyProcessor -processorSeq [p] = p -processorSeq (p : ps) = p >>> prefetchProcessor >>> processorSeq ps - --- | Create a buffer processor, where the process from the first argument --- consumes the input stream but the stream passed in as the second argument --- and produced usually by some other process is returned as an output. --- This kind of processor is very useful for modeling the queues. -bufferProcessor :: (Stream a -> Process ()) - -- ^ a separate process to consume the input - -> Stream b - -- ^ the resulting stream of data - -> Processor a b -bufferProcessor consume output = - Processor $ \xs -> - Cons $ - do spawnProcess CancelTogether (consume xs) - runStream output - --- | Like 'bufferProcessor' but allows creating a loop when some items --- can be processed repeatedly. It is very useful for modeling the processors --- with queues and loop-backs. -bufferProcessorLoop :: (Stream a -> Stream c -> Process ()) - -- ^ consume two streams: the input values of type @a@ - -- and the values of type @c@ returned by the loop - -> Stream d - -- ^ the stream of data that may become results - -> Processor d (Either e b) - -- ^ process and then decide what values of type @e@ - -- should be processed in the loop (this is a condition) - -> Processor e c - -- ^ process in the loop and then return a value - -- of type @c@ to the input again (this is a loop body) - -> Processor a b -bufferProcessorLoop consume preoutput cond body = - Processor $ \xs -> - Cons $ - do (reverted, output) <- - liftSimulation $ - partitionEitherStream $ - runProcessor cond preoutput - spawnProcess CancelTogether - (consume xs $ runProcessor body reverted) - runStream output - --- | Return a processor with help of which we can model the queue. --- --- Although the function doesn't refer to the queue directly, its main use case --- is namely a processing of the queue. The first argument should be the enqueueing --- operation, while the second argument should be the opposite dequeueing operation. --- --- The reason is as follows. There are many possible combinations how the queues --- can be modeled. There is no sense to enumerate all them creating a separate function --- for each case. We can just use combinators to define exactly what we need. --- --- So, the queue can lose the input items if the queue is full, or the input process --- can suspend while the queue is full, or we can use priorities for enqueueing, --- storing and dequeueing the items in different combinations. There are so many use --- cases! --- --- There is a hope that this function along with other similar functions from this --- module is sufficient to cover the most important cases. Even if it is not sufficient --- then you can use a more generic function 'bufferProcessor' which this function is --- based on. In case of need, you can even write your own function from scratch. It is --- quite easy actually. -queueProcessor :: (a -> Process ()) - -- ^ enqueue the input item and wait - -- while the queue is full if required - -- so that there were no hanging items - -> Process b - -- ^ dequeue an output item - -> Processor a b - -- ^ the buffering processor -queueProcessor enqueue dequeue = - bufferProcessor - (consumeStream enqueue) - (repeatProcess dequeue) - --- | Like 'queueProcessor' creates a queue processor but with a loop when some items --- can be processed and then added to the queue again. Also it allows specifying --- how two input streams of data can be merged. -queueProcessorLoopMerging :: (Stream a -> Stream d -> Stream e) - -- ^ merge two streams: the input values of type @a@ - -- and the values of type @d@ returned by the loop - -> (e -> Process ()) - -- ^ enqueue the input item and wait - -- while the queue is full if required - -- so that there were no hanging items - -> Process c - -- ^ dequeue an item for the further processing - -> Processor c (Either f b) - -- ^ process and then decide what values of type @f@ - -- should be processed in the loop (this is a condition) - -> Processor f d - -- ^ process in the loop and then return a value - -- of type @d@ to the queue again (this is a loop body) - -> Processor a b - -- ^ the buffering processor -queueProcessorLoopMerging merge enqueue dequeue = - bufferProcessorLoop - (\bs cs -> - consumeStream enqueue $ - merge bs cs) - (repeatProcess dequeue) - --- | Like 'queueProcessorLoopMerging' creates a queue processor with a loop when --- some items can be processed and then added to the queue again. Only it sequentially --- merges two input streams of data: one stream that come from the external source and --- another stream of data returned by the loop. The first stream has a priority over --- the second one. -queueProcessorLoopSeq :: (a -> Process ()) - -- ^ enqueue the input item and wait - -- while the queue is full if required - -- so that there were no hanging items - -> Process c - -- ^ dequeue an item for the further processing - -> Processor c (Either e b) - -- ^ process and then decide what values of type @e@ - -- should be processed in the loop (this is a condition) - -> Processor e a - -- ^ process in the loop and then return a value - -- of type @a@ to the queue again (this is a loop body) - -> Processor a b - -- ^ the buffering processor -queueProcessorLoopSeq = - queueProcessorLoopMerging mergeStreams - --- | Like 'queueProcessorLoopMerging' creates a queue processor with a loop when --- some items can be processed and then added to the queue again. Only it runs two --- simultaneous processes to enqueue the input streams of data: one stream that come --- from the external source and another stream of data returned by the loop. -queueProcessorLoopParallel :: (a -> Process ()) - -- ^ enqueue the input item and wait - -- while the queue is full if required - -- so that there were no hanging items - -> Process c - -- ^ dequeue an item for the further processing - -> Processor c (Either e b) - -- ^ process and then decide what values of type @e@ - -- should be processed in the loop (this is a condition) - -> Processor e a - -- ^ process in the loop and then return a value - -- of type @a@ to the queue again (this is a loop body) - -> Processor a b - -- ^ the buffering processor -queueProcessorLoopParallel enqueue dequeue = - bufferProcessorLoop - (\bs cs -> - do spawnProcess CancelTogether $ - consumeStream enqueue bs - spawnProcess CancelTogether $ - consumeStream enqueue cs) - (repeatProcess dequeue) - --- | This is a prefetch processor that requests for one more data item from --- the input in advance while the latest item is not yet fully processed in --- the chain of streams, usually by other processors. --- --- You can think of this as the prefetched processor could place its latest --- data item in some temporary space for later use, which is very useful --- for modeling a sequence of separate and independent work places. -prefetchProcessor :: Processor a a -prefetchProcessor = Processor prefetchStream - --- | Convert the specified signal transform to a processor. --- --- The processor may return data with delay as the values are requested by demand. --- Consider using the 'arrivalSignal' function to provide with the information --- about the time points at which the signal was actually triggered. --- --- The point is that the 'Stream' used in the 'Processor' is requested outside, --- while the 'Signal' is triggered inside. They are different by nature. --- The former is passive, while the latter is active. --- --- Cancel the processor's process to unsubscribe from the signals provided. -signalProcessor :: (Signal a -> Signal b) -> Processor a b -signalProcessor f = - Processor $ \xs -> - Cons $ - do sa <- streamSignal xs - sb <- signalStream (f sa) - runStream sb - --- | Convert the specified processor to a signal transform. --- --- The processor may return data with delay as the values are requested by demand. --- Consider using the 'arrivalSignal' function to provide with the information --- about the time points at which the signal was actually triggered. --- --- The point is that the 'Stream' used in the 'Processor' is requested outside, --- while the 'Signal' is triggered inside. They are different by nature. --- The former is passive, while the latter is active. --- --- Cancel the returned process to unsubscribe from the signal specified. -processorSignaling :: Processor a b -> Signal a -> Process (Signal b) -processorSignaling (Processor f) sa = - do xs <- signalStream sa - let ys = f xs - streamSignal ys - --- | A processor that adds the information about the time points at which --- the original stream items were received by demand. -arrivalProcessor :: Processor a (Arrival a) -arrivalProcessor = Processor arrivalStream - --- | A processor that delays the input stream by one step using the specified initial value. -delayProcessor :: a -> Processor a a -delayProcessor a0 = Processor $ delayStream a0 + +-- | +-- Module : Simulation.Aivika.Processor +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The processor of simulation data. +-- +module Simulation.Aivika.Processor + (-- * Processor Type + Processor(..), + -- * Processor Primitives + emptyProcessor, + arrProcessor, + accumProcessor, + -- * Specifying Identifier + processorUsingId, + -- * Prefetch and Delay Processors + prefetchProcessor, + delayProcessor, + -- * Buffer Processor + bufferProcessor, + bufferProcessorLoop, + -- * Processing Queues + queueProcessor, + queueProcessorLoopMerging, + queueProcessorLoopSeq, + queueProcessorLoopParallel, + -- * Sequencing Processors + processorSeq, + -- * Parallelizing Processors + processorParallel, + processorQueuedParallel, + processorPrioritisingOutputParallel, + processorPrioritisingInputParallel, + processorPrioritisingInputOutputParallel, + -- * Arrival Processor + arrivalProcessor, + -- * Integrating with Signals + signalProcessor, + processorSignaling) where + +import qualified Control.Category as C +import Control.Arrow + +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Event +import Simulation.Aivika.Cont +import Simulation.Aivika.Process +import Simulation.Aivika.Stream +import Simulation.Aivika.QueueStrategy +import Simulation.Aivika.Signal +import Simulation.Aivika.Internal.Arrival + +-- | Represents a processor of simulation data. +newtype Processor a b = + Processor { runProcessor :: Stream a -> Stream b + -- ^ Run the processor. + } + +instance C.Category Processor where + + id = Processor id + + Processor x . Processor y = Processor (x . y) + +-- The implementation is based on article +-- A New Notation for Arrows by Ross Paterson, +-- although my streams are different and they +-- already depend on the Process monad, +-- while the pure streams were considered in the +-- mentioned article. + +instance Arrow Processor where + + arr = Processor . mapStream + + first (Processor f) = + Processor $ \xys -> + Cons $ + do (xs, ys) <- liftSimulation $ unzipStream xys + runStream $ zipStreamSeq (f xs) ys + + second (Processor f) = + Processor $ \xys -> + Cons $ + do (xs, ys) <- liftSimulation $ unzipStream xys + runStream $ zipStreamSeq xs (f ys) + + Processor f *** Processor g = + Processor $ \xys -> + Cons $ + do (xs, ys) <- liftSimulation $ unzipStream xys + runStream $ zipStreamSeq (f xs) (g ys) + +instance ArrowChoice Processor where + + left (Processor f) = + Processor $ \xs -> + Cons $ + do ys <- liftSimulation $ memoStream xs + runStream $ replaceLeftStream ys (f $ leftStream ys) + + right (Processor f) = + Processor $ \xs -> + Cons $ + do ys <- liftSimulation $ memoStream xs + runStream $ replaceRightStream ys (f $ rightStream ys) + +instance ArrowZero Processor where + + zeroArrow = Processor $ const emptyStream + +instance ArrowPlus Processor where + + (Processor f) <+> (Processor g) = + Processor $ \xs -> + Cons $ + do [xs1, xs2] <- liftSimulation $ splitStream 2 xs + runStream $ mergeStreams (f xs1) (g xs2) + +-- | A processor that never finishes its work producing an 'emptyStream'. +emptyProcessor :: Processor a b +emptyProcessor = Processor $ const emptyStream + +-- | Create a simple processor by the specified handling function +-- that runs the discontinuous process for each input value to get the output. +arrProcessor :: (a -> Process b) -> Processor a b +arrProcessor = Processor . mapStreamM + +-- | Accumulator that outputs a value determined by the supplied function. +accumProcessor :: (acc -> a -> Process (acc, b)) -> acc -> Processor a b +accumProcessor f acc = + Processor $ \xs -> Cons $ loop xs acc where + loop xs acc = + do (a, xs') <- runStream xs + (acc', b) <- f acc a + return (b, Cons $ loop xs' acc') + +-- | Create a processor that will use the specified process identifier. +-- It can be useful to refer to the underlying 'Process' computation which +-- can be passivated, interrupted, canceled and so on. See also the +-- 'processUsingId' function for more details. +processorUsingId :: ProcessId -> Processor a b -> Processor a b +processorUsingId pid (Processor f) = + Processor $ Cons . processUsingId pid . runStream . f + +-- | Launches the specified processors in parallel consuming the same input +-- stream and producing a combined output stream. +-- +-- If you don't know what the enqueue strategies to apply, then +-- you will probably need 'FCFS' for the both parameters, or +-- function 'processorParallel' that does namely this. +processorQueuedParallel :: (EnqueueStrategy si, + EnqueueStrategy so) + => si + -- ^ the strategy applied for enqueuing the input data + -> so + -- ^ the strategy applied for enqueuing the output data + -> [Processor a b] + -- ^ the processors to parallelize + -> Processor a b + -- ^ the parallelized processor +processorQueuedParallel si so ps = + Processor $ \xs -> + Cons $ + do let n = length ps + input <- liftSimulation $ splitStreamQueueing si n xs + let results = flip map (zip input ps) $ \(input, p) -> + runProcessor p input + output = concatQueuedStreams so results + runStream output + +-- | Launches the specified processors in parallel using priorities for combining the output. +processorPrioritisingOutputParallel :: (EnqueueStrategy si, + PriorityQueueStrategy so po) + => si + -- ^ the strategy applied for enqueuing the input data + -> so + -- ^ the strategy applied for enqueuing the output data + -> [Processor a (po, b)] + -- ^ the processors to parallelize + -> Processor a b + -- ^ the parallelized processor +processorPrioritisingOutputParallel si so ps = + Processor $ \xs -> + Cons $ + do let n = length ps + input <- liftSimulation $ splitStreamQueueing si n xs + let results = flip map (zip input ps) $ \(input, p) -> + runProcessor p input + output = concatPriorityStreams so results + runStream output + +-- | Launches the specified processors in parallel using priorities for consuming the intput. +processorPrioritisingInputParallel :: (PriorityQueueStrategy si pi, + EnqueueStrategy so) + => si + -- ^ the strategy applied for enqueuing the input data + -> so + -- ^ the strategy applied for enqueuing the output data + -> [(Stream pi, Processor a b)] + -- ^ the streams of input priorities and the processors + -- to parallelize + -> Processor a b + -- ^ the parallelized processor +processorPrioritisingInputParallel si so ps = + Processor $ \xs -> + Cons $ + do input <- liftSimulation $ splitStreamPrioritising si (map fst ps) xs + let results = flip map (zip input ps) $ \(input, (_, p)) -> + runProcessor p input + output = concatQueuedStreams so results + runStream output + +-- | Launches the specified processors in parallel using priorities for consuming +-- the input and combining the output. +processorPrioritisingInputOutputParallel :: (PriorityQueueStrategy si pi, + PriorityQueueStrategy so po) + => si + -- ^ the strategy applied for enqueuing the input data + -> so + -- ^ the strategy applied for enqueuing the output data + -> [(Stream pi, Processor a (po, b))] + -- ^ the streams of input priorities and the processors + -- to parallelize + -> Processor a b + -- ^ the parallelized processor +processorPrioritisingInputOutputParallel si so ps = + Processor $ \xs -> + Cons $ + do input <- liftSimulation $ splitStreamPrioritising si (map fst ps) xs + let results = flip map (zip input ps) $ \(input, (_, p)) -> + runProcessor p input + output = concatPriorityStreams so results + runStream output + +-- | Launches the processors in parallel consuming the same input stream and producing +-- a combined output stream. This version applies the 'FCFS' strategy both for input +-- and output, which suits the most part of uses cases. +processorParallel :: [Processor a b] -> Processor a b +processorParallel = processorQueuedParallel FCFS FCFS + +-- | Launches the processors sequentially using the 'prefetchProcessor' between them +-- to model an autonomous work of each of the processors specified. +processorSeq :: [Processor a a] -> Processor a a +processorSeq [] = emptyProcessor +processorSeq [p] = p +processorSeq (p : ps) = p >>> prefetchProcessor >>> processorSeq ps + +-- | Create a buffer processor, where the process from the first argument +-- consumes the input stream but the stream passed in as the second argument +-- and produced usually by some other process is returned as an output. +-- This kind of processor is very useful for modeling the queues. +bufferProcessor :: (Stream a -> Process ()) + -- ^ a separate process to consume the input + -> Stream b + -- ^ the resulting stream of data + -> Processor a b +bufferProcessor consume output = + Processor $ \xs -> + Cons $ + do spawnProcess CancelTogether (consume xs) + runStream output + +-- | Like 'bufferProcessor' but allows creating a loop when some items +-- can be processed repeatedly. It is very useful for modeling the processors +-- with queues and loop-backs. +bufferProcessorLoop :: (Stream a -> Stream c -> Process ()) + -- ^ consume two streams: the input values of type @a@ + -- and the values of type @c@ returned by the loop + -> Stream d + -- ^ the stream of data that may become results + -> Processor d (Either e b) + -- ^ process and then decide what values of type @e@ + -- should be processed in the loop (this is a condition) + -> Processor e c + -- ^ process in the loop and then return a value + -- of type @c@ to the input again (this is a loop body) + -> Processor a b +bufferProcessorLoop consume preoutput cond body = + Processor $ \xs -> + Cons $ + do (reverted, output) <- + liftSimulation $ + partitionEitherStream $ + runProcessor cond preoutput + spawnProcess CancelTogether + (consume xs $ runProcessor body reverted) + runStream output + +-- | Return a processor with help of which we can model the queue. +-- +-- Although the function doesn't refer to the queue directly, its main use case +-- is namely a processing of the queue. The first argument should be the enqueueing +-- operation, while the second argument should be the opposite dequeueing operation. +-- +-- The reason is as follows. There are many possible combinations how the queues +-- can be modeled. There is no sense to enumerate all them creating a separate function +-- for each case. We can just use combinators to define exactly what we need. +-- +-- So, the queue can lose the input items if the queue is full, or the input process +-- can suspend while the queue is full, or we can use priorities for enqueueing, +-- storing and dequeueing the items in different combinations. There are so many use +-- cases! +-- +-- There is a hope that this function along with other similar functions from this +-- module is sufficient to cover the most important cases. Even if it is not sufficient +-- then you can use a more generic function 'bufferProcessor' which this function is +-- based on. In case of need, you can even write your own function from scratch. It is +-- quite easy actually. +queueProcessor :: (a -> Process ()) + -- ^ enqueue the input item and wait + -- while the queue is full if required + -- so that there were no hanging items + -> Process b + -- ^ dequeue an output item + -> Processor a b + -- ^ the buffering processor +queueProcessor enqueue dequeue = + bufferProcessor + (consumeStream enqueue) + (repeatProcess dequeue) + +-- | Like 'queueProcessor' creates a queue processor but with a loop when some items +-- can be processed and then added to the queue again. Also it allows specifying +-- how two input streams of data can be merged. +queueProcessorLoopMerging :: (Stream a -> Stream d -> Stream e) + -- ^ merge two streams: the input values of type @a@ + -- and the values of type @d@ returned by the loop + -> (e -> Process ()) + -- ^ enqueue the input item and wait + -- while the queue is full if required + -- so that there were no hanging items + -> Process c + -- ^ dequeue an item for the further processing + -> Processor c (Either f b) + -- ^ process and then decide what values of type @f@ + -- should be processed in the loop (this is a condition) + -> Processor f d + -- ^ process in the loop and then return a value + -- of type @d@ to the queue again (this is a loop body) + -> Processor a b + -- ^ the buffering processor +queueProcessorLoopMerging merge enqueue dequeue = + bufferProcessorLoop + (\bs cs -> + consumeStream enqueue $ + merge bs cs) + (repeatProcess dequeue) + +-- | Like 'queueProcessorLoopMerging' creates a queue processor with a loop when +-- some items can be processed and then added to the queue again. Only it sequentially +-- merges two input streams of data: one stream that come from the external source and +-- another stream of data returned by the loop. The first stream has a priority over +-- the second one. +queueProcessorLoopSeq :: (a -> Process ()) + -- ^ enqueue the input item and wait + -- while the queue is full if required + -- so that there were no hanging items + -> Process c + -- ^ dequeue an item for the further processing + -> Processor c (Either e b) + -- ^ process and then decide what values of type @e@ + -- should be processed in the loop (this is a condition) + -> Processor e a + -- ^ process in the loop and then return a value + -- of type @a@ to the queue again (this is a loop body) + -> Processor a b + -- ^ the buffering processor +queueProcessorLoopSeq = + queueProcessorLoopMerging mergeStreams + +-- | Like 'queueProcessorLoopMerging' creates a queue processor with a loop when +-- some items can be processed and then added to the queue again. Only it runs two +-- simultaneous processes to enqueue the input streams of data: one stream that come +-- from the external source and another stream of data returned by the loop. +queueProcessorLoopParallel :: (a -> Process ()) + -- ^ enqueue the input item and wait + -- while the queue is full if required + -- so that there were no hanging items + -> Process c + -- ^ dequeue an item for the further processing + -> Processor c (Either e b) + -- ^ process and then decide what values of type @e@ + -- should be processed in the loop (this is a condition) + -> Processor e a + -- ^ process in the loop and then return a value + -- of type @a@ to the queue again (this is a loop body) + -> Processor a b + -- ^ the buffering processor +queueProcessorLoopParallel enqueue dequeue = + bufferProcessorLoop + (\bs cs -> + do spawnProcess CancelTogether $ + consumeStream enqueue bs + spawnProcess CancelTogether $ + consumeStream enqueue cs) + (repeatProcess dequeue) + +-- | This is a prefetch processor that requests for one more data item from +-- the input in advance while the latest item is not yet fully processed in +-- the chain of streams, usually by other processors. +-- +-- You can think of this as the prefetched processor could place its latest +-- data item in some temporary space for later use, which is very useful +-- for modeling a sequence of separate and independent work places. +prefetchProcessor :: Processor a a +prefetchProcessor = Processor prefetchStream + +-- | Convert the specified signal transform to a processor. +-- +-- The processor may return data with delay as the values are requested by demand. +-- Consider using the 'arrivalSignal' function to provide with the information +-- about the time points at which the signal was actually triggered. +-- +-- The point is that the 'Stream' used in the 'Processor' is requested outside, +-- while the 'Signal' is triggered inside. They are different by nature. +-- The former is passive, while the latter is active. +-- +-- Cancel the processor's process to unsubscribe from the signals provided. +signalProcessor :: (Signal a -> Signal b) -> Processor a b +signalProcessor f = + Processor $ \xs -> + Cons $ + do sa <- streamSignal xs + sb <- signalStream (f sa) + runStream sb + +-- | Convert the specified processor to a signal transform. +-- +-- The processor may return data with delay as the values are requested by demand. +-- Consider using the 'arrivalSignal' function to provide with the information +-- about the time points at which the signal was actually triggered. +-- +-- The point is that the 'Stream' used in the 'Processor' is requested outside, +-- while the 'Signal' is triggered inside. They are different by nature. +-- The former is passive, while the latter is active. +-- +-- Cancel the returned process to unsubscribe from the signal specified. +processorSignaling :: Processor a b -> Signal a -> Process (Signal b) +processorSignaling (Processor f) sa = + do xs <- signalStream sa + let ys = f xs + streamSignal ys + +-- | A processor that adds the information about the time points at which +-- the original stream items were received by demand. +arrivalProcessor :: Processor a (Arrival a) +arrivalProcessor = Processor arrivalStream + +-- | A processor that delays the input stream by one step using the specified initial value. +delayProcessor :: a -> Processor a a +delayProcessor a0 = Processor $ delayStream a0 diff --git a/Simulation/Aivika/Processor/RoundRobbin.hs b/Simulation/Aivika/Processor/RoundRobbin.hs --- a/Simulation/Aivika/Processor/RoundRobbin.hs +++ b/Simulation/Aivika/Processor/RoundRobbin.hs @@ -1,58 +1,58 @@ - --- | --- Module : Simulation.Aivika.Processor.RoundRobbin --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- The module defines the Round-Robbin processor. --- -module Simulation.Aivika.Processor.RoundRobbin - (roundRobbinProcessor, - roundRobbinProcessorUsingIds) where - -import Control.Monad - -import Simulation.Aivika.Simulation -import Simulation.Aivika.Event -import Simulation.Aivika.Process -import Simulation.Aivika.Processor -import Simulation.Aivika.Stream -import Simulation.Aivika.Queue.Infinite - --- | Represents the Round-Robbin processor that tries to perform the task within --- the specified timeout. If the task times out, then it is canceled and returned --- to the processor again; otherwise, the successful result is redirected to output. -roundRobbinProcessor :: Processor (Process Double, Process a) a -roundRobbinProcessor = - Processor $ - runProcessor roundRobbinProcessorUsingIds . mapStreamM f where - f (timeout, p) = - let x = do timeout' <- timeout - pid <- liftSimulation newProcessId - return (timeout', pid) - in return (x, p) - --- | Like 'roundRobbinProcessor' but allows specifying the process identifiers which --- must be unique for every new attemp to perform the task even if the task is the same. -roundRobbinProcessorUsingIds :: Processor (Process (Double, ProcessId), Process a) a -roundRobbinProcessorUsingIds = - Processor $ \xs -> - Cons $ - do q <- liftEvent newFCFSQueue - let process = - do t@(x, p) <- dequeue q - (timeout, pid) <- x - result <- timeoutProcessUsingId timeout pid p - case result of - Just a -> return a - Nothing -> - do liftEvent $ enqueue q t - process - processor = - bufferProcessor - (consumeStream $ liftEvent . enqueue q) - (repeatProcess process) - runStream $ runProcessor processor xs + +-- | +-- Module : Simulation.Aivika.Processor.RoundRobbin +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the Round-Robbin processor. +-- +module Simulation.Aivika.Processor.RoundRobbin + (roundRobbinProcessor, + roundRobbinProcessorUsingIds) where + +import Control.Monad + +import Simulation.Aivika.Simulation +import Simulation.Aivika.Event +import Simulation.Aivika.Process +import Simulation.Aivika.Processor +import Simulation.Aivika.Stream +import Simulation.Aivika.Queue.Infinite + +-- | Represents the Round-Robbin processor that tries to perform the task within +-- the specified timeout. If the task times out, then it is canceled and returned +-- to the processor again; otherwise, the successful result is redirected to output. +roundRobbinProcessor :: Processor (Process Double, Process a) a +roundRobbinProcessor = + Processor $ + runProcessor roundRobbinProcessorUsingIds . mapStreamM f where + f (timeout, p) = + let x = do timeout' <- timeout + pid <- liftSimulation newProcessId + return (timeout', pid) + in return (x, p) + +-- | Like 'roundRobbinProcessor' but allows specifying the process identifiers which +-- must be unique for every new attemp to perform the task even if the task is the same. +roundRobbinProcessorUsingIds :: Processor (Process (Double, ProcessId), Process a) a +roundRobbinProcessorUsingIds = + Processor $ \xs -> + Cons $ + do q <- liftEvent newFCFSQueue + let process = + do t@(x, p) <- dequeue q + (timeout, pid) <- x + result <- timeoutProcessUsingId timeout pid p + case result of + Just a -> return a + Nothing -> + do liftEvent $ enqueue q t + process + processor = + bufferProcessor + (consumeStream $ liftEvent . enqueue q) + (repeatProcess process) + runStream $ runProcessor processor xs diff --git a/Simulation/Aivika/Queue.hs b/Simulation/Aivika/Queue.hs --- a/Simulation/Aivika/Queue.hs +++ b/Simulation/Aivika/Queue.hs @@ -1,1103 +1,1097 @@ - --- | --- Module : Simulation.Aivika.Queue --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines a queue that can use the specified strategies. So, having only --- the 'FCFS', 'LCFS', 'SIRO' and 'StaticPriorities' strategies, you can build --- 4 x 4 x 4 = 64 different types of the queue, each of them will have its own --- behaviour. --- -module Simulation.Aivika.Queue - (-- * Queue Types - FCFSQueue, - LCFSQueue, - SIROQueue, - PriorityQueue, - Queue, - -- * Creating Queue - newFCFSQueue, - newLCFSQueue, - newSIROQueue, - newPriorityQueue, - newQueue, - -- * Queue Properties and Activities - enqueueStrategy, - enqueueStoringStrategy, - dequeueStrategy, - queueNull, - queueFull, - queueMaxCount, - queueCount, - queueCountStats, - enqueueCount, - enqueueLostCount, - enqueueStoreCount, - dequeueCount, - dequeueExtractCount, - queueLoadFactor, - enqueueRate, - enqueueStoreRate, - dequeueRate, - dequeueExtractRate, - queueWaitTime, - queueTotalWaitTime, - enqueueWaitTime, - dequeueWaitTime, - queueRate, - -- * Dequeuing and Enqueuing - dequeue, - dequeueWithOutputPriority, - tryDequeue, - enqueue, - enqueueWithInputPriority, - enqueueWithStoringPriority, - enqueueWithInputStoringPriorities, - tryEnqueue, - tryEnqueueWithStoringPriority, - enqueueOrLost, - enqueueOrLost_, - enqueueWithStoringPriorityOrLost, - enqueueWithStoringPriorityOrLost_, - -- * Awaiting - waitWhileFullQueue, - -- * Summary - queueSummary, - -- * Derived Signals for Properties - queueNullChanged, - queueNullChanged_, - queueFullChanged, - queueFullChanged_, - queueCountChanged, - queueCountChanged_, - enqueueCountChanged, - enqueueCountChanged_, - enqueueLostCountChanged, - enqueueLostCountChanged_, - enqueueStoreCountChanged, - enqueueStoreCountChanged_, - dequeueCountChanged, - dequeueCountChanged_, - dequeueExtractCountChanged, - dequeueExtractCountChanged_, - queueLoadFactorChanged, - queueLoadFactorChanged_, - queueWaitTimeChanged, - queueWaitTimeChanged_, - queueTotalWaitTimeChanged, - queueTotalWaitTimeChanged_, - enqueueWaitTimeChanged, - enqueueWaitTimeChanged_, - dequeueWaitTimeChanged, - dequeueWaitTimeChanged_, - queueRateChanged, - queueRateChanged_, - -- * Basic Signals - enqueueInitiated, - enqueueStored, - enqueueLost, - dequeueRequested, - dequeueExtracted, - -- * Overall Signal - queueChanged_) where - -import Data.IORef -import Data.Monoid - -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.Internal.Event -import Simulation.Aivika.Internal.Process -import Simulation.Aivika.Internal.Signal -import Simulation.Aivika.Signal -import Simulation.Aivika.Resource -import Simulation.Aivika.QueueStrategy -import Simulation.Aivika.Statistics - -import qualified Simulation.Aivika.DoubleLinkedList as DLL -import qualified Simulation.Aivika.Vector as V -import qualified Simulation.Aivika.PriorityQueue as PQ - --- | A type synonym for the ordinary FIFO queue also known as the FCFS --- (First Come - First Serviced) queue. -type FCFSQueue a = - Queue FCFS DLL.DoubleLinkedList FCFS DLL.DoubleLinkedList FCFS DLL.DoubleLinkedList a - --- | A type synonym for the ordinary LIFO queue also known as the LCFS --- (Last Come - First Serviced) queue. -type LCFSQueue a = - Queue FCFS DLL.DoubleLinkedList LCFS DLL.DoubleLinkedList FCFS DLL.DoubleLinkedList a - --- | A type synonym for the SIRO (Serviced in Random Order) queue. -type SIROQueue a = - Queue FCFS DLL.DoubleLinkedList SIRO V.Vector FCFS DLL.DoubleLinkedList a - --- | A type synonym for the queue with static priorities applied when --- storing the elements in the queue. -type PriorityQueue a = - Queue FCFS DLL.DoubleLinkedList StaticPriorities PQ.PriorityQueue FCFS DLL.DoubleLinkedList a - --- | Represents a queue using the specified strategies for enqueueing (input), @si@, --- internal storing (in memory), @sm@, and dequeueing (output), @so@, where @a@ denotes --- the type of items stored in the queue. Types @qi@, @qm@ and @qo@ are --- determined automatically and you should not care about them - they --- are dependent types. -data Queue si qi sm qm so qo a = - Queue { queueMaxCount :: Int, - -- ^ The queue capacity. - enqueueStrategy :: si, - -- ^ The strategy applied to the enqueueing (input) processes when the queue is full. - enqueueStoringStrategy :: sm, - -- ^ The strategy applied when storing (in memory) items in the queue. - dequeueStrategy :: so, - -- ^ The strategy applied to the dequeueing (output) processes when the queue is empty. - enqueueRes :: Resource si qi, - queueStore :: qm (QueueItem a), - dequeueRes :: Resource so qo, - queueCountRef :: IORef Int, - queueCountStatsRef :: IORef (TimingStats Int), - enqueueCountRef :: IORef Int, - enqueueLostCountRef :: IORef Int, - enqueueStoreCountRef :: IORef Int, - dequeueCountRef :: IORef Int, - dequeueExtractCountRef :: IORef Int, - queueWaitTimeRef :: IORef (SamplingStats Double), - queueTotalWaitTimeRef :: IORef (SamplingStats Double), - enqueueWaitTimeRef :: IORef (SamplingStats Double), - dequeueWaitTimeRef :: IORef (SamplingStats Double), - enqueueInitiatedSource :: SignalSource a, - enqueueLostSource :: SignalSource a, - enqueueStoredSource :: SignalSource a, - dequeueRequestedSource :: SignalSource (), - dequeueExtractedSource :: SignalSource a } - --- | Stores the item and a time of its enqueuing. -data QueueItem a = - QueueItem { itemValue :: a, - -- ^ Return the item value. - itemInputTime :: Double, - -- ^ Return the time of enqueuing the item. - itemStoringTime :: Double - -- ^ Return the time of storing in the queue, or - -- @itemInputTime@ before the actual storing when - -- the item was just enqueued. - } - --- | Create a new FCFS queue with the specified capacity. -newFCFSQueue :: Int -> Event (FCFSQueue a) -newFCFSQueue = newQueue FCFS FCFS FCFS - --- | Create a new LCFS queue with the specified capacity. -newLCFSQueue :: Int -> Event (LCFSQueue a) -newLCFSQueue = newQueue FCFS LCFS FCFS - --- | Create a new SIRO queue with the specified capacity. -newSIROQueue :: Int -> Event (SIROQueue a) -newSIROQueue = newQueue FCFS SIRO FCFS - --- | Create a new priority queue with the specified capacity. -newPriorityQueue :: Int -> Event (PriorityQueue a) -newPriorityQueue = newQueue FCFS StaticPriorities FCFS - --- | Create a new queue with the specified strategies and capacity. -newQueue :: (QueueStrategy si qi, - QueueStrategy sm qm, - QueueStrategy so qo) => - si - -- ^ the strategy applied to the enqueueing (input) processes when the queue is full - -> sm - -- ^ the strategy applied when storing items in the queue - -> so - -- ^ the strategy applied to the dequeueing (output) processes when the queue is empty - -> Int - -- ^ the queue capacity - -> Event (Queue si qi sm qm so qo a) -newQueue si sm so count = - do t <- liftDynamics time - i <- liftIO $ newIORef 0 - is <- liftIO $ newIORef $ returnTimingStats t 0 - ci <- liftIO $ newIORef 0 - cl <- liftIO $ newIORef 0 - cm <- liftIO $ newIORef 0 - cr <- liftIO $ newIORef 0 - co <- liftIO $ newIORef 0 - ri <- liftSimulation $ newResourceWithMaxCount si count (Just count) - qm <- liftSimulation $ newStrategyQueue sm - ro <- liftSimulation $ newResourceWithMaxCount so 0 (Just count) - w <- liftIO $ newIORef mempty - wt <- liftIO $ newIORef mempty - wi <- liftIO $ newIORef mempty - wo <- liftIO $ newIORef mempty - s1 <- liftSimulation $ newSignalSource - s2 <- liftSimulation $ newSignalSource - s3 <- liftSimulation $ newSignalSource - s4 <- liftSimulation $ newSignalSource - s5 <- liftSimulation $ newSignalSource - return Queue { queueMaxCount = count, - enqueueStrategy = si, - enqueueStoringStrategy = sm, - dequeueStrategy = so, - enqueueRes = ri, - queueStore = qm, - dequeueRes = ro, - queueCountRef = i, - queueCountStatsRef = is, - enqueueCountRef = ci, - enqueueLostCountRef = cl, - enqueueStoreCountRef = cm, - dequeueCountRef = cr, - dequeueExtractCountRef = co, - queueWaitTimeRef = w, - queueTotalWaitTimeRef = wt, - enqueueWaitTimeRef = wi, - dequeueWaitTimeRef = wo, - enqueueInitiatedSource = s1, - enqueueLostSource = s2, - enqueueStoredSource = s3, - dequeueRequestedSource = s4, - dequeueExtractedSource = s5 } - --- | Test whether the queue is empty. --- --- See also 'queueNullChanged' and 'queueNullChanged_'. -queueNull :: Queue si qi sm qm so qo a -> Event Bool -queueNull q = - Event $ \p -> - do n <- readIORef (queueCountRef q) - return (n == 0) - --- | Signal when the 'queueNull' property value has changed. -queueNullChanged :: Queue si qi sm qm so qo a -> Signal Bool -queueNullChanged q = - mapSignalM (const $ queueNull q) (queueNullChanged_ q) - --- | Signal when the 'queueNull' property value has changed. -queueNullChanged_ :: Queue si qi sm qm so qo a -> Signal () -queueNullChanged_ = queueCountChanged_ - --- | Test whether the queue is full. --- --- See also 'queueFullChanged' and 'queueFullChanged_'. -queueFull :: Queue si qi sm qm so qo a -> Event Bool -queueFull q = - Event $ \p -> - do n <- readIORef (queueCountRef q) - return (n == queueMaxCount q) - --- | Signal when the 'queueFull' property value has changed. -queueFullChanged :: Queue si qi sm qm so qo a -> Signal Bool -queueFullChanged q = - mapSignalM (const $ queueFull q) (queueFullChanged_ q) - --- | Signal when the 'queueFull' property value has changed. -queueFullChanged_ :: Queue si qi sm qm so qo a -> Signal () -queueFullChanged_ = queueCountChanged_ - --- | Return the current queue size. --- --- See also 'queueCountStats', 'queueCountChanged' and 'queueCountChanged_'. -queueCount :: Queue si qi sm qm so qo a -> Event Int -queueCount q = - Event $ \p -> readIORef (queueCountRef q) - --- | Return the queue size statistics. -queueCountStats :: Queue si qi sm qm so qo a -> Event (TimingStats Int) -queueCountStats q = - Event $ \p -> readIORef (queueCountStatsRef q) - --- | Signal when the 'queueCount' property value has changed. -queueCountChanged :: Queue si qi sm qm so qo a -> Signal Int -queueCountChanged q = - mapSignalM (const $ queueCount q) (queueCountChanged_ q) - --- | Signal when the 'queueCount' property value has changed. -queueCountChanged_ :: Queue si qi sm qm so qo a -> Signal () -queueCountChanged_ q = - mapSignal (const ()) (enqueueStored q) <> - mapSignal (const ()) (dequeueExtracted q) - --- | Return the total number of input items that were enqueued. --- --- See also 'enqueueCountChanged' and 'enqueueCountChanged_'. -enqueueCount :: Queue si qi sm qm so qo a -> Event Int -enqueueCount q = - Event $ \p -> readIORef (enqueueCountRef q) - --- | Signal when the 'enqueueCount' property value has changed. -enqueueCountChanged :: Queue si qi sm qm so qo a -> Signal Int -enqueueCountChanged q = - mapSignalM (const $ enqueueCount q) (enqueueCountChanged_ q) - --- | Signal when the 'enqueueCount' property value has changed. -enqueueCountChanged_ :: Queue si qi sm qm so qo a -> Signal () -enqueueCountChanged_ q = - mapSignal (const ()) (enqueueInitiated q) - --- | Return the number of lost items. --- --- See also 'enqueueLostCountChanged' and 'enqueueLostCountChanged_'. -enqueueLostCount :: Queue si qi sm qm so qo a -> Event Int -enqueueLostCount q = - Event $ \p -> readIORef (enqueueLostCountRef q) - --- | Signal when the 'enqueueLostCount' property value has changed. -enqueueLostCountChanged :: Queue si qi sm qm so qo a -> Signal Int -enqueueLostCountChanged q = - mapSignalM (const $ enqueueLostCount q) (enqueueLostCountChanged_ q) - --- | Signal when the 'enqueueLostCount' property value has changed. -enqueueLostCountChanged_ :: Queue si qi sm qm so qo a -> Signal () -enqueueLostCountChanged_ q = - mapSignal (const ()) (enqueueLost q) - --- | Return the total number of input items that were stored. --- --- See also 'enqueueStoreCountChanged' and 'enqueueStoreCountChanged_'. -enqueueStoreCount :: Queue si qi sm qm so qo a -> Event Int -enqueueStoreCount q = - Event $ \p -> readIORef (enqueueStoreCountRef q) - --- | Signal when the 'enqueueStoreCount' property value has changed. -enqueueStoreCountChanged :: Queue si qi sm qm so qo a -> Signal Int -enqueueStoreCountChanged q = - mapSignalM (const $ enqueueStoreCount q) (enqueueStoreCountChanged_ q) - --- | Signal when the 'enqueueStoreCount' property value has changed. -enqueueStoreCountChanged_ :: Queue si qi sm qm so qo a -> Signal () -enqueueStoreCountChanged_ q = - mapSignal (const ()) (enqueueStored q) - --- | Return the total number of requests for dequeueing the items, --- not taking into account the failed attempts to dequeue immediately --- without suspension. --- --- See also 'dequeueCountChanged' and 'dequeueCountChanged_'. -dequeueCount :: Queue si qi sm qm so qo a -> Event Int -dequeueCount q = - Event $ \p -> readIORef (dequeueCountRef q) - --- | Signal when the 'dequeueCount' property value has changed. -dequeueCountChanged :: Queue si qi sm qm so qo a -> Signal Int -dequeueCountChanged q = - mapSignalM (const $ dequeueCount q) (dequeueCountChanged_ q) - --- | Signal when the 'dequeueCount' property value has changed. -dequeueCountChanged_ :: Queue si qi sm qm so qo a -> Signal () -dequeueCountChanged_ q = - mapSignal (const ()) (dequeueRequested q) - --- | Return the total number of output items that were actually dequeued. --- --- See also 'dequeueExtractCountChanged' and 'dequeueExtractCountChanged_'. -dequeueExtractCount :: Queue si qi sm qm so qo a -> Event Int -dequeueExtractCount q = - Event $ \p -> readIORef (dequeueExtractCountRef q) - --- | Signal when the 'dequeueExtractCount' property value has changed. -dequeueExtractCountChanged :: Queue si qi sm qm so qo a -> Signal Int -dequeueExtractCountChanged q = - mapSignalM (const $ dequeueExtractCount q) (dequeueExtractCountChanged_ q) - --- | Signal when the 'dequeueExtractCount' property value has changed. -dequeueExtractCountChanged_ :: Queue si qi sm qm so qo a -> Signal () -dequeueExtractCountChanged_ q = - mapSignal (const ()) (dequeueExtracted q) - --- | Return the load factor: the queue size divided by its maximum size. --- --- See also 'queueLoadFactorChanged' and 'queueLoadFactorChanged_'. -queueLoadFactor :: Queue si qi sm qm so qo a -> Event Double -queueLoadFactor q = - Event $ \p -> - do x <- readIORef (queueCountRef q) - let y = queueMaxCount q - return (fromIntegral x / fromIntegral y) - --- | Signal when the 'queueLoadFactor' property value has changed. -queueLoadFactorChanged :: Queue si qi sm qm so qo a -> Signal Double -queueLoadFactorChanged q = - mapSignalM (const $ queueLoadFactor q) (queueLoadFactorChanged_ q) - --- | Signal when the 'queueLoadFactor' property value has changed. -queueLoadFactorChanged_ :: Queue si qi sm qm so qo a -> Signal () -queueLoadFactorChanged_ q = - mapSignal (const ()) (enqueueStored q) <> - mapSignal (const ()) (dequeueExtracted q) - --- | Return the rate of the input items that were enqueued: how many items --- per time. -enqueueRate :: Queue si qi sm qm so qo a -> Event Double -enqueueRate q = - Event $ \p -> - do x <- readIORef (enqueueCountRef q) - let t0 = spcStartTime $ pointSpecs p - t = pointTime p - return (fromIntegral x / (t - t0)) - --- | Return the rate of the items that were stored: how many items --- per time. -enqueueStoreRate :: Queue si qi sm qm so qo a -> Event Double -enqueueStoreRate q = - Event $ \p -> - do x <- readIORef (enqueueStoreCountRef q) - let t0 = spcStartTime $ pointSpecs p - t = pointTime p - return (fromIntegral x / (t - t0)) - --- | Return the rate of the requests for dequeueing the items: how many requests --- per time. It does not include the failed attempts to dequeue immediately --- without suspension. -dequeueRate :: Queue si qi sm qm so qo a -> Event Double -dequeueRate q = - Event $ \p -> - do x <- readIORef (dequeueCountRef q) - let t0 = spcStartTime $ pointSpecs p - t = pointTime p - return (fromIntegral x / (t - t0)) - --- | Return the rate of the output items that were actually dequeued: how many items --- per time. -dequeueExtractRate :: Queue si qi sm qm so qo a -> Event Double -dequeueExtractRate q = - Event $ \p -> - do x <- readIORef (dequeueExtractCountRef q) - let t0 = spcStartTime $ pointSpecs p - t = pointTime p - return (fromIntegral x / (t - t0)) - --- | Return the wait time from the time at which the item was stored in the queue to --- the time at which it was dequeued. --- --- See also 'queueWaitTimeChanged' and 'queueWaitTimeChanged_'. -queueWaitTime :: Queue si qi sm qm so qo a -> Event (SamplingStats Double) -queueWaitTime q = - Event $ \p -> readIORef (queueWaitTimeRef q) - --- | Signal when the 'queueWaitTime' property value has changed. -queueWaitTimeChanged :: Queue si qi sm qm so qo a -> Signal (SamplingStats Double) -queueWaitTimeChanged q = - mapSignalM (const $ queueWaitTime q) (queueWaitTimeChanged_ q) - --- | Signal when the 'queueWaitTime' property value has changed. -queueWaitTimeChanged_ :: Queue si qi sm qm so qo a -> Signal () -queueWaitTimeChanged_ q = - mapSignal (const ()) (dequeueExtracted q) - --- | Return the total wait time from the time at which the enqueueing operation --- was initiated to the time at which the item was dequeued. --- --- In some sense, @queueTotalWaitTime == queueInputWaitTime + queueWaitTime@. --- --- See also 'queueTotalWaitTimeChanged' and 'queueTotalWaitTimeChanged_'. -queueTotalWaitTime :: Queue si qi sm qm so qo a -> Event (SamplingStats Double) -queueTotalWaitTime q = - Event $ \p -> readIORef (queueTotalWaitTimeRef q) - --- | Signal when the 'queueTotalWaitTime' property value has changed. -queueTotalWaitTimeChanged :: Queue si qi sm qm so qo a -> Signal (SamplingStats Double) -queueTotalWaitTimeChanged q = - mapSignalM (const $ queueTotalWaitTime q) (queueTotalWaitTimeChanged_ q) - --- | Signal when the 'queueTotalWaitTime' property value has changed. -queueTotalWaitTimeChanged_ :: Queue si qi sm qm so qo a -> Signal () -queueTotalWaitTimeChanged_ q = - mapSignal (const ()) (dequeueExtracted q) - --- | Return the enqueue wait time from the time at which the enqueueing operation --- was initiated to the time at which the item was stored in the queue. --- --- See also 'enqueueWaitTimeChanged' and 'enqueueWaitTimeChanged_'. -enqueueWaitTime :: Queue si qi sm qm so qo a -> Event (SamplingStats Double) -enqueueWaitTime q = - Event $ \p -> readIORef (enqueueWaitTimeRef q) - --- | Signal when the 'enqueueWaitTime' property value has changed. -enqueueWaitTimeChanged :: Queue si qi sm qm so qo a -> Signal (SamplingStats Double) -enqueueWaitTimeChanged q = - mapSignalM (const $ enqueueWaitTime q) (enqueueWaitTimeChanged_ q) - --- | Signal when the 'enqueueWaitTime' property value has changed. -enqueueWaitTimeChanged_ :: Queue si qi sm qm so qo a -> Signal () -enqueueWaitTimeChanged_ q = - mapSignal (const ()) (enqueueStored q) - --- | Return the dequeue wait time from the time at which the item was requested --- for dequeueing to the time at which it was actually dequeued. --- --- See also 'dequeueWaitTimeChanged' and 'dequeueWaitTimeChanged_'. -dequeueWaitTime :: Queue si qi sm qm so qo a -> Event (SamplingStats Double) -dequeueWaitTime q = - Event $ \p -> readIORef (dequeueWaitTimeRef q) - --- | Signal when the 'dequeueWaitTime' property value has changed. -dequeueWaitTimeChanged :: Queue si qi sm qm so qo a -> Signal (SamplingStats Double) -dequeueWaitTimeChanged q = - mapSignalM (const $ dequeueWaitTime q) (dequeueWaitTimeChanged_ q) - --- | Signal when the 'dequeueWaitTime' property value has changed. -dequeueWaitTimeChanged_ :: Queue si qi sm qm so qo a -> Signal () -dequeueWaitTimeChanged_ q = - mapSignal (const ()) (dequeueExtracted q) - --- | Return a long-term average queue rate calculated as --- the average queue size divided by the average wait time. --- --- This value may be less than the actual arrival rate as the queue is --- finite and new arrivals may be locked while the queue remains full. --- --- See also 'queueRateChanged' and 'queueRateChanged_'. -queueRate :: Queue si qi sm qm so qo a -> Event Double -queueRate q = - Event $ \p -> - do x <- readIORef (queueCountStatsRef q) - y <- readIORef (queueWaitTimeRef q) - return (timingStatsMean x / samplingStatsMean y) - --- | Signal when the 'queueRate' property value has changed. -queueRateChanged :: Queue si qi sm qm so qo a -> Signal Double -queueRateChanged q = - mapSignalM (const $ queueRate q) (queueRateChanged_ q) - --- | Signal when the 'queueRate' property value has changed. -queueRateChanged_ :: Queue si qi sm qm so qo a -> Signal () -queueRateChanged_ q = - mapSignal (const ()) (enqueueStored q) <> - mapSignal (const ()) (dequeueExtracted q) - --- | Dequeue suspending the process if the queue is empty. -dequeue :: (DequeueStrategy si qi, - DequeueStrategy sm qm, - EnqueueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> Process a - -- ^ the dequeued value -dequeue q = - do t <- liftEvent $ dequeueRequest q - requestResource (dequeueRes q) - liftEvent $ dequeueExtract q t - --- | Dequeue with the output priority suspending the process if the queue is empty. -dequeueWithOutputPriority :: (DequeueStrategy si qi, - DequeueStrategy sm qm, - PriorityQueueStrategy so qo po) - => Queue si qi sm qm so qo a - -- ^ the queue - -> po - -- ^ the priority for output - -> Process a - -- ^ the dequeued value -dequeueWithOutputPriority q po = - do t <- liftEvent $ dequeueRequest q - requestResourceWithPriority (dequeueRes q) po - liftEvent $ dequeueExtract q t - --- | Try to dequeue immediately. -tryDequeue :: (DequeueStrategy si qi, - DequeueStrategy sm qm) - => Queue si qi sm qm so qo a - -- ^ the queue - -> Event (Maybe a) - -- ^ the dequeued value of 'Nothing' -tryDequeue q = - do x <- tryRequestResourceWithinEvent (dequeueRes q) - if x - then do t <- dequeueRequest q - fmap Just $ dequeueExtract q t - else return Nothing - --- | Enqueue the item suspending the process if the queue is full. -enqueue :: (EnqueueStrategy si qi, - EnqueueStrategy sm qm, - DequeueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> a - -- ^ the item to enqueue - -> Process () -enqueue q a = - do i <- liftEvent $ enqueueInitiate q a - requestResource (enqueueRes q) - liftEvent $ enqueueStore q i - --- | Enqueue with the input priority the item suspending the process if the queue is full. -enqueueWithInputPriority :: (PriorityQueueStrategy si qi pi, - EnqueueStrategy sm qm, - DequeueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> pi - -- ^ the priority for input - -> a - -- ^ the item to enqueue - -> Process () -enqueueWithInputPriority q pi a = - do i <- liftEvent $ enqueueInitiate q a - requestResourceWithPriority (enqueueRes q) pi - liftEvent $ enqueueStore q i - --- | Enqueue with the storing priority the item suspending the process if the queue is full. -enqueueWithStoringPriority :: (EnqueueStrategy si qi, - PriorityQueueStrategy sm qm pm, - DequeueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> pm - -- ^ the priority for storing - -> a - -- ^ the item to enqueue - -> Process () -enqueueWithStoringPriority q pm a = - do i <- liftEvent $ enqueueInitiate q a - requestResource (enqueueRes q) - liftEvent $ enqueueStoreWithPriority q pm i - --- | Enqueue with the input and storing priorities the item suspending the process if the queue is full. -enqueueWithInputStoringPriorities :: (PriorityQueueStrategy si qi pi, - PriorityQueueStrategy sm qm pm, - DequeueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> pi - -- ^ the priority for input - -> pm - -- ^ the priority for storing - -> a - -- ^ the item to enqueue - -> Process () -enqueueWithInputStoringPriorities q pi pm a = - do i <- liftEvent $ enqueueInitiate q a - requestResourceWithPriority (enqueueRes q) pi - liftEvent $ enqueueStoreWithPriority q pm i - --- | Try to enqueue the item. Return 'False' in the monad if the queue is full. -tryEnqueue :: (EnqueueStrategy sm qm, - DequeueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> a - -- ^ the item which we try to enqueue - -> Event Bool -tryEnqueue q a = - do x <- tryRequestResourceWithinEvent (enqueueRes q) - if x - then do enqueueInitiate q a >>= enqueueStore q - return True - else return False - --- | Try to enqueue with the storing priority the item. Return 'False' in --- the monad if the queue is full. -tryEnqueueWithStoringPriority :: (PriorityQueueStrategy sm qm pm, - DequeueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> pm - -- ^ the priority for storing - -> a - -- ^ the item which we try to enqueue - -> Event Bool -tryEnqueueWithStoringPriority q pm a = - do x <- tryRequestResourceWithinEvent (enqueueRes q) - if x - then do enqueueInitiate q a >>= enqueueStoreWithPriority q pm - return True - else return False - --- | Try to enqueue the item. If the queue is full then the item will be lost --- and 'False' will be returned. -enqueueOrLost :: (EnqueueStrategy sm qm, - DequeueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> a - -- ^ the item which we try to enqueue - -> Event Bool -enqueueOrLost q a = - do x <- tryRequestResourceWithinEvent (enqueueRes q) - if x - then do enqueueInitiate q a >>= enqueueStore q - return True - else do enqueueDeny q a - return False - --- | Try to enqueue with the storing priority the item. If the queue is full --- then the item will be lost and 'False' will be returned. -enqueueWithStoringPriorityOrLost :: (PriorityQueueStrategy sm qm pm, - DequeueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> pm - -- ^ the priority for storing - -> a - -- ^ the item which we try to enqueue - -> Event Bool -enqueueWithStoringPriorityOrLost q pm a = - do x <- tryRequestResourceWithinEvent (enqueueRes q) - if x - then do enqueueInitiate q a >>= enqueueStoreWithPriority q pm - return True - else do enqueueDeny q a - return False - --- | Try to enqueue the item. If the queue is full then the item will be lost. -enqueueOrLost_ :: (EnqueueStrategy sm qm, - DequeueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> a - -- ^ the item which we try to enqueue - -> Event () -enqueueOrLost_ q a = - do x <- enqueueOrLost q a - return () - --- | Try to enqueue with the storing priority the item. If the queue is full --- then the item will be lost. -enqueueWithStoringPriorityOrLost_ :: (PriorityQueueStrategy sm qm pm, - DequeueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> pm - -- ^ the priority for storing - -> a - -- ^ the item which we try to enqueue - -> Event () -enqueueWithStoringPriorityOrLost_ q pm a = - do x <- enqueueWithStoringPriorityOrLost q pm a - return () - --- | Return a signal that notifies when the enqueuing operation is initiated. -enqueueInitiated :: Queue si qi sm qm so qo a -> Signal a -enqueueInitiated q = publishSignal (enqueueInitiatedSource q) - --- | Return a signal that notifies when the enqueuing operation is completed --- and the item is stored in the internal memory of the queue. -enqueueStored :: Queue si qi sm qm so qo a -> Signal a -enqueueStored q = publishSignal (enqueueStoredSource q) - --- | Return a signal which notifies that the item was lost when --- attempting to add it to the full queue with help of --- 'enqueueOrLost', 'enqueueOrLost_' or similar functions that imply --- that the element can be lost. All their names are ending with @OrLost@ --- or @OrLost_@. --- --- In other cases the enqueued items are not lost but the corresponded process --- can suspend until the internal queue storage is freed. Although there is one --- exception from this rule. If the process trying to enqueue a new element was --- suspended but then canceled through 'cancelProcess' from the outside then --- the item will not be added. -enqueueLost :: Queue si qi sm qm so qo a -> Signal a -enqueueLost q = publishSignal (enqueueLostSource q) - --- | Return a signal that notifies when the dequeuing operation was requested. -dequeueRequested :: Queue si qi sm qm so qo a -> Signal () -dequeueRequested q = publishSignal (dequeueRequestedSource q) - --- | Return a signal that notifies when the item was extracted from the internal --- storage of the queue and prepared for immediate receiving by the dequeuing process. -dequeueExtracted :: Queue si qi sm qm so qo a -> Signal a -dequeueExtracted q = publishSignal (dequeueExtractedSource q) - --- | Initiate the process of enqueuing the item. -enqueueInitiate :: Queue si qi sm qm so qo a - -- ^ the queue - -> a - -- ^ the item to be enqueued - -> Event (QueueItem a) -enqueueInitiate q a = - Event $ \p -> - do let t = pointTime p - modifyIORef' (enqueueCountRef q) (+ 1) - invokeEvent p $ - triggerSignal (enqueueInitiatedSource q) a - return QueueItem { itemValue = a, - itemInputTime = t, - itemStoringTime = t -- it will be updated soon - } - --- | Store the item. -enqueueStore :: (EnqueueStrategy sm qm, - DequeueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> QueueItem a - -- ^ the item to be stored - -> Event () -enqueueStore q i = - Event $ \p -> - do let i' = i { itemStoringTime = pointTime p } -- now we have the actual time of storing - invokeEvent p $ - strategyEnqueue (enqueueStoringStrategy q) (queueStore q) i' - c <- readIORef (queueCountRef q) - let c' = c + 1 - t = pointTime p - c' `seq` writeIORef (queueCountRef q) c' - modifyIORef' (queueCountStatsRef q) (addTimingStats t c') - modifyIORef' (enqueueStoreCountRef q) (+ 1) - invokeEvent p $ - enqueueStat q i' - invokeEvent p $ - releaseResourceWithinEvent (dequeueRes q) - invokeEvent p $ - triggerSignal (enqueueStoredSource q) (itemValue i') - --- | Store with the priority the item. -enqueueStoreWithPriority :: (PriorityQueueStrategy sm qm pm, - DequeueStrategy so qo) - => Queue si qi sm qm so qo a - -- ^ the queue - -> pm - -- ^ the priority for storing - -> QueueItem a - -- ^ the item to be enqueued - -> Event () -enqueueStoreWithPriority q pm i = - Event $ \p -> - do let i' = i { itemStoringTime = pointTime p } -- now we have the actual time of storing - invokeEvent p $ - strategyEnqueueWithPriority (enqueueStoringStrategy q) (queueStore q) pm i' - c <- readIORef (queueCountRef q) - let c' = c + 1 - t = pointTime p - c' `seq` writeIORef (queueCountRef q) c' - modifyIORef' (queueCountStatsRef q) (addTimingStats t c') - modifyIORef' (enqueueStoreCountRef q) (+ 1) - invokeEvent p $ - enqueueStat q i' - invokeEvent p $ - releaseResourceWithinEvent (dequeueRes q) - invokeEvent p $ - triggerSignal (enqueueStoredSource q) (itemValue i') - --- | Deny the enqueuing. -enqueueDeny :: Queue si qi sm qm so qo a - -- ^ the queue - -> a - -- ^ the item to be denied - -> Event () -enqueueDeny q a = - Event $ \p -> - do modifyIORef' (enqueueLostCountRef q) $ (+) 1 - invokeEvent p $ - triggerSignal (enqueueLostSource q) a - --- | Update the statistics for the input wait time of the enqueuing operation. -enqueueStat :: Queue si qi sm qm so qo a - -- ^ the queue - -> QueueItem a - -- ^ the item and its input time - -> Event () - -- ^ the action of updating the statistics -enqueueStat q i = - Event $ \p -> - do let t0 = itemInputTime i - t1 = itemStoringTime i - modifyIORef' (enqueueWaitTimeRef q) $ - addSamplingStats (t1 - t0) - --- | Accept the dequeuing request and return the current simulation time. -dequeueRequest :: Queue si qi sm qm so qo a - -- ^ the queue - -> Event Double - -- ^ the current time -dequeueRequest q = - Event $ \p -> - do modifyIORef' (dequeueCountRef q) (+ 1) - invokeEvent p $ - triggerSignal (dequeueRequestedSource q) () - return $ pointTime p - --- | Extract an item for the dequeuing request. -dequeueExtract :: (DequeueStrategy si qi, - DequeueStrategy sm qm) - => Queue si qi sm qm so qo a - -- ^ the queue - -> Double - -- ^ the time of the dequeuing request - -> Event a - -- ^ the dequeued value -dequeueExtract q t' = - Event $ \p -> - do i <- invokeEvent p $ - strategyDequeue (enqueueStoringStrategy q) (queueStore q) - c <- readIORef (queueCountRef q) - let c' = c - 1 - t = pointTime p - c' `seq` writeIORef (queueCountRef q) c' - modifyIORef' (queueCountStatsRef q) (addTimingStats t c') - modifyIORef' (dequeueExtractCountRef q) (+ 1) - invokeEvent p $ - dequeueStat q t' i - invokeEvent p $ - releaseResourceWithinEvent (enqueueRes q) - invokeEvent p $ - triggerSignal (dequeueExtractedSource q) (itemValue i) - return $ itemValue i - --- | Update the statistics for the output wait time of the dequeuing operation --- and the wait time of storing in the queue. -dequeueStat :: Queue si qi sm qm so qo a - -- ^ the queue - -> Double - -- ^ the time of the dequeuing request - -> QueueItem a - -- ^ the item and its input time - -> Event () - -- ^ the action of updating the statistics -dequeueStat q t' i = - Event $ \p -> - do let t0 = itemInputTime i - t1 = itemStoringTime i - t = pointTime p - modifyIORef' (dequeueWaitTimeRef q) $ - addSamplingStats (t - t') - modifyIORef' (queueTotalWaitTimeRef q) $ - addSamplingStats (t - t0) - modifyIORef' (queueWaitTimeRef q) $ - addSamplingStats (t - t1) - --- | Wait while the queue is full. -waitWhileFullQueue :: Queue si qi sm qm so qo a -> Process () -waitWhileFullQueue q = - do x <- liftEvent (queueFull q) - when x $ - do processAwait (dequeueExtracted q) - waitWhileFullQueue q - --- | Signal whenever any property of the queue changes. --- --- The property must have the corresponded signal. There are also characteristics --- similar to the properties but that have no signals. As a rule, such characteristics --- already depend on the simulation time and therefore they may change at any --- time point. -queueChanged_ :: Queue si qi sm qm so qo a -> Signal () -queueChanged_ q = - mapSignal (const ()) (enqueueInitiated q) <> - mapSignal (const ()) (enqueueStored q) <> - mapSignal (const ()) (enqueueLost q) <> - dequeueRequested q <> - mapSignal (const ()) (dequeueExtracted q) - --- | Return the summary for the queue with desciption of its --- properties and activities using the specified indent. -queueSummary :: (Show si, Show sm, Show so) => Queue si qi sm qm so qo a -> Int -> Event ShowS -queueSummary q indent = - do let si = enqueueStrategy q - sm = enqueueStoringStrategy q - so = dequeueStrategy q - null <- queueNull q - full <- queueFull q - let maxCount = queueMaxCount q - count <- queueCount q - countStats <- queueCountStats q - enqueueCount <- enqueueCount q - enqueueLostCount <- enqueueLostCount q - enqueueStoreCount <- enqueueStoreCount q - dequeueCount <- dequeueCount q - dequeueExtractCount <- dequeueExtractCount q - loadFactor <- queueLoadFactor q - enqueueRate <- enqueueRate q - enqueueStoreRate <- enqueueStoreRate q - dequeueRate <- dequeueRate q - dequeueExtractRate <- dequeueExtractRate q - waitTime <- queueWaitTime q - totalWaitTime <- queueTotalWaitTime q - enqueueWaitTime <- enqueueWaitTime q - dequeueWaitTime <- dequeueWaitTime q - let tab = replicate indent ' ' - return $ - showString tab . - showString "the enqueueing (input) strategy = " . - shows si . - showString "\n" . - showString tab . - showString "the storing (memory) strategy = " . - shows sm . - showString "\n" . - showString tab . - showString "the dequeueing (output) strategy = " . - shows so . - showString "\n" . - showString tab . - showString "empty? = " . - shows null . - showString "\n" . - showString tab . - showString "full? = " . - shows full . - showString "\n" . - showString tab . - showString "max. capacity = " . - shows maxCount . - showString "\n" . - showString tab . - showString "size = " . - shows count . - showString "\n" . - showString tab . - showString "the size statistics = \n\n" . - timingStatsSummary countStats (2 + indent) . - showString "\n\n" . - showString tab . - showString "the enqueue count (number of the input items that were enqueued) = " . - shows enqueueCount . - showString "\n" . - showString tab . - showString "the enqueue lost count (number of the lost items) = " . - shows enqueueLostCount . - showString "\n" . - showString tab . - showString "the enqueue store count (number of the input items that were stored) = " . - shows enqueueStoreCount . - showString "\n" . - showString tab . - showString "the dequeue count (number of requests for dequeueing an item) = " . - shows dequeueCount . - showString "\n" . - showString tab . - showString "the dequeue extract count (number of the output items that were dequeued) = " . - shows dequeueExtractCount . - showString "\n" . - showString tab . - showString "the load factor (size / max. capacity) = " . - shows loadFactor . - showString "\n" . - showString tab . - showString "the enqueue rate (how many input items were enqueued per time) = " . - shows enqueueRate . - showString "\n" . - showString tab . - showString "the enqueue store rate (how many input items were stored per time) = " . - shows enqueueStoreRate . - showString "\n" . - showString tab . - showString "the dequeue rate (how many requests for dequeueing per time) = " . - shows dequeueRate . - showString "\n" . - showString tab . - showString "the dequeue extract rate (how many output items were dequeued per time) = " . - shows dequeueExtractRate . - showString "\n" . - showString tab . - showString "the wait time (when was stored -> when was dequeued) = \n\n" . - samplingStatsSummary waitTime (2 + indent) . - showString "\n\n" . - showString tab . - showString "the total wait time (when the enqueueing was initiated -> when was dequeued) = \n\n" . - samplingStatsSummary totalWaitTime (2 + indent) . - showString "\n\n" . - showString tab . - showString "the enqueue wait time (when the enqueueing was initiated -> when was stored) = \n\n" . - samplingStatsSummary enqueueWaitTime (2 + indent) . - showString "\n\n" . - showString tab . - showString "the dequeue wait time (when was requested for dequeueing -> when was dequeued) = \n\n" . - samplingStatsSummary dequeueWaitTime (2 + indent) + +-- | +-- Module : Simulation.Aivika.Queue +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines a queue that can use the specified strategies. So, having only +-- the 'FCFS', 'LCFS', 'SIRO' and 'StaticPriorities' strategies, you can build +-- 4 x 4 x 4 = 64 different types of the queue, each of them will have its own +-- behaviour. +-- +module Simulation.Aivika.Queue + (-- * Queue Types + FCFSQueue, + LCFSQueue, + SIROQueue, + PriorityQueue, + Queue, + -- * Creating Queue + newFCFSQueue, + newLCFSQueue, + newSIROQueue, + newPriorityQueue, + newQueue, + -- * Queue Properties and Activities + enqueueStrategy, + enqueueStoringStrategy, + dequeueStrategy, + queueNull, + queueFull, + queueMaxCount, + queueCount, + queueCountStats, + enqueueCount, + enqueueLostCount, + enqueueStoreCount, + dequeueCount, + dequeueExtractCount, + queueLoadFactor, + enqueueRate, + enqueueStoreRate, + dequeueRate, + dequeueExtractRate, + queueWaitTime, + queueTotalWaitTime, + enqueueWaitTime, + dequeueWaitTime, + queueRate, + -- * Dequeuing and Enqueuing + dequeue, + dequeueWithOutputPriority, + tryDequeue, + enqueue, + enqueueWithInputPriority, + enqueueWithStoringPriority, + enqueueWithInputStoringPriorities, + tryEnqueue, + tryEnqueueWithStoringPriority, + enqueueOrLost, + enqueueOrLost_, + enqueueWithStoringPriorityOrLost, + enqueueWithStoringPriorityOrLost_, + -- * Awaiting + waitWhileFullQueue, + -- * Summary + queueSummary, + -- * Derived Signals for Properties + queueNullChanged, + queueNullChanged_, + queueFullChanged, + queueFullChanged_, + queueCountChanged, + queueCountChanged_, + enqueueCountChanged, + enqueueCountChanged_, + enqueueLostCountChanged, + enqueueLostCountChanged_, + enqueueStoreCountChanged, + enqueueStoreCountChanged_, + dequeueCountChanged, + dequeueCountChanged_, + dequeueExtractCountChanged, + dequeueExtractCountChanged_, + queueLoadFactorChanged, + queueLoadFactorChanged_, + queueWaitTimeChanged, + queueWaitTimeChanged_, + queueTotalWaitTimeChanged, + queueTotalWaitTimeChanged_, + enqueueWaitTimeChanged, + enqueueWaitTimeChanged_, + dequeueWaitTimeChanged, + dequeueWaitTimeChanged_, + queueRateChanged, + queueRateChanged_, + -- * Basic Signals + enqueueInitiated, + enqueueStored, + enqueueLost, + dequeueRequested, + dequeueExtracted, + -- * Overall Signal + queueChanged_) where + +import Data.IORef +import Data.Monoid + +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.Internal.Event +import Simulation.Aivika.Internal.Process +import Simulation.Aivika.Internal.Signal +import Simulation.Aivika.Signal +import Simulation.Aivika.Resource +import Simulation.Aivika.QueueStrategy +import Simulation.Aivika.Statistics + +import qualified Simulation.Aivika.DoubleLinkedList as DLL +import qualified Simulation.Aivika.Vector as V +import qualified Simulation.Aivika.PriorityQueue as PQ + +-- | A type synonym for the ordinary FIFO queue also known as the FCFS +-- (First Come - First Serviced) queue. +type FCFSQueue a = Queue FCFS FCFS FCFS a + +-- | A type synonym for the ordinary LIFO queue also known as the LCFS +-- (Last Come - First Serviced) queue. +type LCFSQueue a = Queue FCFS LCFS FCFS a + +-- | A type synonym for the SIRO (Serviced in Random Order) queue. +type SIROQueue a = Queue FCFS SIRO FCFS a + +-- | A type synonym for the queue with static priorities applied when +-- storing the elements in the queue. +type PriorityQueue a = Queue FCFS StaticPriorities FCFS a + +-- | Represents a queue using the specified strategies for enqueueing (input), @si@, +-- internal storing (in memory), @sm@, and dequeueing (output), @so@, where @a@ denotes +-- the type of items stored in the queue. +data Queue si sm so a = + Queue { queueMaxCount :: Int, + -- ^ The queue capacity. + enqueueStrategy :: si, + -- ^ The strategy applied to the enqueueing (input) processes when the queue is full. + enqueueStoringStrategy :: sm, + -- ^ The strategy applied when storing (in memory) items in the queue. + dequeueStrategy :: so, + -- ^ The strategy applied to the dequeueing (output) processes when the queue is empty. + enqueueRes :: Resource si, + queueStore :: StrategyQueue sm (QueueItem a), + dequeueRes :: Resource so, + queueCountRef :: IORef Int, + queueCountStatsRef :: IORef (TimingStats Int), + enqueueCountRef :: IORef Int, + enqueueLostCountRef :: IORef Int, + enqueueStoreCountRef :: IORef Int, + dequeueCountRef :: IORef Int, + dequeueExtractCountRef :: IORef Int, + queueWaitTimeRef :: IORef (SamplingStats Double), + queueTotalWaitTimeRef :: IORef (SamplingStats Double), + enqueueWaitTimeRef :: IORef (SamplingStats Double), + dequeueWaitTimeRef :: IORef (SamplingStats Double), + enqueueInitiatedSource :: SignalSource a, + enqueueLostSource :: SignalSource a, + enqueueStoredSource :: SignalSource a, + dequeueRequestedSource :: SignalSource (), + dequeueExtractedSource :: SignalSource a } + +-- | Stores the item and a time of its enqueuing. +data QueueItem a = + QueueItem { itemValue :: a, + -- ^ Return the item value. + itemInputTime :: Double, + -- ^ Return the time of enqueuing the item. + itemStoringTime :: Double + -- ^ Return the time of storing in the queue, or + -- @itemInputTime@ before the actual storing when + -- the item was just enqueued. + } + +-- | Create a new FCFS queue with the specified capacity. +newFCFSQueue :: Int -> Event (FCFSQueue a) +newFCFSQueue = newQueue FCFS FCFS FCFS + +-- | Create a new LCFS queue with the specified capacity. +newLCFSQueue :: Int -> Event (LCFSQueue a) +newLCFSQueue = newQueue FCFS LCFS FCFS + +-- | Create a new SIRO queue with the specified capacity. +newSIROQueue :: Int -> Event (SIROQueue a) +newSIROQueue = newQueue FCFS SIRO FCFS + +-- | Create a new priority queue with the specified capacity. +newPriorityQueue :: Int -> Event (PriorityQueue a) +newPriorityQueue = newQueue FCFS StaticPriorities FCFS + +-- | Create a new queue with the specified strategies and capacity. +newQueue :: (QueueStrategy si, + QueueStrategy sm, + QueueStrategy so) => + si + -- ^ the strategy applied to the enqueueing (input) processes when the queue is full + -> sm + -- ^ the strategy applied when storing items in the queue + -> so + -- ^ the strategy applied to the dequeueing (output) processes when the queue is empty + -> Int + -- ^ the queue capacity + -> Event (Queue si sm so a) +newQueue si sm so count = + do t <- liftDynamics time + i <- liftIO $ newIORef 0 + is <- liftIO $ newIORef $ returnTimingStats t 0 + ci <- liftIO $ newIORef 0 + cl <- liftIO $ newIORef 0 + cm <- liftIO $ newIORef 0 + cr <- liftIO $ newIORef 0 + co <- liftIO $ newIORef 0 + ri <- liftSimulation $ newResourceWithMaxCount si count (Just count) + qm <- liftSimulation $ newStrategyQueue sm + ro <- liftSimulation $ newResourceWithMaxCount so 0 (Just count) + w <- liftIO $ newIORef mempty + wt <- liftIO $ newIORef mempty + wi <- liftIO $ newIORef mempty + wo <- liftIO $ newIORef mempty + s1 <- liftSimulation $ newSignalSource + s2 <- liftSimulation $ newSignalSource + s3 <- liftSimulation $ newSignalSource + s4 <- liftSimulation $ newSignalSource + s5 <- liftSimulation $ newSignalSource + return Queue { queueMaxCount = count, + enqueueStrategy = si, + enqueueStoringStrategy = sm, + dequeueStrategy = so, + enqueueRes = ri, + queueStore = qm, + dequeueRes = ro, + queueCountRef = i, + queueCountStatsRef = is, + enqueueCountRef = ci, + enqueueLostCountRef = cl, + enqueueStoreCountRef = cm, + dequeueCountRef = cr, + dequeueExtractCountRef = co, + queueWaitTimeRef = w, + queueTotalWaitTimeRef = wt, + enqueueWaitTimeRef = wi, + dequeueWaitTimeRef = wo, + enqueueInitiatedSource = s1, + enqueueLostSource = s2, + enqueueStoredSource = s3, + dequeueRequestedSource = s4, + dequeueExtractedSource = s5 } + +-- | Test whether the queue is empty. +-- +-- See also 'queueNullChanged' and 'queueNullChanged_'. +queueNull :: Queue si sm so a -> Event Bool +queueNull q = + Event $ \p -> + do n <- readIORef (queueCountRef q) + return (n == 0) + +-- | Signal when the 'queueNull' property value has changed. +queueNullChanged :: Queue si sm so a -> Signal Bool +queueNullChanged q = + mapSignalM (const $ queueNull q) (queueNullChanged_ q) + +-- | Signal when the 'queueNull' property value has changed. +queueNullChanged_ :: Queue si sm so a -> Signal () +queueNullChanged_ = queueCountChanged_ + +-- | Test whether the queue is full. +-- +-- See also 'queueFullChanged' and 'queueFullChanged_'. +queueFull :: Queue si sm so a -> Event Bool +queueFull q = + Event $ \p -> + do n <- readIORef (queueCountRef q) + return (n == queueMaxCount q) + +-- | Signal when the 'queueFull' property value has changed. +queueFullChanged :: Queue si sm so a -> Signal Bool +queueFullChanged q = + mapSignalM (const $ queueFull q) (queueFullChanged_ q) + +-- | Signal when the 'queueFull' property value has changed. +queueFullChanged_ :: Queue si sm so a -> Signal () +queueFullChanged_ = queueCountChanged_ + +-- | Return the current queue size. +-- +-- See also 'queueCountStats', 'queueCountChanged' and 'queueCountChanged_'. +queueCount :: Queue si sm so a -> Event Int +queueCount q = + Event $ \p -> readIORef (queueCountRef q) + +-- | Return the queue size statistics. +queueCountStats :: Queue si sm so a -> Event (TimingStats Int) +queueCountStats q = + Event $ \p -> readIORef (queueCountStatsRef q) + +-- | Signal when the 'queueCount' property value has changed. +queueCountChanged :: Queue si sm so a -> Signal Int +queueCountChanged q = + mapSignalM (const $ queueCount q) (queueCountChanged_ q) + +-- | Signal when the 'queueCount' property value has changed. +queueCountChanged_ :: Queue si sm so a -> Signal () +queueCountChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the total number of input items that were enqueued. +-- +-- See also 'enqueueCountChanged' and 'enqueueCountChanged_'. +enqueueCount :: Queue si sm so a -> Event Int +enqueueCount q = + Event $ \p -> readIORef (enqueueCountRef q) + +-- | Signal when the 'enqueueCount' property value has changed. +enqueueCountChanged :: Queue si sm so a -> Signal Int +enqueueCountChanged q = + mapSignalM (const $ enqueueCount q) (enqueueCountChanged_ q) + +-- | Signal when the 'enqueueCount' property value has changed. +enqueueCountChanged_ :: Queue si sm so a -> Signal () +enqueueCountChanged_ q = + mapSignal (const ()) (enqueueInitiated q) + +-- | Return the number of lost items. +-- +-- See also 'enqueueLostCountChanged' and 'enqueueLostCountChanged_'. +enqueueLostCount :: Queue si sm so a -> Event Int +enqueueLostCount q = + Event $ \p -> readIORef (enqueueLostCountRef q) + +-- | Signal when the 'enqueueLostCount' property value has changed. +enqueueLostCountChanged :: Queue si sm so a -> Signal Int +enqueueLostCountChanged q = + mapSignalM (const $ enqueueLostCount q) (enqueueLostCountChanged_ q) + +-- | Signal when the 'enqueueLostCount' property value has changed. +enqueueLostCountChanged_ :: Queue si sm so a -> Signal () +enqueueLostCountChanged_ q = + mapSignal (const ()) (enqueueLost q) + +-- | Return the total number of input items that were stored. +-- +-- See also 'enqueueStoreCountChanged' and 'enqueueStoreCountChanged_'. +enqueueStoreCount :: Queue si sm so a -> Event Int +enqueueStoreCount q = + Event $ \p -> readIORef (enqueueStoreCountRef q) + +-- | Signal when the 'enqueueStoreCount' property value has changed. +enqueueStoreCountChanged :: Queue si sm so a -> Signal Int +enqueueStoreCountChanged q = + mapSignalM (const $ enqueueStoreCount q) (enqueueStoreCountChanged_ q) + +-- | Signal when the 'enqueueStoreCount' property value has changed. +enqueueStoreCountChanged_ :: Queue si sm so a -> Signal () +enqueueStoreCountChanged_ q = + mapSignal (const ()) (enqueueStored q) + +-- | Return the total number of requests for dequeueing the items, +-- not taking into account the failed attempts to dequeue immediately +-- without suspension. +-- +-- See also 'dequeueCountChanged' and 'dequeueCountChanged_'. +dequeueCount :: Queue si sm so a -> Event Int +dequeueCount q = + Event $ \p -> readIORef (dequeueCountRef q) + +-- | Signal when the 'dequeueCount' property value has changed. +dequeueCountChanged :: Queue si sm so a -> Signal Int +dequeueCountChanged q = + mapSignalM (const $ dequeueCount q) (dequeueCountChanged_ q) + +-- | Signal when the 'dequeueCount' property value has changed. +dequeueCountChanged_ :: Queue si sm so a -> Signal () +dequeueCountChanged_ q = + mapSignal (const ()) (dequeueRequested q) + +-- | Return the total number of output items that were actually dequeued. +-- +-- See also 'dequeueExtractCountChanged' and 'dequeueExtractCountChanged_'. +dequeueExtractCount :: Queue si sm so a -> Event Int +dequeueExtractCount q = + Event $ \p -> readIORef (dequeueExtractCountRef q) + +-- | Signal when the 'dequeueExtractCount' property value has changed. +dequeueExtractCountChanged :: Queue si sm so a -> Signal Int +dequeueExtractCountChanged q = + mapSignalM (const $ dequeueExtractCount q) (dequeueExtractCountChanged_ q) + +-- | Signal when the 'dequeueExtractCount' property value has changed. +dequeueExtractCountChanged_ :: Queue si sm so a -> Signal () +dequeueExtractCountChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the load factor: the queue size divided by its maximum size. +-- +-- See also 'queueLoadFactorChanged' and 'queueLoadFactorChanged_'. +queueLoadFactor :: Queue si sm so a -> Event Double +queueLoadFactor q = + Event $ \p -> + do x <- readIORef (queueCountRef q) + let y = queueMaxCount q + return (fromIntegral x / fromIntegral y) + +-- | Signal when the 'queueLoadFactor' property value has changed. +queueLoadFactorChanged :: Queue si sm so a -> Signal Double +queueLoadFactorChanged q = + mapSignalM (const $ queueLoadFactor q) (queueLoadFactorChanged_ q) + +-- | Signal when the 'queueLoadFactor' property value has changed. +queueLoadFactorChanged_ :: Queue si sm so a -> Signal () +queueLoadFactorChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the rate of the input items that were enqueued: how many items +-- per time. +enqueueRate :: Queue si sm so a -> Event Double +enqueueRate q = + Event $ \p -> + do x <- readIORef (enqueueCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the rate of the items that were stored: how many items +-- per time. +enqueueStoreRate :: Queue si sm so a -> Event Double +enqueueStoreRate q = + Event $ \p -> + do x <- readIORef (enqueueStoreCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the rate of the requests for dequeueing the items: how many requests +-- per time. It does not include the failed attempts to dequeue immediately +-- without suspension. +dequeueRate :: Queue si sm so a -> Event Double +dequeueRate q = + Event $ \p -> + do x <- readIORef (dequeueCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the rate of the output items that were actually dequeued: how many items +-- per time. +dequeueExtractRate :: Queue si sm so a -> Event Double +dequeueExtractRate q = + Event $ \p -> + do x <- readIORef (dequeueExtractCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the wait time from the time at which the item was stored in the queue to +-- the time at which it was dequeued. +-- +-- See also 'queueWaitTimeChanged' and 'queueWaitTimeChanged_'. +queueWaitTime :: Queue si sm so a -> Event (SamplingStats Double) +queueWaitTime q = + Event $ \p -> readIORef (queueWaitTimeRef q) + +-- | Signal when the 'queueWaitTime' property value has changed. +queueWaitTimeChanged :: Queue si sm so a -> Signal (SamplingStats Double) +queueWaitTimeChanged q = + mapSignalM (const $ queueWaitTime q) (queueWaitTimeChanged_ q) + +-- | Signal when the 'queueWaitTime' property value has changed. +queueWaitTimeChanged_ :: Queue si sm so a -> Signal () +queueWaitTimeChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the total wait time from the time at which the enqueueing operation +-- was initiated to the time at which the item was dequeued. +-- +-- In some sense, @queueTotalWaitTime == queueInputWaitTime + queueWaitTime@. +-- +-- See also 'queueTotalWaitTimeChanged' and 'queueTotalWaitTimeChanged_'. +queueTotalWaitTime :: Queue si sm so a -> Event (SamplingStats Double) +queueTotalWaitTime q = + Event $ \p -> readIORef (queueTotalWaitTimeRef q) + +-- | Signal when the 'queueTotalWaitTime' property value has changed. +queueTotalWaitTimeChanged :: Queue si sm so a -> Signal (SamplingStats Double) +queueTotalWaitTimeChanged q = + mapSignalM (const $ queueTotalWaitTime q) (queueTotalWaitTimeChanged_ q) + +-- | Signal when the 'queueTotalWaitTime' property value has changed. +queueTotalWaitTimeChanged_ :: Queue si sm so a -> Signal () +queueTotalWaitTimeChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the enqueue wait time from the time at which the enqueueing operation +-- was initiated to the time at which the item was stored in the queue. +-- +-- See also 'enqueueWaitTimeChanged' and 'enqueueWaitTimeChanged_'. +enqueueWaitTime :: Queue si sm so a -> Event (SamplingStats Double) +enqueueWaitTime q = + Event $ \p -> readIORef (enqueueWaitTimeRef q) + +-- | Signal when the 'enqueueWaitTime' property value has changed. +enqueueWaitTimeChanged :: Queue si sm so a -> Signal (SamplingStats Double) +enqueueWaitTimeChanged q = + mapSignalM (const $ enqueueWaitTime q) (enqueueWaitTimeChanged_ q) + +-- | Signal when the 'enqueueWaitTime' property value has changed. +enqueueWaitTimeChanged_ :: Queue si sm so a -> Signal () +enqueueWaitTimeChanged_ q = + mapSignal (const ()) (enqueueStored q) + +-- | Return the dequeue wait time from the time at which the item was requested +-- for dequeueing to the time at which it was actually dequeued. +-- +-- See also 'dequeueWaitTimeChanged' and 'dequeueWaitTimeChanged_'. +dequeueWaitTime :: Queue si sm so a -> Event (SamplingStats Double) +dequeueWaitTime q = + Event $ \p -> readIORef (dequeueWaitTimeRef q) + +-- | Signal when the 'dequeueWaitTime' property value has changed. +dequeueWaitTimeChanged :: Queue si sm so a -> Signal (SamplingStats Double) +dequeueWaitTimeChanged q = + mapSignalM (const $ dequeueWaitTime q) (dequeueWaitTimeChanged_ q) + +-- | Signal when the 'dequeueWaitTime' property value has changed. +dequeueWaitTimeChanged_ :: Queue si sm so a -> Signal () +dequeueWaitTimeChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return a long-term average queue rate calculated as +-- the average queue size divided by the average wait time. +-- +-- This value may be less than the actual arrival rate as the queue is +-- finite and new arrivals may be locked while the queue remains full. +-- +-- See also 'queueRateChanged' and 'queueRateChanged_'. +queueRate :: Queue si sm so a -> Event Double +queueRate q = + Event $ \p -> + do x <- readIORef (queueCountStatsRef q) + y <- readIORef (queueWaitTimeRef q) + return (timingStatsMean x / samplingStatsMean y) + +-- | Signal when the 'queueRate' property value has changed. +queueRateChanged :: Queue si sm so a -> Signal Double +queueRateChanged q = + mapSignalM (const $ queueRate q) (queueRateChanged_ q) + +-- | Signal when the 'queueRate' property value has changed. +queueRateChanged_ :: Queue si sm so a -> Signal () +queueRateChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Dequeue suspending the process if the queue is empty. +dequeue :: (DequeueStrategy si, + DequeueStrategy sm, + EnqueueStrategy so) + => Queue si sm so a + -- ^ the queue + -> Process a + -- ^ the dequeued value +dequeue q = + do t <- liftEvent $ dequeueRequest q + requestResource (dequeueRes q) + liftEvent $ dequeueExtract q t + +-- | Dequeue with the output priority suspending the process if the queue is empty. +dequeueWithOutputPriority :: (DequeueStrategy si, + DequeueStrategy sm, + PriorityQueueStrategy so po) + => Queue si sm so a + -- ^ the queue + -> po + -- ^ the priority for output + -> Process a + -- ^ the dequeued value +dequeueWithOutputPriority q po = + do t <- liftEvent $ dequeueRequest q + requestResourceWithPriority (dequeueRes q) po + liftEvent $ dequeueExtract q t + +-- | Try to dequeue immediately. +tryDequeue :: (DequeueStrategy si, + DequeueStrategy sm) + => Queue si sm so a + -- ^ the queue + -> Event (Maybe a) + -- ^ the dequeued value of 'Nothing' +tryDequeue q = + do x <- tryRequestResourceWithinEvent (dequeueRes q) + if x + then do t <- dequeueRequest q + fmap Just $ dequeueExtract q t + else return Nothing + +-- | Enqueue the item suspending the process if the queue is full. +enqueue :: (EnqueueStrategy si, + EnqueueStrategy sm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> a + -- ^ the item to enqueue + -> Process () +enqueue q a = + do i <- liftEvent $ enqueueInitiate q a + requestResource (enqueueRes q) + liftEvent $ enqueueStore q i + +-- | Enqueue with the input priority the item suspending the process if the queue is full. +enqueueWithInputPriority :: (PriorityQueueStrategy si pi, + EnqueueStrategy sm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> pi + -- ^ the priority for input + -> a + -- ^ the item to enqueue + -> Process () +enqueueWithInputPriority q pi a = + do i <- liftEvent $ enqueueInitiate q a + requestResourceWithPriority (enqueueRes q) pi + liftEvent $ enqueueStore q i + +-- | Enqueue with the storing priority the item suspending the process if the queue is full. +enqueueWithStoringPriority :: (EnqueueStrategy si, + PriorityQueueStrategy sm pm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to enqueue + -> Process () +enqueueWithStoringPriority q pm a = + do i <- liftEvent $ enqueueInitiate q a + requestResource (enqueueRes q) + liftEvent $ enqueueStoreWithPriority q pm i + +-- | Enqueue with the input and storing priorities the item suspending the process if the queue is full. +enqueueWithInputStoringPriorities :: (PriorityQueueStrategy si pi, + PriorityQueueStrategy sm pm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> pi + -- ^ the priority for input + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to enqueue + -> Process () +enqueueWithInputStoringPriorities q pi pm a = + do i <- liftEvent $ enqueueInitiate q a + requestResourceWithPriority (enqueueRes q) pi + liftEvent $ enqueueStoreWithPriority q pm i + +-- | Try to enqueue the item. Return 'False' in the monad if the queue is full. +tryEnqueue :: (EnqueueStrategy sm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> a + -- ^ the item which we try to enqueue + -> Event Bool +tryEnqueue q a = + do x <- tryRequestResourceWithinEvent (enqueueRes q) + if x + then do enqueueInitiate q a >>= enqueueStore q + return True + else return False + +-- | Try to enqueue with the storing priority the item. Return 'False' in +-- the monad if the queue is full. +tryEnqueueWithStoringPriority :: (PriorityQueueStrategy sm pm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item which we try to enqueue + -> Event Bool +tryEnqueueWithStoringPriority q pm a = + do x <- tryRequestResourceWithinEvent (enqueueRes q) + if x + then do enqueueInitiate q a >>= enqueueStoreWithPriority q pm + return True + else return False + +-- | Try to enqueue the item. If the queue is full then the item will be lost +-- and 'False' will be returned. +enqueueOrLost :: (EnqueueStrategy sm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> a + -- ^ the item which we try to enqueue + -> Event Bool +enqueueOrLost q a = + do x <- tryRequestResourceWithinEvent (enqueueRes q) + if x + then do enqueueInitiate q a >>= enqueueStore q + return True + else do enqueueDeny q a + return False + +-- | Try to enqueue with the storing priority the item. If the queue is full +-- then the item will be lost and 'False' will be returned. +enqueueWithStoringPriorityOrLost :: (PriorityQueueStrategy sm pm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item which we try to enqueue + -> Event Bool +enqueueWithStoringPriorityOrLost q pm a = + do x <- tryRequestResourceWithinEvent (enqueueRes q) + if x + then do enqueueInitiate q a >>= enqueueStoreWithPriority q pm + return True + else do enqueueDeny q a + return False + +-- | Try to enqueue the item. If the queue is full then the item will be lost. +enqueueOrLost_ :: (EnqueueStrategy sm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> a + -- ^ the item which we try to enqueue + -> Event () +enqueueOrLost_ q a = + do x <- enqueueOrLost q a + return () + +-- | Try to enqueue with the storing priority the item. If the queue is full +-- then the item will be lost. +enqueueWithStoringPriorityOrLost_ :: (PriorityQueueStrategy sm pm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item which we try to enqueue + -> Event () +enqueueWithStoringPriorityOrLost_ q pm a = + do x <- enqueueWithStoringPriorityOrLost q pm a + return () + +-- | Return a signal that notifies when the enqueuing operation is initiated. +enqueueInitiated :: Queue si sm so a -> Signal a +enqueueInitiated q = publishSignal (enqueueInitiatedSource q) + +-- | Return a signal that notifies when the enqueuing operation is completed +-- and the item is stored in the internal memory of the queue. +enqueueStored :: Queue si sm so a -> Signal a +enqueueStored q = publishSignal (enqueueStoredSource q) + +-- | Return a signal which notifies that the item was lost when +-- attempting to add it to the full queue with help of +-- 'enqueueOrLost', 'enqueueOrLost_' or similar functions that imply +-- that the element can be lost. All their names are ending with @OrLost@ +-- or @OrLost_@. +-- +-- In other cases the enqueued items are not lost but the corresponded process +-- can suspend until the internal queue storage is freed. Although there is one +-- exception from this rule. If the process trying to enqueue a new element was +-- suspended but then canceled through 'cancelProcess' from the outside then +-- the item will not be added. +enqueueLost :: Queue si sm so a -> Signal a +enqueueLost q = publishSignal (enqueueLostSource q) + +-- | Return a signal that notifies when the dequeuing operation was requested. +dequeueRequested :: Queue si sm so a -> Signal () +dequeueRequested q = publishSignal (dequeueRequestedSource q) + +-- | Return a signal that notifies when the item was extracted from the internal +-- storage of the queue and prepared for immediate receiving by the dequeuing process. +dequeueExtracted :: Queue si sm so a -> Signal a +dequeueExtracted q = publishSignal (dequeueExtractedSource q) + +-- | Initiate the process of enqueuing the item. +enqueueInitiate :: Queue si sm so a + -- ^ the queue + -> a + -- ^ the item to be enqueued + -> Event (QueueItem a) +enqueueInitiate q a = + Event $ \p -> + do let t = pointTime p + modifyIORef' (enqueueCountRef q) (+ 1) + invokeEvent p $ + triggerSignal (enqueueInitiatedSource q) a + return QueueItem { itemValue = a, + itemInputTime = t, + itemStoringTime = t -- it will be updated soon + } + +-- | Store the item. +enqueueStore :: (EnqueueStrategy sm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> QueueItem a + -- ^ the item to be stored + -> Event () +enqueueStore q i = + Event $ \p -> + do let i' = i { itemStoringTime = pointTime p } -- now we have the actual time of storing + invokeEvent p $ + strategyEnqueue (queueStore q) i' + c <- readIORef (queueCountRef q) + let c' = c + 1 + t = pointTime p + c' `seq` writeIORef (queueCountRef q) c' + modifyIORef' (queueCountStatsRef q) (addTimingStats t c') + modifyIORef' (enqueueStoreCountRef q) (+ 1) + invokeEvent p $ + enqueueStat q i' + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + invokeEvent p $ + triggerSignal (enqueueStoredSource q) (itemValue i') + +-- | Store with the priority the item. +enqueueStoreWithPriority :: (PriorityQueueStrategy sm pm, + DequeueStrategy so) + => Queue si sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> QueueItem a + -- ^ the item to be enqueued + -> Event () +enqueueStoreWithPriority q pm i = + Event $ \p -> + do let i' = i { itemStoringTime = pointTime p } -- now we have the actual time of storing + invokeEvent p $ + strategyEnqueueWithPriority (queueStore q) pm i' + c <- readIORef (queueCountRef q) + let c' = c + 1 + t = pointTime p + c' `seq` writeIORef (queueCountRef q) c' + modifyIORef' (queueCountStatsRef q) (addTimingStats t c') + modifyIORef' (enqueueStoreCountRef q) (+ 1) + invokeEvent p $ + enqueueStat q i' + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + invokeEvent p $ + triggerSignal (enqueueStoredSource q) (itemValue i') + +-- | Deny the enqueuing. +enqueueDeny :: Queue si sm so a + -- ^ the queue + -> a + -- ^ the item to be denied + -> Event () +enqueueDeny q a = + Event $ \p -> + do modifyIORef' (enqueueLostCountRef q) $ (+) 1 + invokeEvent p $ + triggerSignal (enqueueLostSource q) a + +-- | Update the statistics for the input wait time of the enqueuing operation. +enqueueStat :: Queue si sm so a + -- ^ the queue + -> QueueItem a + -- ^ the item and its input time + -> Event () + -- ^ the action of updating the statistics +enqueueStat q i = + Event $ \p -> + do let t0 = itemInputTime i + t1 = itemStoringTime i + modifyIORef' (enqueueWaitTimeRef q) $ + addSamplingStats (t1 - t0) + +-- | Accept the dequeuing request and return the current simulation time. +dequeueRequest :: Queue si sm so a + -- ^ the queue + -> Event Double + -- ^ the current time +dequeueRequest q = + Event $ \p -> + do modifyIORef' (dequeueCountRef q) (+ 1) + invokeEvent p $ + triggerSignal (dequeueRequestedSource q) () + return $ pointTime p + +-- | Extract an item for the dequeuing request. +dequeueExtract :: (DequeueStrategy si, + DequeueStrategy sm) + => Queue si sm so a + -- ^ the queue + -> Double + -- ^ the time of the dequeuing request + -> Event a + -- ^ the dequeued value +dequeueExtract q t' = + Event $ \p -> + do i <- invokeEvent p $ + strategyDequeue (queueStore q) + c <- readIORef (queueCountRef q) + let c' = c - 1 + t = pointTime p + c' `seq` writeIORef (queueCountRef q) c' + modifyIORef' (queueCountStatsRef q) (addTimingStats t c') + modifyIORef' (dequeueExtractCountRef q) (+ 1) + invokeEvent p $ + dequeueStat q t' i + invokeEvent p $ + releaseResourceWithinEvent (enqueueRes q) + invokeEvent p $ + triggerSignal (dequeueExtractedSource q) (itemValue i) + return $ itemValue i + +-- | Update the statistics for the output wait time of the dequeuing operation +-- and the wait time of storing in the queue. +dequeueStat :: Queue si sm so a + -- ^ the queue + -> Double + -- ^ the time of the dequeuing request + -> QueueItem a + -- ^ the item and its input time + -> Event () + -- ^ the action of updating the statistics +dequeueStat q t' i = + Event $ \p -> + do let t0 = itemInputTime i + t1 = itemStoringTime i + t = pointTime p + modifyIORef' (dequeueWaitTimeRef q) $ + addSamplingStats (t - t') + modifyIORef' (queueTotalWaitTimeRef q) $ + addSamplingStats (t - t0) + modifyIORef' (queueWaitTimeRef q) $ + addSamplingStats (t - t1) + +-- | Wait while the queue is full. +waitWhileFullQueue :: Queue si sm so a -> Process () +waitWhileFullQueue q = + do x <- liftEvent (queueFull q) + when x $ + do processAwait (dequeueExtracted q) + waitWhileFullQueue q + +-- | Signal whenever any property of the queue changes. +-- +-- The property must have the corresponded signal. There are also characteristics +-- similar to the properties but that have no signals. As a rule, such characteristics +-- already depend on the simulation time and therefore they may change at any +-- time point. +queueChanged_ :: Queue si sm so a -> Signal () +queueChanged_ q = + mapSignal (const ()) (enqueueInitiated q) <> + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (enqueueLost q) <> + dequeueRequested q <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the summary for the queue with desciption of its +-- properties and activities using the specified indent. +queueSummary :: (Show si, Show sm, Show so) => Queue si sm so a -> Int -> Event ShowS +queueSummary q indent = + do let si = enqueueStrategy q + sm = enqueueStoringStrategy q + so = dequeueStrategy q + null <- queueNull q + full <- queueFull q + let maxCount = queueMaxCount q + count <- queueCount q + countStats <- queueCountStats q + enqueueCount <- enqueueCount q + enqueueLostCount <- enqueueLostCount q + enqueueStoreCount <- enqueueStoreCount q + dequeueCount <- dequeueCount q + dequeueExtractCount <- dequeueExtractCount q + loadFactor <- queueLoadFactor q + enqueueRate <- enqueueRate q + enqueueStoreRate <- enqueueStoreRate q + dequeueRate <- dequeueRate q + dequeueExtractRate <- dequeueExtractRate q + waitTime <- queueWaitTime q + totalWaitTime <- queueTotalWaitTime q + enqueueWaitTime <- enqueueWaitTime q + dequeueWaitTime <- dequeueWaitTime q + let tab = replicate indent ' ' + return $ + showString tab . + showString "the enqueueing (input) strategy = " . + shows si . + showString "\n" . + showString tab . + showString "the storing (memory) strategy = " . + shows sm . + showString "\n" . + showString tab . + showString "the dequeueing (output) strategy = " . + shows so . + showString "\n" . + showString tab . + showString "empty? = " . + shows null . + showString "\n" . + showString tab . + showString "full? = " . + shows full . + showString "\n" . + showString tab . + showString "max. capacity = " . + shows maxCount . + showString "\n" . + showString tab . + showString "size = " . + shows count . + showString "\n" . + showString tab . + showString "the size statistics = \n\n" . + timingStatsSummary countStats (2 + indent) . + showString "\n\n" . + showString tab . + showString "the enqueue count (number of the input items that were enqueued) = " . + shows enqueueCount . + showString "\n" . + showString tab . + showString "the enqueue lost count (number of the lost items) = " . + shows enqueueLostCount . + showString "\n" . + showString tab . + showString "the enqueue store count (number of the input items that were stored) = " . + shows enqueueStoreCount . + showString "\n" . + showString tab . + showString "the dequeue count (number of requests for dequeueing an item) = " . + shows dequeueCount . + showString "\n" . + showString tab . + showString "the dequeue extract count (number of the output items that were dequeued) = " . + shows dequeueExtractCount . + showString "\n" . + showString tab . + showString "the load factor (size / max. capacity) = " . + shows loadFactor . + showString "\n" . + showString tab . + showString "the enqueue rate (how many input items were enqueued per time) = " . + shows enqueueRate . + showString "\n" . + showString tab . + showString "the enqueue store rate (how many input items were stored per time) = " . + shows enqueueStoreRate . + showString "\n" . + showString tab . + showString "the dequeue rate (how many requests for dequeueing per time) = " . + shows dequeueRate . + showString "\n" . + showString tab . + showString "the dequeue extract rate (how many output items were dequeued per time) = " . + shows dequeueExtractRate . + showString "\n" . + showString tab . + showString "the wait time (when was stored -> when was dequeued) = \n\n" . + samplingStatsSummary waitTime (2 + indent) . + showString "\n\n" . + showString tab . + showString "the total wait time (when the enqueueing was initiated -> when was dequeued) = \n\n" . + samplingStatsSummary totalWaitTime (2 + indent) . + showString "\n\n" . + showString tab . + showString "the enqueue wait time (when the enqueueing was initiated -> when was stored) = \n\n" . + samplingStatsSummary enqueueWaitTime (2 + indent) . + showString "\n\n" . + showString tab . + showString "the dequeue wait time (when was requested for dequeueing -> when was dequeued) = \n\n" . + samplingStatsSummary dequeueWaitTime (2 + indent) diff --git a/Simulation/Aivika/Queue/Infinite.hs b/Simulation/Aivika/Queue/Infinite.hs --- a/Simulation/Aivika/Queue/Infinite.hs +++ b/Simulation/Aivika/Queue/Infinite.hs @@ -1,642 +1,636 @@ - --- | --- Module : Simulation.Aivika.Queue.Infinite --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- This module defines an infinite queue that can use the specified strategies. --- -module Simulation.Aivika.Queue.Infinite - (-- * Queue Types - FCFSQueue, - LCFSQueue, - SIROQueue, - PriorityQueue, - Queue, - -- * Creating Queue - newFCFSQueue, - newLCFSQueue, - newSIROQueue, - newPriorityQueue, - newQueue, - -- * Queue Properties and Activities - enqueueStoringStrategy, - dequeueStrategy, - queueNull, - queueCount, - queueCountStats, - enqueueStoreCount, - dequeueCount, - dequeueExtractCount, - enqueueStoreRate, - dequeueRate, - dequeueExtractRate, - queueWaitTime, - dequeueWaitTime, - queueRate, - -- * Dequeuing and Enqueuing - dequeue, - dequeueWithOutputPriority, - tryDequeue, - enqueue, - enqueueWithStoringPriority, - -- * Summary - queueSummary, - -- * Derived Signals for Properties - queueNullChanged, - queueNullChanged_, - queueCountChanged, - queueCountChanged_, - enqueueStoreCountChanged, - enqueueStoreCountChanged_, - dequeueCountChanged, - dequeueCountChanged_, - dequeueExtractCountChanged, - dequeueExtractCountChanged_, - queueWaitTimeChanged, - queueWaitTimeChanged_, - dequeueWaitTimeChanged, - dequeueWaitTimeChanged_, - queueRateChanged, - queueRateChanged_, - -- * Basic Signals - enqueueStored, - dequeueRequested, - dequeueExtracted, - -- * Overall Signal - queueChanged_) where - -import Data.IORef -import Data.Monoid - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Internal.Specs -import Simulation.Aivika.Internal.Simulation -import Simulation.Aivika.Internal.Dynamics -import Simulation.Aivika.Internal.Event -import Simulation.Aivika.Internal.Process -import Simulation.Aivika.Internal.Signal -import Simulation.Aivika.Signal -import Simulation.Aivika.Resource -import Simulation.Aivika.QueueStrategy -import Simulation.Aivika.Statistics - -import qualified Simulation.Aivika.DoubleLinkedList as DLL -import qualified Simulation.Aivika.Vector as V -import qualified Simulation.Aivika.PriorityQueue as PQ - --- | A type synonym for the ordinary FIFO queue also known as the FCFS --- (First Come - First Serviced) queue. -type FCFSQueue a = - Queue FCFS DLL.DoubleLinkedList FCFS DLL.DoubleLinkedList a - --- | A type synonym for the ordinary LIFO queue also known as the LCFS --- (Last Come - First Serviced) queue. -type LCFSQueue a = - Queue LCFS DLL.DoubleLinkedList FCFS DLL.DoubleLinkedList a - --- | A type synonym for the SIRO (Serviced in Random Order) queue. -type SIROQueue a = - Queue SIRO V.Vector FCFS DLL.DoubleLinkedList a - --- | A type synonym for the queue with static priorities applied when --- storing the elements in the queue. -type PriorityQueue a = - Queue StaticPriorities PQ.PriorityQueue FCFS DLL.DoubleLinkedList a - --- | Represents an infinite queue using the specified strategies for --- internal storing (in memory), @sm@, and dequeueing (output), @so@, where @a@ denotes --- the type of items stored in the queue. Types @qm@ and @qo@ are --- determined automatically and you should not care about them - they --- are dependent types. -data Queue sm qm so qo a = - Queue { enqueueStoringStrategy :: sm, - -- ^ The strategy applied when storing (in memory) items in the queue. - dequeueStrategy :: so, - -- ^ The strategy applied to the dequeueing (output) processes. - queueStore :: qm (QueueItem a), - dequeueRes :: Resource so qo, - queueCountRef :: IORef Int, - queueCountStatsRef :: IORef (TimingStats Int), - enqueueStoreCountRef :: IORef Int, - dequeueCountRef :: IORef Int, - dequeueExtractCountRef :: IORef Int, - queueWaitTimeRef :: IORef (SamplingStats Double), - dequeueWaitTimeRef :: IORef (SamplingStats Double), - enqueueStoredSource :: SignalSource a, - dequeueRequestedSource :: SignalSource (), - dequeueExtractedSource :: SignalSource a } - --- | Stores the item and a time of its enqueuing. -data QueueItem a = - QueueItem { itemValue :: a, - -- ^ Return the item value. - itemStoringTime :: Double - -- ^ Return the time of storing in the queue. - } - --- | Create a new infinite FCFS queue. -newFCFSQueue :: Event (FCFSQueue a) -newFCFSQueue = newQueue FCFS FCFS - --- | Create a new infinite LCFS queue. -newLCFSQueue :: Event (LCFSQueue a) -newLCFSQueue = newQueue LCFS FCFS - --- | Create a new infinite SIRO queue. -newSIROQueue :: Event (SIROQueue a) -newSIROQueue = newQueue SIRO FCFS - --- | Create a new infinite priority queue. -newPriorityQueue :: Event (PriorityQueue a) -newPriorityQueue = newQueue StaticPriorities FCFS - --- | Create a new infinite queue with the specified strategies. -newQueue :: (QueueStrategy sm qm, - QueueStrategy so qo) => - sm - -- ^ the strategy applied when storing items in the queue - -> so - -- ^ the strategy applied to the dequeueing (output) processes when the queue is empty - -> Event (Queue sm qm so qo a) -newQueue sm so = - do t <- liftDynamics time - i <- liftIO $ newIORef 0 - is <- liftIO $ newIORef $ returnTimingStats t 0 - cm <- liftIO $ newIORef 0 - cr <- liftIO $ newIORef 0 - co <- liftIO $ newIORef 0 - qm <- liftSimulation $ newStrategyQueue sm - ro <- liftSimulation $ newResourceWithMaxCount so 0 Nothing - w <- liftIO $ newIORef mempty - wo <- liftIO $ newIORef mempty - s3 <- liftSimulation newSignalSource - s4 <- liftSimulation newSignalSource - s5 <- liftSimulation newSignalSource - return Queue { enqueueStoringStrategy = sm, - dequeueStrategy = so, - queueStore = qm, - dequeueRes = ro, - queueCountRef = i, - queueCountStatsRef = is, - enqueueStoreCountRef = cm, - dequeueCountRef = cr, - dequeueExtractCountRef = co, - queueWaitTimeRef = w, - dequeueWaitTimeRef = wo, - enqueueStoredSource = s3, - dequeueRequestedSource = s4, - dequeueExtractedSource = s5 } - --- | Test whether the queue is empty. --- --- See also 'queueNullChanged' and 'queueNullChanged_'. -queueNull :: Queue sm qm so qo a -> Event Bool -queueNull q = - Event $ \p -> - do n <- readIORef (queueCountRef q) - return (n == 0) - --- | Signal when the 'queueNull' property value has changed. -queueNullChanged :: Queue sm qm so qo a -> Signal Bool -queueNullChanged q = - mapSignalM (const $ queueNull q) (queueNullChanged_ q) - --- | Signal when the 'queueNull' property value has changed. -queueNullChanged_ :: Queue sm qm so qo a -> Signal () -queueNullChanged_ = queueCountChanged_ - --- | Return the current queue size. --- --- See also 'queueCountStats', 'queueCountChanged' and 'queueCountChanged_'. -queueCount :: Queue sm qm so qo a -> Event Int -queueCount q = - Event $ \p -> readIORef (queueCountRef q) - --- | Return the queue size statistics. -queueCountStats :: Queue sm qm so qo a -> Event (TimingStats Int) -queueCountStats q = - Event $ \p -> readIORef (queueCountStatsRef q) - --- | Signal when the 'queueCount' property value has changed. -queueCountChanged :: Queue sm qm so qo a -> Signal Int -queueCountChanged q = - mapSignalM (const $ queueCount q) (queueCountChanged_ q) - --- | Signal when the 'queueCount' property value has changed. -queueCountChanged_ :: Queue sm qm so qo a -> Signal () -queueCountChanged_ q = - mapSignal (const ()) (enqueueStored q) <> - mapSignal (const ()) (dequeueExtracted q) - --- | Return the total number of input items that were stored. --- --- See also 'enqueueStoreCountChanged' and 'enqueueStoreCountChanged_'. -enqueueStoreCount :: Queue sm qm so qo a -> Event Int -enqueueStoreCount q = - Event $ \p -> readIORef (enqueueStoreCountRef q) - --- | Signal when the 'enqueueStoreCount' property value has changed. -enqueueStoreCountChanged :: Queue sm qm so qo a -> Signal Int -enqueueStoreCountChanged q = - mapSignalM (const $ enqueueStoreCount q) (enqueueStoreCountChanged_ q) - --- | Signal when the 'enqueueStoreCount' property value has changed. -enqueueStoreCountChanged_ :: Queue sm qm so qo a -> Signal () -enqueueStoreCountChanged_ q = - mapSignal (const ()) (enqueueStored q) - --- | Return the total number of requests for dequeueing the items, --- not taking into account the failed attempts to dequeue immediately --- without suspension. --- --- See also 'dequeueCountChanged' and 'dequeueCountChanged_'. -dequeueCount :: Queue sm qm so qo a -> Event Int -dequeueCount q = - Event $ \p -> readIORef (dequeueCountRef q) - --- | Signal when the 'dequeueCount' property value has changed. -dequeueCountChanged :: Queue sm qm so qo a -> Signal Int -dequeueCountChanged q = - mapSignalM (const $ dequeueCount q) (dequeueCountChanged_ q) - --- | Signal when the 'dequeueCount' property value has changed. -dequeueCountChanged_ :: Queue sm qm so qo a -> Signal () -dequeueCountChanged_ q = - mapSignal (const ()) (dequeueRequested q) - --- | Return the total number of output items that were actually dequeued. --- --- See also 'dequeueExtractCountChanged' and 'dequeueExtractCountChanged_'. -dequeueExtractCount :: Queue sm qm so qo a -> Event Int -dequeueExtractCount q = - Event $ \p -> readIORef (dequeueExtractCountRef q) - --- | Signal when the 'dequeueExtractCount' property value has changed. -dequeueExtractCountChanged :: Queue sm qm so qo a -> Signal Int -dequeueExtractCountChanged q = - mapSignalM (const $ dequeueExtractCount q) (dequeueExtractCountChanged_ q) - --- | Signal when the 'dequeueExtractCount' property value has changed. -dequeueExtractCountChanged_ :: Queue sm qm so qo a -> Signal () -dequeueExtractCountChanged_ q = - mapSignal (const ()) (dequeueExtracted q) - --- | Return the rate of the items that were stored: how many items --- per time. -enqueueStoreRate :: Queue sm qm so qo a -> Event Double -enqueueStoreRate q = - Event $ \p -> - do x <- readIORef (enqueueStoreCountRef q) - let t0 = spcStartTime $ pointSpecs p - t = pointTime p - return (fromIntegral x / (t - t0)) - --- | Return the rate of the requests for dequeueing the items: how many requests --- per time. It does not include the failed attempts to dequeue immediately --- without suspension. -dequeueRate :: Queue sm qm so qo a -> Event Double -dequeueRate q = - Event $ \p -> - do x <- readIORef (dequeueCountRef q) - let t0 = spcStartTime $ pointSpecs p - t = pointTime p - return (fromIntegral x / (t - t0)) - --- | Return the rate of the output items that were dequeued: how many items --- per time. -dequeueExtractRate :: Queue sm qm so qo a -> Event Double -dequeueExtractRate q = - Event $ \p -> - do x <- readIORef (dequeueExtractCountRef q) - let t0 = spcStartTime $ pointSpecs p - t = pointTime p - return (fromIntegral x / (t - t0)) - --- | Return the wait time from the time at which the item was stored in the queue to --- the time at which it was dequeued. --- --- See also 'queueWaitTimeChanged' and 'queueWaitTimeChanged_'. -queueWaitTime :: Queue sm qm so qo a -> Event (SamplingStats Double) -queueWaitTime q = - Event $ \p -> readIORef (queueWaitTimeRef q) - --- | Signal when the 'queueWaitTime' property value has changed. -queueWaitTimeChanged :: Queue sm qm so qo a -> Signal (SamplingStats Double) -queueWaitTimeChanged q = - mapSignalM (const $ queueWaitTime q) (queueWaitTimeChanged_ q) - --- | Signal when the 'queueWaitTime' property value has changed. -queueWaitTimeChanged_ :: Queue sm qm so qo a -> Signal () -queueWaitTimeChanged_ q = - mapSignal (const ()) (dequeueExtracted q) - --- | Return the dequeue wait time from the time at which the item was requested --- for dequeueing to the time at which it was actually dequeued. --- --- See also 'dequeueWaitTimeChanged' and 'dequeueWaitTimeChanged_'. -dequeueWaitTime :: Queue sm qm so qo a -> Event (SamplingStats Double) -dequeueWaitTime q = - Event $ \p -> readIORef (dequeueWaitTimeRef q) - --- | Signal when the 'dequeueWaitTime' property value has changed. -dequeueWaitTimeChanged :: Queue sm qm so qo a -> Signal (SamplingStats Double) -dequeueWaitTimeChanged q = - mapSignalM (const $ dequeueWaitTime q) (dequeueWaitTimeChanged_ q) - --- | Signal when the 'dequeueWaitTime' property value has changed. -dequeueWaitTimeChanged_ :: Queue sm qm so qo a -> Signal () -dequeueWaitTimeChanged_ q = - mapSignal (const ()) (dequeueExtracted q) - --- | Return a long-term average queue rate calculated as --- the average queue size divided by the average wait time. --- --- See also 'queueRateChanged' and 'queueRateChanged_'. -queueRate :: Queue sm qm so qo a -> Event Double -queueRate q = - Event $ \p -> - do x <- readIORef (queueCountStatsRef q) - y <- readIORef (queueWaitTimeRef q) - return (timingStatsMean x / samplingStatsMean y) - --- | Signal when the 'queueRate' property value has changed. -queueRateChanged :: Queue sm qm so qo a -> Signal Double -queueRateChanged q = - mapSignalM (const $ queueRate q) (queueRateChanged_ q) - --- | Signal when the 'queueRate' property value has changed. -queueRateChanged_ :: Queue sm qm so qo a -> Signal () -queueRateChanged_ q = - mapSignal (const ()) (enqueueStored q) <> - mapSignal (const ()) (dequeueExtracted q) - --- | Dequeue suspending the process if the queue is empty. -dequeue :: (DequeueStrategy sm qm, - EnqueueStrategy so qo) - => Queue sm qm so qo a - -- ^ the queue - -> Process a - -- ^ the dequeued value -dequeue q = - do t <- liftEvent $ dequeueRequest q - requestResource (dequeueRes q) - liftEvent $ dequeueExtract q t - --- | Dequeue with the output priority suspending the process if the queue is empty. -dequeueWithOutputPriority :: (DequeueStrategy sm qm, - PriorityQueueStrategy so qo po) - => Queue sm qm so qo a - -- ^ the queue - -> po - -- ^ the priority for output - -> Process a - -- ^ the dequeued value -dequeueWithOutputPriority q po = - do t <- liftEvent $ dequeueRequest q - requestResourceWithPriority (dequeueRes q) po - liftEvent $ dequeueExtract q t - --- | Try to dequeue immediately. -tryDequeue :: DequeueStrategy sm qm - => Queue sm qm so qo a - -- ^ the queue - -> Event (Maybe a) - -- ^ the dequeued value of 'Nothing' -tryDequeue q = - do x <- tryRequestResourceWithinEvent (dequeueRes q) - if x - then do t <- dequeueRequest q - fmap Just $ dequeueExtract q t - else return Nothing - --- | Enqueue the item. -enqueue :: (EnqueueStrategy sm qm, - DequeueStrategy so qo) - => Queue sm qm so qo a - -- ^ the queue - -> a - -- ^ the item to enqueue - -> Event () -enqueue = enqueueStore - --- | Enqueue with the storing priority the item. -enqueueWithStoringPriority :: (PriorityQueueStrategy sm qm pm, - DequeueStrategy so qo) - => Queue sm qm so qo a - -- ^ the queue - -> pm - -- ^ the priority for storing - -> a - -- ^ the item to enqueue - -> Event () -enqueueWithStoringPriority = enqueueStoreWithPriority - --- | Return a signal that notifies when the enqueued item --- is stored in the internal memory of the queue. -enqueueStored :: Queue sm qm so qo a -> Signal a -enqueueStored q = publishSignal (enqueueStoredSource q) - --- | Return a signal that notifies when the dequeuing operation was requested. -dequeueRequested :: Queue sm qm so qo a -> Signal () -dequeueRequested q = publishSignal (dequeueRequestedSource q) - --- | Return a signal that notifies when the item was extracted from the internal --- storage of the queue and prepared for immediate receiving by the dequeuing process. -dequeueExtracted :: Queue sm qm so qo a -> Signal a -dequeueExtracted q = publishSignal (dequeueExtractedSource q) - --- | Store the item. -enqueueStore :: (EnqueueStrategy sm qm, - DequeueStrategy so qo) - => Queue sm qm so qo a - -- ^ the queue - -> a - -- ^ the item to be stored - -> Event () -enqueueStore q a = - Event $ \p -> - do let i = QueueItem { itemValue = a, - itemStoringTime = pointTime p } - invokeEvent p $ - strategyEnqueue (enqueueStoringStrategy q) (queueStore q) i - c <- readIORef (queueCountRef q) - let c' = c + 1 - t = pointTime p - c' `seq` writeIORef (queueCountRef q) c' - modifyIORef' (queueCountStatsRef q) (addTimingStats t c') - modifyIORef' (enqueueStoreCountRef q) (+ 1) - invokeEvent p $ - releaseResourceWithinEvent (dequeueRes q) - invokeEvent p $ - triggerSignal (enqueueStoredSource q) (itemValue i) - --- | Store with the priority the item. -enqueueStoreWithPriority :: (PriorityQueueStrategy sm qm pm, - DequeueStrategy so qo) - => Queue sm qm so qo a - -- ^ the queue - -> pm - -- ^ the priority for storing - -> a - -- ^ the item to be enqueued - -> Event () -enqueueStoreWithPriority q pm a = - Event $ \p -> - do let i = QueueItem { itemValue = a, - itemStoringTime = pointTime p } - invokeEvent p $ - strategyEnqueueWithPriority (enqueueStoringStrategy q) (queueStore q) pm i - c <- readIORef (queueCountRef q) - let c' = c + 1 - t = pointTime p - c' `seq` writeIORef (queueCountRef q) c' - modifyIORef' (queueCountStatsRef q) (addTimingStats t c') - modifyIORef' (enqueueStoreCountRef q) (+ 1) - invokeEvent p $ - releaseResourceWithinEvent (dequeueRes q) - invokeEvent p $ - triggerSignal (enqueueStoredSource q) (itemValue i) - --- | Accept the dequeuing request and return the current simulation time. -dequeueRequest :: Queue sm qm so qo a - -- ^ the queue - -> Event Double - -- ^ the current time -dequeueRequest q = - Event $ \p -> - do modifyIORef' (dequeueCountRef q) (+ 1) - invokeEvent p $ - triggerSignal (dequeueRequestedSource q) () - return $ pointTime p - --- | Extract an item for the dequeuing request. -dequeueExtract :: DequeueStrategy sm qm - => Queue sm qm so qo a - -- ^ the queue - -> Double - -- ^ the time of the dequeuing request - -> Event a - -- ^ the dequeued value -dequeueExtract q t' = - Event $ \p -> - do i <- invokeEvent p $ - strategyDequeue (enqueueStoringStrategy q) (queueStore q) - c <- readIORef (queueCountRef q) - let c' = c - 1 - t = pointTime p - c' `seq` writeIORef (queueCountRef q) c' - modifyIORef' (queueCountStatsRef q) (addTimingStats t c') - modifyIORef' (dequeueExtractCountRef q) (+ 1) - invokeEvent p $ - dequeueStat q t' i - invokeEvent p $ - triggerSignal (dequeueExtractedSource q) (itemValue i) - return $ itemValue i - --- | Update the statistics for the output wait time of the dequeuing operation --- and the wait time of storing in the queue. -dequeueStat :: Queue sm qm so qo a - -- ^ the queue - -> Double - -- ^ the time of the dequeuing request - -> QueueItem a - -- ^ the item and its input time - -> Event () - -- ^ the action of updating the statistics -dequeueStat q t' i = - Event $ \p -> - do let t1 = itemStoringTime i - t = pointTime p - modifyIORef' (dequeueWaitTimeRef q) $ - addSamplingStats (t - t') - modifyIORef' (queueWaitTimeRef q) $ - addSamplingStats (t - t1) - --- | Signal whenever any property of the queue changes. --- --- The property must have the corresponded signal. There are also characteristics --- similar to the properties but that have no signals. As a rule, such characteristics --- already depend on the simulation time and therefore they may change at any --- time point. -queueChanged_ :: Queue sm qm so qo a -> Signal () -queueChanged_ q = - mapSignal (const ()) (enqueueStored q) <> - dequeueRequested q <> - mapSignal (const ()) (dequeueExtracted q) - --- | Return the summary for the queue with desciption of its --- properties and activities using the specified indent. -queueSummary :: (Show sm, Show so) => Queue sm qm so qo a -> Int -> Event ShowS -queueSummary q indent = - do let sm = enqueueStoringStrategy q - so = dequeueStrategy q - null <- queueNull q - count <- queueCount q - countStats <- queueCountStats q - enqueueStoreCount <- enqueueStoreCount q - dequeueCount <- dequeueCount q - dequeueExtractCount <- dequeueExtractCount q - enqueueStoreRate <- enqueueStoreRate q - dequeueRate <- dequeueRate q - dequeueExtractRate <- dequeueExtractRate q - waitTime <- queueWaitTime q - dequeueWaitTime <- dequeueWaitTime q - let tab = replicate indent ' ' - return $ - showString tab . - showString "the storing (memory) strategy = " . - shows sm . - showString "\n" . - showString tab . - showString "the dequeueing (output) strategy = " . - shows so . - showString "\n" . - showString tab . - showString "empty? = " . - shows null . - showString "\n" . - showString tab . - showString "the current size = " . - shows count . - showString "\n" . - showString tab . - showString "the size statistics = \n\n" . - timingStatsSummary countStats (2 + indent) . - showString "\n\n" . - showString tab . - showString "the enqueue store count (number of the input items that were stored) = " . - shows enqueueStoreCount . - showString "\n" . - showString tab . - showString "the dequeue count (number of requests for dequeueing an item) = " . - shows dequeueCount . - showString "\n" . - showString tab . - showString "the dequeue extract count (number of the output items that were dequeued) = " . - shows dequeueExtractCount . - showString "\n" . - showString tab . - showString "the enqueue store rate (how many input items were stored per time) = " . - shows enqueueStoreRate . - showString "\n" . - showString tab . - showString "the dequeue rate (how many requests for dequeueing per time) = " . - shows dequeueRate . - showString "\n" . - showString tab . - showString "the dequeue extract rate (how many output items were dequeued per time) = " . - shows dequeueExtractRate . - showString "\n" . - showString tab . - showString "the wait time (when was stored -> when was dequeued) = \n\n" . - samplingStatsSummary waitTime (2 + indent) . - showString "\n\n" . - showString tab . - showString "the dequeue wait time (when was requested for dequeueing -> when was dequeued) = \n\n" . - samplingStatsSummary dequeueWaitTime (2 + indent) + +-- | +-- Module : Simulation.Aivika.Queue.Infinite +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines an infinite queue that can use the specified strategies. +-- +module Simulation.Aivika.Queue.Infinite + (-- * Queue Types + FCFSQueue, + LCFSQueue, + SIROQueue, + PriorityQueue, + Queue, + -- * Creating Queue + newFCFSQueue, + newLCFSQueue, + newSIROQueue, + newPriorityQueue, + newQueue, + -- * Queue Properties and Activities + enqueueStoringStrategy, + dequeueStrategy, + queueNull, + queueCount, + queueCountStats, + enqueueStoreCount, + dequeueCount, + dequeueExtractCount, + enqueueStoreRate, + dequeueRate, + dequeueExtractRate, + queueWaitTime, + dequeueWaitTime, + queueRate, + -- * Dequeuing and Enqueuing + dequeue, + dequeueWithOutputPriority, + tryDequeue, + enqueue, + enqueueWithStoringPriority, + -- * Summary + queueSummary, + -- * Derived Signals for Properties + queueNullChanged, + queueNullChanged_, + queueCountChanged, + queueCountChanged_, + enqueueStoreCountChanged, + enqueueStoreCountChanged_, + dequeueCountChanged, + dequeueCountChanged_, + dequeueExtractCountChanged, + dequeueExtractCountChanged_, + queueWaitTimeChanged, + queueWaitTimeChanged_, + dequeueWaitTimeChanged, + dequeueWaitTimeChanged_, + queueRateChanged, + queueRateChanged_, + -- * Basic Signals + enqueueStored, + dequeueRequested, + dequeueExtracted, + -- * Overall Signal + queueChanged_) where + +import Data.IORef +import Data.Monoid + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Simulation +import Simulation.Aivika.Internal.Dynamics +import Simulation.Aivika.Internal.Event +import Simulation.Aivika.Internal.Process +import Simulation.Aivika.Internal.Signal +import Simulation.Aivika.Signal +import Simulation.Aivika.Resource +import Simulation.Aivika.QueueStrategy +import Simulation.Aivika.Statistics + +import qualified Simulation.Aivika.DoubleLinkedList as DLL +import qualified Simulation.Aivika.Vector as V +import qualified Simulation.Aivika.PriorityQueue as PQ + +-- | A type synonym for the ordinary FIFO queue also known as the FCFS +-- (First Come - First Serviced) queue. +type FCFSQueue a = Queue FCFS FCFS a + +-- | A type synonym for the ordinary LIFO queue also known as the LCFS +-- (Last Come - First Serviced) queue. +type LCFSQueue a = Queue LCFS FCFS a + +-- | A type synonym for the SIRO (Serviced in Random Order) queue. +type SIROQueue a = Queue SIRO FCFS a + +-- | A type synonym for the queue with static priorities applied when +-- storing the elements in the queue. +type PriorityQueue a = Queue StaticPriorities FCFS a + +-- | Represents an infinite queue using the specified strategies for +-- internal storing (in memory), @sm@, and dequeueing (output), @so@, where @a@ denotes +-- the type of items stored in the queue. +data Queue sm so a = + Queue { enqueueStoringStrategy :: sm, + -- ^ The strategy applied when storing (in memory) items in the queue. + dequeueStrategy :: so, + -- ^ The strategy applied to the dequeueing (output) processes. + queueStore :: StrategyQueue sm (QueueItem a), + dequeueRes :: Resource so, + queueCountRef :: IORef Int, + queueCountStatsRef :: IORef (TimingStats Int), + enqueueStoreCountRef :: IORef Int, + dequeueCountRef :: IORef Int, + dequeueExtractCountRef :: IORef Int, + queueWaitTimeRef :: IORef (SamplingStats Double), + dequeueWaitTimeRef :: IORef (SamplingStats Double), + enqueueStoredSource :: SignalSource a, + dequeueRequestedSource :: SignalSource (), + dequeueExtractedSource :: SignalSource a } + +-- | Stores the item and a time of its enqueuing. +data QueueItem a = + QueueItem { itemValue :: a, + -- ^ Return the item value. + itemStoringTime :: Double + -- ^ Return the time of storing in the queue. + } + +-- | Create a new infinite FCFS queue. +newFCFSQueue :: Event (FCFSQueue a) +newFCFSQueue = newQueue FCFS FCFS + +-- | Create a new infinite LCFS queue. +newLCFSQueue :: Event (LCFSQueue a) +newLCFSQueue = newQueue LCFS FCFS + +-- | Create a new infinite SIRO queue. +newSIROQueue :: Event (SIROQueue a) +newSIROQueue = newQueue SIRO FCFS + +-- | Create a new infinite priority queue. +newPriorityQueue :: Event (PriorityQueue a) +newPriorityQueue = newQueue StaticPriorities FCFS + +-- | Create a new infinite queue with the specified strategies. +newQueue :: (QueueStrategy sm, + QueueStrategy so) => + sm + -- ^ the strategy applied when storing items in the queue + -> so + -- ^ the strategy applied to the dequeueing (output) processes when the queue is empty + -> Event (Queue sm so a) +newQueue sm so = + do t <- liftDynamics time + i <- liftIO $ newIORef 0 + is <- liftIO $ newIORef $ returnTimingStats t 0 + cm <- liftIO $ newIORef 0 + cr <- liftIO $ newIORef 0 + co <- liftIO $ newIORef 0 + qm <- liftSimulation $ newStrategyQueue sm + ro <- liftSimulation $ newResourceWithMaxCount so 0 Nothing + w <- liftIO $ newIORef mempty + wo <- liftIO $ newIORef mempty + s3 <- liftSimulation newSignalSource + s4 <- liftSimulation newSignalSource + s5 <- liftSimulation newSignalSource + return Queue { enqueueStoringStrategy = sm, + dequeueStrategy = so, + queueStore = qm, + dequeueRes = ro, + queueCountRef = i, + queueCountStatsRef = is, + enqueueStoreCountRef = cm, + dequeueCountRef = cr, + dequeueExtractCountRef = co, + queueWaitTimeRef = w, + dequeueWaitTimeRef = wo, + enqueueStoredSource = s3, + dequeueRequestedSource = s4, + dequeueExtractedSource = s5 } + +-- | Test whether the queue is empty. +-- +-- See also 'queueNullChanged' and 'queueNullChanged_'. +queueNull :: Queue sm so a -> Event Bool +queueNull q = + Event $ \p -> + do n <- readIORef (queueCountRef q) + return (n == 0) + +-- | Signal when the 'queueNull' property value has changed. +queueNullChanged :: Queue sm so a -> Signal Bool +queueNullChanged q = + mapSignalM (const $ queueNull q) (queueNullChanged_ q) + +-- | Signal when the 'queueNull' property value has changed. +queueNullChanged_ :: Queue sm so a -> Signal () +queueNullChanged_ = queueCountChanged_ + +-- | Return the current queue size. +-- +-- See also 'queueCountStats', 'queueCountChanged' and 'queueCountChanged_'. +queueCount :: Queue sm so a -> Event Int +queueCount q = + Event $ \p -> readIORef (queueCountRef q) + +-- | Return the queue size statistics. +queueCountStats :: Queue sm so a -> Event (TimingStats Int) +queueCountStats q = + Event $ \p -> readIORef (queueCountStatsRef q) + +-- | Signal when the 'queueCount' property value has changed. +queueCountChanged :: Queue sm so a -> Signal Int +queueCountChanged q = + mapSignalM (const $ queueCount q) (queueCountChanged_ q) + +-- | Signal when the 'queueCount' property value has changed. +queueCountChanged_ :: Queue sm so a -> Signal () +queueCountChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the total number of input items that were stored. +-- +-- See also 'enqueueStoreCountChanged' and 'enqueueStoreCountChanged_'. +enqueueStoreCount :: Queue sm so a -> Event Int +enqueueStoreCount q = + Event $ \p -> readIORef (enqueueStoreCountRef q) + +-- | Signal when the 'enqueueStoreCount' property value has changed. +enqueueStoreCountChanged :: Queue sm so a -> Signal Int +enqueueStoreCountChanged q = + mapSignalM (const $ enqueueStoreCount q) (enqueueStoreCountChanged_ q) + +-- | Signal when the 'enqueueStoreCount' property value has changed. +enqueueStoreCountChanged_ :: Queue sm so a -> Signal () +enqueueStoreCountChanged_ q = + mapSignal (const ()) (enqueueStored q) + +-- | Return the total number of requests for dequeueing the items, +-- not taking into account the failed attempts to dequeue immediately +-- without suspension. +-- +-- See also 'dequeueCountChanged' and 'dequeueCountChanged_'. +dequeueCount :: Queue sm so a -> Event Int +dequeueCount q = + Event $ \p -> readIORef (dequeueCountRef q) + +-- | Signal when the 'dequeueCount' property value has changed. +dequeueCountChanged :: Queue sm so a -> Signal Int +dequeueCountChanged q = + mapSignalM (const $ dequeueCount q) (dequeueCountChanged_ q) + +-- | Signal when the 'dequeueCount' property value has changed. +dequeueCountChanged_ :: Queue sm so a -> Signal () +dequeueCountChanged_ q = + mapSignal (const ()) (dequeueRequested q) + +-- | Return the total number of output items that were actually dequeued. +-- +-- See also 'dequeueExtractCountChanged' and 'dequeueExtractCountChanged_'. +dequeueExtractCount :: Queue sm so a -> Event Int +dequeueExtractCount q = + Event $ \p -> readIORef (dequeueExtractCountRef q) + +-- | Signal when the 'dequeueExtractCount' property value has changed. +dequeueExtractCountChanged :: Queue sm so a -> Signal Int +dequeueExtractCountChanged q = + mapSignalM (const $ dequeueExtractCount q) (dequeueExtractCountChanged_ q) + +-- | Signal when the 'dequeueExtractCount' property value has changed. +dequeueExtractCountChanged_ :: Queue sm so a -> Signal () +dequeueExtractCountChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the rate of the items that were stored: how many items +-- per time. +enqueueStoreRate :: Queue sm so a -> Event Double +enqueueStoreRate q = + Event $ \p -> + do x <- readIORef (enqueueStoreCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the rate of the requests for dequeueing the items: how many requests +-- per time. It does not include the failed attempts to dequeue immediately +-- without suspension. +dequeueRate :: Queue sm so a -> Event Double +dequeueRate q = + Event $ \p -> + do x <- readIORef (dequeueCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the rate of the output items that were dequeued: how many items +-- per time. +dequeueExtractRate :: Queue sm so a -> Event Double +dequeueExtractRate q = + Event $ \p -> + do x <- readIORef (dequeueExtractCountRef q) + let t0 = spcStartTime $ pointSpecs p + t = pointTime p + return (fromIntegral x / (t - t0)) + +-- | Return the wait time from the time at which the item was stored in the queue to +-- the time at which it was dequeued. +-- +-- See also 'queueWaitTimeChanged' and 'queueWaitTimeChanged_'. +queueWaitTime :: Queue sm so a -> Event (SamplingStats Double) +queueWaitTime q = + Event $ \p -> readIORef (queueWaitTimeRef q) + +-- | Signal when the 'queueWaitTime' property value has changed. +queueWaitTimeChanged :: Queue sm so a -> Signal (SamplingStats Double) +queueWaitTimeChanged q = + mapSignalM (const $ queueWaitTime q) (queueWaitTimeChanged_ q) + +-- | Signal when the 'queueWaitTime' property value has changed. +queueWaitTimeChanged_ :: Queue sm so a -> Signal () +queueWaitTimeChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the dequeue wait time from the time at which the item was requested +-- for dequeueing to the time at which it was actually dequeued. +-- +-- See also 'dequeueWaitTimeChanged' and 'dequeueWaitTimeChanged_'. +dequeueWaitTime :: Queue sm so a -> Event (SamplingStats Double) +dequeueWaitTime q = + Event $ \p -> readIORef (dequeueWaitTimeRef q) + +-- | Signal when the 'dequeueWaitTime' property value has changed. +dequeueWaitTimeChanged :: Queue sm so a -> Signal (SamplingStats Double) +dequeueWaitTimeChanged q = + mapSignalM (const $ dequeueWaitTime q) (dequeueWaitTimeChanged_ q) + +-- | Signal when the 'dequeueWaitTime' property value has changed. +dequeueWaitTimeChanged_ :: Queue sm so a -> Signal () +dequeueWaitTimeChanged_ q = + mapSignal (const ()) (dequeueExtracted q) + +-- | Return a long-term average queue rate calculated as +-- the average queue size divided by the average wait time. +-- +-- See also 'queueRateChanged' and 'queueRateChanged_'. +queueRate :: Queue sm so a -> Event Double +queueRate q = + Event $ \p -> + do x <- readIORef (queueCountStatsRef q) + y <- readIORef (queueWaitTimeRef q) + return (timingStatsMean x / samplingStatsMean y) + +-- | Signal when the 'queueRate' property value has changed. +queueRateChanged :: Queue sm so a -> Signal Double +queueRateChanged q = + mapSignalM (const $ queueRate q) (queueRateChanged_ q) + +-- | Signal when the 'queueRate' property value has changed. +queueRateChanged_ :: Queue sm so a -> Signal () +queueRateChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Dequeue suspending the process if the queue is empty. +dequeue :: (DequeueStrategy sm, + EnqueueStrategy so) + => Queue sm so a + -- ^ the queue + -> Process a + -- ^ the dequeued value +dequeue q = + do t <- liftEvent $ dequeueRequest q + requestResource (dequeueRes q) + liftEvent $ dequeueExtract q t + +-- | Dequeue with the output priority suspending the process if the queue is empty. +dequeueWithOutputPriority :: (DequeueStrategy sm, + PriorityQueueStrategy so po) + => Queue sm so a + -- ^ the queue + -> po + -- ^ the priority for output + -> Process a + -- ^ the dequeued value +dequeueWithOutputPriority q po = + do t <- liftEvent $ dequeueRequest q + requestResourceWithPriority (dequeueRes q) po + liftEvent $ dequeueExtract q t + +-- | Try to dequeue immediately. +tryDequeue :: DequeueStrategy sm + => Queue sm so a + -- ^ the queue + -> Event (Maybe a) + -- ^ the dequeued value of 'Nothing' +tryDequeue q = + do x <- tryRequestResourceWithinEvent (dequeueRes q) + if x + then do t <- dequeueRequest q + fmap Just $ dequeueExtract q t + else return Nothing + +-- | Enqueue the item. +enqueue :: (EnqueueStrategy sm, + DequeueStrategy so) + => Queue sm so a + -- ^ the queue + -> a + -- ^ the item to enqueue + -> Event () +enqueue = enqueueStore + +-- | Enqueue with the storing priority the item. +enqueueWithStoringPriority :: (PriorityQueueStrategy sm pm, + DequeueStrategy so) + => Queue sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to enqueue + -> Event () +enqueueWithStoringPriority = enqueueStoreWithPriority + +-- | Return a signal that notifies when the enqueued item +-- is stored in the internal memory of the queue. +enqueueStored :: Queue sm so a -> Signal a +enqueueStored q = publishSignal (enqueueStoredSource q) + +-- | Return a signal that notifies when the dequeuing operation was requested. +dequeueRequested :: Queue sm so a -> Signal () +dequeueRequested q = publishSignal (dequeueRequestedSource q) + +-- | Return a signal that notifies when the item was extracted from the internal +-- storage of the queue and prepared for immediate receiving by the dequeuing process. +dequeueExtracted :: Queue sm so a -> Signal a +dequeueExtracted q = publishSignal (dequeueExtractedSource q) + +-- | Store the item. +enqueueStore :: (EnqueueStrategy sm, + DequeueStrategy so) + => Queue sm so a + -- ^ the queue + -> a + -- ^ the item to be stored + -> Event () +enqueueStore q a = + Event $ \p -> + do let i = QueueItem { itemValue = a, + itemStoringTime = pointTime p } + invokeEvent p $ + strategyEnqueue (queueStore q) i + c <- readIORef (queueCountRef q) + let c' = c + 1 + t = pointTime p + c' `seq` writeIORef (queueCountRef q) c' + modifyIORef' (queueCountStatsRef q) (addTimingStats t c') + modifyIORef' (enqueueStoreCountRef q) (+ 1) + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + invokeEvent p $ + triggerSignal (enqueueStoredSource q) (itemValue i) + +-- | Store with the priority the item. +enqueueStoreWithPriority :: (PriorityQueueStrategy sm pm, + DequeueStrategy so) + => Queue sm so a + -- ^ the queue + -> pm + -- ^ the priority for storing + -> a + -- ^ the item to be enqueued + -> Event () +enqueueStoreWithPriority q pm a = + Event $ \p -> + do let i = QueueItem { itemValue = a, + itemStoringTime = pointTime p } + invokeEvent p $ + strategyEnqueueWithPriority (queueStore q) pm i + c <- readIORef (queueCountRef q) + let c' = c + 1 + t = pointTime p + c' `seq` writeIORef (queueCountRef q) c' + modifyIORef' (queueCountStatsRef q) (addTimingStats t c') + modifyIORef' (enqueueStoreCountRef q) (+ 1) + invokeEvent p $ + releaseResourceWithinEvent (dequeueRes q) + invokeEvent p $ + triggerSignal (enqueueStoredSource q) (itemValue i) + +-- | Accept the dequeuing request and return the current simulation time. +dequeueRequest :: Queue sm so a + -- ^ the queue + -> Event Double + -- ^ the current time +dequeueRequest q = + Event $ \p -> + do modifyIORef' (dequeueCountRef q) (+ 1) + invokeEvent p $ + triggerSignal (dequeueRequestedSource q) () + return $ pointTime p + +-- | Extract an item for the dequeuing request. +dequeueExtract :: DequeueStrategy sm + => Queue sm so a + -- ^ the queue + -> Double + -- ^ the time of the dequeuing request + -> Event a + -- ^ the dequeued value +dequeueExtract q t' = + Event $ \p -> + do i <- invokeEvent p $ + strategyDequeue (queueStore q) + c <- readIORef (queueCountRef q) + let c' = c - 1 + t = pointTime p + c' `seq` writeIORef (queueCountRef q) c' + modifyIORef' (queueCountStatsRef q) (addTimingStats t c') + modifyIORef' (dequeueExtractCountRef q) (+ 1) + invokeEvent p $ + dequeueStat q t' i + invokeEvent p $ + triggerSignal (dequeueExtractedSource q) (itemValue i) + return $ itemValue i + +-- | Update the statistics for the output wait time of the dequeuing operation +-- and the wait time of storing in the queue. +dequeueStat :: Queue sm so a + -- ^ the queue + -> Double + -- ^ the time of the dequeuing request + -> QueueItem a + -- ^ the item and its input time + -> Event () + -- ^ the action of updating the statistics +dequeueStat q t' i = + Event $ \p -> + do let t1 = itemStoringTime i + t = pointTime p + modifyIORef' (dequeueWaitTimeRef q) $ + addSamplingStats (t - t') + modifyIORef' (queueWaitTimeRef q) $ + addSamplingStats (t - t1) + +-- | Signal whenever any property of the queue changes. +-- +-- The property must have the corresponded signal. There are also characteristics +-- similar to the properties but that have no signals. As a rule, such characteristics +-- already depend on the simulation time and therefore they may change at any +-- time point. +queueChanged_ :: Queue sm so a -> Signal () +queueChanged_ q = + mapSignal (const ()) (enqueueStored q) <> + dequeueRequested q <> + mapSignal (const ()) (dequeueExtracted q) + +-- | Return the summary for the queue with desciption of its +-- properties and activities using the specified indent. +queueSummary :: (Show sm, Show so) => Queue sm so a -> Int -> Event ShowS +queueSummary q indent = + do let sm = enqueueStoringStrategy q + so = dequeueStrategy q + null <- queueNull q + count <- queueCount q + countStats <- queueCountStats q + enqueueStoreCount <- enqueueStoreCount q + dequeueCount <- dequeueCount q + dequeueExtractCount <- dequeueExtractCount q + enqueueStoreRate <- enqueueStoreRate q + dequeueRate <- dequeueRate q + dequeueExtractRate <- dequeueExtractRate q + waitTime <- queueWaitTime q + dequeueWaitTime <- dequeueWaitTime q + let tab = replicate indent ' ' + return $ + showString tab . + showString "the storing (memory) strategy = " . + shows sm . + showString "\n" . + showString tab . + showString "the dequeueing (output) strategy = " . + shows so . + showString "\n" . + showString tab . + showString "empty? = " . + shows null . + showString "\n" . + showString tab . + showString "the current size = " . + shows count . + showString "\n" . + showString tab . + showString "the size statistics = \n\n" . + timingStatsSummary countStats (2 + indent) . + showString "\n\n" . + showString tab . + showString "the enqueue store count (number of the input items that were stored) = " . + shows enqueueStoreCount . + showString "\n" . + showString tab . + showString "the dequeue count (number of requests for dequeueing an item) = " . + shows dequeueCount . + showString "\n" . + showString tab . + showString "the dequeue extract count (number of the output items that were dequeued) = " . + shows dequeueExtractCount . + showString "\n" . + showString tab . + showString "the enqueue store rate (how many input items were stored per time) = " . + shows enqueueStoreRate . + showString "\n" . + showString tab . + showString "the dequeue rate (how many requests for dequeueing per time) = " . + shows dequeueRate . + showString "\n" . + showString tab . + showString "the dequeue extract rate (how many output items were dequeued per time) = " . + shows dequeueExtractRate . + showString "\n" . + showString tab . + showString "the wait time (when was stored -> when was dequeued) = \n\n" . + samplingStatsSummary waitTime (2 + indent) . + showString "\n\n" . + showString tab . + showString "the dequeue wait time (when was requested for dequeueing -> when was dequeued) = \n\n" . + samplingStatsSummary dequeueWaitTime (2 + indent) diff --git a/Simulation/Aivika/QueueStrategy.hs b/Simulation/Aivika/QueueStrategy.hs --- a/Simulation/Aivika/QueueStrategy.hs +++ b/Simulation/Aivika/QueueStrategy.hs @@ -1,178 +1,187 @@ - -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} - --- | --- Module : Simulation.Aivika.QueueStrategy --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines the queue strategies. --- -module Simulation.Aivika.QueueStrategy - (-- * Strategy Classes - QueueStrategy(..), - DequeueStrategy(..), - EnqueueStrategy(..), - PriorityQueueStrategy(..), - -- * Strategy Instances - FCFS(..), - LCFS(..), - SIRO(..), - StaticPriorities(..)) where - -import System.Random -import Control.Monad.Trans - -import Simulation.Aivika.Simulation -import Simulation.Aivika.Event -import Simulation.Aivika.DoubleLinkedList -import qualified Simulation.Aivika.PriorityQueue as PQ -import qualified Simulation.Aivika.Vector as V - --- | Defines the basic queue strategy. -class QueueStrategy s q | s -> q where - - -- | Create a new queue by the specified strategy. - newStrategyQueue :: s - -- ^ the strategy - -> Simulation (q i) - -- ^ a new queue - - -- | Test whether the queue is empty. - strategyQueueNull :: s - -- ^ the strategy - -> q i - -- ^ the queue - -> Event Bool - -- ^ the result of the test - --- | Defines a strategy with support of the dequeuing operation. -class QueueStrategy s q => DequeueStrategy s q | s -> q where - - -- | Dequeue the front element and return it. - strategyDequeue :: s - -- ^ the strategy - -> q i - -- ^ the queue - -> Event i - -- ^ the dequeued element - --- | It defines a strategy when we can enqueue a single element. -class DequeueStrategy s q => EnqueueStrategy s q | s -> q where - - -- | Enqueue an element. - strategyEnqueue :: s - -- ^ the strategy - -> q i - -- ^ the queue - -> i - -- ^ the element to be enqueued - -> Event () - -- ^ the action of enqueuing - --- | It defines a strategy when we can enqueue an element with the specified priority. -class DequeueStrategy s q => PriorityQueueStrategy s q p | s -> q, s -> p where - - -- | Enqueue an element with the specified priority. - strategyEnqueueWithPriority :: s - -- ^ the strategy - -> q i - -- ^ the queue - -> p - -- ^ the priority - -> i - -- ^ the element to be enqueued - -> Event () - -- ^ the action of enqueuing - --- | Strategy: First Come - First Served (FCFS). -data FCFS = FCFS deriving (Eq, Ord, Show) - --- | Strategy: Last Come - First Served (LCFS) -data LCFS = LCFS deriving (Eq, Ord, Show) - --- | Strategy: Service in Random Order (SIRO). -data SIRO = SIRO deriving (Eq, Ord, Show) - --- | Strategy: Static Priorities. It uses the priority queue. -data StaticPriorities = StaticPriorities deriving (Eq, Ord, Show) - -instance QueueStrategy FCFS DoubleLinkedList where - - newStrategyQueue s = liftIO newList - - strategyQueueNull s q = liftIO $ listNull q - -instance DequeueStrategy FCFS DoubleLinkedList where - - strategyDequeue s q = - liftIO $ - do i <- listFirst q - listRemoveFirst q - return i - -instance EnqueueStrategy FCFS DoubleLinkedList where - - strategyEnqueue s q i = liftIO $ listAddLast q i - -instance QueueStrategy LCFS DoubleLinkedList where - - newStrategyQueue s = liftIO newList - - strategyQueueNull s q = liftIO $ listNull q - -instance DequeueStrategy LCFS DoubleLinkedList where - - strategyDequeue s q = - liftIO $ - do i <- listFirst q - listRemoveFirst q - return i - -instance EnqueueStrategy LCFS DoubleLinkedList where - - strategyEnqueue s q i = liftIO $ listInsertFirst q i - -instance QueueStrategy StaticPriorities PQ.PriorityQueue where - - newStrategyQueue s = liftIO PQ.newQueue - - strategyQueueNull s q = liftIO $ PQ.queueNull q - -instance DequeueStrategy StaticPriorities PQ.PriorityQueue where - - strategyDequeue s q = - liftIO $ - do (_, i) <- PQ.queueFront q - PQ.dequeue q - return i - -instance PriorityQueueStrategy StaticPriorities PQ.PriorityQueue Double where - - strategyEnqueueWithPriority s q p i = liftIO $ PQ.enqueue q p i - -instance QueueStrategy SIRO V.Vector where - - newStrategyQueue s = liftIO V.newVector - - strategyQueueNull s q = - liftIO $ - do n <- V.vectorCount q - return (n == 0) - -instance DequeueStrategy SIRO V.Vector where - - strategyDequeue s q = - liftIO $ - do n <- V.vectorCount q - i <- getStdRandom (randomR (0, n - 1)) - x <- V.readVector q i - V.vectorDeleteAt q i - return x - -instance EnqueueStrategy SIRO V.Vector where - - strategyEnqueue s q i = liftIO $ V.appendVector q i + +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FunctionalDependencies #-} + +-- | +-- Module : Simulation.Aivika.QueueStrategy +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the queue strategies. +-- +module Simulation.Aivika.QueueStrategy where + +import System.Random +import Control.Monad.Trans + +import Simulation.Aivika.Simulation +import Simulation.Aivika.Event +import Simulation.Aivika.DoubleLinkedList +import qualified Simulation.Aivika.PriorityQueue as PQ +import qualified Simulation.Aivika.Vector as V + +-- | Defines the basic queue strategy. +class QueueStrategy s where + + -- | A queue used by the strategy. + data StrategyQueue s :: * -> * + + -- | Create a new queue by the specified strategy. + newStrategyQueue :: s + -- ^ the strategy + -> Simulation (StrategyQueue s i) + -- ^ a new queue + + -- | Test whether the queue is empty. + strategyQueueNull :: StrategyQueue s i + -- ^ the queue + -> Event Bool + -- ^ the result of the test + +-- | Defines a strategy with support of the dequeuing operation. +class QueueStrategy s => DequeueStrategy s where + + -- | Dequeue the front element and return it. + strategyDequeue :: StrategyQueue s i + -- ^ the queue + -> Event i + -- ^ the dequeued element + +-- | It defines a strategy when we can enqueue a single element. +class DequeueStrategy s => EnqueueStrategy s where + + -- | Enqueue an element. + strategyEnqueue :: StrategyQueue s i + -- ^ the queue + -> i + -- ^ the element to be enqueued + -> Event () + -- ^ the action of enqueuing + +-- | It defines a strategy when we can enqueue an element with the specified priority. +class DequeueStrategy s => PriorityQueueStrategy s p | s -> p where + + -- | Enqueue an element with the specified priority. + strategyEnqueueWithPriority :: StrategyQueue s i + -- ^ the queue + -> p + -- ^ the priority + -> i + -- ^ the element to be enqueued + -> Event () + -- ^ the action of enqueuing + +-- | Strategy: First Come - First Served (FCFS). +data FCFS = FCFS deriving (Eq, Ord, Show) + +-- | Strategy: Last Come - First Served (LCFS) +data LCFS = LCFS deriving (Eq, Ord, Show) + +-- | Strategy: Service in Random Order (SIRO). +data SIRO = SIRO deriving (Eq, Ord, Show) + +-- | Strategy: Static Priorities. It uses the priority queue. +data StaticPriorities = StaticPriorities deriving (Eq, Ord, Show) + +-- | An implementation of the 'FCFS' queue strategy. +instance QueueStrategy FCFS where + + -- | A queue used by the 'FCFS' strategy. + newtype StrategyQueue FCFS i = FCFSQueue (DoubleLinkedList i) + + newStrategyQueue s = fmap FCFSQueue $ liftIO newList + + strategyQueueNull (FCFSQueue q) = liftIO $ listNull q + +-- | An implementation of the 'FCFS' queue strategy. +instance DequeueStrategy FCFS where + + strategyDequeue (FCFSQueue q) = + liftIO $ + do i <- listFirst q + listRemoveFirst q + return i + +-- | An implementation of the 'FCFS' queue strategy. +instance EnqueueStrategy FCFS where + + strategyEnqueue (FCFSQueue q) i = liftIO $ listAddLast q i + +-- | An implementation of the 'LCFS' queue strategy. +instance QueueStrategy LCFS where + + -- | A queue used by the 'LCFS' strategy. + newtype StrategyQueue LCFS i = LCFSQueue (DoubleLinkedList i) + + newStrategyQueue s = fmap LCFSQueue $ liftIO newList + + strategyQueueNull (LCFSQueue q) = liftIO $ listNull q + +-- | An implementation of the 'LCFS' queue strategy. +instance DequeueStrategy LCFS where + + strategyDequeue (LCFSQueue q) = + liftIO $ + do i <- listFirst q + listRemoveFirst q + return i + +-- | An implementation of the 'LCFS' queue strategy. +instance EnqueueStrategy LCFS where + + strategyEnqueue (LCFSQueue q) i = liftIO $ listInsertFirst q i + +-- | An implementation of the 'StaticPriorities' queue strategy. +instance QueueStrategy StaticPriorities where + + -- | A queue used by the 'StaticPriorities' strategy. + newtype StrategyQueue StaticPriorities i = StaticPriorityQueue (PQ.PriorityQueue i) + + newStrategyQueue s = fmap StaticPriorityQueue $ liftIO PQ.newQueue + + strategyQueueNull (StaticPriorityQueue q) = liftIO $ PQ.queueNull q + +-- | An implementation of the 'StaticPriorities' queue strategy. +instance DequeueStrategy StaticPriorities where + + strategyDequeue (StaticPriorityQueue q) = + liftIO $ + do (_, i) <- PQ.queueFront q + PQ.dequeue q + return i + +-- | An implementation of the 'StaticPriorities' queue strategy. +instance PriorityQueueStrategy StaticPriorities Double where + + strategyEnqueueWithPriority (StaticPriorityQueue q) p i = liftIO $ PQ.enqueue q p i + +-- | An implementation of the 'SIRO' queue strategy. +instance QueueStrategy SIRO where + + -- | A queue used by the 'SIRO' strategy. + newtype StrategyQueue SIRO i = SIROQueue (V.Vector i) + + newStrategyQueue s = fmap SIROQueue $ liftIO V.newVector + + strategyQueueNull (SIROQueue q) = + liftIO $ + do n <- V.vectorCount q + return (n == 0) + +-- | An implementation of the 'SIRO' queue strategy. +instance DequeueStrategy SIRO where + + strategyDequeue (SIROQueue q) = + liftIO $ + do n <- V.vectorCount q + i <- getStdRandom (randomR (0, n - 1)) + x <- V.readVector q i + V.vectorDeleteAt q i + return x + +-- | An implementation of the 'SIRO' queue strategy. +instance EnqueueStrategy SIRO where + + strategyEnqueue (SIROQueue q) i = liftIO $ V.appendVector q i diff --git a/Simulation/Aivika/Ref.hs b/Simulation/Aivika/Ref.hs --- a/Simulation/Aivika/Ref.hs +++ b/Simulation/Aivika/Ref.hs @@ -1,69 +1,69 @@ - --- | --- Module : Simulation.Aivika.Ref --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines an updatable reference that depends on the event queue. --- -module Simulation.Aivika.Ref - (Ref, - refChanged, - refChanged_, - newRef, - readRef, - writeRef, - modifyRef) where - -import Data.IORef -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Internal.Simulation -import Simulation.Aivika.Internal.Event -import Simulation.Aivika.Internal.Signal -import Simulation.Aivika.Signal - --- | The 'Ref' type represents a mutable variable similar to the 'IORef' variable --- but only dependent on the event queue, which allows synchronizing the reference --- with the model explicitly through the 'Event' monad. -data Ref a = - Ref { refValue :: IORef a, - refChangedSource :: SignalSource a } - --- | Create a new reference. -newRef :: a -> Simulation (Ref a) -newRef a = - do x <- liftIO $ newIORef a - s <- newSignalSource - return Ref { refValue = x, - refChangedSource = s } - --- | Read the value of a reference. -readRef :: Ref a -> Event a -readRef r = Event $ \p -> readIORef (refValue r) - --- | Write a new value into the reference. -writeRef :: Ref a -> a -> Event () -writeRef r a = Event $ \p -> - do a `seq` writeIORef (refValue r) a - invokeEvent p $ triggerSignal (refChangedSource r) a - --- | Mutate the contents of the reference. -modifyRef :: Ref a -> (a -> a) -> Event () -modifyRef r f = Event $ \p -> - do a <- readIORef (refValue r) - let b = f a - b `seq` writeIORef (refValue r) b - invokeEvent p $ triggerSignal (refChangedSource r) b - --- | Return a signal that notifies about every change of the reference state. -refChanged :: Ref a -> Signal a -refChanged v = publishSignal (refChangedSource v) - --- | Return a signal that notifies about every change of the reference state. -refChanged_ :: Ref a -> Signal () -refChanged_ r = mapSignal (const ()) $ refChanged r + +-- | +-- Module : Simulation.Aivika.Ref +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines an updatable reference that depends on the event queue. +-- +module Simulation.Aivika.Ref + (Ref, + refChanged, + refChanged_, + newRef, + readRef, + writeRef, + modifyRef) where + +import Data.IORef +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Internal.Simulation +import Simulation.Aivika.Internal.Event +import Simulation.Aivika.Internal.Signal +import Simulation.Aivika.Signal + +-- | The 'Ref' type represents a mutable variable similar to the 'IORef' variable +-- but only dependent on the event queue, which allows synchronizing the reference +-- with the model explicitly through the 'Event' monad. +data Ref a = + Ref { refValue :: IORef a, + refChangedSource :: SignalSource a } + +-- | Create a new reference. +newRef :: a -> Simulation (Ref a) +newRef a = + do x <- liftIO $ newIORef a + s <- newSignalSource + return Ref { refValue = x, + refChangedSource = s } + +-- | Read the value of a reference. +readRef :: Ref a -> Event a +readRef r = Event $ \p -> readIORef (refValue r) + +-- | Write a new value into the reference. +writeRef :: Ref a -> a -> Event () +writeRef r a = Event $ \p -> + do a `seq` writeIORef (refValue r) a + invokeEvent p $ triggerSignal (refChangedSource r) a + +-- | Mutate the contents of the reference. +modifyRef :: Ref a -> (a -> a) -> Event () +modifyRef r f = Event $ \p -> + do a <- readIORef (refValue r) + let b = f a + b `seq` writeIORef (refValue r) b + invokeEvent p $ triggerSignal (refChangedSource r) b + +-- | Return a signal that notifies about every change of the reference state. +refChanged :: Ref a -> Signal a +refChanged v = publishSignal (refChangedSource v) + +-- | Return a signal that notifies about every change of the reference state. +refChanged_ :: Ref a -> Signal () +refChanged_ r = mapSignal (const ()) $ refChanged r diff --git a/Simulation/Aivika/Ref/Light.hs b/Simulation/Aivika/Ref/Light.hs deleted file mode 100644 --- a/Simulation/Aivika/Ref/Light.hs +++ /dev/null @@ -1,53 +0,0 @@ - --- | --- Module : Simulation.Aivika.Ref.Light --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- This module defines a light-weight and more fast version of an updatable reference --- that depends on the event queue but that doesn't supply with the signal notification. --- -module Simulation.Aivika.Ref.Light - (Ref, - newRef, - readRef, - writeRef, - modifyRef) where - -import Data.IORef -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Internal.Simulation -import Simulation.Aivika.Internal.Event - --- | The 'Ref' type represents a mutable variable similar to the 'IORef' variable --- but only dependent on the event queue, which allows synchronizing the reference --- with the model explicitly through the 'Event' monad. -newtype Ref a = - Ref { refValue :: IORef a } - --- | Create a new reference. -newRef :: a -> Simulation (Ref a) -newRef a = - do x <- liftIO $ newIORef a - return Ref { refValue = x } - --- | Read the value of a reference. -readRef :: Ref a -> Event a -readRef r = Event $ \p -> readIORef (refValue r) - --- | Write a new value into the reference. -writeRef :: Ref a -> a -> Event () -writeRef r a = Event $ \p -> - a `seq` writeIORef (refValue r) a - --- | Mutate the contents of the reference. -modifyRef :: Ref a -> (a -> a) -> Event () -modifyRef r f = Event $ \p -> - do a <- readIORef (refValue r) - let b = f a - b `seq` writeIORef (refValue r) b diff --git a/Simulation/Aivika/Ref/Plain.hs b/Simulation/Aivika/Ref/Plain.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Ref/Plain.hs @@ -0,0 +1,53 @@ + +-- | +-- Module : Simulation.Aivika.Ref.Plain +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines a light-weight and more fast version of an updatable reference +-- that depends on the event queue but that doesn't supply with the signal notification. +-- +module Simulation.Aivika.Ref.Plain + (Ref, + newRef, + readRef, + writeRef, + modifyRef) where + +import Data.IORef +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Internal.Simulation +import Simulation.Aivika.Internal.Event + +-- | The 'Ref' type represents a mutable variable similar to the 'IORef' variable +-- but only dependent on the event queue, which allows synchronizing the reference +-- with the model explicitly through the 'Event' monad. +newtype Ref a = + Ref { refValue :: IORef a } + +-- | Create a new reference. +newRef :: a -> Simulation (Ref a) +newRef a = + do x <- liftIO $ newIORef a + return Ref { refValue = x } + +-- | Read the value of a reference. +readRef :: Ref a -> Event a +readRef r = Event $ \p -> readIORef (refValue r) + +-- | Write a new value into the reference. +writeRef :: Ref a -> a -> Event () +writeRef r a = Event $ \p -> + a `seq` writeIORef (refValue r) a + +-- | Mutate the contents of the reference. +modifyRef :: Ref a -> (a -> a) -> Event () +modifyRef r f = Event $ \p -> + do a <- readIORef (refValue r) + let b = f a + b `seq` writeIORef (refValue r) b diff --git a/Simulation/Aivika/Resource.hs b/Simulation/Aivika/Resource.hs --- a/Simulation/Aivika/Resource.hs +++ b/Simulation/Aivika/Resource.hs @@ -1,336 +1,335 @@ - --- | --- Module : Simulation.Aivika.Resource --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines the resource which can be acquired and --- then released by the discontinuous process 'Process'. --- The resource can be either limited by the upper bound --- (run-time check), or it can have no upper bound. The latter --- is useful for modeling the infinite queue, for example. --- -module Simulation.Aivika.Resource - (-- * Resource Types - FCFSResource, - LCFSResource, - SIROResource, - PriorityResource, - Resource, - -- * Creating Resource - newFCFSResource, - newFCFSResourceWithMaxCount, - newLCFSResource, - newLCFSResourceWithMaxCount, - newSIROResource, - newSIROResourceWithMaxCount, - newPriorityResource, - newPriorityResourceWithMaxCount, - newResource, - newResourceWithMaxCount, - -- * Resource Properties - resourceStrategy, - resourceMaxCount, - resourceCount, - -- * Requesting for and Releasing Resource - requestResource, - requestResourceWithPriority, - tryRequestResourceWithinEvent, - releaseResource, - releaseResourceWithinEvent, - usingResource, - usingResourceWithPriority) where - -import Data.IORef -import Control.Monad -import Control.Monad.Trans -import Control.Exception - -import Simulation.Aivika.Internal.Specs -import Simulation.Aivika.Internal.Simulation -import Simulation.Aivika.Internal.Event -import Simulation.Aivika.Internal.Cont -import Simulation.Aivika.Internal.Process -import Simulation.Aivika.QueueStrategy - -import qualified Simulation.Aivika.DoubleLinkedList as DLL -import qualified Simulation.Aivika.Vector as V -import qualified Simulation.Aivika.PriorityQueue as PQ - --- | The ordinary FCFS (First Come - First Serviced) resource. -type FCFSResource = Resource FCFS DLL.DoubleLinkedList - --- | The ordinary LCFS (Last Come - First Serviced) resource. -type LCFSResource = Resource LCFS DLL.DoubleLinkedList - --- | The SIRO (Serviced in Random Order) resource. -type SIROResource = Resource SIRO V.Vector - --- | The resource with static priorities. -type PriorityResource = Resource StaticPriorities PQ.PriorityQueue - --- | Represents the resource with strategy @s@ applied for queuing the requests. --- The @q@ type is dependent and it is usually derived automatically. -data Resource s q = - Resource { resourceStrategy :: s, - -- ^ Return the strategy applied for queuing the requests. - resourceMaxCount :: Maybe Int, - -- ^ Return the maximum count of the resource, where 'Nothing' - -- means that the resource has no upper bound. - resourceCountRef :: IORef Int, - resourceWaitList :: q (Event (Maybe (ContParams ()))) } - -instance Eq (Resource s q) where - x == y = resourceCountRef x == resourceCountRef y -- unique references - --- | Create a new FCFS resource with the specified initial count which value becomes --- the upper bound as well. -newFCFSResource :: Int - -- ^ the initial count (and maximal count too) of the resource - -> Simulation FCFSResource -newFCFSResource = newResource FCFS - --- | Create a new FCFS resource with the specified initial and maximum counts, --- where 'Nothing' means that the resource has no upper bound. -newFCFSResourceWithMaxCount :: Int - -- ^ the initial count of the resource - -> Maybe Int - -- ^ the maximum count of the resource, which can be indefinite - -> Simulation FCFSResource -newFCFSResourceWithMaxCount = newResourceWithMaxCount FCFS - --- | Create a new LCFS resource with the specified initial count which value becomes --- the upper bound as well. -newLCFSResource :: Int - -- ^ the initial count (and maximal count too) of the resource - -> Simulation LCFSResource -newLCFSResource = newResource LCFS - --- | Create a new LCFS resource with the specified initial and maximum counts, --- where 'Nothing' means that the resource has no upper bound. -newLCFSResourceWithMaxCount :: Int - -- ^ the initial count of the resource - -> Maybe Int - -- ^ the maximum count of the resource, which can be indefinite - -> Simulation LCFSResource -newLCFSResourceWithMaxCount = newResourceWithMaxCount LCFS - --- | Create a new SIRO resource with the specified initial count which value becomes --- the upper bound as well. -newSIROResource :: Int - -- ^ the initial count (and maximal count too) of the resource - -> Simulation SIROResource -newSIROResource = newResource SIRO - --- | Create a new SIRO resource with the specified initial and maximum counts, --- where 'Nothing' means that the resource has no upper bound. -newSIROResourceWithMaxCount :: Int - -- ^ the initial count of the resource - -> Maybe Int - -- ^ the maximum count of the resource, which can be indefinite - -> Simulation SIROResource -newSIROResourceWithMaxCount = newResourceWithMaxCount SIRO - --- | Create a new priority resource with the specified initial count which value becomes --- the upper bound as well. -newPriorityResource :: Int - -- ^ the initial count (and maximal count too) of the resource - -> Simulation PriorityResource -newPriorityResource = newResource StaticPriorities - --- | Create a new priority resource with the specified initial and maximum counts, --- where 'Nothing' means that the resource has no upper bound. -newPriorityResourceWithMaxCount :: Int - -- ^ the initial count of the resource - -> Maybe Int - -- ^ the maximum count of the resource, which can be indefinite - -> Simulation PriorityResource -newPriorityResourceWithMaxCount = newResourceWithMaxCount StaticPriorities - --- | Create a new resource with the specified queue strategy and initial count. --- The last value becomes the upper bound as well. -newResource :: QueueStrategy s q - => s - -- ^ the strategy for managing the queuing requests - -> Int - -- ^ the initial count (and maximal count too) of the resource - -> Simulation (Resource s q) -newResource s count = - Simulation $ \r -> - do when (count < 0) $ - error $ - "The resource count cannot be negative: " ++ - "newResource." - countRef <- newIORef count - waitList <- invokeSimulation r $ newStrategyQueue s - return Resource { resourceStrategy = s, - resourceMaxCount = Just count, - resourceCountRef = countRef, - resourceWaitList = waitList } - --- | Create a new resource with the specified queue strategy, initial and maximum counts, --- where 'Nothing' means that the resource has no upper bound. -newResourceWithMaxCount :: QueueStrategy s q - => s - -- ^ the strategy for managing the queuing requests - -> Int - -- ^ the initial count of the resource - -> Maybe Int - -- ^ the maximum count of the resource, which can be indefinite - -> Simulation (Resource s q) -newResourceWithMaxCount s count maxCount = - Simulation $ \r -> - do when (count < 0) $ - error $ - "The resource count cannot be negative: " ++ - "newResourceWithMaxCount." - case maxCount of - Just maxCount | count > maxCount -> - error $ - "The resource count cannot be greater than " ++ - "its maximum value: newResourceWithMaxCount." - _ -> - return () - countRef <- newIORef count - waitList <- invokeSimulation r $ newStrategyQueue s - return Resource { resourceStrategy = s, - resourceMaxCount = maxCount, - resourceCountRef = countRef, - resourceWaitList = waitList } - --- | Return the current count of the resource. -resourceCount :: Resource s q -> Event Int -resourceCount r = - Event $ \p -> readIORef (resourceCountRef r) - --- | Request for the resource decreasing its count in case of success, --- otherwise suspending the discontinuous process until some other --- process releases the resource. -requestResource :: EnqueueStrategy s q - => Resource s q - -- ^ the requested resource - -> Process () -requestResource r = - Process $ \pid -> - Cont $ \c -> - Event $ \p -> - do a <- readIORef (resourceCountRef r) - if a == 0 - then do c <- invokeEvent p $ contFreeze c - invokeEvent p $ - strategyEnqueue (resourceStrategy r) (resourceWaitList r) c - else do let a' = a - 1 - a' `seq` writeIORef (resourceCountRef r) a' - invokeEvent p $ resumeCont c () - --- | Request with the priority for the resource decreasing its count --- in case of success, otherwise suspending the discontinuous process --- until some other process releases the resource. -requestResourceWithPriority :: PriorityQueueStrategy s q p - => Resource s q - -- ^ the requested resource - -> p - -- ^ the priority - -> Process () -requestResourceWithPriority r priority = - Process $ \pid -> - Cont $ \c -> - Event $ \p -> - do a <- readIORef (resourceCountRef r) - if a == 0 - then do c <- invokeEvent p $ contFreeze c - invokeEvent p $ - strategyEnqueueWithPriority (resourceStrategy r) (resourceWaitList r) priority c - else do let a' = a - 1 - a' `seq` writeIORef (resourceCountRef r) a' - invokeEvent p $ resumeCont c () - --- | Release the resource increasing its count and resuming one of the --- previously suspended processes as possible. -releaseResource :: DequeueStrategy s q - => Resource s q - -- ^ the resource to release - -> Process () -releaseResource r = - Process $ \_ -> - Cont $ \c -> - Event $ \p -> - do invokeEvent p $ releaseResourceWithinEvent r - invokeEvent p $ resumeCont c () - --- | Release the resource increasing its count and resuming one of the --- previously suspended processes as possible. -releaseResourceWithinEvent :: DequeueStrategy s q - => Resource s q - -- ^ the resource to release - -> Event () -releaseResourceWithinEvent r = - Event $ \p -> - do a <- readIORef (resourceCountRef r) - let a' = a + 1 - case resourceMaxCount r of - Just maxCount | a' > maxCount -> - error $ - "The resource count cannot be greater than " ++ - "its maximum value: releaseResourceWithinEvent." - _ -> - return () - f <- invokeEvent p $ - strategyQueueNull (resourceStrategy r) (resourceWaitList r) - if f - then a' `seq` writeIORef (resourceCountRef r) a' - else do c <- invokeEvent p $ - strategyDequeue (resourceStrategy r) (resourceWaitList r) - c <- invokeEvent p c - case c of - Nothing -> - invokeEvent p $ releaseResourceWithinEvent r - Just c -> - invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c () - --- | Try to request for the resource decreasing its count in case of success --- and returning 'True' in the 'Event' monad; otherwise, returning 'False'. -tryRequestResourceWithinEvent :: Resource s q - -- ^ the resource which we try to request for - -> Event Bool -tryRequestResourceWithinEvent r = - Event $ \p -> - do a <- readIORef (resourceCountRef r) - if a == 0 - then return False - else do let a' = a - 1 - a' `seq` writeIORef (resourceCountRef r) a' - return True - --- | Acquire the resource, perform some action and safely release the resource --- in the end, even if the 'IOException' was raised within the action. -usingResource :: EnqueueStrategy s q - => Resource s q - -- ^ the resource we are going to request for and then release in the end - -> Process a - -- ^ the action we are going to apply having the resource - -> Process a - -- ^ the result of the action -usingResource r m = - do requestResource r - finallyProcess m $ releaseResource r - --- | Acquire the resource with the specified priority, perform some action and --- safely release the resource in the end, even if the 'IOException' was raised --- within the action. -usingResourceWithPriority :: PriorityQueueStrategy s q p - => Resource s q - -- ^ the resource we are going to request for and then - -- release in the end - -> p - -- ^ the priority - -> Process a - -- ^ the action we are going to apply having the resource - -> Process a - -- ^ the result of the action -usingResourceWithPriority r priority m = - do requestResourceWithPriority r priority - finallyProcess m $ releaseResource r + +-- | +-- Module : Simulation.Aivika.Resource +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the resource which can be acquired and +-- then released by the discontinuous process 'Process'. +-- The resource can be either limited by the upper bound +-- (run-time check), or it can have no upper bound. The latter +-- is useful for modeling the infinite queue, for example. +-- +module Simulation.Aivika.Resource + (-- * Resource Types + FCFSResource, + LCFSResource, + SIROResource, + PriorityResource, + Resource, + -- * Creating Resource + newFCFSResource, + newFCFSResourceWithMaxCount, + newLCFSResource, + newLCFSResourceWithMaxCount, + newSIROResource, + newSIROResourceWithMaxCount, + newPriorityResource, + newPriorityResourceWithMaxCount, + newResource, + newResourceWithMaxCount, + -- * Resource Properties + resourceStrategy, + resourceMaxCount, + resourceCount, + -- * Requesting for and Releasing Resource + requestResource, + requestResourceWithPriority, + tryRequestResourceWithinEvent, + releaseResource, + releaseResourceWithinEvent, + usingResource, + usingResourceWithPriority) where + +import Data.IORef +import Control.Monad +import Control.Monad.Trans +import Control.Exception + +import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Simulation +import Simulation.Aivika.Internal.Event +import Simulation.Aivika.Internal.Cont +import Simulation.Aivika.Internal.Process +import Simulation.Aivika.QueueStrategy + +import qualified Simulation.Aivika.DoubleLinkedList as DLL +import qualified Simulation.Aivika.Vector as V +import qualified Simulation.Aivika.PriorityQueue as PQ + +-- | The ordinary FCFS (First Come - First Serviced) resource. +type FCFSResource = Resource FCFS + +-- | The ordinary LCFS (Last Come - First Serviced) resource. +type LCFSResource = Resource LCFS + +-- | The SIRO (Serviced in Random Order) resource. +type SIROResource = Resource SIRO + +-- | The resource with static priorities. +type PriorityResource = Resource StaticPriorities + +-- | Represents the resource with strategy @s@ applied for queuing the requests. +data Resource s = + Resource { resourceStrategy :: s, + -- ^ Return the strategy applied for queuing the requests. + resourceMaxCount :: Maybe Int, + -- ^ Return the maximum count of the resource, where 'Nothing' + -- means that the resource has no upper bound. + resourceCountRef :: IORef Int, + resourceWaitList :: StrategyQueue s (Event (Maybe (ContParams ()))) } + +instance Eq (Resource s) where + x == y = resourceCountRef x == resourceCountRef y -- unique references + +-- | Create a new FCFS resource with the specified initial count which value becomes +-- the upper bound as well. +newFCFSResource :: Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation FCFSResource +newFCFSResource = newResource FCFS + +-- | Create a new FCFS resource with the specified initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newFCFSResourceWithMaxCount :: Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation FCFSResource +newFCFSResourceWithMaxCount = newResourceWithMaxCount FCFS + +-- | Create a new LCFS resource with the specified initial count which value becomes +-- the upper bound as well. +newLCFSResource :: Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation LCFSResource +newLCFSResource = newResource LCFS + +-- | Create a new LCFS resource with the specified initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newLCFSResourceWithMaxCount :: Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation LCFSResource +newLCFSResourceWithMaxCount = newResourceWithMaxCount LCFS + +-- | Create a new SIRO resource with the specified initial count which value becomes +-- the upper bound as well. +newSIROResource :: Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation SIROResource +newSIROResource = newResource SIRO + +-- | Create a new SIRO resource with the specified initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newSIROResourceWithMaxCount :: Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation SIROResource +newSIROResourceWithMaxCount = newResourceWithMaxCount SIRO + +-- | Create a new priority resource with the specified initial count which value becomes +-- the upper bound as well. +newPriorityResource :: Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation PriorityResource +newPriorityResource = newResource StaticPriorities + +-- | Create a new priority resource with the specified initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newPriorityResourceWithMaxCount :: Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation PriorityResource +newPriorityResourceWithMaxCount = newResourceWithMaxCount StaticPriorities + +-- | Create a new resource with the specified queue strategy and initial count. +-- The last value becomes the upper bound as well. +newResource :: QueueStrategy s + => s + -- ^ the strategy for managing the queuing requests + -> Int + -- ^ the initial count (and maximal count too) of the resource + -> Simulation (Resource s) +newResource s count = + Simulation $ \r -> + do when (count < 0) $ + error $ + "The resource count cannot be negative: " ++ + "newResource." + countRef <- newIORef count + waitList <- invokeSimulation r $ newStrategyQueue s + return Resource { resourceStrategy = s, + resourceMaxCount = Just count, + resourceCountRef = countRef, + resourceWaitList = waitList } + +-- | Create a new resource with the specified queue strategy, initial and maximum counts, +-- where 'Nothing' means that the resource has no upper bound. +newResourceWithMaxCount :: QueueStrategy s + => s + -- ^ the strategy for managing the queuing requests + -> Int + -- ^ the initial count of the resource + -> Maybe Int + -- ^ the maximum count of the resource, which can be indefinite + -> Simulation (Resource s) +newResourceWithMaxCount s count maxCount = + Simulation $ \r -> + do when (count < 0) $ + error $ + "The resource count cannot be negative: " ++ + "newResourceWithMaxCount." + case maxCount of + Just maxCount | count > maxCount -> + error $ + "The resource count cannot be greater than " ++ + "its maximum value: newResourceWithMaxCount." + _ -> + return () + countRef <- newIORef count + waitList <- invokeSimulation r $ newStrategyQueue s + return Resource { resourceStrategy = s, + resourceMaxCount = maxCount, + resourceCountRef = countRef, + resourceWaitList = waitList } + +-- | Return the current count of the resource. +resourceCount :: Resource s -> Event Int +resourceCount r = + Event $ \p -> readIORef (resourceCountRef r) + +-- | Request for the resource decreasing its count in case of success, +-- otherwise suspending the discontinuous process until some other +-- process releases the resource. +requestResource :: EnqueueStrategy s + => Resource s + -- ^ the requested resource + -> Process () +requestResource r = + Process $ \pid -> + Cont $ \c -> + Event $ \p -> + do a <- readIORef (resourceCountRef r) + if a == 0 + then do c <- invokeEvent p $ contFreeze c + invokeEvent p $ + strategyEnqueue (resourceWaitList r) c + else do let a' = a - 1 + a' `seq` writeIORef (resourceCountRef r) a' + invokeEvent p $ resumeCont c () + +-- | Request with the priority for the resource decreasing its count +-- in case of success, otherwise suspending the discontinuous process +-- until some other process releases the resource. +requestResourceWithPriority :: PriorityQueueStrategy s p + => Resource s + -- ^ the requested resource + -> p + -- ^ the priority + -> Process () +requestResourceWithPriority r priority = + Process $ \pid -> + Cont $ \c -> + Event $ \p -> + do a <- readIORef (resourceCountRef r) + if a == 0 + then do c <- invokeEvent p $ contFreeze c + invokeEvent p $ + strategyEnqueueWithPriority (resourceWaitList r) priority c + else do let a' = a - 1 + a' `seq` writeIORef (resourceCountRef r) a' + invokeEvent p $ resumeCont c () + +-- | Release the resource increasing its count and resuming one of the +-- previously suspended processes as possible. +releaseResource :: DequeueStrategy s + => Resource s + -- ^ the resource to release + -> Process () +releaseResource r = + Process $ \_ -> + Cont $ \c -> + Event $ \p -> + do invokeEvent p $ releaseResourceWithinEvent r + invokeEvent p $ resumeCont c () + +-- | Release the resource increasing its count and resuming one of the +-- previously suspended processes as possible. +releaseResourceWithinEvent :: DequeueStrategy s + => Resource s + -- ^ the resource to release + -> Event () +releaseResourceWithinEvent r = + Event $ \p -> + do a <- readIORef (resourceCountRef r) + let a' = a + 1 + case resourceMaxCount r of + Just maxCount | a' > maxCount -> + error $ + "The resource count cannot be greater than " ++ + "its maximum value: releaseResourceWithinEvent." + _ -> + return () + f <- invokeEvent p $ + strategyQueueNull (resourceWaitList r) + if f + then a' `seq` writeIORef (resourceCountRef r) a' + else do c <- invokeEvent p $ + strategyDequeue (resourceWaitList r) + c <- invokeEvent p c + case c of + Nothing -> + invokeEvent p $ releaseResourceWithinEvent r + Just c -> + invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c () + +-- | Try to request for the resource decreasing its count in case of success +-- and returning 'True' in the 'Event' monad; otherwise, returning 'False'. +tryRequestResourceWithinEvent :: Resource s + -- ^ the resource which we try to request for + -> Event Bool +tryRequestResourceWithinEvent r = + Event $ \p -> + do a <- readIORef (resourceCountRef r) + if a == 0 + then return False + else do let a' = a - 1 + a' `seq` writeIORef (resourceCountRef r) a' + return True + +-- | Acquire the resource, perform some action and safely release the resource +-- in the end, even if the 'IOException' was raised within the action. +usingResource :: EnqueueStrategy s + => Resource s + -- ^ the resource we are going to request for and then release in the end + -> Process a + -- ^ the action we are going to apply having the resource + -> Process a + -- ^ the result of the action +usingResource r m = + do requestResource r + finallyProcess m $ releaseResource r + +-- | Acquire the resource with the specified priority, perform some action and +-- safely release the resource in the end, even if the 'IOException' was raised +-- within the action. +usingResourceWithPriority :: PriorityQueueStrategy s p + => Resource s + -- ^ the resource we are going to request for and then + -- release in the end + -> p + -- ^ the priority + -> Process a + -- ^ the action we are going to apply having the resource + -> Process a + -- ^ the result of the action +usingResourceWithPriority r priority m = + do requestResourceWithPriority r priority + finallyProcess m $ releaseResource r diff --git a/Simulation/Aivika/Results.hs b/Simulation/Aivika/Results.hs --- a/Simulation/Aivika/Results.hs +++ b/Simulation/Aivika/Results.hs @@ -1,1841 +1,1884 @@ - -{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, UndecidableInstances, ExistentialQuantification #-} - --- | --- Module : Simulation.Aivika.Results --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module allows exporting the simulation results from the model. --- -module Simulation.Aivika.Results - (-- * Definitions Focused on Modeling - Results, - ResultTransform, - ResultName, - ResultProvider(..), - results, - expandResults, - resultSummary, - resultByName, - resultByProperty, - resultByIndex, - resultBySubscript, - ResultComputing(..), - ResultComputation(..), - ResultListWithSubscript(..), - ResultArrayWithSubscript(..), -#ifndef __HASTE__ - ResultVectorWithSubscript(..), -#endif - -- * Definitions Focused on Using the Library - ResultExtract(..), - extractIntResults, - extractIntListResults, - extractIntStatsResults, - extractIntStatsEitherResults, - extractIntTimingStatsResults, - extractDoubleResults, - extractDoubleListResults, - extractDoubleStatsResults, - extractDoubleStatsEitherResults, - extractDoubleTimingStatsResults, - extractStringResults, - ResultPredefinedSignals(..), - newResultPredefinedSignals, - resultSignal, - pureResultSignal, - -- * Definitions Focused on Extending the Library - ResultSourceMap, - ResultSource(..), - ResultItem(..), - ResultItemable(..), - resultItemToIntStatsEitherValue, - resultItemToDoubleStatsEitherValue, - ResultObject(..), - ResultProperty(..), - ResultVector(..), - memoResultVectorSignal, - memoResultVectorSummary, - ResultSeparator(..), - ResultValue(..), - voidResultValue, - ResultContainer(..), - resultContainerPropertySource, - resultContainerConstProperty, - resultContainerIntegProperty, - resultContainerProperty, - resultContainerMapProperty, - resultValueToContainer, - resultContainerToValue, - ResultData, - ResultSignal(..), - maybeResultSignal, - textResultSource, - timeResultSource, - resultSourceToIntValues, - resultSourceToIntListValues, - resultSourceToIntStatsValues, - resultSourceToIntStatsEitherValues, - resultSourceToIntTimingStatsValues, - resultSourceToDoubleValues, - resultSourceToDoubleListValues, - resultSourceToDoubleStatsValues, - resultSourceToDoubleStatsEitherValues, - resultSourceToDoubleTimingStatsValues, - resultSourceToStringValues, - resultSourceMap, - resultSourceList, - resultsToIntValues, - resultsToIntListValues, - resultsToIntStatsValues, - resultsToIntStatsEitherValues, - resultsToIntTimingStatsValues, - resultsToDoubleValues, - resultsToDoubleListValues, - resultsToDoubleStatsValues, - resultsToDoubleStatsEitherValues, - resultsToDoubleTimingStatsValues, - resultsToStringValues, - composeResults, - computeResultValue) where - -import Control.Monad -import Control.Monad.Trans - -import qualified Data.Map as M -import qualified Data.Array as A - -#ifndef __HASTE__ -import qualified Data.Vector as V -#endif - -import Data.Ix -import Data.Maybe -import Data.Monoid - -import Simulation.Aivika.Parameter -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Signal -import Simulation.Aivika.Statistics -import Simulation.Aivika.Statistics.Accumulator -import Simulation.Aivika.Ref -import qualified Simulation.Aivika.Ref.Light as LR -import Simulation.Aivika.Var -import Simulation.Aivika.QueueStrategy -import qualified Simulation.Aivika.Queue as Q -import qualified Simulation.Aivika.Queue.Infinite as IQ -import Simulation.Aivika.Arrival -import Simulation.Aivika.Server -import Simulation.Aivika.Results.Locale - --- | A name used for indentifying the results when generating output. -type ResultName = String - --- | Represents a provider of the simulation results. It is usually something, or --- an array of something, or a list of such values which can be simulated to get data. -class ResultProvider p where - - -- | Return the source of simulation results by the specified name, description and provider. - resultSource :: ResultName -> ResultDescription -> p -> ResultSource - resultSource name descr = resultSource' name (UserDefinedResultId descr) - - -- | Return the source of simulation results by the specified name, identifier and provider. - resultSource' :: ResultName -> ResultId -> p -> ResultSource - --- | It associates the result sources with their names. -type ResultSourceMap = M.Map ResultName ResultSource - --- | Encapsulates the result source. -data ResultSource = ResultItemSource ResultItem - -- ^ The source consisting of a single item. - | ResultObjectSource ResultObject - -- ^ An object-like source. - | ResultVectorSource ResultVector - -- ^ A vector-like structure. - | ResultSeparatorSource ResultSeparator - -- ^ This is a separator text. - --- | The simulation results represented by a single item. -data ResultItem = forall a. ResultItemable a => ResultItem a - --- | Represents a type class for actual representing the items. -class ResultItemable a where - - -- | The item name. - resultItemName :: a -> ResultName - - -- | The item identifier. - resultItemId :: a -> ResultId - - -- | Whether the item emits a signal. - resultItemSignal :: a -> ResultSignal - - -- | Return an expanded version of the item, for example, - -- when the statistics item is exanded to an object - -- having the corresponded properties for count, average, - -- deviation, minimum, maximum and so on. - resultItemExpansion :: a -> ResultSource - - -- | Return usually a short version of the item, i.e. its summary, - -- but values of some data types such as statistics can be - -- implicitly expanded to an object with the corresponded - -- properties. - resultItemSummary :: a -> ResultSource - - -- | Return integer numbers in time points. - resultItemToIntValue :: a -> ResultValue Int - - -- | Return lists of integer numbers in time points. - resultItemToIntListValue :: a -> ResultValue [Int] - - -- | Return statistics based on integer numbers. - resultItemToIntStatsValue :: a -> ResultValue (SamplingStats Int) - - -- | Return timing statistics based on integer numbers. - resultItemToIntTimingStatsValue :: a -> ResultValue (TimingStats Int) - - -- | Return double numbers in time points. - resultItemToDoubleValue :: a -> ResultValue Double - - -- | Return lists of double numbers in time points. - resultItemToDoubleListValue :: a -> ResultValue [Double] - - -- | Return statistics based on double numbers. - resultItemToDoubleStatsValue :: a -> ResultValue (SamplingStats Double) - - -- | Return timing statistics based on integer numbers. - resultItemToDoubleTimingStatsValue :: a -> ResultValue (TimingStats Double) - - -- | Return string representations in time points. - resultItemToStringValue :: a -> ResultValue String - --- | Return a version optimised for fast aggregation of the statistics based on integer numbers. -resultItemToIntStatsEitherValue :: ResultItemable a => a -> ResultValue (Either Int (SamplingStats Int)) -resultItemToIntStatsEitherValue x = - case resultValueData x1 of - Just a1 -> fmap Left x1 - Nothing -> - case resultValueData x2 of - Just a2 -> fmap Right x2 - Nothing -> voidResultValue x2 - where - x1 = resultItemToIntValue x - x2 = resultItemToIntStatsValue x - --- | Return a version optimised for fast aggregation of the statistics based on double floating point numbers. -resultItemToDoubleStatsEitherValue :: ResultItemable a => a -> ResultValue (Either Double (SamplingStats Double)) -resultItemToDoubleStatsEitherValue x = - case resultValueData x1 of - Just a1 -> fmap Left x1 - Nothing -> - case resultValueData x2 of - Just a2 -> fmap Right x2 - Nothing -> voidResultValue x2 - where - x1 = resultItemToDoubleValue x - x2 = resultItemToDoubleStatsValue x - --- | The simulation results represented by an object having properties. -data ResultObject = - ResultObject { resultObjectName :: ResultName, - -- ^ The object name. - resultObjectId :: ResultId, - -- ^ The object identifier. - resultObjectTypeId :: ResultId, - -- ^ The object type identifier. - resultObjectProperties :: [ResultProperty], - -- ^ The object properties. - resultObjectSignal :: ResultSignal, - -- ^ A combined signal if present. - resultObjectSummary :: ResultSource - -- ^ A short version of the object, i.e. its summary. - } - --- | The object property containing the simulation results. -data ResultProperty = - ResultProperty { resultPropertyLabel :: ResultName, - -- ^ The property short label. - resultPropertyId :: ResultId, - -- ^ The property identifier. - resultPropertySource :: ResultSource - -- ^ The simulation results supplied by the property. - } - --- | The simulation results represented by a vector. -data ResultVector = - ResultVector { resultVectorName :: ResultName, - -- ^ The vector name. - resultVectorId :: ResultId, - -- ^ The vector identifier. - resultVectorItems :: A.Array Int ResultSource, - -- ^ The results supplied by the vector items. - resultVectorSubscript :: A.Array Int ResultName, - -- ^ The subscript used as a suffix to create item names. - resultVectorSignal :: ResultSignal, - -- ^ A combined signal if present. - resultVectorSummary :: ResultSource - -- ^ A short version of the vector, i.e. summary. - } - --- | Calculate the result vector signal and memoize it in a new vector. -memoResultVectorSignal :: ResultVector -> ResultVector -memoResultVectorSignal x = - x { resultVectorSignal = - foldr (<>) mempty $ map resultSourceSignal $ A.elems $ resultVectorItems x } - --- | Calculate the result vector summary and memoize it in a new vector. -memoResultVectorSummary :: ResultVector -> ResultVector -memoResultVectorSummary x = - x { resultVectorSummary = - ResultVectorSource $ - x { resultVectorItems = - A.array bnds [(i, resultSourceSummary e) | (i, e) <- ies] } } - where - arr = resultVectorItems x - bnds = A.bounds arr - ies = A.assocs arr - --- | It separates the simulation results when printing. -data ResultSeparator = - ResultSeparator { resultSeparatorText :: String - -- ^ The separator text. - } - --- | A parameterised value that actually represents a generalised result item that have no parametric type. -data ResultValue e = - ResultValue { resultValueName :: ResultName, - -- ^ The value name. - resultValueId :: ResultId, - -- ^ The value identifier. - resultValueData :: ResultData e, - -- ^ Simulation data supplied by the value. - resultValueSignal :: ResultSignal - -- ^ Whether the value emits a signal when changing simulation data. - } - -instance Functor ResultValue where - fmap f x = x { resultValueData = fmap (fmap f) (resultValueData x) } - --- | Return a new value with the discarded simulation results. -voidResultValue :: ResultValue a -> ResultValue b -voidResultValue x = x { resultValueData = Nothing } - --- | A container of the simulation results such as queue, server or array. -data ResultContainer e = - ResultContainer { resultContainerName :: ResultName, - -- ^ The container name. - resultContainerId :: ResultId, - -- ^ The container identifier. - resultContainerData :: e, - -- ^ The container data. - resultContainerSignal :: ResultSignal - -- ^ Whether the container emits a signal when changing simulation data. - } - -instance Functor ResultContainer where - fmap f x = x { resultContainerData = f (resultContainerData x) } - --- | Create a new property source by the specified container. -resultContainerPropertySource :: ResultItemable (ResultValue b) - => ResultContainer a - -- ^ the container - -> ResultName - -- ^ the property label - -> ResultId - -- ^ the property identifier - -> (a -> ResultData b) - -- ^ get the specified data from the container - -> (a -> ResultSignal) - -- ^ get the data signal from the container - -> ResultSource -resultContainerPropertySource cont name i f g = - ResultItemSource $ - ResultItem $ - ResultValue { - resultValueName = (resultContainerName cont) ++ "." ++ name, - resultValueId = i, - resultValueData = f (resultContainerData cont), - resultValueSignal = g (resultContainerData cont) } - --- | Create a constant property by the specified container. -resultContainerConstProperty :: ResultItemable (ResultValue b) - => ResultContainer a - -- ^ the container - -> ResultName - -- ^ the property label - -> ResultId - -- ^ the property identifier - -> (a -> b) - -- ^ get the specified data from the container - -> ResultProperty -resultContainerConstProperty cont name i f = - ResultProperty { - resultPropertyLabel = name, - resultPropertyId = i, - resultPropertySource = - resultContainerPropertySource cont name i (Just . return . f) (const EmptyResultSignal) } - --- | Create by the specified container a property that changes in the integration time points, or it is supposed to be such one. -resultContainerIntegProperty :: ResultItemable (ResultValue b) - => ResultContainer a - -- ^ the container - -> ResultName - -- ^ the property label - -> ResultId - -- ^ the property identifier - -> (a -> Event b) - -- ^ get the specified data from the container - -> ResultProperty -resultContainerIntegProperty cont name i f = - ResultProperty { - resultPropertyLabel = name, - resultPropertyId = i, - resultPropertySource = - resultContainerPropertySource cont name i (Just . f) (const UnknownResultSignal) } - --- | Create a property by the specified container. -resultContainerProperty :: ResultItemable (ResultValue b) - => ResultContainer a - -- ^ the container - -> ResultName - -- ^ the property label - -> ResultId - -- ^ the property identifier - -> (a -> Event b) - -- ^ get the specified data from the container - -> (a -> Signal ()) - -- ^ get a signal triggered when changing data. - -> ResultProperty -resultContainerProperty cont name i f g = - ResultProperty { - resultPropertyLabel = name, - resultPropertyId = i, - resultPropertySource = - resultContainerPropertySource cont name i (Just . f) (ResultSignal . g) } - --- | Create by the specified container a mapped property which is recomputed each time again and again. -resultContainerMapProperty :: ResultItemable (ResultValue b) - => ResultContainer (ResultData a) - -- ^ the container - -> ResultName - -- ^ the property label - -> ResultId - -- ^ the property identifier - -> (a -> b) - -- ^ recompute the specified data - -> ResultProperty -resultContainerMapProperty cont name i f = - ResultProperty { - resultPropertyLabel = name, - resultPropertyId = i, - resultPropertySource = - resultContainerPropertySource cont name i (fmap $ fmap f) (const $ resultContainerSignal cont) } - --- | Convert the result value to a container with the specified object identifier. -resultValueToContainer :: ResultValue a -> ResultContainer (ResultData a) -resultValueToContainer x = - ResultContainer { - resultContainerName = resultValueName x, - resultContainerId = resultValueId x, - resultContainerData = resultValueData x, - resultContainerSignal = resultValueSignal x } - --- | Convert the result container to a value. -resultContainerToValue :: ResultContainer (ResultData a) -> ResultValue a -resultContainerToValue x = - ResultValue { - resultValueName = resultContainerName x, - resultValueId = resultContainerId x, - resultValueData = resultContainerData x, - resultValueSignal = resultContainerSignal x } - --- | Represents the very simulation results. -type ResultData e = Maybe (Event e) - --- | Whether an object containing the results emits a signal notifying about change of data. -data ResultSignal = EmptyResultSignal - -- ^ There is no signal at all. - | UnknownResultSignal - -- ^ The signal is unknown, but the entity probably changes. - | ResultSignal (Signal ()) - -- ^ When the signal is precisely specified. - | ResultSignalMix (Signal ()) - -- ^ When the specified signal was combined with unknown signal. - -instance Monoid ResultSignal where - - mempty = EmptyResultSignal - - mappend EmptyResultSignal z = z - - mappend UnknownResultSignal EmptyResultSignal = UnknownResultSignal - mappend UnknownResultSignal UnknownResultSignal = UnknownResultSignal - mappend UnknownResultSignal (ResultSignal x) = ResultSignalMix x - mappend UnknownResultSignal z@(ResultSignalMix x) = z - - mappend z@(ResultSignal x) EmptyResultSignal = z - mappend (ResultSignal x) UnknownResultSignal = ResultSignalMix x - mappend (ResultSignal x) (ResultSignal y) = ResultSignal (x <> y) - mappend (ResultSignal x) (ResultSignalMix y) = ResultSignalMix (x <> y) - - mappend z@(ResultSignalMix x) EmptyResultSignal = z - mappend z@(ResultSignalMix x) UnknownResultSignal = z - mappend (ResultSignalMix x) (ResultSignal y) = ResultSignalMix (x <> y) - mappend (ResultSignalMix x) (ResultSignalMix y) = ResultSignalMix (x <> y) - --- | Construct a new result signal by the specified optional pure signal. -maybeResultSignal :: Maybe (Signal ()) -> ResultSignal -maybeResultSignal (Just x) = ResultSignal x -maybeResultSignal Nothing = EmptyResultSignal - -instance ResultItemable (ResultValue Int) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = id - resultItemToIntListValue = fmap return - resultItemToIntStatsValue = fmap returnSamplingStats - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = fmap fromIntegral - resultItemToDoubleListValue = fmap (return . fromIntegral) - resultItemToDoubleStatsValue = fmap (returnSamplingStats . fromIntegral) - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = fmap show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue Double) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = id - resultItemToDoubleListValue = fmap return - resultItemToDoubleStatsValue = fmap returnSamplingStats - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = fmap show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue [Int]) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = id - resultItemToIntStatsValue = fmap listSamplingStats - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = fmap (map fromIntegral) - resultItemToDoubleStatsValue = fmap (fromIntSamplingStats . listSamplingStats) - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = fmap show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue [Double]) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = id - resultItemToDoubleStatsValue = fmap listSamplingStats - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = fmap show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue (SamplingStats Int)) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = id - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = fmap fromIntSamplingStats - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = fmap show - - resultItemExpansion = samplingStatsResultSource - resultItemSummary = samplingStatsResultSummary - -instance ResultItemable (ResultValue (SamplingStats Double)) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = id - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = fmap show - - resultItemExpansion = samplingStatsResultSource - resultItemSummary = samplingStatsResultSummary - -instance ResultItemable (ResultValue (TimingStats Int)) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = id - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = fmap fromIntTimingStats - - resultItemToStringValue = fmap show - - resultItemExpansion = timingStatsResultSource - resultItemSummary = timingStatsResultSummary - -instance ResultItemable (ResultValue (TimingStats Double)) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = id - - resultItemToStringValue = fmap show - - resultItemExpansion = timingStatsResultSource - resultItemSummary = timingStatsResultSummary - -instance ResultItemable (ResultValue Bool) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = fmap show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue String) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = fmap show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue ()) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = fmap show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue FCFS) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = fmap show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue LCFS) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = fmap show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue SIRO) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = fmap show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - -instance ResultItemable (ResultValue StaticPriorities) where - - resultItemName = resultValueName - resultItemId = resultValueId - resultItemSignal = resultValueSignal - - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue - - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue - - resultItemToStringValue = fmap show - - resultItemExpansion = ResultItemSource . ResultItem - resultItemSummary = ResultItemSource . ResultItem - --- | Flatten the result source. -flattenResultSource :: ResultSource -> [ResultItem] -flattenResultSource (ResultItemSource x) = [x] -flattenResultSource (ResultObjectSource x) = - concat $ map (flattenResultSource . resultPropertySource) $ resultObjectProperties x -flattenResultSource (ResultVectorSource x) = - concat $ map flattenResultSource $ A.elems $ resultVectorItems x -flattenResultSource (ResultSeparatorSource x) = [] - --- | Return the result source name. -resultSourceName :: ResultSource -> ResultName -resultSourceName (ResultItemSource (ResultItem x)) = resultItemName x -resultSourceName (ResultObjectSource x) = resultObjectName x -resultSourceName (ResultVectorSource x) = resultVectorName x -resultSourceName (ResultSeparatorSource x) = [] - --- | Expand the result source returning a more detailed version expanding the properties as possible. -expandResultSource :: ResultSource -> ResultSource -expandResultSource (ResultItemSource (ResultItem x)) = resultItemExpansion x -expandResultSource (ResultObjectSource x) = - ResultObjectSource $ - x { resultObjectProperties = - flip fmap (resultObjectProperties x) $ \p -> - p { resultPropertySource = expandResultSource (resultPropertySource p) } } -expandResultSource (ResultVectorSource x) = - ResultVectorSource $ - x { resultVectorItems = - A.array bnds [(i, expandResultSource e) | (i, e) <- ies] } - where arr = resultVectorItems x - bnds = A.bounds arr - ies = A.assocs arr -expandResultSource z@(ResultSeparatorSource x) = z - --- | Return a summarised and usually more short version of the result source expanding the main properties or excluding auxiliary properties if required. -resultSourceSummary :: ResultSource -> ResultSource -resultSourceSummary (ResultItemSource (ResultItem x)) = resultItemSummary x -resultSourceSummary (ResultObjectSource x) = resultObjectSummary x -resultSourceSummary (ResultVectorSource x) = resultVectorSummary x -resultSourceSummary z@(ResultSeparatorSource x) = z - --- | Return a signal emitted by the source. -resultSourceSignal :: ResultSource -> ResultSignal -resultSourceSignal (ResultItemSource (ResultItem x)) = resultItemSignal x -resultSourceSignal (ResultObjectSource x) = resultObjectSignal x -resultSourceSignal (ResultVectorSource x) = resultVectorSignal x -resultSourceSignal (ResultSeparatorSource x) = EmptyResultSignal - --- | Represent the result source as integer numbers. -resultSourceToIntValues :: ResultSource -> [ResultValue Int] -resultSourceToIntValues = map (\(ResultItem x) -> resultItemToIntValue x) . flattenResultSource - --- | Represent the result source as lists of integer numbers. -resultSourceToIntListValues :: ResultSource -> [ResultValue [Int]] -resultSourceToIntListValues = map (\(ResultItem x) -> resultItemToIntListValue x) . flattenResultSource - --- | Represent the result source as statistics based on integer numbers. -resultSourceToIntStatsValues :: ResultSource -> [ResultValue (SamplingStats Int)] -resultSourceToIntStatsValues = map (\(ResultItem x) -> resultItemToIntStatsValue x) . flattenResultSource - --- | Represent the result source as statistics based on integer numbers and optimised for fast aggregation. -resultSourceToIntStatsEitherValues :: ResultSource -> [ResultValue (Either Int (SamplingStats Int))] -resultSourceToIntStatsEitherValues = map (\(ResultItem x) -> resultItemToIntStatsEitherValue x) . flattenResultSource - --- | Represent the result source as timing statistics based on integer numbers. -resultSourceToIntTimingStatsValues :: ResultSource -> [ResultValue (TimingStats Int)] -resultSourceToIntTimingStatsValues = map (\(ResultItem x) -> resultItemToIntTimingStatsValue x) . flattenResultSource - --- | Represent the result source as double floating point numbers. -resultSourceToDoubleValues :: ResultSource -> [ResultValue Double] -resultSourceToDoubleValues = map (\(ResultItem x) -> resultItemToDoubleValue x) . flattenResultSource - --- | Represent the result source as lists of double floating point numbers. -resultSourceToDoubleListValues :: ResultSource -> [ResultValue [Double]] -resultSourceToDoubleListValues = map (\(ResultItem x) -> resultItemToDoubleListValue x) . flattenResultSource - --- | Represent the result source as statistics based on double floating point numbers. -resultSourceToDoubleStatsValues :: ResultSource -> [ResultValue (SamplingStats Double)] -resultSourceToDoubleStatsValues = map (\(ResultItem x) -> resultItemToDoubleStatsValue x) . flattenResultSource - --- | Represent the result source as statistics based on double floating point numbers and optimised for fast aggregation. -resultSourceToDoubleStatsEitherValues :: ResultSource -> [ResultValue (Either Double (SamplingStats Double))] -resultSourceToDoubleStatsEitherValues = map (\(ResultItem x) -> resultItemToDoubleStatsEitherValue x) . flattenResultSource - --- | Represent the result source as timing statistics based on double floating point numbers. -resultSourceToDoubleTimingStatsValues :: ResultSource -> [ResultValue (TimingStats Double)] -resultSourceToDoubleTimingStatsValues = map (\(ResultItem x) -> resultItemToDoubleTimingStatsValue x) . flattenResultSource - --- | Represent the result source as string values. -resultSourceToStringValues :: ResultSource -> [ResultValue String] -resultSourceToStringValues = map (\(ResultItem x) -> resultItemToStringValue x) . flattenResultSource - --- | It contains the results of simulation. -data Results = - Results { resultSourceMap :: ResultSourceMap, - -- ^ The sources of simulation results as a map of associated names. - resultSourceList :: [ResultSource] - -- ^ The sources of simulation results as an ordered list. - } - --- | It transforms the results of simulation. -type ResultTransform = Results -> Results - --- | It representes the predefined signals provided by every simulation model. -data ResultPredefinedSignals = - ResultPredefinedSignals { resultSignalInIntegTimes :: Signal Double, - -- ^ The signal triggered in the integration time points. - resultSignalInStartTime :: Signal Double, - -- ^ The signal triggered in the start time. - resultSignalInStopTime :: Signal Double - -- ^ The signal triggered in the stop time. - } - --- | Create the predefined signals provided by every simulation model. -newResultPredefinedSignals :: Simulation ResultPredefinedSignals -newResultPredefinedSignals = runDynamicsInStartTime $ runEventWith EarlierEvents d where - d = do signalInIntegTimes <- newSignalInIntegTimes - signalInStartTime <- newSignalInStartTime - signalInStopTime <- newSignalInStopTime - return ResultPredefinedSignals { resultSignalInIntegTimes = signalInIntegTimes, - resultSignalInStartTime = signalInStartTime, - resultSignalInStopTime = signalInStopTime } - -instance Monoid Results where - - mempty = results mempty - mappend x y = results $ resultSourceList x <> resultSourceList y - --- | Prepare the simulation results. -results :: [ResultSource] -> Results -results ms = - Results { resultSourceMap = M.fromList $ map (\x -> (resultSourceName x, x)) ms, - resultSourceList = ms } - --- | Represent the results as integer numbers. -resultsToIntValues :: Results -> [ResultValue Int] -resultsToIntValues = concat . map resultSourceToIntValues . resultSourceList - --- | Represent the results as lists of integer numbers. -resultsToIntListValues :: Results -> [ResultValue [Int]] -resultsToIntListValues = concat . map resultSourceToIntListValues . resultSourceList - --- | Represent the results as statistics based on integer numbers. -resultsToIntStatsValues :: Results -> [ResultValue (SamplingStats Int)] -resultsToIntStatsValues = concat . map resultSourceToIntStatsValues . resultSourceList - --- | Represent the results as statistics based on integer numbers and optimised for fast aggregation. -resultsToIntStatsEitherValues :: Results -> [ResultValue (Either Int (SamplingStats Int))] -resultsToIntStatsEitherValues = concat . map resultSourceToIntStatsEitherValues . resultSourceList - --- | Represent the results as timing statistics based on integer numbers. -resultsToIntTimingStatsValues :: Results -> [ResultValue (TimingStats Int)] -resultsToIntTimingStatsValues = concat . map resultSourceToIntTimingStatsValues . resultSourceList - --- | Represent the results as double floating point numbers. -resultsToDoubleValues :: Results -> [ResultValue Double] -resultsToDoubleValues = concat . map resultSourceToDoubleValues . resultSourceList - --- | Represent the results as lists of double floating point numbers. -resultsToDoubleListValues :: Results -> [ResultValue [Double]] -resultsToDoubleListValues = concat . map resultSourceToDoubleListValues . resultSourceList - --- | Represent the results as statistics based on double floating point numbers. -resultsToDoubleStatsValues :: Results -> [ResultValue (SamplingStats Double)] -resultsToDoubleStatsValues = concat . map resultSourceToDoubleStatsValues . resultSourceList - --- | Represent the results as statistics based on double floating point numbers and optimised for fast aggregation. -resultsToDoubleStatsEitherValues :: Results -> [ResultValue (Either Double (SamplingStats Double))] -resultsToDoubleStatsEitherValues = concat . map resultSourceToDoubleStatsEitherValues . resultSourceList - --- | Represent the results as timing statistics based on double floating point numbers. -resultsToDoubleTimingStatsValues :: Results -> [ResultValue (TimingStats Double)] -resultsToDoubleTimingStatsValues = concat . map resultSourceToDoubleTimingStatsValues . resultSourceList - --- | Represent the results as string values. -resultsToStringValues :: Results -> [ResultValue String] -resultsToStringValues = concat . map resultSourceToStringValues . resultSourceList - --- | Return a signal emitted by the specified results. -resultSignal :: Results -> ResultSignal -resultSignal = mconcat . map resultSourceSignal . resultSourceList - --- | Return an expanded version of the simulation results expanding the properties as possible, which --- takes place for expanding statistics to show the count, average, deviation, minimum, maximum etc. --- as separate values. -expandResults :: ResultTransform -expandResults = results . map expandResultSource . resultSourceList - --- | Return a short version of the simulation results, i.e. their summary, expanding the main properties --- or excluding auxiliary properties if required. -resultSummary :: ResultTransform -resultSummary = results . map resultSourceSummary . resultSourceList - --- | Take a result by its name. -resultByName :: ResultName -> ResultTransform -resultByName name rs = - case M.lookup name (resultSourceMap rs) of - Just x -> results [x] - Nothing -> - error $ - "Not found result source with name " ++ name ++ - ": resultByName" - --- | Take a result from the object with the specified property label. -resultByProperty :: ResultName -> ResultTransform -resultByProperty label rs = flip composeResults rs loop - where - loop x = - case x of - ResultObjectSource s -> - let ps = - flip filter (resultObjectProperties s) $ \p -> - resultPropertyLabel p == label - in case ps of - [] -> - error $ - "Not found property " ++ label ++ - " for object " ++ resultObjectName s ++ - ": resultByProperty" - ps -> - map resultPropertySource ps - ResultVectorSource s -> - concat $ map loop $ A.elems $ resultVectorItems s - x -> - error $ - "Result source " ++ resultSourceName x ++ - " is neither object, nor vector " ++ - ": resultByProperty" - --- | Take a result from the vector by the specified integer index. -resultByIndex :: Int -> ResultTransform -resultByIndex index rs = flip composeResults rs loop - where - loop x = - case x of - ResultVectorSource s -> - [resultVectorItems s A.! index] - x -> - error $ - "Result source " ++ resultSourceName x ++ - " is not vector " ++ - ": resultByIndex" - --- | Take a result from the vector by the specified string subscript. -resultBySubscript :: ResultName -> ResultTransform -resultBySubscript subscript rs = flip composeResults rs loop - where - loop x = - case x of - ResultVectorSource s -> - let ys = A.elems $ resultVectorItems s - zs = A.elems $ resultVectorSubscript s - ps = - flip filter (zip ys zs) $ \(y, z) -> - z == subscript - in case ps of - [] -> - error $ - "Not found subscript " ++ subscript ++ - " for vector " ++ resultVectorName s ++ - ": resultBySubscript" - ps -> - map fst ps - x -> - error $ - "Result source " ++ resultSourceName x ++ - " is not vector " ++ - ": resultBySubscript" - --- | Compose the results using the specified transformation function. -composeResults :: (ResultSource -> [ResultSource]) -> ResultTransform -composeResults f = - results . concat . map f . resultSourceList - --- | Concatenate the results using the specified list of transformation functions. -concatResults :: [ResultTransform] -> ResultTransform -concatResults trs rs = - results $ concat $ map (\tr -> resultSourceList $ tr rs) trs - --- | Append the results using the specified transformation functions. -appendResults :: ResultTransform -> ResultTransform -> ResultTransform -appendResults x y = - concatResults [x, y] - --- | Return a pure signal as a result of combination of the predefined signals --- with the specified result signal usually provided by the sources. --- --- The signal returned is triggered when the source signal is triggered. --- The pure signal is also triggered in the integration time points --- if the source signal is unknown or it was combined with any unknown signal. -pureResultSignal :: ResultPredefinedSignals -> ResultSignal -> Signal () -pureResultSignal rs EmptyResultSignal = - void (resultSignalInStartTime rs) -pureResultSignal rs UnknownResultSignal = - void (resultSignalInIntegTimes rs) -pureResultSignal rs (ResultSignal s) = - void (resultSignalInStartTime rs) <> void (resultSignalInStopTime rs) <> s -pureResultSignal rs (ResultSignalMix s) = - void (resultSignalInIntegTimes rs) <> s - --- | Defines a final result extract: its name, values and other data. -data ResultExtract e = - ResultExtract { resultExtractName :: ResultName, - -- ^ The result name. - resultExtractId :: ResultId, - -- ^ The result identifier. - resultExtractData :: Event e, - -- ^ The result values. - resultExtractSignal :: ResultSignal - -- ^ Whether the result emits a signal. - } - --- | Extract the results as integer values, or raise a conversion error. -extractIntResults :: Results -> [ResultExtract Int] -extractIntResults rs = flip map (resultsToIntValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of integer values: extractIntResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as lists of integer values, or raise a conversion error. -extractIntListResults :: Results -> [ResultExtract [Int]] -extractIntListResults rs = flip map (resultsToIntListValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of lists of integer values: extractIntListResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as statistics based on integer values, --- or raise a conversion error. -extractIntStatsResults :: Results -> [ResultExtract (SamplingStats Int)] -extractIntStatsResults rs = flip map (resultsToIntStatsValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of statistics based on integer values: extractIntStatsResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as statistics based on integer values and optimised --- for fast aggregation, or raise a conversion error. -extractIntStatsEitherResults :: Results -> [ResultExtract (Either Int (SamplingStats Int))] -extractIntStatsEitherResults rs = flip map (resultsToIntStatsEitherValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of statistics based on integer values: extractIntStatsEitherResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as timing statistics based on integer values, --- or raise a conversion error. -extractIntTimingStatsResults :: Results -> [ResultExtract (TimingStats Int)] -extractIntTimingStatsResults rs = flip map (resultsToIntTimingStatsValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of timing statistics based on integer values: extractIntTimingStatsResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as double floating point values, or raise a conversion error. -extractDoubleResults :: Results -> [ResultExtract Double] -extractDoubleResults rs = flip map (resultsToDoubleValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of double floating point values: extractDoubleResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as lists of double floating point values, --- or raise a conversion error. -extractDoubleListResults :: Results -> [ResultExtract [Double]] -extractDoubleListResults rs = flip map (resultsToDoubleListValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of lists of double floating point values: extractDoubleListResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as statistics based on double floating point values, --- or raise a conversion error. -extractDoubleStatsResults :: Results -> [ResultExtract (SamplingStats Double)] -extractDoubleStatsResults rs = flip map (resultsToDoubleStatsValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of statistics based on double floating point values: extractDoubleStatsResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as statistics based on double floating point values --- and optimised for fast aggregation, or raise a conversion error. -extractDoubleStatsEitherResults :: Results -> [ResultExtract (Either Double (SamplingStats Double))] -extractDoubleStatsEitherResults rs = flip map (resultsToDoubleStatsEitherValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of statistics based on double floating point values: extractDoubleStatsEitherResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as timing statistics based on double floating point values, --- or raise a conversion error. -extractDoubleTimingStatsResults :: Results -> [ResultExtract (TimingStats Double)] -extractDoubleTimingStatsResults rs = flip map (resultsToDoubleTimingStatsValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of timing statistics based on double floating point values: extractDoubleTimingStatsResults" - Just a -> - ResultExtract n i a s - --- | Extract the results as string values, or raise a conversion error. -extractStringResults :: Results -> [ResultExtract String] -extractStringResults rs = flip map (resultsToStringValues rs) $ \x -> - let n = resultValueName x - i = resultValueId x - a = resultValueData x - s = resultValueSignal x - in case a of - Nothing -> - error $ - "Cannot represent variable " ++ n ++ - " as a source of string values: extractStringResults" - Just a -> - ResultExtract n i a s - --- | Represents a computation that can return the simulation data. -class ResultComputing m where - - -- | Compute data with the results of simulation. - computeResultData :: m a -> ResultData a - - -- | Return the signal triggered when data change if such a signal exists. - computeResultSignal :: m a -> ResultSignal - --- | Return a new result value by the specified name, identifier and computation. -computeResultValue :: ResultComputing m - => ResultName - -- ^ the result name - -> ResultId - -- ^ the result identifier - -> m a - -- ^ the result computation - -> ResultValue a -computeResultValue name i m = - ResultValue { - resultValueName = name, - resultValueId = i, - resultValueData = computeResultData m, - resultValueSignal = computeResultSignal m } - --- | Represents a computation that can return the simulation data. -data ResultComputation a = - ResultComputation { resultComputationData :: ResultData a, - -- ^ Return data from the computation. - resultComputationSignal :: ResultSignal - -- ^ Return a signal from the computation. - } - -instance ResultComputing ResultComputation where - - computeResultData = resultComputationData - computeResultSignal = resultComputationSignal - -instance ResultComputing Parameter where - - computeResultData = Just . liftParameter - computeResultSignal = const UnknownResultSignal - -instance ResultComputing Simulation where - - computeResultData = Just . liftSimulation - computeResultSignal = const UnknownResultSignal - -instance ResultComputing Dynamics where - - computeResultData = Just . liftDynamics - computeResultSignal = const UnknownResultSignal - -instance ResultComputing Event where - - computeResultData = Just . id - computeResultSignal = const UnknownResultSignal - -instance ResultComputing Ref where - - computeResultData = Just . readRef - computeResultSignal = ResultSignal . refChanged_ - -instance ResultComputing LR.Ref where - - computeResultData = Just . LR.readRef - computeResultSignal = const UnknownResultSignal - -instance ResultComputing Var where - - computeResultData = Just . readVar - computeResultSignal = ResultSignal . varChanged_ - -instance ResultComputing Signalable where - - computeResultData = Just . readSignalable - computeResultSignal = ResultSignal . signalableChanged_ - --- | Return a source by the specified statistics. -samplingStatsResultSource :: (ResultItemable (ResultValue a), - ResultItemable (ResultValue (SamplingStats a))) - => ResultValue (SamplingStats a) - -- ^ the statistics - -> ResultSource -samplingStatsResultSource x = - ResultObjectSource $ - ResultObject { - resultObjectName = resultValueName x, - resultObjectId = resultValueId x, - resultObjectTypeId = SamplingStatsId, - resultObjectSignal = resultValueSignal x, - resultObjectSummary = samplingStatsResultSummary x, - resultObjectProperties = [ - resultContainerMapProperty c "count" SamplingStatsCountId samplingStatsCount, - resultContainerMapProperty c "mean" SamplingStatsMeanId samplingStatsMean, - resultContainerMapProperty c "mean2" SamplingStatsMean2Id samplingStatsMean2, - resultContainerMapProperty c "std" SamplingStatsDeviationId samplingStatsDeviation, - resultContainerMapProperty c "var" SamplingStatsVarianceId samplingStatsVariance, - resultContainerMapProperty c "min" SamplingStatsMinId samplingStatsMin, - resultContainerMapProperty c "max" SamplingStatsMaxId samplingStatsMax ] } - where - c = resultValueToContainer x - --- | Return the summary by the specified statistics. -samplingStatsResultSummary :: ResultItemable (ResultValue (SamplingStats a)) - => ResultValue (SamplingStats a) - -- ^ the statistics - -> ResultSource -samplingStatsResultSummary = ResultItemSource . ResultItem . resultItemToStringValue - --- | Return a source by the specified timing statistics. -timingStatsResultSource :: (TimingData a, - ResultItemable (ResultValue a), - ResultItemable (ResultValue (TimingStats a))) - => ResultValue (TimingStats a) - -- ^ the statistics - -> ResultSource -timingStatsResultSource x = - ResultObjectSource $ - ResultObject { - resultObjectName = resultValueName x, - resultObjectId = resultValueId x, - resultObjectTypeId = TimingStatsId, - resultObjectSignal = resultValueSignal x, - resultObjectSummary = timingStatsResultSummary x, - resultObjectProperties = [ - resultContainerMapProperty c "count" TimingStatsCountId timingStatsCount, - resultContainerMapProperty c "mean" TimingStatsMeanId timingStatsMean, - resultContainerMapProperty c "std" TimingStatsDeviationId timingStatsDeviation, - resultContainerMapProperty c "var" TimingStatsVarianceId timingStatsVariance, - resultContainerMapProperty c "min" TimingStatsMinId timingStatsMin, - resultContainerMapProperty c "max" TimingStatsMaxId timingStatsMax, - resultContainerMapProperty c "minTime" TimingStatsMinTimeId timingStatsMinTime, - resultContainerMapProperty c "maxTime" TimingStatsMaxTimeId timingStatsMaxTime, - resultContainerMapProperty c "startTime" TimingStatsStartTimeId timingStatsStartTime, - resultContainerMapProperty c "lastTime" TimingStatsLastTimeId timingStatsLastTime, - resultContainerMapProperty c "sum" TimingStatsSumId timingStatsSum, - resultContainerMapProperty c "sum2" TimingStatsSum2Id timingStatsSum2 ] } - where - c = resultValueToContainer x - --- | Return the summary by the specified timing statistics. -timingStatsResultSummary :: (TimingData a, ResultItemable (ResultValue (TimingStats a))) - => ResultValue (TimingStats a) - -- ^ the statistics - -> ResultSource -timingStatsResultSummary = ResultItemSource . ResultItem . resultItemToStringValue - --- | Return a source by the specified finite queue. -queueResultSource :: (Show si, Show sm, Show so, - ResultItemable (ResultValue si), - ResultItemable (ResultValue sm), - ResultItemable (ResultValue so)) - => ResultContainer (Q.Queue si qi sm qm so qo a) - -- ^ the queue container - -> ResultSource -queueResultSource c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = FiniteQueueId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = queueResultSummary c, - resultObjectProperties = [ - resultContainerConstProperty c "enqueueStrategy" EnqueueStrategyId Q.enqueueStrategy, - resultContainerConstProperty c "enqueueStoringStrategy" EnqueueStoringStrategyId Q.enqueueStoringStrategy, - resultContainerConstProperty c "dequeueStrategy" DequeueStrategyId Q.dequeueStrategy, - resultContainerProperty c "queueNull" QueueNullId Q.queueNull Q.queueNullChanged_, - resultContainerProperty c "queueFull" QueueFullId Q.queueFull Q.queueFullChanged_, - resultContainerConstProperty c "queueMaxCount" QueueMaxCountId Q.queueMaxCount, - resultContainerProperty c "queueCount" QueueCountId Q.queueCount Q.queueCountChanged_, - resultContainerProperty c "queueCountStats" QueueCountStatsId Q.queueCountStats Q.queueCountChanged_, - resultContainerProperty c "enqueueCount" EnqueueCountId Q.enqueueCount Q.enqueueCountChanged_, - resultContainerProperty c "enqueueLostCount" EnqueueLostCountId Q.enqueueLostCount Q.enqueueLostCountChanged_, - resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId Q.enqueueStoreCount Q.enqueueStoreCountChanged_, - resultContainerProperty c "dequeueCount" DequeueCountId Q.dequeueCount Q.dequeueCountChanged_, - resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId Q.dequeueExtractCount Q.dequeueExtractCountChanged_, - resultContainerProperty c "queueLoadFactor" QueueLoadFactorId Q.queueLoadFactor Q.queueLoadFactorChanged_, - resultContainerIntegProperty c "enqueueRate" EnqueueRateId Q.enqueueRate, - resultContainerIntegProperty c "enqueueStoreRate" EnqueueStoreRateId Q.enqueueStoreRate, - resultContainerIntegProperty c "dequeueRate" DequeueRateId Q.dequeueRate, - resultContainerIntegProperty c "dequeueExtractRate" DequeueExtractRateId Q.dequeueExtractRate, - resultContainerProperty c "queueWaitTime" QueueWaitTimeId Q.queueWaitTime Q.queueWaitTimeChanged_, - resultContainerProperty c "queueTotalWaitTime" QueueTotalWaitTimeId Q.queueTotalWaitTime Q.queueTotalWaitTimeChanged_, - resultContainerProperty c "enqueueWaitTime" EnqueueWaitTimeId Q.enqueueWaitTime Q.enqueueWaitTimeChanged_, - resultContainerProperty c "dequeueWaitTime" DequeueWaitTimeId Q.dequeueWaitTime Q.dequeueWaitTimeChanged_, - resultContainerProperty c "queueRate" QueueRateId Q.queueRate Q.queueRateChanged_ ] } - --- | Return the summary by the specified finite queue. -queueResultSummary :: (Show si, Show sm, Show so) - => ResultContainer (Q.Queue si qi sm qm so qo a) - -- ^ the queue container - -> ResultSource -queueResultSummary c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = FiniteQueueId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = queueResultSummary c, - resultObjectProperties = [ - resultContainerConstProperty c "queueMaxCount" QueueMaxCountId Q.queueMaxCount, - resultContainerProperty c "queueCountStats" QueueCountStatsId Q.queueCountStats Q.queueCountChanged_, - resultContainerProperty c "enqueueCount" EnqueueCountId Q.enqueueCount Q.enqueueCountChanged_, - resultContainerProperty c "enqueueLostCount" EnqueueLostCountId Q.enqueueLostCount Q.enqueueLostCountChanged_, - resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId Q.enqueueStoreCount Q.enqueueStoreCountChanged_, - resultContainerProperty c "dequeueCount" DequeueCountId Q.dequeueCount Q.dequeueCountChanged_, - resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId Q.dequeueExtractCount Q.dequeueExtractCountChanged_, - resultContainerProperty c "queueLoadFactor" QueueLoadFactorId Q.queueLoadFactor Q.queueLoadFactorChanged_, - resultContainerProperty c "queueWaitTime" QueueWaitTimeId Q.queueWaitTime Q.queueWaitTimeChanged_, - resultContainerProperty c "queueRate" QueueRateId Q.queueRate Q.queueRateChanged_ ] } - --- | Return a source by the specified infinite queue. -infiniteQueueResultSource :: (Show sm, Show so, - ResultItemable (ResultValue sm), - ResultItemable (ResultValue so)) - => ResultContainer (IQ.Queue sm qm so qo a) - -- ^ the queue container - -> ResultSource -infiniteQueueResultSource c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = FiniteQueueId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = infiniteQueueResultSummary c, - resultObjectProperties = [ - resultContainerConstProperty c "enqueueStoringStrategy" EnqueueStoringStrategyId IQ.enqueueStoringStrategy, - resultContainerConstProperty c "dequeueStrategy" DequeueStrategyId IQ.dequeueStrategy, - resultContainerProperty c "queueNull" QueueNullId IQ.queueNull IQ.queueNullChanged_, - resultContainerProperty c "queueCount" QueueCountId IQ.queueCount IQ.queueCountChanged_, - resultContainerProperty c "queueCountStats" QueueCountStatsId IQ.queueCountStats IQ.queueCountChanged_, - resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId IQ.enqueueStoreCount IQ.enqueueStoreCountChanged_, - resultContainerProperty c "dequeueCount" DequeueCountId IQ.dequeueCount IQ.dequeueCountChanged_, - resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId IQ.dequeueExtractCount IQ.dequeueExtractCountChanged_, - resultContainerIntegProperty c "enqueueStoreRate" EnqueueStoreRateId IQ.enqueueStoreRate, - resultContainerIntegProperty c "dequeueRate" DequeueRateId IQ.dequeueRate, - resultContainerIntegProperty c "dequeueExtractRate" DequeueExtractRateId IQ.dequeueExtractRate, - resultContainerProperty c "queueWaitTime" QueueWaitTimeId IQ.queueWaitTime IQ.queueWaitTimeChanged_, - resultContainerProperty c "dequeueWaitTime" DequeueWaitTimeId IQ.dequeueWaitTime IQ.dequeueWaitTimeChanged_, - resultContainerProperty c "queueRate" QueueRateId IQ.queueRate IQ.queueRateChanged_ ] } - --- | Return the summary by the specified infinite queue. -infiniteQueueResultSummary :: (Show sm, Show so) - => ResultContainer (IQ.Queue sm qm so qo a) - -- ^ the queue container - -> ResultSource -infiniteQueueResultSummary c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = FiniteQueueId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = infiniteQueueResultSummary c, - resultObjectProperties = [ - resultContainerProperty c "queueCountStats" QueueCountStatsId IQ.queueCountStats IQ.queueCountChanged_, - resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId IQ.enqueueStoreCount IQ.enqueueStoreCountChanged_, - resultContainerProperty c "dequeueCount" DequeueCountId IQ.dequeueCount IQ.dequeueCountChanged_, - resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId IQ.dequeueExtractCount IQ.dequeueExtractCountChanged_, - resultContainerProperty c "queueWaitTime" QueueWaitTimeId IQ.queueWaitTime IQ.queueWaitTimeChanged_, - resultContainerProperty c "queueRate" QueueRateId IQ.queueRate IQ.queueRateChanged_ ] } - --- | Return a source by the specified arrival timer. -arrivalTimerResultSource :: ResultContainer ArrivalTimer - -- ^ the arrival timer container - -> ResultSource -arrivalTimerResultSource c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = ArrivalTimerId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = arrivalTimerResultSummary c, - resultObjectProperties = [ - resultContainerProperty c "processingTime" ArrivalProcessingTimeId arrivalProcessingTime arrivalProcessingTimeChanged_ ] } - --- | Return the summary by the specified arrival timer. -arrivalTimerResultSummary :: ResultContainer ArrivalTimer - -- ^ the arrival timer container - -> ResultSource -arrivalTimerResultSummary c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = ArrivalTimerId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = arrivalTimerResultSummary c, - resultObjectProperties = [ - resultContainerProperty c "processingTime" ArrivalProcessingTimeId arrivalProcessingTime arrivalProcessingTimeChanged_ ] } - --- | Return a source by the specified server. -serverResultSource :: (Show s, ResultItemable (ResultValue s)) - => ResultContainer (Server s a b) - -- ^ the server container - -> ResultSource -serverResultSource c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = ServerId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = serverResultSummary c, - resultObjectProperties = [ - resultContainerConstProperty c "initState" ServerInitStateId serverInitState, - resultContainerProperty c "state" ServerStateId serverState serverStateChanged_, - resultContainerProperty c "totalInputWaitTime" ServerTotalInputWaitTimeId serverTotalInputWaitTime serverTotalInputWaitTimeChanged_, - resultContainerProperty c "totalProcessingTime" ServerTotalProcessingTimeId serverTotalProcessingTime serverTotalProcessingTimeChanged_, - resultContainerProperty c "totalOutputWaitTime" ServerTotalOutputWaitTimeId serverTotalOutputWaitTime serverTotalOutputWaitTimeChanged_, - resultContainerProperty c "inputWaitTime" ServerInputWaitTimeId serverInputWaitTime serverInputWaitTimeChanged_, - resultContainerProperty c "processingTime" ServerProcessingTimeId serverProcessingTime serverProcessingTimeChanged_, - resultContainerProperty c "outputWaitTime" ServerOutputWaitTimeId serverOutputWaitTime serverOutputWaitTimeChanged_, - resultContainerProperty c "inputWaitFactor" ServerInputWaitFactorId serverInputWaitFactor serverInputWaitFactorChanged_, - resultContainerProperty c "processingFactor" ServerProcessingFactorId serverProcessingFactor serverProcessingFactorChanged_, - resultContainerProperty c "outputWaitFactor" ServerOutputWaitFactorId serverOutputWaitFactor serverOutputWaitFactorChanged_ ] } - --- | Return the summary by the specified server. -serverResultSummary :: ResultContainer (Server s a b) - -- ^ the server container - -> ResultSource -serverResultSummary c = - ResultObjectSource $ - ResultObject { - resultObjectName = resultContainerName c, - resultObjectId = resultContainerId c, - resultObjectTypeId = ServerId, - resultObjectSignal = resultContainerSignal c, - resultObjectSummary = serverResultSummary c, - resultObjectProperties = [ - resultContainerProperty c "inputWaitTime" ServerInputWaitTimeId serverInputWaitTime serverInputWaitTimeChanged_, - resultContainerProperty c "processingTime" ServerProcessingTimeId serverProcessingTime serverProcessingTimeChanged_, - resultContainerProperty c "outputWaitTime" ServerOutputWaitTimeId serverOutputWaitTime serverOutputWaitTimeChanged_, - resultContainerProperty c "inputWaitFactor" ServerInputWaitFactorId serverInputWaitFactor serverInputWaitFactorChanged_, - resultContainerProperty c "processingFactor" ServerProcessingFactorId serverProcessingFactor serverProcessingFactorChanged_, - resultContainerProperty c "outputWaitFactor" ServerOutputWaitFactorId serverOutputWaitFactor serverOutputWaitFactorChanged_ ] } - --- | Return an arbitrary text as a separator source. -textResultSource :: String -> ResultSource -textResultSource text = - ResultSeparatorSource $ - ResultSeparator { resultSeparatorText = text } - --- | Return the source of the modeling time. -timeResultSource :: ResultSource -timeResultSource = resultSource' "t" TimeId time - --- | Make an integer subscript -intSubscript :: Int -> ResultName -intSubscript i = "[" ++ show i ++ "]" - -instance ResultComputing m => ResultProvider (m Double) where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing m => ResultProvider (m [Double]) where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing m => ResultProvider (m (SamplingStats Double)) where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing m => ResultProvider (m (TimingStats Double)) where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing m => ResultProvider (m Int) where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing m => ResultProvider (m [Int]) where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing m => ResultProvider (m (SamplingStats Int)) where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing m => ResultProvider (m (TimingStats Int)) where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultComputing m => ResultProvider (m String) where - - resultSource' name i m = - ResultItemSource $ ResultItem $ computeResultValue name i m - -instance ResultProvider p => ResultProvider [p] where - - resultSource' name i m = - resultSource' name i $ ResultListWithSubscript m subscript where - subscript = map snd $ zip m $ map intSubscript [0..] - -instance (Show i, Ix i, ResultProvider p) => ResultProvider (A.Array i p) where - - resultSource' name i m = - resultSource' name i $ ResultListWithSubscript items subscript where - items = A.elems m - subscript = map (\i -> "[" ++ show i ++ "]") (A.indices m) - -#ifndef __HASTE__ - -instance ResultProvider p => ResultProvider (V.Vector p) where - - resultSource' name i m = - resultSource' name i $ ResultVectorWithSubscript m subscript where - subscript = V.imap (\i x -> intSubscript i) m - -#endif - --- | Represents a list with the specified subscript. -data ResultListWithSubscript p = - ResultListWithSubscript [p] [String] - --- | Represents an array with the specified subscript. -data ResultArrayWithSubscript i p = - ResultArrayWithSubscript (A.Array i p) (A.Array i String) - -#ifndef __HASTE__ - --- | Represents a vector with the specified subscript. -data ResultVectorWithSubscript p = - ResultVectorWithSubscript (V.Vector p) (V.Vector String) - -#endif - -instance ResultProvider p => ResultProvider (ResultListWithSubscript p) where - - resultSource' name i (ResultListWithSubscript xs ys) = - ResultVectorSource $ - memoResultVectorSignal $ - memoResultVectorSummary $ - ResultVector { resultVectorName = name, - resultVectorId = i, - resultVectorItems = axs, - resultVectorSubscript = ays, - resultVectorSignal = undefined, - resultVectorSummary = undefined } - where - bnds = (0, length xs - 1) - axs = A.listArray bnds items - ays = A.listArray bnds ys - items = - flip map (zip ys xs) $ \(y, x) -> - let name' = name ++ y - in resultSource' name' (VectorItemId y) x - items' = map resultSourceSummary items - -instance (Show i, Ix i, ResultProvider p) => ResultProvider (ResultArrayWithSubscript i p) where - - resultSource' name i (ResultArrayWithSubscript xs ys) = - resultSource' name i $ ResultListWithSubscript items subscript where - items = A.elems xs - subscript = A.elems ys - -#ifndef __HASTE__ - -instance ResultProvider p => ResultProvider (ResultVectorWithSubscript p) where - - resultSource' name i (ResultVectorWithSubscript xs ys) = - ResultVectorSource $ - memoResultVectorSignal $ - memoResultVectorSummary $ - ResultVector { resultVectorName = name, - resultVectorId = i, - resultVectorItems = axs, - resultVectorSubscript = ays, - resultVectorSignal = undefined, - resultVectorSummary = undefined } - where - bnds = (0, V.length xs - 1) - axs = A.listArray bnds (V.toList items) - ays = A.listArray bnds (V.toList ys) - items = - V.generate (V.length xs) $ \i -> - let x = xs V.! i - y = ys V.! i - name' = name ++ y - in resultSource' name' (VectorItemId y) x - items' = V.map resultSourceSummary items - -#endif - -instance (Ix i, Show i, ResultComputing m) => ResultProvider (m (A.Array i Double)) where - - resultSource' name i m = - ResultItemSource $ ResultItem $ fmap A.elems $ computeResultValue name i m - -instance (Ix i, Show i, ResultComputing m) => ResultProvider (m (A.Array i Int)) where - - resultSource' name i m = - ResultItemSource $ ResultItem $ fmap A.elems $ computeResultValue name i m - -#ifndef __HASTE__ - -instance ResultComputing m => ResultProvider (m (V.Vector Double)) where - - resultSource' name i m = - ResultItemSource $ ResultItem $ fmap V.toList $ computeResultValue name i m - -instance ResultComputing m => ResultProvider (m (V.Vector Int)) where - - resultSource' name i m = - ResultItemSource $ ResultItem $ fmap V.toList $ computeResultValue name i m - -#endif - -instance (Show si, Show sm, Show so, - ResultItemable (ResultValue si), - ResultItemable (ResultValue sm), - ResultItemable (ResultValue so)) - => ResultProvider (Q.Queue si qi sm qm so qo a) where - - resultSource' name i m = - queueResultSource $ ResultContainer name i m (ResultSignal $ Q.queueChanged_ m) - -instance (Show sm, Show so, - ResultItemable (ResultValue sm), - ResultItemable (ResultValue so)) - => ResultProvider (IQ.Queue sm qm so qo a) where - - resultSource' name i m = - infiniteQueueResultSource $ ResultContainer name i m (ResultSignal $ IQ.queueChanged_ m) - -instance ResultProvider ArrivalTimer where - - resultSource' name i m = - arrivalTimerResultSource $ ResultContainer name i m (ResultSignal $ arrivalProcessingTimeChanged_ m) - -instance (Show s, ResultItemable (ResultValue s)) => ResultProvider (Server s a b) where - - resultSource' name i m = - serverResultSource $ ResultContainer name i m (ResultSignal $ serverChanged_ m) + +{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, UndecidableInstances, ExistentialQuantification #-} + +-- | +-- Module : Simulation.Aivika.Results +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module allows exporting the simulation results from the model. +-- +module Simulation.Aivika.Results + (-- * Definitions Focused on Modeling + Results, + ResultTransform, + ResultName, + ResultProvider(..), + results, + expandResults, + resultSummary, + resultByName, + resultByProperty, + resultById, + resultByIndex, + resultBySubscript, + ResultComputing(..), + ResultComputation(..), + ResultListWithSubscript(..), + ResultArrayWithSubscript(..), +#ifndef __HASTE__ + ResultVectorWithSubscript(..), +#endif + -- * Definitions Focused on Using the Library + ResultExtract(..), + extractIntResults, + extractIntListResults, + extractIntStatsResults, + extractIntStatsEitherResults, + extractIntTimingStatsResults, + extractDoubleResults, + extractDoubleListResults, + extractDoubleStatsResults, + extractDoubleStatsEitherResults, + extractDoubleTimingStatsResults, + extractStringResults, + ResultPredefinedSignals(..), + newResultPredefinedSignals, + resultSignal, + pureResultSignal, + -- * Definitions Focused on Extending the Library + ResultSourceMap, + ResultSource(..), + ResultItem(..), + ResultItemable(..), + resultItemToIntStatsEitherValue, + resultItemToDoubleStatsEitherValue, + ResultObject(..), + ResultProperty(..), + ResultVector(..), + memoResultVectorSignal, + memoResultVectorSummary, + ResultSeparator(..), + ResultValue(..), + voidResultValue, + ResultContainer(..), + resultContainerPropertySource, + resultContainerConstProperty, + resultContainerIntegProperty, + resultContainerProperty, + resultContainerMapProperty, + resultValueToContainer, + resultContainerToValue, + ResultData, + ResultSignal(..), + maybeResultSignal, + textResultSource, + timeResultSource, + resultSourceToIntValues, + resultSourceToIntListValues, + resultSourceToIntStatsValues, + resultSourceToIntStatsEitherValues, + resultSourceToIntTimingStatsValues, + resultSourceToDoubleValues, + resultSourceToDoubleListValues, + resultSourceToDoubleStatsValues, + resultSourceToDoubleStatsEitherValues, + resultSourceToDoubleTimingStatsValues, + resultSourceToStringValues, + resultSourceMap, + resultSourceList, + resultsToIntValues, + resultsToIntListValues, + resultsToIntStatsValues, + resultsToIntStatsEitherValues, + resultsToIntTimingStatsValues, + resultsToDoubleValues, + resultsToDoubleListValues, + resultsToDoubleStatsValues, + resultsToDoubleStatsEitherValues, + resultsToDoubleTimingStatsValues, + resultsToStringValues, + composeResults, + computeResultValue) where + +import Control.Monad +import Control.Monad.Trans + +import qualified Data.Map as M +import qualified Data.Array as A + +#ifndef __HASTE__ +import qualified Data.Vector as V +#endif + +import Data.Ix +import Data.Maybe +import Data.Monoid + +import Simulation.Aivika.Parameter +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Event +import Simulation.Aivika.Signal +import Simulation.Aivika.Statistics +import Simulation.Aivika.Statistics.Accumulator +import Simulation.Aivika.Ref +import qualified Simulation.Aivika.Ref.Plain as LR +import Simulation.Aivika.Var +import Simulation.Aivika.QueueStrategy +import qualified Simulation.Aivika.Queue as Q +import qualified Simulation.Aivika.Queue.Infinite as IQ +import Simulation.Aivika.Arrival +import Simulation.Aivika.Server +import Simulation.Aivika.Results.Locale + +-- | A name used for indentifying the results when generating output. +type ResultName = String + +-- | Represents a provider of the simulation results. It is usually something, or +-- an array of something, or a list of such values which can be simulated to get data. +class ResultProvider p where + + -- | Return the source of simulation results by the specified name, description and provider. + resultSource :: ResultName -> ResultDescription -> p -> ResultSource + resultSource name descr = resultSource' name (UserDefinedResultId descr) + + -- | Return the source of simulation results by the specified name, identifier and provider. + resultSource' :: ResultName -> ResultId -> p -> ResultSource + +-- | It associates the result sources with their names. +type ResultSourceMap = M.Map ResultName ResultSource + +-- | Encapsulates the result source. +data ResultSource = ResultItemSource ResultItem + -- ^ The source consisting of a single item. + | ResultObjectSource ResultObject + -- ^ An object-like source. + | ResultVectorSource ResultVector + -- ^ A vector-like structure. + | ResultSeparatorSource ResultSeparator + -- ^ This is a separator text. + +-- | The simulation results represented by a single item. +data ResultItem = forall a. ResultItemable a => ResultItem a + +-- | Represents a type class for actual representing the items. +class ResultItemable a where + + -- | The item name. + resultItemName :: a -> ResultName + + -- | The item identifier. + resultItemId :: a -> ResultId + + -- | Whether the item emits a signal. + resultItemSignal :: a -> ResultSignal + + -- | Return an expanded version of the item, for example, + -- when the statistics item is exanded to an object + -- having the corresponded properties for count, average, + -- deviation, minimum, maximum and so on. + resultItemExpansion :: a -> ResultSource + + -- | Return usually a short version of the item, i.e. its summary, + -- but values of some data types such as statistics can be + -- implicitly expanded to an object with the corresponded + -- properties. + resultItemSummary :: a -> ResultSource + + -- | Return integer numbers in time points. + resultItemToIntValue :: a -> ResultValue Int + + -- | Return lists of integer numbers in time points. + resultItemToIntListValue :: a -> ResultValue [Int] + + -- | Return statistics based on integer numbers. + resultItemToIntStatsValue :: a -> ResultValue (SamplingStats Int) + + -- | Return timing statistics based on integer numbers. + resultItemToIntTimingStatsValue :: a -> ResultValue (TimingStats Int) + + -- | Return double numbers in time points. + resultItemToDoubleValue :: a -> ResultValue Double + + -- | Return lists of double numbers in time points. + resultItemToDoubleListValue :: a -> ResultValue [Double] + + -- | Return statistics based on double numbers. + resultItemToDoubleStatsValue :: a -> ResultValue (SamplingStats Double) + + -- | Return timing statistics based on integer numbers. + resultItemToDoubleTimingStatsValue :: a -> ResultValue (TimingStats Double) + + -- | Return string representations in time points. + resultItemToStringValue :: a -> ResultValue String + +-- | Return a version optimised for fast aggregation of the statistics based on integer numbers. +resultItemToIntStatsEitherValue :: ResultItemable a => a -> ResultValue (Either Int (SamplingStats Int)) +resultItemToIntStatsEitherValue x = + case resultValueData x1 of + Just a1 -> fmap Left x1 + Nothing -> + case resultValueData x2 of + Just a2 -> fmap Right x2 + Nothing -> voidResultValue x2 + where + x1 = resultItemToIntValue x + x2 = resultItemToIntStatsValue x + +-- | Return a version optimised for fast aggregation of the statistics based on double floating point numbers. +resultItemToDoubleStatsEitherValue :: ResultItemable a => a -> ResultValue (Either Double (SamplingStats Double)) +resultItemToDoubleStatsEitherValue x = + case resultValueData x1 of + Just a1 -> fmap Left x1 + Nothing -> + case resultValueData x2 of + Just a2 -> fmap Right x2 + Nothing -> voidResultValue x2 + where + x1 = resultItemToDoubleValue x + x2 = resultItemToDoubleStatsValue x + +-- | The simulation results represented by an object having properties. +data ResultObject = + ResultObject { resultObjectName :: ResultName, + -- ^ The object name. + resultObjectId :: ResultId, + -- ^ The object identifier. + resultObjectTypeId :: ResultId, + -- ^ The object type identifier. + resultObjectProperties :: [ResultProperty], + -- ^ The object properties. + resultObjectSignal :: ResultSignal, + -- ^ A combined signal if present. + resultObjectSummary :: ResultSource + -- ^ A short version of the object, i.e. its summary. + } + +-- | The object property containing the simulation results. +data ResultProperty = + ResultProperty { resultPropertyLabel :: ResultName, + -- ^ The property short label. + resultPropertyId :: ResultId, + -- ^ The property identifier. + resultPropertySource :: ResultSource + -- ^ The simulation results supplied by the property. + } + +-- | The simulation results represented by a vector. +data ResultVector = + ResultVector { resultVectorName :: ResultName, + -- ^ The vector name. + resultVectorId :: ResultId, + -- ^ The vector identifier. + resultVectorItems :: A.Array Int ResultSource, + -- ^ The results supplied by the vector items. + resultVectorSubscript :: A.Array Int ResultName, + -- ^ The subscript used as a suffix to create item names. + resultVectorSignal :: ResultSignal, + -- ^ A combined signal if present. + resultVectorSummary :: ResultSource + -- ^ A short version of the vector, i.e. summary. + } + +-- | Calculate the result vector signal and memoize it in a new vector. +memoResultVectorSignal :: ResultVector -> ResultVector +memoResultVectorSignal x = + x { resultVectorSignal = + foldr (<>) mempty $ map resultSourceSignal $ A.elems $ resultVectorItems x } + +-- | Calculate the result vector summary and memoize it in a new vector. +memoResultVectorSummary :: ResultVector -> ResultVector +memoResultVectorSummary x = + x { resultVectorSummary = + ResultVectorSource $ + x { resultVectorItems = + A.array bnds [(i, resultSourceSummary e) | (i, e) <- ies] } } + where + arr = resultVectorItems x + bnds = A.bounds arr + ies = A.assocs arr + +-- | It separates the simulation results when printing. +data ResultSeparator = + ResultSeparator { resultSeparatorText :: String + -- ^ The separator text. + } + +-- | A parameterised value that actually represents a generalised result item that have no parametric type. +data ResultValue e = + ResultValue { resultValueName :: ResultName, + -- ^ The value name. + resultValueId :: ResultId, + -- ^ The value identifier. + resultValueData :: ResultData e, + -- ^ Simulation data supplied by the value. + resultValueSignal :: ResultSignal + -- ^ Whether the value emits a signal when changing simulation data. + } + +instance Functor ResultValue where + fmap f x = x { resultValueData = fmap (fmap f) (resultValueData x) } + +-- | Return a new value with the discarded simulation results. +voidResultValue :: ResultValue a -> ResultValue b +voidResultValue x = x { resultValueData = Nothing } + +-- | A container of the simulation results such as queue, server or array. +data ResultContainer e = + ResultContainer { resultContainerName :: ResultName, + -- ^ The container name. + resultContainerId :: ResultId, + -- ^ The container identifier. + resultContainerData :: e, + -- ^ The container data. + resultContainerSignal :: ResultSignal + -- ^ Whether the container emits a signal when changing simulation data. + } + +instance Functor ResultContainer where + fmap f x = x { resultContainerData = f (resultContainerData x) } + +-- | Create a new property source by the specified container. +resultContainerPropertySource :: ResultItemable (ResultValue b) + => ResultContainer a + -- ^ the container + -> ResultName + -- ^ the property label + -> ResultId + -- ^ the property identifier + -> (a -> ResultData b) + -- ^ get the specified data from the container + -> (a -> ResultSignal) + -- ^ get the data signal from the container + -> ResultSource +resultContainerPropertySource cont name i f g = + ResultItemSource $ + ResultItem $ + ResultValue { + resultValueName = (resultContainerName cont) ++ "." ++ name, + resultValueId = i, + resultValueData = f (resultContainerData cont), + resultValueSignal = g (resultContainerData cont) } + +-- | Create a constant property by the specified container. +resultContainerConstProperty :: ResultItemable (ResultValue b) + => ResultContainer a + -- ^ the container + -> ResultName + -- ^ the property label + -> ResultId + -- ^ the property identifier + -> (a -> b) + -- ^ get the specified data from the container + -> ResultProperty +resultContainerConstProperty cont name i f = + ResultProperty { + resultPropertyLabel = name, + resultPropertyId = i, + resultPropertySource = + resultContainerPropertySource cont name i (Just . return . f) (const EmptyResultSignal) } + +-- | Create by the specified container a property that changes in the integration time points, or it is supposed to be such one. +resultContainerIntegProperty :: ResultItemable (ResultValue b) + => ResultContainer a + -- ^ the container + -> ResultName + -- ^ the property label + -> ResultId + -- ^ the property identifier + -> (a -> Event b) + -- ^ get the specified data from the container + -> ResultProperty +resultContainerIntegProperty cont name i f = + ResultProperty { + resultPropertyLabel = name, + resultPropertyId = i, + resultPropertySource = + resultContainerPropertySource cont name i (Just . f) (const UnknownResultSignal) } + +-- | Create a property by the specified container. +resultContainerProperty :: ResultItemable (ResultValue b) + => ResultContainer a + -- ^ the container + -> ResultName + -- ^ the property label + -> ResultId + -- ^ the property identifier + -> (a -> Event b) + -- ^ get the specified data from the container + -> (a -> Signal ()) + -- ^ get a signal triggered when changing data. + -> ResultProperty +resultContainerProperty cont name i f g = + ResultProperty { + resultPropertyLabel = name, + resultPropertyId = i, + resultPropertySource = + resultContainerPropertySource cont name i (Just . f) (ResultSignal . g) } + +-- | Create by the specified container a mapped property which is recomputed each time again and again. +resultContainerMapProperty :: ResultItemable (ResultValue b) + => ResultContainer (ResultData a) + -- ^ the container + -> ResultName + -- ^ the property label + -> ResultId + -- ^ the property identifier + -> (a -> b) + -- ^ recompute the specified data + -> ResultProperty +resultContainerMapProperty cont name i f = + ResultProperty { + resultPropertyLabel = name, + resultPropertyId = i, + resultPropertySource = + resultContainerPropertySource cont name i (fmap $ fmap f) (const $ resultContainerSignal cont) } + +-- | Convert the result value to a container with the specified object identifier. +resultValueToContainer :: ResultValue a -> ResultContainer (ResultData a) +resultValueToContainer x = + ResultContainer { + resultContainerName = resultValueName x, + resultContainerId = resultValueId x, + resultContainerData = resultValueData x, + resultContainerSignal = resultValueSignal x } + +-- | Convert the result container to a value. +resultContainerToValue :: ResultContainer (ResultData a) -> ResultValue a +resultContainerToValue x = + ResultValue { + resultValueName = resultContainerName x, + resultValueId = resultContainerId x, + resultValueData = resultContainerData x, + resultValueSignal = resultContainerSignal x } + +-- | Represents the very simulation results. +type ResultData e = Maybe (Event e) + +-- | Whether an object containing the results emits a signal notifying about change of data. +data ResultSignal = EmptyResultSignal + -- ^ There is no signal at all. + | UnknownResultSignal + -- ^ The signal is unknown, but the entity probably changes. + | ResultSignal (Signal ()) + -- ^ When the signal is precisely specified. + | ResultSignalMix (Signal ()) + -- ^ When the specified signal was combined with unknown signal. + +instance Monoid ResultSignal where + + mempty = EmptyResultSignal + + mappend EmptyResultSignal z = z + + mappend UnknownResultSignal EmptyResultSignal = UnknownResultSignal + mappend UnknownResultSignal UnknownResultSignal = UnknownResultSignal + mappend UnknownResultSignal (ResultSignal x) = ResultSignalMix x + mappend UnknownResultSignal z@(ResultSignalMix x) = z + + mappend z@(ResultSignal x) EmptyResultSignal = z + mappend (ResultSignal x) UnknownResultSignal = ResultSignalMix x + mappend (ResultSignal x) (ResultSignal y) = ResultSignal (x <> y) + mappend (ResultSignal x) (ResultSignalMix y) = ResultSignalMix (x <> y) + + mappend z@(ResultSignalMix x) EmptyResultSignal = z + mappend z@(ResultSignalMix x) UnknownResultSignal = z + mappend (ResultSignalMix x) (ResultSignal y) = ResultSignalMix (x <> y) + mappend (ResultSignalMix x) (ResultSignalMix y) = ResultSignalMix (x <> y) + +-- | Construct a new result signal by the specified optional pure signal. +maybeResultSignal :: Maybe (Signal ()) -> ResultSignal +maybeResultSignal (Just x) = ResultSignal x +maybeResultSignal Nothing = EmptyResultSignal + +instance ResultItemable (ResultValue Int) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = id + resultItemToIntListValue = fmap return + resultItemToIntStatsValue = fmap returnSamplingStats + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = fmap fromIntegral + resultItemToDoubleListValue = fmap (return . fromIntegral) + resultItemToDoubleStatsValue = fmap (returnSamplingStats . fromIntegral) + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = fmap show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue Double) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = id + resultItemToDoubleListValue = fmap return + resultItemToDoubleStatsValue = fmap returnSamplingStats + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = fmap show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue [Int]) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = id + resultItemToIntStatsValue = fmap listSamplingStats + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = fmap (map fromIntegral) + resultItemToDoubleStatsValue = fmap (fromIntSamplingStats . listSamplingStats) + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = fmap show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue [Double]) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = id + resultItemToDoubleStatsValue = fmap listSamplingStats + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = fmap show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue (SamplingStats Int)) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = id + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = fmap fromIntSamplingStats + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = fmap show + + resultItemExpansion = samplingStatsResultSource + resultItemSummary = samplingStatsResultSummary + +instance ResultItemable (ResultValue (SamplingStats Double)) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = id + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = fmap show + + resultItemExpansion = samplingStatsResultSource + resultItemSummary = samplingStatsResultSummary + +instance ResultItemable (ResultValue (TimingStats Int)) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = id + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = fmap fromIntTimingStats + + resultItemToStringValue = fmap show + + resultItemExpansion = timingStatsResultSource + resultItemSummary = timingStatsResultSummary + +instance ResultItemable (ResultValue (TimingStats Double)) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = id + + resultItemToStringValue = fmap show + + resultItemExpansion = timingStatsResultSource + resultItemSummary = timingStatsResultSummary + +instance ResultItemable (ResultValue Bool) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = fmap show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue String) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = fmap show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue ()) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = fmap show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue FCFS) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = fmap show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue LCFS) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = fmap show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue SIRO) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = fmap show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +instance ResultItemable (ResultValue StaticPriorities) where + + resultItemName = resultValueName + resultItemId = resultValueId + resultItemSignal = resultValueSignal + + resultItemToIntValue = voidResultValue + resultItemToIntListValue = voidResultValue + resultItemToIntStatsValue = voidResultValue + resultItemToIntTimingStatsValue = voidResultValue + + resultItemToDoubleValue = voidResultValue + resultItemToDoubleListValue = voidResultValue + resultItemToDoubleStatsValue = voidResultValue + resultItemToDoubleTimingStatsValue = voidResultValue + + resultItemToStringValue = fmap show + + resultItemExpansion = ResultItemSource . ResultItem + resultItemSummary = ResultItemSource . ResultItem + +-- | Flatten the result source. +flattenResultSource :: ResultSource -> [ResultItem] +flattenResultSource (ResultItemSource x) = [x] +flattenResultSource (ResultObjectSource x) = + concat $ map (flattenResultSource . resultPropertySource) $ resultObjectProperties x +flattenResultSource (ResultVectorSource x) = + concat $ map flattenResultSource $ A.elems $ resultVectorItems x +flattenResultSource (ResultSeparatorSource x) = [] + +-- | Return the result source name. +resultSourceName :: ResultSource -> ResultName +resultSourceName (ResultItemSource (ResultItem x)) = resultItemName x +resultSourceName (ResultObjectSource x) = resultObjectName x +resultSourceName (ResultVectorSource x) = resultVectorName x +resultSourceName (ResultSeparatorSource x) = [] + +-- | Expand the result source returning a more detailed version expanding the properties as possible. +expandResultSource :: ResultSource -> ResultSource +expandResultSource (ResultItemSource (ResultItem x)) = resultItemExpansion x +expandResultSource (ResultObjectSource x) = + ResultObjectSource $ + x { resultObjectProperties = + flip fmap (resultObjectProperties x) $ \p -> + p { resultPropertySource = expandResultSource (resultPropertySource p) } } +expandResultSource (ResultVectorSource x) = + ResultVectorSource $ + x { resultVectorItems = + A.array bnds [(i, expandResultSource e) | (i, e) <- ies] } + where arr = resultVectorItems x + bnds = A.bounds arr + ies = A.assocs arr +expandResultSource z@(ResultSeparatorSource x) = z + +-- | Return a summarised and usually more short version of the result source expanding the main properties or excluding auxiliary properties if required. +resultSourceSummary :: ResultSource -> ResultSource +resultSourceSummary (ResultItemSource (ResultItem x)) = resultItemSummary x +resultSourceSummary (ResultObjectSource x) = resultObjectSummary x +resultSourceSummary (ResultVectorSource x) = resultVectorSummary x +resultSourceSummary z@(ResultSeparatorSource x) = z + +-- | Return a signal emitted by the source. +resultSourceSignal :: ResultSource -> ResultSignal +resultSourceSignal (ResultItemSource (ResultItem x)) = resultItemSignal x +resultSourceSignal (ResultObjectSource x) = resultObjectSignal x +resultSourceSignal (ResultVectorSource x) = resultVectorSignal x +resultSourceSignal (ResultSeparatorSource x) = EmptyResultSignal + +-- | Represent the result source as integer numbers. +resultSourceToIntValues :: ResultSource -> [ResultValue Int] +resultSourceToIntValues = map (\(ResultItem x) -> resultItemToIntValue x) . flattenResultSource + +-- | Represent the result source as lists of integer numbers. +resultSourceToIntListValues :: ResultSource -> [ResultValue [Int]] +resultSourceToIntListValues = map (\(ResultItem x) -> resultItemToIntListValue x) . flattenResultSource + +-- | Represent the result source as statistics based on integer numbers. +resultSourceToIntStatsValues :: ResultSource -> [ResultValue (SamplingStats Int)] +resultSourceToIntStatsValues = map (\(ResultItem x) -> resultItemToIntStatsValue x) . flattenResultSource + +-- | Represent the result source as statistics based on integer numbers and optimised for fast aggregation. +resultSourceToIntStatsEitherValues :: ResultSource -> [ResultValue (Either Int (SamplingStats Int))] +resultSourceToIntStatsEitherValues = map (\(ResultItem x) -> resultItemToIntStatsEitherValue x) . flattenResultSource + +-- | Represent the result source as timing statistics based on integer numbers. +resultSourceToIntTimingStatsValues :: ResultSource -> [ResultValue (TimingStats Int)] +resultSourceToIntTimingStatsValues = map (\(ResultItem x) -> resultItemToIntTimingStatsValue x) . flattenResultSource + +-- | Represent the result source as double floating point numbers. +resultSourceToDoubleValues :: ResultSource -> [ResultValue Double] +resultSourceToDoubleValues = map (\(ResultItem x) -> resultItemToDoubleValue x) . flattenResultSource + +-- | Represent the result source as lists of double floating point numbers. +resultSourceToDoubleListValues :: ResultSource -> [ResultValue [Double]] +resultSourceToDoubleListValues = map (\(ResultItem x) -> resultItemToDoubleListValue x) . flattenResultSource + +-- | Represent the result source as statistics based on double floating point numbers. +resultSourceToDoubleStatsValues :: ResultSource -> [ResultValue (SamplingStats Double)] +resultSourceToDoubleStatsValues = map (\(ResultItem x) -> resultItemToDoubleStatsValue x) . flattenResultSource + +-- | Represent the result source as statistics based on double floating point numbers and optimised for fast aggregation. +resultSourceToDoubleStatsEitherValues :: ResultSource -> [ResultValue (Either Double (SamplingStats Double))] +resultSourceToDoubleStatsEitherValues = map (\(ResultItem x) -> resultItemToDoubleStatsEitherValue x) . flattenResultSource + +-- | Represent the result source as timing statistics based on double floating point numbers. +resultSourceToDoubleTimingStatsValues :: ResultSource -> [ResultValue (TimingStats Double)] +resultSourceToDoubleTimingStatsValues = map (\(ResultItem x) -> resultItemToDoubleTimingStatsValue x) . flattenResultSource + +-- | Represent the result source as string values. +resultSourceToStringValues :: ResultSource -> [ResultValue String] +resultSourceToStringValues = map (\(ResultItem x) -> resultItemToStringValue x) . flattenResultSource + +-- | It contains the results of simulation. +data Results = + Results { resultSourceMap :: ResultSourceMap, + -- ^ The sources of simulation results as a map of associated names. + resultSourceList :: [ResultSource] + -- ^ The sources of simulation results as an ordered list. + } + +-- | It transforms the results of simulation. +type ResultTransform = Results -> Results + +-- | It representes the predefined signals provided by every simulation model. +data ResultPredefinedSignals = + ResultPredefinedSignals { resultSignalInIntegTimes :: Signal Double, + -- ^ The signal triggered in the integration time points. + resultSignalInStartTime :: Signal Double, + -- ^ The signal triggered in the start time. + resultSignalInStopTime :: Signal Double + -- ^ The signal triggered in the stop time. + } + +-- | Create the predefined signals provided by every simulation model. +newResultPredefinedSignals :: Simulation ResultPredefinedSignals +newResultPredefinedSignals = runDynamicsInStartTime $ runEventWith EarlierEvents d where + d = do signalInIntegTimes <- newSignalInIntegTimes + signalInStartTime <- newSignalInStartTime + signalInStopTime <- newSignalInStopTime + return ResultPredefinedSignals { resultSignalInIntegTimes = signalInIntegTimes, + resultSignalInStartTime = signalInStartTime, + resultSignalInStopTime = signalInStopTime } + +instance Monoid Results where + + mempty = results mempty + mappend x y = results $ resultSourceList x <> resultSourceList y + +-- | Prepare the simulation results. +results :: [ResultSource] -> Results +results ms = + Results { resultSourceMap = M.fromList $ map (\x -> (resultSourceName x, x)) ms, + resultSourceList = ms } + +-- | Represent the results as integer numbers. +resultsToIntValues :: Results -> [ResultValue Int] +resultsToIntValues = concat . map resultSourceToIntValues . resultSourceList + +-- | Represent the results as lists of integer numbers. +resultsToIntListValues :: Results -> [ResultValue [Int]] +resultsToIntListValues = concat . map resultSourceToIntListValues . resultSourceList + +-- | Represent the results as statistics based on integer numbers. +resultsToIntStatsValues :: Results -> [ResultValue (SamplingStats Int)] +resultsToIntStatsValues = concat . map resultSourceToIntStatsValues . resultSourceList + +-- | Represent the results as statistics based on integer numbers and optimised for fast aggregation. +resultsToIntStatsEitherValues :: Results -> [ResultValue (Either Int (SamplingStats Int))] +resultsToIntStatsEitherValues = concat . map resultSourceToIntStatsEitherValues . resultSourceList + +-- | Represent the results as timing statistics based on integer numbers. +resultsToIntTimingStatsValues :: Results -> [ResultValue (TimingStats Int)] +resultsToIntTimingStatsValues = concat . map resultSourceToIntTimingStatsValues . resultSourceList + +-- | Represent the results as double floating point numbers. +resultsToDoubleValues :: Results -> [ResultValue Double] +resultsToDoubleValues = concat . map resultSourceToDoubleValues . resultSourceList + +-- | Represent the results as lists of double floating point numbers. +resultsToDoubleListValues :: Results -> [ResultValue [Double]] +resultsToDoubleListValues = concat . map resultSourceToDoubleListValues . resultSourceList + +-- | Represent the results as statistics based on double floating point numbers. +resultsToDoubleStatsValues :: Results -> [ResultValue (SamplingStats Double)] +resultsToDoubleStatsValues = concat . map resultSourceToDoubleStatsValues . resultSourceList + +-- | Represent the results as statistics based on double floating point numbers and optimised for fast aggregation. +resultsToDoubleStatsEitherValues :: Results -> [ResultValue (Either Double (SamplingStats Double))] +resultsToDoubleStatsEitherValues = concat . map resultSourceToDoubleStatsEitherValues . resultSourceList + +-- | Represent the results as timing statistics based on double floating point numbers. +resultsToDoubleTimingStatsValues :: Results -> [ResultValue (TimingStats Double)] +resultsToDoubleTimingStatsValues = concat . map resultSourceToDoubleTimingStatsValues . resultSourceList + +-- | Represent the results as string values. +resultsToStringValues :: Results -> [ResultValue String] +resultsToStringValues = concat . map resultSourceToStringValues . resultSourceList + +-- | Return a signal emitted by the specified results. +resultSignal :: Results -> ResultSignal +resultSignal = mconcat . map resultSourceSignal . resultSourceList + +-- | Return an expanded version of the simulation results expanding the properties as possible, which +-- takes place for expanding statistics to show the count, average, deviation, minimum, maximum etc. +-- as separate values. +expandResults :: ResultTransform +expandResults = results . map expandResultSource . resultSourceList + +-- | Return a short version of the simulation results, i.e. their summary, expanding the main properties +-- or excluding auxiliary properties if required. +resultSummary :: ResultTransform +resultSummary = results . map resultSourceSummary . resultSourceList + +-- | Take a result by its name. +resultByName :: ResultName -> ResultTransform +resultByName name rs = + case M.lookup name (resultSourceMap rs) of + Just x -> results [x] + Nothing -> + error $ + "Not found result source with name " ++ name ++ + ": resultByName" + +-- | Take a result from the object with the specified property label, +-- but it is more preferrable to refer to the property by its 'ResultId' +-- identifier with help of the 'resultById' function. +resultByProperty :: ResultName -> ResultTransform +resultByProperty label rs = flip composeResults rs loop + where + loop x = + case x of + ResultObjectSource s -> + let ps = + flip filter (resultObjectProperties s) $ \p -> + resultPropertyLabel p == label + in case ps of + [] -> + error $ + "Not found property " ++ label ++ + " for object " ++ resultObjectName s ++ + ": resultByProperty" + ps -> + map resultPropertySource ps + ResultVectorSource s -> + concat $ map loop $ A.elems $ resultVectorItems s + x -> + error $ + "Result source " ++ resultSourceName x ++ + " is neither object, nor vector " ++ + ": resultByProperty" + +-- | Take a result from the object with the specified identifier. It can identify +-- an item, object property, the object iself, vector or its elements. +resultById :: ResultId -> ResultTransform +resultById i rs = flip composeResults rs loop + where + loop x = + case x of + ResultItemSource (ResultItem s) -> + if resultItemId s == i + then [x] + else error $ + "Expected to find item with Id = " ++ show i ++ + ", while the item " ++ resultItemName s ++ + " has actual Id = " ++ show (resultItemId s) ++ + ": resultById" + ResultObjectSource s -> + if resultObjectId s == i + then [x] + else let ps = + flip filter (resultObjectProperties s) $ \p -> + resultPropertyId p == i + in case ps of + [] -> + error $ + "Not found property with Id = " ++ show i ++ + " for object " ++ resultObjectName s ++ + " that has actual Id = " ++ show (resultObjectId s) ++ + ": resultById" + ps -> + map resultPropertySource ps + ResultVectorSource s -> + if resultVectorId s == i + then [x] + else concat $ map loop $ A.elems $ resultVectorItems s + x -> + error $ + "Result source " ++ resultSourceName x ++ + " is neither item, nor object, nor vector " ++ + ": resultById" + +-- | Take a result from the vector by the specified integer index. +resultByIndex :: Int -> ResultTransform +resultByIndex index rs = flip composeResults rs loop + where + loop x = + case x of + ResultVectorSource s -> + [resultVectorItems s A.! index] + x -> + error $ + "Result source " ++ resultSourceName x ++ + " is not vector " ++ + ": resultByIndex" + +-- | Take a result from the vector by the specified string subscript. +resultBySubscript :: ResultName -> ResultTransform +resultBySubscript subscript rs = flip composeResults rs loop + where + loop x = + case x of + ResultVectorSource s -> + let ys = A.elems $ resultVectorItems s + zs = A.elems $ resultVectorSubscript s + ps = + flip filter (zip ys zs) $ \(y, z) -> + z == subscript + in case ps of + [] -> + error $ + "Not found subscript " ++ subscript ++ + " for vector " ++ resultVectorName s ++ + ": resultBySubscript" + ps -> + map fst ps + x -> + error $ + "Result source " ++ resultSourceName x ++ + " is not vector " ++ + ": resultBySubscript" + +-- | Compose the results using the specified transformation function. +composeResults :: (ResultSource -> [ResultSource]) -> ResultTransform +composeResults f = + results . concat . map f . resultSourceList + +-- | Concatenate the results using the specified list of transformation functions. +concatResults :: [ResultTransform] -> ResultTransform +concatResults trs rs = + results $ concat $ map (\tr -> resultSourceList $ tr rs) trs + +-- | Append the results using the specified transformation functions. +appendResults :: ResultTransform -> ResultTransform -> ResultTransform +appendResults x y = + concatResults [x, y] + +-- | Return a pure signal as a result of combination of the predefined signals +-- with the specified result signal usually provided by the sources. +-- +-- The signal returned is triggered when the source signal is triggered. +-- The pure signal is also triggered in the integration time points +-- if the source signal is unknown or it was combined with any unknown signal. +pureResultSignal :: ResultPredefinedSignals -> ResultSignal -> Signal () +pureResultSignal rs EmptyResultSignal = + void (resultSignalInStartTime rs) +pureResultSignal rs UnknownResultSignal = + void (resultSignalInIntegTimes rs) +pureResultSignal rs (ResultSignal s) = + void (resultSignalInStartTime rs) <> void (resultSignalInStopTime rs) <> s +pureResultSignal rs (ResultSignalMix s) = + void (resultSignalInIntegTimes rs) <> s + +-- | Defines a final result extract: its name, values and other data. +data ResultExtract e = + ResultExtract { resultExtractName :: ResultName, + -- ^ The result name. + resultExtractId :: ResultId, + -- ^ The result identifier. + resultExtractData :: Event e, + -- ^ The result values. + resultExtractSignal :: ResultSignal + -- ^ Whether the result emits a signal. + } + +-- | Extract the results as integer values, or raise a conversion error. +extractIntResults :: Results -> [ResultExtract Int] +extractIntResults rs = flip map (resultsToIntValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of integer values: extractIntResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as lists of integer values, or raise a conversion error. +extractIntListResults :: Results -> [ResultExtract [Int]] +extractIntListResults rs = flip map (resultsToIntListValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of lists of integer values: extractIntListResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as statistics based on integer values, +-- or raise a conversion error. +extractIntStatsResults :: Results -> [ResultExtract (SamplingStats Int)] +extractIntStatsResults rs = flip map (resultsToIntStatsValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of statistics based on integer values: extractIntStatsResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as statistics based on integer values and optimised +-- for fast aggregation, or raise a conversion error. +extractIntStatsEitherResults :: Results -> [ResultExtract (Either Int (SamplingStats Int))] +extractIntStatsEitherResults rs = flip map (resultsToIntStatsEitherValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of statistics based on integer values: extractIntStatsEitherResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as timing statistics based on integer values, +-- or raise a conversion error. +extractIntTimingStatsResults :: Results -> [ResultExtract (TimingStats Int)] +extractIntTimingStatsResults rs = flip map (resultsToIntTimingStatsValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of timing statistics based on integer values: extractIntTimingStatsResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as double floating point values, or raise a conversion error. +extractDoubleResults :: Results -> [ResultExtract Double] +extractDoubleResults rs = flip map (resultsToDoubleValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of double floating point values: extractDoubleResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as lists of double floating point values, +-- or raise a conversion error. +extractDoubleListResults :: Results -> [ResultExtract [Double]] +extractDoubleListResults rs = flip map (resultsToDoubleListValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of lists of double floating point values: extractDoubleListResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as statistics based on double floating point values, +-- or raise a conversion error. +extractDoubleStatsResults :: Results -> [ResultExtract (SamplingStats Double)] +extractDoubleStatsResults rs = flip map (resultsToDoubleStatsValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of statistics based on double floating point values: extractDoubleStatsResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as statistics based on double floating point values +-- and optimised for fast aggregation, or raise a conversion error. +extractDoubleStatsEitherResults :: Results -> [ResultExtract (Either Double (SamplingStats Double))] +extractDoubleStatsEitherResults rs = flip map (resultsToDoubleStatsEitherValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of statistics based on double floating point values: extractDoubleStatsEitherResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as timing statistics based on double floating point values, +-- or raise a conversion error. +extractDoubleTimingStatsResults :: Results -> [ResultExtract (TimingStats Double)] +extractDoubleTimingStatsResults rs = flip map (resultsToDoubleTimingStatsValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of timing statistics based on double floating point values: extractDoubleTimingStatsResults" + Just a -> + ResultExtract n i a s + +-- | Extract the results as string values, or raise a conversion error. +extractStringResults :: Results -> [ResultExtract String] +extractStringResults rs = flip map (resultsToStringValues rs) $ \x -> + let n = resultValueName x + i = resultValueId x + a = resultValueData x + s = resultValueSignal x + in case a of + Nothing -> + error $ + "Cannot represent variable " ++ n ++ + " as a source of string values: extractStringResults" + Just a -> + ResultExtract n i a s + +-- | Represents a computation that can return the simulation data. +class ResultComputing m where + + -- | Compute data with the results of simulation. + computeResultData :: m a -> ResultData a + + -- | Return the signal triggered when data change if such a signal exists. + computeResultSignal :: m a -> ResultSignal + +-- | Return a new result value by the specified name, identifier and computation. +computeResultValue :: ResultComputing m + => ResultName + -- ^ the result name + -> ResultId + -- ^ the result identifier + -> m a + -- ^ the result computation + -> ResultValue a +computeResultValue name i m = + ResultValue { + resultValueName = name, + resultValueId = i, + resultValueData = computeResultData m, + resultValueSignal = computeResultSignal m } + +-- | Represents a computation that can return the simulation data. +data ResultComputation a = + ResultComputation { resultComputationData :: ResultData a, + -- ^ Return data from the computation. + resultComputationSignal :: ResultSignal + -- ^ Return a signal from the computation. + } + +instance ResultComputing ResultComputation where + + computeResultData = resultComputationData + computeResultSignal = resultComputationSignal + +instance ResultComputing Parameter where + + computeResultData = Just . liftParameter + computeResultSignal = const UnknownResultSignal + +instance ResultComputing Simulation where + + computeResultData = Just . liftSimulation + computeResultSignal = const UnknownResultSignal + +instance ResultComputing Dynamics where + + computeResultData = Just . liftDynamics + computeResultSignal = const UnknownResultSignal + +instance ResultComputing Event where + + computeResultData = Just . id + computeResultSignal = const UnknownResultSignal + +instance ResultComputing Ref where + + computeResultData = Just . readRef + computeResultSignal = ResultSignal . refChanged_ + +instance ResultComputing LR.Ref where + + computeResultData = Just . LR.readRef + computeResultSignal = const UnknownResultSignal + +instance ResultComputing Var where + + computeResultData = Just . readVar + computeResultSignal = ResultSignal . varChanged_ + +instance ResultComputing Signalable where + + computeResultData = Just . readSignalable + computeResultSignal = ResultSignal . signalableChanged_ + +-- | Return a source by the specified statistics. +samplingStatsResultSource :: (ResultItemable (ResultValue a), + ResultItemable (ResultValue (SamplingStats a))) + => ResultValue (SamplingStats a) + -- ^ the statistics + -> ResultSource +samplingStatsResultSource x = + ResultObjectSource $ + ResultObject { + resultObjectName = resultValueName x, + resultObjectId = resultValueId x, + resultObjectTypeId = SamplingStatsId, + resultObjectSignal = resultValueSignal x, + resultObjectSummary = samplingStatsResultSummary x, + resultObjectProperties = [ + resultContainerMapProperty c "count" SamplingStatsCountId samplingStatsCount, + resultContainerMapProperty c "mean" SamplingStatsMeanId samplingStatsMean, + resultContainerMapProperty c "mean2" SamplingStatsMean2Id samplingStatsMean2, + resultContainerMapProperty c "std" SamplingStatsDeviationId samplingStatsDeviation, + resultContainerMapProperty c "var" SamplingStatsVarianceId samplingStatsVariance, + resultContainerMapProperty c "min" SamplingStatsMinId samplingStatsMin, + resultContainerMapProperty c "max" SamplingStatsMaxId samplingStatsMax ] } + where + c = resultValueToContainer x + +-- | Return the summary by the specified statistics. +samplingStatsResultSummary :: ResultItemable (ResultValue (SamplingStats a)) + => ResultValue (SamplingStats a) + -- ^ the statistics + -> ResultSource +samplingStatsResultSummary = ResultItemSource . ResultItem . resultItemToStringValue + +-- | Return a source by the specified timing statistics. +timingStatsResultSource :: (TimingData a, + ResultItemable (ResultValue a), + ResultItemable (ResultValue (TimingStats a))) + => ResultValue (TimingStats a) + -- ^ the statistics + -> ResultSource +timingStatsResultSource x = + ResultObjectSource $ + ResultObject { + resultObjectName = resultValueName x, + resultObjectId = resultValueId x, + resultObjectTypeId = TimingStatsId, + resultObjectSignal = resultValueSignal x, + resultObjectSummary = timingStatsResultSummary x, + resultObjectProperties = [ + resultContainerMapProperty c "count" TimingStatsCountId timingStatsCount, + resultContainerMapProperty c "mean" TimingStatsMeanId timingStatsMean, + resultContainerMapProperty c "std" TimingStatsDeviationId timingStatsDeviation, + resultContainerMapProperty c "var" TimingStatsVarianceId timingStatsVariance, + resultContainerMapProperty c "min" TimingStatsMinId timingStatsMin, + resultContainerMapProperty c "max" TimingStatsMaxId timingStatsMax, + resultContainerMapProperty c "minTime" TimingStatsMinTimeId timingStatsMinTime, + resultContainerMapProperty c "maxTime" TimingStatsMaxTimeId timingStatsMaxTime, + resultContainerMapProperty c "startTime" TimingStatsStartTimeId timingStatsStartTime, + resultContainerMapProperty c "lastTime" TimingStatsLastTimeId timingStatsLastTime, + resultContainerMapProperty c "sum" TimingStatsSumId timingStatsSum, + resultContainerMapProperty c "sum2" TimingStatsSum2Id timingStatsSum2 ] } + where + c = resultValueToContainer x + +-- | Return the summary by the specified timing statistics. +timingStatsResultSummary :: (TimingData a, ResultItemable (ResultValue (TimingStats a))) + => ResultValue (TimingStats a) + -- ^ the statistics + -> ResultSource +timingStatsResultSummary = ResultItemSource . ResultItem . resultItemToStringValue + +-- | Return a source by the specified finite queue. +queueResultSource :: (Show si, Show sm, Show so, + ResultItemable (ResultValue si), + ResultItemable (ResultValue sm), + ResultItemable (ResultValue so)) + => ResultContainer (Q.Queue si sm so a) + -- ^ the queue container + -> ResultSource +queueResultSource c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = FiniteQueueId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = queueResultSummary c, + resultObjectProperties = [ + resultContainerConstProperty c "enqueueStrategy" EnqueueStrategyId Q.enqueueStrategy, + resultContainerConstProperty c "enqueueStoringStrategy" EnqueueStoringStrategyId Q.enqueueStoringStrategy, + resultContainerConstProperty c "dequeueStrategy" DequeueStrategyId Q.dequeueStrategy, + resultContainerProperty c "queueNull" QueueNullId Q.queueNull Q.queueNullChanged_, + resultContainerProperty c "queueFull" QueueFullId Q.queueFull Q.queueFullChanged_, + resultContainerConstProperty c "queueMaxCount" QueueMaxCountId Q.queueMaxCount, + resultContainerProperty c "queueCount" QueueCountId Q.queueCount Q.queueCountChanged_, + resultContainerProperty c "queueCountStats" QueueCountStatsId Q.queueCountStats Q.queueCountChanged_, + resultContainerProperty c "enqueueCount" EnqueueCountId Q.enqueueCount Q.enqueueCountChanged_, + resultContainerProperty c "enqueueLostCount" EnqueueLostCountId Q.enqueueLostCount Q.enqueueLostCountChanged_, + resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId Q.enqueueStoreCount Q.enqueueStoreCountChanged_, + resultContainerProperty c "dequeueCount" DequeueCountId Q.dequeueCount Q.dequeueCountChanged_, + resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId Q.dequeueExtractCount Q.dequeueExtractCountChanged_, + resultContainerProperty c "queueLoadFactor" QueueLoadFactorId Q.queueLoadFactor Q.queueLoadFactorChanged_, + resultContainerIntegProperty c "enqueueRate" EnqueueRateId Q.enqueueRate, + resultContainerIntegProperty c "enqueueStoreRate" EnqueueStoreRateId Q.enqueueStoreRate, + resultContainerIntegProperty c "dequeueRate" DequeueRateId Q.dequeueRate, + resultContainerIntegProperty c "dequeueExtractRate" DequeueExtractRateId Q.dequeueExtractRate, + resultContainerProperty c "queueWaitTime" QueueWaitTimeId Q.queueWaitTime Q.queueWaitTimeChanged_, + resultContainerProperty c "queueTotalWaitTime" QueueTotalWaitTimeId Q.queueTotalWaitTime Q.queueTotalWaitTimeChanged_, + resultContainerProperty c "enqueueWaitTime" EnqueueWaitTimeId Q.enqueueWaitTime Q.enqueueWaitTimeChanged_, + resultContainerProperty c "dequeueWaitTime" DequeueWaitTimeId Q.dequeueWaitTime Q.dequeueWaitTimeChanged_, + resultContainerProperty c "queueRate" QueueRateId Q.queueRate Q.queueRateChanged_ ] } + +-- | Return the summary by the specified finite queue. +queueResultSummary :: (Show si, Show sm, Show so) + => ResultContainer (Q.Queue si sm so a) + -- ^ the queue container + -> ResultSource +queueResultSummary c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = FiniteQueueId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = queueResultSummary c, + resultObjectProperties = [ + resultContainerConstProperty c "queueMaxCount" QueueMaxCountId Q.queueMaxCount, + resultContainerProperty c "queueCountStats" QueueCountStatsId Q.queueCountStats Q.queueCountChanged_, + resultContainerProperty c "enqueueCount" EnqueueCountId Q.enqueueCount Q.enqueueCountChanged_, + resultContainerProperty c "enqueueLostCount" EnqueueLostCountId Q.enqueueLostCount Q.enqueueLostCountChanged_, + resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId Q.enqueueStoreCount Q.enqueueStoreCountChanged_, + resultContainerProperty c "dequeueCount" DequeueCountId Q.dequeueCount Q.dequeueCountChanged_, + resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId Q.dequeueExtractCount Q.dequeueExtractCountChanged_, + resultContainerProperty c "queueLoadFactor" QueueLoadFactorId Q.queueLoadFactor Q.queueLoadFactorChanged_, + resultContainerProperty c "queueWaitTime" QueueWaitTimeId Q.queueWaitTime Q.queueWaitTimeChanged_, + resultContainerProperty c "queueRate" QueueRateId Q.queueRate Q.queueRateChanged_ ] } + +-- | Return a source by the specified infinite queue. +infiniteQueueResultSource :: (Show sm, Show so, + ResultItemable (ResultValue sm), + ResultItemable (ResultValue so)) + => ResultContainer (IQ.Queue sm so a) + -- ^ the queue container + -> ResultSource +infiniteQueueResultSource c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = FiniteQueueId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = infiniteQueueResultSummary c, + resultObjectProperties = [ + resultContainerConstProperty c "enqueueStoringStrategy" EnqueueStoringStrategyId IQ.enqueueStoringStrategy, + resultContainerConstProperty c "dequeueStrategy" DequeueStrategyId IQ.dequeueStrategy, + resultContainerProperty c "queueNull" QueueNullId IQ.queueNull IQ.queueNullChanged_, + resultContainerProperty c "queueCount" QueueCountId IQ.queueCount IQ.queueCountChanged_, + resultContainerProperty c "queueCountStats" QueueCountStatsId IQ.queueCountStats IQ.queueCountChanged_, + resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId IQ.enqueueStoreCount IQ.enqueueStoreCountChanged_, + resultContainerProperty c "dequeueCount" DequeueCountId IQ.dequeueCount IQ.dequeueCountChanged_, + resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId IQ.dequeueExtractCount IQ.dequeueExtractCountChanged_, + resultContainerIntegProperty c "enqueueStoreRate" EnqueueStoreRateId IQ.enqueueStoreRate, + resultContainerIntegProperty c "dequeueRate" DequeueRateId IQ.dequeueRate, + resultContainerIntegProperty c "dequeueExtractRate" DequeueExtractRateId IQ.dequeueExtractRate, + resultContainerProperty c "queueWaitTime" QueueWaitTimeId IQ.queueWaitTime IQ.queueWaitTimeChanged_, + resultContainerProperty c "dequeueWaitTime" DequeueWaitTimeId IQ.dequeueWaitTime IQ.dequeueWaitTimeChanged_, + resultContainerProperty c "queueRate" QueueRateId IQ.queueRate IQ.queueRateChanged_ ] } + +-- | Return the summary by the specified infinite queue. +infiniteQueueResultSummary :: (Show sm, Show so) + => ResultContainer (IQ.Queue sm so a) + -- ^ the queue container + -> ResultSource +infiniteQueueResultSummary c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = FiniteQueueId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = infiniteQueueResultSummary c, + resultObjectProperties = [ + resultContainerProperty c "queueCountStats" QueueCountStatsId IQ.queueCountStats IQ.queueCountChanged_, + resultContainerProperty c "enqueueStoreCount" EnqueueStoreCountId IQ.enqueueStoreCount IQ.enqueueStoreCountChanged_, + resultContainerProperty c "dequeueCount" DequeueCountId IQ.dequeueCount IQ.dequeueCountChanged_, + resultContainerProperty c "dequeueExtractCount" DequeueExtractCountId IQ.dequeueExtractCount IQ.dequeueExtractCountChanged_, + resultContainerProperty c "queueWaitTime" QueueWaitTimeId IQ.queueWaitTime IQ.queueWaitTimeChanged_, + resultContainerProperty c "queueRate" QueueRateId IQ.queueRate IQ.queueRateChanged_ ] } + +-- | Return a source by the specified arrival timer. +arrivalTimerResultSource :: ResultContainer ArrivalTimer + -- ^ the arrival timer container + -> ResultSource +arrivalTimerResultSource c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = ArrivalTimerId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = arrivalTimerResultSummary c, + resultObjectProperties = [ + resultContainerProperty c "processingTime" ArrivalProcessingTimeId arrivalProcessingTime arrivalProcessingTimeChanged_ ] } + +-- | Return the summary by the specified arrival timer. +arrivalTimerResultSummary :: ResultContainer ArrivalTimer + -- ^ the arrival timer container + -> ResultSource +arrivalTimerResultSummary c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = ArrivalTimerId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = arrivalTimerResultSummary c, + resultObjectProperties = [ + resultContainerProperty c "processingTime" ArrivalProcessingTimeId arrivalProcessingTime arrivalProcessingTimeChanged_ ] } + +-- | Return a source by the specified server. +serverResultSource :: (Show s, ResultItemable (ResultValue s)) + => ResultContainer (Server s a b) + -- ^ the server container + -> ResultSource +serverResultSource c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = ServerId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = serverResultSummary c, + resultObjectProperties = [ + resultContainerConstProperty c "initState" ServerInitStateId serverInitState, + resultContainerProperty c "state" ServerStateId serverState serverStateChanged_, + resultContainerProperty c "totalInputWaitTime" ServerTotalInputWaitTimeId serverTotalInputWaitTime serverTotalInputWaitTimeChanged_, + resultContainerProperty c "totalProcessingTime" ServerTotalProcessingTimeId serverTotalProcessingTime serverTotalProcessingTimeChanged_, + resultContainerProperty c "totalOutputWaitTime" ServerTotalOutputWaitTimeId serverTotalOutputWaitTime serverTotalOutputWaitTimeChanged_, + resultContainerProperty c "inputWaitTime" ServerInputWaitTimeId serverInputWaitTime serverInputWaitTimeChanged_, + resultContainerProperty c "processingTime" ServerProcessingTimeId serverProcessingTime serverProcessingTimeChanged_, + resultContainerProperty c "outputWaitTime" ServerOutputWaitTimeId serverOutputWaitTime serverOutputWaitTimeChanged_, + resultContainerProperty c "inputWaitFactor" ServerInputWaitFactorId serverInputWaitFactor serverInputWaitFactorChanged_, + resultContainerProperty c "processingFactor" ServerProcessingFactorId serverProcessingFactor serverProcessingFactorChanged_, + resultContainerProperty c "outputWaitFactor" ServerOutputWaitFactorId serverOutputWaitFactor serverOutputWaitFactorChanged_ ] } + +-- | Return the summary by the specified server. +serverResultSummary :: ResultContainer (Server s a b) + -- ^ the server container + -> ResultSource +serverResultSummary c = + ResultObjectSource $ + ResultObject { + resultObjectName = resultContainerName c, + resultObjectId = resultContainerId c, + resultObjectTypeId = ServerId, + resultObjectSignal = resultContainerSignal c, + resultObjectSummary = serverResultSummary c, + resultObjectProperties = [ + resultContainerProperty c "inputWaitTime" ServerInputWaitTimeId serverInputWaitTime serverInputWaitTimeChanged_, + resultContainerProperty c "processingTime" ServerProcessingTimeId serverProcessingTime serverProcessingTimeChanged_, + resultContainerProperty c "outputWaitTime" ServerOutputWaitTimeId serverOutputWaitTime serverOutputWaitTimeChanged_, + resultContainerProperty c "inputWaitFactor" ServerInputWaitFactorId serverInputWaitFactor serverInputWaitFactorChanged_, + resultContainerProperty c "processingFactor" ServerProcessingFactorId serverProcessingFactor serverProcessingFactorChanged_, + resultContainerProperty c "outputWaitFactor" ServerOutputWaitFactorId serverOutputWaitFactor serverOutputWaitFactorChanged_ ] } + +-- | Return an arbitrary text as a separator source. +textResultSource :: String -> ResultSource +textResultSource text = + ResultSeparatorSource $ + ResultSeparator { resultSeparatorText = text } + +-- | Return the source of the modeling time. +timeResultSource :: ResultSource +timeResultSource = resultSource' "t" TimeId time + +-- | Make an integer subscript +intSubscript :: Int -> ResultName +intSubscript i = "[" ++ show i ++ "]" + +instance ResultComputing m => ResultProvider (m Double) where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing m => ResultProvider (m [Double]) where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing m => ResultProvider (m (SamplingStats Double)) where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing m => ResultProvider (m (TimingStats Double)) where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing m => ResultProvider (m Int) where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing m => ResultProvider (m [Int]) where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing m => ResultProvider (m (SamplingStats Int)) where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing m => ResultProvider (m (TimingStats Int)) where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultComputing m => ResultProvider (m String) where + + resultSource' name i m = + ResultItemSource $ ResultItem $ computeResultValue name i m + +instance ResultProvider p => ResultProvider [p] where + + resultSource' name i m = + resultSource' name i $ ResultListWithSubscript m subscript where + subscript = map snd $ zip m $ map intSubscript [0..] + +instance (Show i, Ix i, ResultProvider p) => ResultProvider (A.Array i p) where + + resultSource' name i m = + resultSource' name i $ ResultListWithSubscript items subscript where + items = A.elems m + subscript = map (\i -> "[" ++ show i ++ "]") (A.indices m) + +#ifndef __HASTE__ + +instance ResultProvider p => ResultProvider (V.Vector p) where + + resultSource' name i m = + resultSource' name i $ ResultVectorWithSubscript m subscript where + subscript = V.imap (\i x -> intSubscript i) m + +#endif + +-- | Represents a list with the specified subscript. +data ResultListWithSubscript p = + ResultListWithSubscript [p] [String] + +-- | Represents an array with the specified subscript. +data ResultArrayWithSubscript i p = + ResultArrayWithSubscript (A.Array i p) (A.Array i String) + +#ifndef __HASTE__ + +-- | Represents a vector with the specified subscript. +data ResultVectorWithSubscript p = + ResultVectorWithSubscript (V.Vector p) (V.Vector String) + +#endif + +instance ResultProvider p => ResultProvider (ResultListWithSubscript p) where + + resultSource' name i (ResultListWithSubscript xs ys) = + ResultVectorSource $ + memoResultVectorSignal $ + memoResultVectorSummary $ + ResultVector { resultVectorName = name, + resultVectorId = i, + resultVectorItems = axs, + resultVectorSubscript = ays, + resultVectorSignal = undefined, + resultVectorSummary = undefined } + where + bnds = (0, length xs - 1) + axs = A.listArray bnds items + ays = A.listArray bnds ys + items = + flip map (zip ys xs) $ \(y, x) -> + let name' = name ++ y + in resultSource' name' (VectorItemId y) x + items' = map resultSourceSummary items + +instance (Show i, Ix i, ResultProvider p) => ResultProvider (ResultArrayWithSubscript i p) where + + resultSource' name i (ResultArrayWithSubscript xs ys) = + resultSource' name i $ ResultListWithSubscript items subscript where + items = A.elems xs + subscript = A.elems ys + +#ifndef __HASTE__ + +instance ResultProvider p => ResultProvider (ResultVectorWithSubscript p) where + + resultSource' name i (ResultVectorWithSubscript xs ys) = + ResultVectorSource $ + memoResultVectorSignal $ + memoResultVectorSummary $ + ResultVector { resultVectorName = name, + resultVectorId = i, + resultVectorItems = axs, + resultVectorSubscript = ays, + resultVectorSignal = undefined, + resultVectorSummary = undefined } + where + bnds = (0, V.length xs - 1) + axs = A.listArray bnds (V.toList items) + ays = A.listArray bnds (V.toList ys) + items = + V.generate (V.length xs) $ \i -> + let x = xs V.! i + y = ys V.! i + name' = name ++ y + in resultSource' name' (VectorItemId y) x + items' = V.map resultSourceSummary items + +#endif + +instance (Ix i, Show i, ResultComputing m) => ResultProvider (m (A.Array i Double)) where + + resultSource' name i m = + ResultItemSource $ ResultItem $ fmap A.elems $ computeResultValue name i m + +instance (Ix i, Show i, ResultComputing m) => ResultProvider (m (A.Array i Int)) where + + resultSource' name i m = + ResultItemSource $ ResultItem $ fmap A.elems $ computeResultValue name i m + +#ifndef __HASTE__ + +instance ResultComputing m => ResultProvider (m (V.Vector Double)) where + + resultSource' name i m = + ResultItemSource $ ResultItem $ fmap V.toList $ computeResultValue name i m + +instance ResultComputing m => ResultProvider (m (V.Vector Int)) where + + resultSource' name i m = + ResultItemSource $ ResultItem $ fmap V.toList $ computeResultValue name i m + +#endif + +instance (Show si, Show sm, Show so, + ResultItemable (ResultValue si), + ResultItemable (ResultValue sm), + ResultItemable (ResultValue so)) + => ResultProvider (Q.Queue si sm so a) where + + resultSource' name i m = + queueResultSource $ ResultContainer name i m (ResultSignal $ Q.queueChanged_ m) + +instance (Show sm, Show so, + ResultItemable (ResultValue sm), + ResultItemable (ResultValue so)) + => ResultProvider (IQ.Queue sm so a) where + + resultSource' name i m = + infiniteQueueResultSource $ ResultContainer name i m (ResultSignal $ IQ.queueChanged_ m) + +instance ResultProvider ArrivalTimer where + + resultSource' name i m = + arrivalTimerResultSource $ ResultContainer name i m (ResultSignal $ arrivalProcessingTimeChanged_ m) + +instance (Show s, ResultItemable (ResultValue s)) => ResultProvider (Server s a b) where + + resultSource' name i m = + serverResultSource $ ResultContainer name i m (ResultSignal $ serverChanged_ m) diff --git a/Simulation/Aivika/Results/IO.hs b/Simulation/Aivika/Results/IO.hs --- a/Simulation/Aivika/Results/IO.hs +++ b/Simulation/Aivika/Results/IO.hs @@ -1,476 +1,476 @@ - --- | --- Module : Simulation.Aivika.Results.IO --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- The module allows printing and converting the 'Simulation' 'Results' to a 'String'. --- -module Simulation.Aivika.Results.IO - (-- * Basic Types - ResultSourcePrint, - ResultSourceShowS, - -- * Printing the Results - printResultsWithTime, - printResultsInStartTime, - printResultsInStopTime, - printResultsInIntegTimes, - printResultsInTime, - printResultsInTimes, - -- * Simulating and Printing the Results - printSimulationResultsInStartTime, - printSimulationResultsInStopTime, - printSimulationResultsInIntegTimes, - printSimulationResultsInTime, - printSimulationResultsInTimes, - -- * Showing the Results - showResultsWithTime, - showResultsInStartTime, - showResultsInStopTime, - showResultsInIntegTimes, - showResultsInTime, - showResultsInTimes, - -- * Simulating and Showing the Results - showSimulationResultsInStartTime, - showSimulationResultsInStopTime, - showSimulationResultsInIntegTimes, - showSimulationResultsInTime, - showSimulationResultsInTimes, - -- * Printing the Result Source - hPrintResultSourceIndented, - hPrintResultSource, - hPrintResultSourceInRussian, - hPrintResultSourceInEnglish, - printResultSourceIndented, - printResultSource, - printResultSourceInRussian, - printResultSourceInEnglish, - -- * Showing the Result Source - showResultSourceIndented, - showResultSource, - showResultSourceInRussian, - showResultSourceInEnglish) where - -import Control.Monad -import Control.Monad.Trans - -import qualified Data.Map as M -import qualified Data.Array as A - -import System.IO - -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Results -import Simulation.Aivika.Results.Locale - --- | This is a function that shows the simulation results within --- the 'Event' computation synchronized with the event queue. -type ResultSourceShowS = ResultSource -> Event ShowS - --- | This is a function that prints the simulation results within --- the 'Event' computation synchronized with the event queue. -type ResultSourcePrint = ResultSource -> Event () - --- | Print a localised text representation of the results by the specified source --- and with the given indent. -hPrintResultSourceIndented :: Handle - -- ^ a handle - -> Int - -- ^ an indent - -> ResultLocalisation - -- ^ a localisation - -> ResultSourcePrint -hPrintResultSourceIndented h indent loc source@(ResultItemSource (ResultItem x)) = - hPrintResultSourceIndentedLabelled h indent (resultItemName x) loc source -hPrintResultSourceIndented h indent loc source@(ResultVectorSource x) = - hPrintResultSourceIndentedLabelled h indent (resultVectorName x) loc source -hPrintResultSourceIndented h indent loc source@(ResultObjectSource x) = - hPrintResultSourceIndentedLabelled h indent (resultObjectName x) loc source -hPrintResultSourceIndented h indent loc source@(ResultSeparatorSource x) = - hPrintResultSourceIndentedLabelled h indent (resultSeparatorText x) loc source - --- | Print an indented and labelled text representation of the results by --- the specified source. -hPrintResultSourceIndentedLabelled :: Handle - -- ^ a handle - -> Int - -- ^ an indent - -> ResultName - -- ^ a label - -> ResultLocalisation - -- ^ a localisation - -> ResultSourcePrint -hPrintResultSourceIndentedLabelled h indent label loc (ResultItemSource (ResultItem x)) = - case resultValueData (resultItemToStringValue x) of - Just m -> - do a <- m - let tab = replicate indent ' ' - liftIO $ - do hPutStr h tab - hPutStr h "-- " - hPutStr h (loc $ resultItemId x) - hPutStrLn h "" - hPutStr h tab - hPutStr h label - hPutStr h " = " - hPutStrLn h a - hPutStrLn h "" - _ -> - error $ - "Expected to see a string value for variable " ++ - (resultItemName x) ++ ": hPrintResultSourceIndentedLabelled" -hPrintResultSourceIndentedLabelled h indent label loc (ResultVectorSource x) = - do let tab = replicate indent ' ' - liftIO $ - do hPutStr h tab - hPutStr h "-- " - hPutStr h (loc $ resultVectorId x) - hPutStrLn h "" - hPutStr h tab - hPutStr h label - hPutStrLn h ":" - hPutStrLn h "" - let items = A.elems (resultVectorItems x) - subscript = A.elems (resultVectorSubscript x) - forM_ (zip items subscript) $ \(i, s) -> - hPrintResultSourceIndentedLabelled h (indent + 2) (label ++ s) loc i -hPrintResultSourceIndentedLabelled h indent label loc (ResultObjectSource x) = - do let tab = replicate indent ' ' - liftIO $ - do hPutStr h tab - hPutStr h "-- " - hPutStr h (loc $ resultObjectId x) - hPutStrLn h "" - hPutStr h tab - hPutStr h label - hPutStrLn h ":" - hPutStrLn h "" - forM_ (resultObjectProperties x) $ \p -> - do let indent' = 2 + indent - tab' = " " ++ tab - label' = resultPropertyLabel p - source' = resultPropertySource p - hPrintResultSourceIndentedLabelled h indent' label' loc source' -hPrintResultSourceIndentedLabelled h indent label loc (ResultSeparatorSource x) = - do let tab = replicate indent ' ' - liftIO $ - do hPutStr h tab - hPutStr h label - hPutStrLn h "" - hPutStrLn h "" - --- | Print a localised text representation of the results by the specified source --- and with the given indent. -printResultSourceIndented :: Int - -- ^ an indent - -> ResultLocalisation - -- ^ a localisation - -> ResultSourcePrint -printResultSourceIndented = hPrintResultSourceIndented stdout - --- | Print a localised text representation of the results by the specified source. -hPrintResultSource :: Handle - -- ^ a handle - -> ResultLocalisation - -- ^ a localisation - -> ResultSourcePrint -hPrintResultSource h = hPrintResultSourceIndented h 0 - --- | Print a localised text representation of the results by the specified source. -printResultSource :: ResultLocalisation - -- ^ a localisation - -> ResultSourcePrint -printResultSource = hPrintResultSource stdout - --- | Print in Russian a text representation of the results by the specified source. -hPrintResultSourceInRussian :: Handle -> ResultSourcePrint -hPrintResultSourceInRussian h = hPrintResultSource h russianResultLocalisation - --- | Print in English a text representation of the results by the specified source. -hPrintResultSourceInEnglish :: Handle -> ResultSourcePrint -hPrintResultSourceInEnglish h = hPrintResultSource h englishResultLocalisation - --- | Print in Russian a text representation of the results by the specified source. -printResultSourceInRussian :: ResultSourcePrint -printResultSourceInRussian = hPrintResultSourceInRussian stdout - --- | Print in English a text representation of the results by the specified source. -printResultSourceInEnglish :: ResultSourcePrint -printResultSourceInEnglish = hPrintResultSourceInEnglish stdout - --- | Show a localised text representation of the results by the specified source --- and with the given indent. -showResultSourceIndented :: Int - -- ^ an indent - -> ResultLocalisation - -- ^ a localisation - -> ResultSourceShowS -showResultSourceIndented indent loc source@(ResultItemSource (ResultItem x)) = - showResultSourceIndentedLabelled indent (resultItemName x) loc source -showResultSourceIndented indent loc source@(ResultVectorSource x) = - showResultSourceIndentedLabelled indent (resultVectorName x) loc source -showResultSourceIndented indent loc source@(ResultObjectSource x) = - showResultSourceIndentedLabelled indent (resultObjectName x) loc source -showResultSourceIndented indent loc source@(ResultSeparatorSource x) = - showResultSourceIndentedLabelled indent (resultSeparatorText x) loc source - --- | Show an indented and labelled text representation of the results by the specified source. -showResultSourceIndentedLabelled :: Int - -- ^ an indent - -> String - -- ^ a label - -> ResultLocalisation - -- ^ a localisation - -> ResultSourceShowS -showResultSourceIndentedLabelled indent label loc (ResultItemSource (ResultItem x)) = - case resultValueData (resultItemToStringValue x) of - Just m -> - do a <- m - let tab = replicate indent ' ' - return $ - showString tab . - showString "-- " . - showString (loc $ resultItemId x) . - showString "\n" . - showString tab . - showString label . - showString " = " . - showString a . - showString "\n\n" - _ -> - error $ - "Expected to see a string value for variable " ++ - (resultItemName x) ++ ": showResultSourceIndentedLabelled" -showResultSourceIndentedLabelled indent label loc (ResultVectorSource x) = - do let tab = replicate indent ' ' - items = A.elems (resultVectorItems x) - subscript = A.elems (resultVectorSubscript x) - contents <- - forM (zip items subscript) $ \(i, s) -> - showResultSourceIndentedLabelled (indent + 2) (label ++ s) loc i - let showContents = foldr (.) id contents - return $ - showString tab . - showString "-- " . - showString (loc $ resultVectorId x) . - showString "\n" . - showString tab . - showString label . - showString ":\n\n" . - showContents -showResultSourceIndentedLabelled indent label loc (ResultObjectSource x) = - do let tab = replicate indent ' ' - contents <- - forM (resultObjectProperties x) $ \p -> - do let indent' = 2 + indent - tab' = " " ++ tab - label' = resultPropertyLabel p - output' = resultPropertySource p - showResultSourceIndentedLabelled indent' label' loc output' - let showContents = foldr (.) id contents - return $ - showString tab . - showString "-- " . - showString (loc $ resultObjectId x) . - showString "\n" . - showString tab . - showString label . - showString ":\n\n" . - showContents -showResultSourceIndentedLabelled indent label loc (ResultSeparatorSource x) = - do let tab = replicate indent ' ' - return $ - showString tab . - showString label . - showString "\n\n" - --- | Show a localised text representation of the results by the specified source. -showResultSource :: ResultLocalisation - -- ^ a localisation - -> ResultSourceShowS -showResultSource = showResultSourceIndented 0 - --- | Show in Russian a text representation of the results by the specified source. -showResultSourceInRussian :: ResultSourceShowS -showResultSourceInRussian = showResultSource russianResultLocalisation - --- | Show in English a text representation of the results by the specified source. -showResultSourceInEnglish :: ResultSourceShowS -showResultSourceInEnglish = showResultSource englishResultLocalisation - --- | Print the results with the information about the modeling time. -printResultsWithTime :: ResultSourcePrint -> Results -> Event () -printResultsWithTime print results = - do let x1 = textResultSource "----------" - x2 = timeResultSource - x3 = textResultSource "" - xs = resultSourceList results - print x1 - print x2 - -- print x3 - mapM_ print xs - -- print x3 - --- | Print the simulation results in start time. -printResultsInStartTime :: ResultSourcePrint -> Results -> Simulation () -printResultsInStartTime print results = - runEventInStartTime $ printResultsWithTime print results - --- | Print the simulation results in stop time. -printResultsInStopTime :: ResultSourcePrint -> Results -> Simulation () -printResultsInStopTime print results = - runEventInStopTime $ printResultsWithTime print results - --- | Print the simulation results in the integration time points. -printResultsInIntegTimes :: ResultSourcePrint -> Results -> Simulation () -printResultsInIntegTimes print results = - do let loop (m : ms) = m >> loop ms - loop [] = return () - ms <- runDynamicsInIntegTimes $ runEvent $ - printResultsWithTime print results - liftIO $ loop ms - --- | Print the simulation results in the specified time. -printResultsInTime :: Double -> ResultSourcePrint -> Results -> Simulation () -printResultsInTime t print results = - runDynamicsInTime t $ runEvent $ - printResultsWithTime print results - --- | Print the simulation results in the specified time points. -printResultsInTimes :: [Double] -> ResultSourcePrint -> Results -> Simulation () -printResultsInTimes ts print results = - do let loop (m : ms) = m >> loop ms - loop [] = return () - ms <- runDynamicsInTimes ts $ runEvent $ - printResultsWithTime print results - liftIO $ loop ms - --- | Show the results with the information about the modeling time. -showResultsWithTime :: ResultSourceShowS -> Results -> Event ShowS -showResultsWithTime f results = - do let x1 = textResultSource "----------" - x2 = timeResultSource - x3 = textResultSource "" - xs = resultSourceList results - y1 <- f x1 - y2 <- f x2 - y3 <- f x3 - ys <- forM xs f - return $ - y1 . - y2 . - -- y3 . - foldr (.) id ys - -- y3 - --- | Show the simulation results in start time. -showResultsInStartTime :: ResultSourceShowS -> Results -> Simulation ShowS -showResultsInStartTime f results = - runEventInStartTime $ showResultsWithTime f results - --- | Show the simulation results in stop time. -showResultsInStopTime :: ResultSourceShowS -> Results -> Simulation ShowS -showResultsInStopTime f results = - runEventInStopTime $ showResultsWithTime f results - --- | Show the simulation results in the integration time points. --- --- It may consume much memory, for we have to traverse all the integration --- points to create the resulting function within the 'Simulation' computation. -showResultsInIntegTimes :: ResultSourceShowS -> Results -> Simulation ShowS -showResultsInIntegTimes f results = - do let loop (m : ms) = return (.) `ap` m `ap` loop ms - loop [] = return id - ms <- runDynamicsInIntegTimes $ runEvent $ - showResultsWithTime f results - liftIO $ loop ms - --- | Show the simulation results in the specified time point. -showResultsInTime :: Double -> ResultSourceShowS -> Results -> Simulation ShowS -showResultsInTime t f results = - runDynamicsInTime t $ runEvent $ - showResultsWithTime f results - --- | Show the simulation results in the specified time points. --- --- It may consume much memory, for we have to traverse all the specified --- points to create the resulting function within the 'Simulation' computation. -showResultsInTimes :: [Double] -> ResultSourceShowS -> Results -> Simulation ShowS -showResultsInTimes ts f results = - do let loop (m : ms) = return (.) `ap` m `ap` loop ms - loop [] = return id - ms <- runDynamicsInTimes ts $ runEvent $ - showResultsWithTime f results - liftIO $ loop ms - --- | Run the simulation and then print the results in the start time. -printSimulationResultsInStartTime :: ResultSourcePrint -> Simulation Results -> Specs -> IO () -printSimulationResultsInStartTime print model specs = - flip runSimulation specs $ - model >>= printResultsInStartTime print - --- | Run the simulation and then print the results in the final time. -printSimulationResultsInStopTime :: ResultSourcePrint -> Simulation Results -> Specs -> IO () -printSimulationResultsInStopTime print model specs = - flip runSimulation specs $ - model >>= printResultsInStopTime print - --- | Run the simulation and then print the results in the integration time points. -printSimulationResultsInIntegTimes :: ResultSourcePrint -> Simulation Results -> Specs -> IO () -printSimulationResultsInIntegTimes print model specs = - flip runSimulation specs $ - model >>= printResultsInIntegTimes print - --- | Run the simulation and then print the results in the specified time point. -printSimulationResultsInTime :: Double -> ResultSourcePrint -> Simulation Results -> Specs -> IO () -printSimulationResultsInTime t print model specs = - flip runSimulation specs $ - model >>= printResultsInTime t print - --- | Run the simulation and then print the results in the specified time points. -printSimulationResultsInTimes :: [Double] -> ResultSourcePrint -> Simulation Results -> Specs -> IO () -printSimulationResultsInTimes ts print model specs = - flip runSimulation specs $ - model >>= printResultsInTimes ts print - --- | Run the simulation and then show the results in the start time. -showSimulationResultsInStartTime :: ResultSourceShowS -> Simulation Results -> Specs -> IO ShowS -showSimulationResultsInStartTime f model specs = - flip runSimulation specs $ - model >>= showResultsInStartTime f - --- | Run the simulation and then show the results in the final time. -showSimulationResultsInStopTime :: ResultSourceShowS -> Simulation Results -> Specs -> IO ShowS -showSimulationResultsInStopTime f model specs = - flip runSimulation specs $ - model >>= showResultsInStopTime f - --- | Run the simulation and then show the results in the integration time points. --- --- It may consume much memory, for we have to traverse all the integration --- points to create the resulting function within the 'IO' computation. -showSimulationResultsInIntegTimes :: ResultSourceShowS -> Simulation Results -> Specs -> IO ShowS -showSimulationResultsInIntegTimes f model specs = - flip runSimulation specs $ - model >>= showResultsInIntegTimes f - --- | Run the simulation and then show the results in the integration time point. -showSimulationResultsInTime :: Double -> ResultSourceShowS -> Simulation Results -> Specs -> IO ShowS -showSimulationResultsInTime t f model specs = - flip runSimulation specs $ - model >>= showResultsInTime t f - --- | Run the simulation and then show the results in the specified time points. --- --- It may consume much memory, for we have to traverse all the specified --- points to create the resulting function within the 'IO' computation. -showSimulationResultsInTimes :: [Double] -> ResultSourceShowS -> Simulation Results -> Specs -> IO ShowS -showSimulationResultsInTimes ts f model specs = - flip runSimulation specs $ - model >>= showResultsInTimes ts f + +-- | +-- Module : Simulation.Aivika.Results.IO +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module allows printing and converting the 'Simulation' 'Results' to a 'String'. +-- +module Simulation.Aivika.Results.IO + (-- * Basic Types + ResultSourcePrint, + ResultSourceShowS, + -- * Printing the Results + printResultsWithTime, + printResultsInStartTime, + printResultsInStopTime, + printResultsInIntegTimes, + printResultsInTime, + printResultsInTimes, + -- * Simulating and Printing the Results + printSimulationResultsInStartTime, + printSimulationResultsInStopTime, + printSimulationResultsInIntegTimes, + printSimulationResultsInTime, + printSimulationResultsInTimes, + -- * Showing the Results + showResultsWithTime, + showResultsInStartTime, + showResultsInStopTime, + showResultsInIntegTimes, + showResultsInTime, + showResultsInTimes, + -- * Simulating and Showing the Results + showSimulationResultsInStartTime, + showSimulationResultsInStopTime, + showSimulationResultsInIntegTimes, + showSimulationResultsInTime, + showSimulationResultsInTimes, + -- * Printing the Result Source + hPrintResultSourceIndented, + hPrintResultSource, + hPrintResultSourceInRussian, + hPrintResultSourceInEnglish, + printResultSourceIndented, + printResultSource, + printResultSourceInRussian, + printResultSourceInEnglish, + -- * Showing the Result Source + showResultSourceIndented, + showResultSource, + showResultSourceInRussian, + showResultSourceInEnglish) where + +import Control.Monad +import Control.Monad.Trans + +import qualified Data.Map as M +import qualified Data.Array as A + +import System.IO + +import Simulation.Aivika.Specs +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Event +import Simulation.Aivika.Results +import Simulation.Aivika.Results.Locale + +-- | This is a function that shows the simulation results within +-- the 'Event' computation synchronized with the event queue. +type ResultSourceShowS = ResultSource -> Event ShowS + +-- | This is a function that prints the simulation results within +-- the 'Event' computation synchronized with the event queue. +type ResultSourcePrint = ResultSource -> Event () + +-- | Print a localised text representation of the results by the specified source +-- and with the given indent. +hPrintResultSourceIndented :: Handle + -- ^ a handle + -> Int + -- ^ an indent + -> ResultLocalisation + -- ^ a localisation + -> ResultSourcePrint +hPrintResultSourceIndented h indent loc source@(ResultItemSource (ResultItem x)) = + hPrintResultSourceIndentedLabelled h indent (resultItemName x) loc source +hPrintResultSourceIndented h indent loc source@(ResultVectorSource x) = + hPrintResultSourceIndentedLabelled h indent (resultVectorName x) loc source +hPrintResultSourceIndented h indent loc source@(ResultObjectSource x) = + hPrintResultSourceIndentedLabelled h indent (resultObjectName x) loc source +hPrintResultSourceIndented h indent loc source@(ResultSeparatorSource x) = + hPrintResultSourceIndentedLabelled h indent (resultSeparatorText x) loc source + +-- | Print an indented and labelled text representation of the results by +-- the specified source. +hPrintResultSourceIndentedLabelled :: Handle + -- ^ a handle + -> Int + -- ^ an indent + -> ResultName + -- ^ a label + -> ResultLocalisation + -- ^ a localisation + -> ResultSourcePrint +hPrintResultSourceIndentedLabelled h indent label loc (ResultItemSource (ResultItem x)) = + case resultValueData (resultItemToStringValue x) of + Just m -> + do a <- m + let tab = replicate indent ' ' + liftIO $ + do hPutStr h tab + hPutStr h "-- " + hPutStr h (loc $ resultItemId x) + hPutStrLn h "" + hPutStr h tab + hPutStr h label + hPutStr h " = " + hPutStrLn h a + hPutStrLn h "" + _ -> + error $ + "Expected to see a string value for variable " ++ + (resultItemName x) ++ ": hPrintResultSourceIndentedLabelled" +hPrintResultSourceIndentedLabelled h indent label loc (ResultVectorSource x) = + do let tab = replicate indent ' ' + liftIO $ + do hPutStr h tab + hPutStr h "-- " + hPutStr h (loc $ resultVectorId x) + hPutStrLn h "" + hPutStr h tab + hPutStr h label + hPutStrLn h ":" + hPutStrLn h "" + let items = A.elems (resultVectorItems x) + subscript = A.elems (resultVectorSubscript x) + forM_ (zip items subscript) $ \(i, s) -> + hPrintResultSourceIndentedLabelled h (indent + 2) (label ++ s) loc i +hPrintResultSourceIndentedLabelled h indent label loc (ResultObjectSource x) = + do let tab = replicate indent ' ' + liftIO $ + do hPutStr h tab + hPutStr h "-- " + hPutStr h (loc $ resultObjectId x) + hPutStrLn h "" + hPutStr h tab + hPutStr h label + hPutStrLn h ":" + hPutStrLn h "" + forM_ (resultObjectProperties x) $ \p -> + do let indent' = 2 + indent + tab' = " " ++ tab + label' = resultPropertyLabel p + source' = resultPropertySource p + hPrintResultSourceIndentedLabelled h indent' label' loc source' +hPrintResultSourceIndentedLabelled h indent label loc (ResultSeparatorSource x) = + do let tab = replicate indent ' ' + liftIO $ + do hPutStr h tab + hPutStr h label + hPutStrLn h "" + hPutStrLn h "" + +-- | Print a localised text representation of the results by the specified source +-- and with the given indent. +printResultSourceIndented :: Int + -- ^ an indent + -> ResultLocalisation + -- ^ a localisation + -> ResultSourcePrint +printResultSourceIndented = hPrintResultSourceIndented stdout + +-- | Print a localised text representation of the results by the specified source. +hPrintResultSource :: Handle + -- ^ a handle + -> ResultLocalisation + -- ^ a localisation + -> ResultSourcePrint +hPrintResultSource h = hPrintResultSourceIndented h 0 + +-- | Print a localised text representation of the results by the specified source. +printResultSource :: ResultLocalisation + -- ^ a localisation + -> ResultSourcePrint +printResultSource = hPrintResultSource stdout + +-- | Print in Russian a text representation of the results by the specified source. +hPrintResultSourceInRussian :: Handle -> ResultSourcePrint +hPrintResultSourceInRussian h = hPrintResultSource h russianResultLocalisation + +-- | Print in English a text representation of the results by the specified source. +hPrintResultSourceInEnglish :: Handle -> ResultSourcePrint +hPrintResultSourceInEnglish h = hPrintResultSource h englishResultLocalisation + +-- | Print in Russian a text representation of the results by the specified source. +printResultSourceInRussian :: ResultSourcePrint +printResultSourceInRussian = hPrintResultSourceInRussian stdout + +-- | Print in English a text representation of the results by the specified source. +printResultSourceInEnglish :: ResultSourcePrint +printResultSourceInEnglish = hPrintResultSourceInEnglish stdout + +-- | Show a localised text representation of the results by the specified source +-- and with the given indent. +showResultSourceIndented :: Int + -- ^ an indent + -> ResultLocalisation + -- ^ a localisation + -> ResultSourceShowS +showResultSourceIndented indent loc source@(ResultItemSource (ResultItem x)) = + showResultSourceIndentedLabelled indent (resultItemName x) loc source +showResultSourceIndented indent loc source@(ResultVectorSource x) = + showResultSourceIndentedLabelled indent (resultVectorName x) loc source +showResultSourceIndented indent loc source@(ResultObjectSource x) = + showResultSourceIndentedLabelled indent (resultObjectName x) loc source +showResultSourceIndented indent loc source@(ResultSeparatorSource x) = + showResultSourceIndentedLabelled indent (resultSeparatorText x) loc source + +-- | Show an indented and labelled text representation of the results by the specified source. +showResultSourceIndentedLabelled :: Int + -- ^ an indent + -> String + -- ^ a label + -> ResultLocalisation + -- ^ a localisation + -> ResultSourceShowS +showResultSourceIndentedLabelled indent label loc (ResultItemSource (ResultItem x)) = + case resultValueData (resultItemToStringValue x) of + Just m -> + do a <- m + let tab = replicate indent ' ' + return $ + showString tab . + showString "-- " . + showString (loc $ resultItemId x) . + showString "\n" . + showString tab . + showString label . + showString " = " . + showString a . + showString "\n\n" + _ -> + error $ + "Expected to see a string value for variable " ++ + (resultItemName x) ++ ": showResultSourceIndentedLabelled" +showResultSourceIndentedLabelled indent label loc (ResultVectorSource x) = + do let tab = replicate indent ' ' + items = A.elems (resultVectorItems x) + subscript = A.elems (resultVectorSubscript x) + contents <- + forM (zip items subscript) $ \(i, s) -> + showResultSourceIndentedLabelled (indent + 2) (label ++ s) loc i + let showContents = foldr (.) id contents + return $ + showString tab . + showString "-- " . + showString (loc $ resultVectorId x) . + showString "\n" . + showString tab . + showString label . + showString ":\n\n" . + showContents +showResultSourceIndentedLabelled indent label loc (ResultObjectSource x) = + do let tab = replicate indent ' ' + contents <- + forM (resultObjectProperties x) $ \p -> + do let indent' = 2 + indent + tab' = " " ++ tab + label' = resultPropertyLabel p + output' = resultPropertySource p + showResultSourceIndentedLabelled indent' label' loc output' + let showContents = foldr (.) id contents + return $ + showString tab . + showString "-- " . + showString (loc $ resultObjectId x) . + showString "\n" . + showString tab . + showString label . + showString ":\n\n" . + showContents +showResultSourceIndentedLabelled indent label loc (ResultSeparatorSource x) = + do let tab = replicate indent ' ' + return $ + showString tab . + showString label . + showString "\n\n" + +-- | Show a localised text representation of the results by the specified source. +showResultSource :: ResultLocalisation + -- ^ a localisation + -> ResultSourceShowS +showResultSource = showResultSourceIndented 0 + +-- | Show in Russian a text representation of the results by the specified source. +showResultSourceInRussian :: ResultSourceShowS +showResultSourceInRussian = showResultSource russianResultLocalisation + +-- | Show in English a text representation of the results by the specified source. +showResultSourceInEnglish :: ResultSourceShowS +showResultSourceInEnglish = showResultSource englishResultLocalisation + +-- | Print the results with the information about the modeling time. +printResultsWithTime :: ResultSourcePrint -> Results -> Event () +printResultsWithTime print results = + do let x1 = textResultSource "----------" + x2 = timeResultSource + x3 = textResultSource "" + xs = resultSourceList results + print x1 + print x2 + -- print x3 + mapM_ print xs + -- print x3 + +-- | Print the simulation results in start time. +printResultsInStartTime :: ResultSourcePrint -> Results -> Simulation () +printResultsInStartTime print results = + runEventInStartTime $ printResultsWithTime print results + +-- | Print the simulation results in stop time. +printResultsInStopTime :: ResultSourcePrint -> Results -> Simulation () +printResultsInStopTime print results = + runEventInStopTime $ printResultsWithTime print results + +-- | Print the simulation results in the integration time points. +printResultsInIntegTimes :: ResultSourcePrint -> Results -> Simulation () +printResultsInIntegTimes print results = + do let loop (m : ms) = m >> loop ms + loop [] = return () + ms <- runDynamicsInIntegTimes $ runEvent $ + printResultsWithTime print results + liftIO $ loop ms + +-- | Print the simulation results in the specified time. +printResultsInTime :: Double -> ResultSourcePrint -> Results -> Simulation () +printResultsInTime t print results = + runDynamicsInTime t $ runEvent $ + printResultsWithTime print results + +-- | Print the simulation results in the specified time points. +printResultsInTimes :: [Double] -> ResultSourcePrint -> Results -> Simulation () +printResultsInTimes ts print results = + do let loop (m : ms) = m >> loop ms + loop [] = return () + ms <- runDynamicsInTimes ts $ runEvent $ + printResultsWithTime print results + liftIO $ loop ms + +-- | Show the results with the information about the modeling time. +showResultsWithTime :: ResultSourceShowS -> Results -> Event ShowS +showResultsWithTime f results = + do let x1 = textResultSource "----------" + x2 = timeResultSource + x3 = textResultSource "" + xs = resultSourceList results + y1 <- f x1 + y2 <- f x2 + y3 <- f x3 + ys <- forM xs f + return $ + y1 . + y2 . + -- y3 . + foldr (.) id ys + -- y3 + +-- | Show the simulation results in start time. +showResultsInStartTime :: ResultSourceShowS -> Results -> Simulation ShowS +showResultsInStartTime f results = + runEventInStartTime $ showResultsWithTime f results + +-- | Show the simulation results in stop time. +showResultsInStopTime :: ResultSourceShowS -> Results -> Simulation ShowS +showResultsInStopTime f results = + runEventInStopTime $ showResultsWithTime f results + +-- | Show the simulation results in the integration time points. +-- +-- It may consume much memory, for we have to traverse all the integration +-- points to create the resulting function within the 'Simulation' computation. +showResultsInIntegTimes :: ResultSourceShowS -> Results -> Simulation ShowS +showResultsInIntegTimes f results = + do let loop (m : ms) = return (.) `ap` m `ap` loop ms + loop [] = return id + ms <- runDynamicsInIntegTimes $ runEvent $ + showResultsWithTime f results + liftIO $ loop ms + +-- | Show the simulation results in the specified time point. +showResultsInTime :: Double -> ResultSourceShowS -> Results -> Simulation ShowS +showResultsInTime t f results = + runDynamicsInTime t $ runEvent $ + showResultsWithTime f results + +-- | Show the simulation results in the specified time points. +-- +-- It may consume much memory, for we have to traverse all the specified +-- points to create the resulting function within the 'Simulation' computation. +showResultsInTimes :: [Double] -> ResultSourceShowS -> Results -> Simulation ShowS +showResultsInTimes ts f results = + do let loop (m : ms) = return (.) `ap` m `ap` loop ms + loop [] = return id + ms <- runDynamicsInTimes ts $ runEvent $ + showResultsWithTime f results + liftIO $ loop ms + +-- | Run the simulation and then print the results in the start time. +printSimulationResultsInStartTime :: ResultSourcePrint -> Simulation Results -> Specs -> IO () +printSimulationResultsInStartTime print model specs = + flip runSimulation specs $ + model >>= printResultsInStartTime print + +-- | Run the simulation and then print the results in the final time. +printSimulationResultsInStopTime :: ResultSourcePrint -> Simulation Results -> Specs -> IO () +printSimulationResultsInStopTime print model specs = + flip runSimulation specs $ + model >>= printResultsInStopTime print + +-- | Run the simulation and then print the results in the integration time points. +printSimulationResultsInIntegTimes :: ResultSourcePrint -> Simulation Results -> Specs -> IO () +printSimulationResultsInIntegTimes print model specs = + flip runSimulation specs $ + model >>= printResultsInIntegTimes print + +-- | Run the simulation and then print the results in the specified time point. +printSimulationResultsInTime :: Double -> ResultSourcePrint -> Simulation Results -> Specs -> IO () +printSimulationResultsInTime t print model specs = + flip runSimulation specs $ + model >>= printResultsInTime t print + +-- | Run the simulation and then print the results in the specified time points. +printSimulationResultsInTimes :: [Double] -> ResultSourcePrint -> Simulation Results -> Specs -> IO () +printSimulationResultsInTimes ts print model specs = + flip runSimulation specs $ + model >>= printResultsInTimes ts print + +-- | Run the simulation and then show the results in the start time. +showSimulationResultsInStartTime :: ResultSourceShowS -> Simulation Results -> Specs -> IO ShowS +showSimulationResultsInStartTime f model specs = + flip runSimulation specs $ + model >>= showResultsInStartTime f + +-- | Run the simulation and then show the results in the final time. +showSimulationResultsInStopTime :: ResultSourceShowS -> Simulation Results -> Specs -> IO ShowS +showSimulationResultsInStopTime f model specs = + flip runSimulation specs $ + model >>= showResultsInStopTime f + +-- | Run the simulation and then show the results in the integration time points. +-- +-- It may consume much memory, for we have to traverse all the integration +-- points to create the resulting function within the 'IO' computation. +showSimulationResultsInIntegTimes :: ResultSourceShowS -> Simulation Results -> Specs -> IO ShowS +showSimulationResultsInIntegTimes f model specs = + flip runSimulation specs $ + model >>= showResultsInIntegTimes f + +-- | Run the simulation and then show the results in the integration time point. +showSimulationResultsInTime :: Double -> ResultSourceShowS -> Simulation Results -> Specs -> IO ShowS +showSimulationResultsInTime t f model specs = + flip runSimulation specs $ + model >>= showResultsInTime t f + +-- | Run the simulation and then show the results in the specified time points. +-- +-- It may consume much memory, for we have to traverse all the specified +-- points to create the resulting function within the 'IO' computation. +showSimulationResultsInTimes :: [Double] -> ResultSourceShowS -> Simulation Results -> Specs -> IO ShowS +showSimulationResultsInTimes ts f model specs = + flip runSimulation specs $ + model >>= showResultsInTimes ts f diff --git a/Simulation/Aivika/Results/Locale.hs b/Simulation/Aivika/Results/Locale.hs --- a/Simulation/Aivika/Results/Locale.hs +++ b/Simulation/Aivika/Results/Locale.hs @@ -1,339 +1,340 @@ - --- | --- Module : Simulation.Aivika.Results.Locale --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- The module defines locales for outputting and printing the simulation results. --- -module Simulation.Aivika.Results.Locale - (-- * Basic Types - ResultLocale, - ResultLocalisation, - ResultDescription, - -- * Locale Codes - russianResultLocale, - englishResultLocale, - -- * Localisations - lookupResultLocalisation, - russianResultLocalisation, - englishResultLocalisation, - -- * Unique Identifiers - ResultId(..)) where - -import qualified Data.Map as M - -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Statistics -import Simulation.Aivika.Statistics.Accumulator -import qualified Simulation.Aivika.Queue as Q -import qualified Simulation.Aivika.Queue.Infinite as IQ -import Simulation.Aivika.Arrival -import Simulation.Aivika.Server - --- | A locale to output the simulation results. --- --- Examples are: @\"ru\", @\"en\" etc. -type ResultLocale = String - --- | It localises the description of simulation results. -type ResultLocalisation = ResultId -> ResultDescription - --- | A description used for describing the results when generating output. -type ResultDescription = String - --- | The result entity identifier. -data ResultId = TimeId - -- ^ A 'time' computation. - | VectorId - -- ^ Describes a vector. - | VectorItemId String - -- ^ Describes a vector item with the specified subscript. - | SamplingStatsId - -- ^ A 'SamplingStats' value. - | SamplingStatsCountId - -- ^ Property 'samplingStatsCount'. - | SamplingStatsMinId - -- ^ Property 'samplingStatsMin'. - | SamplingStatsMaxId - -- ^ Property 'samplingStatsMax'. - | SamplingStatsMeanId - -- ^ Property 'samplingStatsMean'. - | SamplingStatsMean2Id - -- ^ Property 'samplingStatsMean2'. - | SamplingStatsVarianceId - -- ^ Property 'samplingStatsVariance'. - | SamplingStatsDeviationId - -- ^ Property 'samplingStatsDeviation'. - | TimingStatsId - -- ^ A 'TimingStats' value. - | TimingStatsCountId - -- ^ Property 'timingStatsCount'. - | TimingStatsMinId - -- ^ Property 'timingStatsMin'. - | TimingStatsMaxId - -- ^ Property 'timingStatsMax'. - | TimingStatsMeanId - -- ^ Property 'timingStatsMean'. - | TimingStatsVarianceId - -- ^ Property 'timingStatsVariance'. - | TimingStatsDeviationId - -- ^ Property 'timingStatsDeviation'. - | TimingStatsMinTimeId - -- ^ Property 'timingStatsMinTime'. - | TimingStatsMaxTimeId - -- ^ Property 'timingStatsMaxTime'. - | TimingStatsStartTimeId - -- ^ Property 'timingStatsStartTime'. - | TimingStatsLastTimeId - -- ^ Property 'timingStatsLastTime'. - | TimingStatsSumId - -- ^ Property 'timingStatsSum'. - | TimingStatsSum2Id - -- ^ Property 'timingStatsSum2'. - | FiniteQueueId - -- ^ A finite 'Q.Queue'. - | InfiniteQueueId - -- ^ An infinite 'IQ.Queue'. - | EnqueueStrategyId - -- ^ Property 'Q.enqueueStrategy'. - | EnqueueStoringStrategyId - -- ^ Property 'Q.enqueueStoringStrategy'. - | DequeueStrategyId - -- ^ Property 'Q.dequeueStrategy'. - | QueueNullId - -- ^ Property 'Q.queueNull'. - | QueueFullId - -- ^ Property 'Q.queueFull'. - | QueueMaxCountId - -- ^ Property 'Q.queueMaxCount'. - | QueueCountId - -- ^ Property 'Q.queueCount'. - | QueueCountStatsId - -- ^ Property 'Q.queueCountStats'. - | EnqueueCountId - -- ^ Property 'Q.enqueueCount'. - | EnqueueLostCountId - -- ^ Property 'Q.enqueueLostCount'. - | EnqueueStoreCountId - -- ^ Property 'Q.enqueueStoreCount'. - | DequeueCountId - -- ^ Property 'Q.dequeueCount'. - | DequeueExtractCountId - -- ^ Property 'Q.dequeueExtractCount'. - | QueueLoadFactorId - -- ^ Property 'Q.queueLoadFactor'. - | EnqueueRateId - -- ^ Property 'Q.enqueueRate'. - | EnqueueStoreRateId - -- ^ Property 'Q.enqueueStoreRate'. - | DequeueRateId - -- ^ Property 'Q.dequeueRate'. - | DequeueExtractRateId - -- ^ Property 'Q.dequeueExtractRate'. - | QueueWaitTimeId - -- ^ Property 'Q.queueWaitTime'. - | QueueTotalWaitTimeId - -- ^ Property 'Q.queueTotalWaitTime'. - | EnqueueWaitTimeId - -- ^ Property 'Q.enqueueWaitTime'. - | DequeueWaitTimeId - -- ^ Property 'Q.dequeueWaitTime'. - | QueueRateId - -- ^ Property 'Q.queueRate'. - | ArrivalTimerId - -- ^ An 'ArrivalTimer'. - | ArrivalProcessingTimeId - -- ^ Property 'arrivalProcessingTime'. - | ServerId - -- ^ Represents a 'Server'. - | ServerInitStateId - -- ^ Property 'serverInitState'. - | ServerStateId - -- ^ Property 'serverState'. - | ServerTotalInputWaitTimeId - -- ^ Property 'serverTotalInputWaitTime'. - | ServerTotalProcessingTimeId - -- ^ Property 'serverTotalProcessingTime'. - | ServerTotalOutputWaitTimeId - -- ^ Property 'serverTotalOutputWaitTime'. - | ServerInputWaitTimeId - -- ^ Property 'serverInputWaitTime'. - | ServerProcessingTimeId - -- ^ Property 'serverProcessingTime'. - | ServerOutputWaitTimeId - -- ^ Property 'serverOutputWaitTime'. - | ServerInputWaitFactorId - -- ^ Property 'serverInputWaitFactor'. - | ServerProcessingFactorId - -- ^ Property 'serverProcessingFactor'. - | ServerOutputWaitFactorId - -- ^ Property 'serverOutputWaitFactor'. - | UserDefinedResultId ResultDescription - -- ^ An user defined description. - | LocalisedResultId (M.Map ResultLocale ResultDescription) - -- ^ A localised property or object name. - --- | The Russian locale. -russianResultLocale :: ResultLocale -russianResultLocale = "ru" - --- | The English locale. -englishResultLocale :: ResultLocale -englishResultLocale = "en" - --- | The Russian localisation of the simulation results. -russianResultLocalisation :: ResultLocalisation -russianResultLocalisation TimeId = "модельное время" -russianResultLocalisation VectorId = "вектор" -russianResultLocalisation (VectorItemId x) = "элемент с индексом " ++ x -russianResultLocalisation SamplingStatsId = "сводная статистика" -russianResultLocalisation SamplingStatsCountId = "количество" -russianResultLocalisation SamplingStatsMinId = "минимальное значение" -russianResultLocalisation SamplingStatsMaxId = "максимальное значение" -russianResultLocalisation SamplingStatsMeanId = "среднее значение" -russianResultLocalisation SamplingStatsMean2Id = "среднее квадратов" -russianResultLocalisation SamplingStatsVarianceId = "дисперсия" -russianResultLocalisation SamplingStatsDeviationId = "среднеквадратическое отклонение" -russianResultLocalisation TimingStatsId = "временная статистика" -russianResultLocalisation TimingStatsCountId = "количество" -russianResultLocalisation TimingStatsMinId = "минимальное значение" -russianResultLocalisation TimingStatsMaxId = "максимальное значение" -russianResultLocalisation TimingStatsMeanId = "среднее значение" -russianResultLocalisation TimingStatsVarianceId = "дисперсия" -russianResultLocalisation TimingStatsDeviationId = "среднеквадратическое отклонение" -russianResultLocalisation TimingStatsMinTimeId = "время достижения минимума" -russianResultLocalisation TimingStatsMaxTimeId = "время достижения максимума" -russianResultLocalisation TimingStatsStartTimeId = "начальное время сбора статистики" -russianResultLocalisation TimingStatsLastTimeId = "конечное время сбора статистики" -russianResultLocalisation TimingStatsSumId = "сумма" -russianResultLocalisation TimingStatsSum2Id = "сумма квадратов" -russianResultLocalisation FiniteQueueId = "конечная очередь" -russianResultLocalisation InfiniteQueueId = "бесконечная очередь" -russianResultLocalisation EnqueueStrategyId = "стратегия добавления элементов" -russianResultLocalisation EnqueueStoringStrategyId = "стратегия хранения элементов" -russianResultLocalisation DequeueStrategyId = "стратегия извлечения элементов" -russianResultLocalisation QueueNullId = "очередь пуста?" -russianResultLocalisation QueueFullId = "очередь заполнена?" -russianResultLocalisation QueueMaxCountId = "емкость очереди" -russianResultLocalisation QueueCountId = "текущий размер очереди" -russianResultLocalisation QueueCountStatsId = "статистика по размеру очереди" -russianResultLocalisation EnqueueCountId = "общее количество попыток добавить элементы" -russianResultLocalisation EnqueueLostCountId = "общее количество неудачных попыток добавить элементы" -russianResultLocalisation EnqueueStoreCountId = "общее количество сохраненных элементов" -russianResultLocalisation DequeueCountId = "общее количество запросов на извлечение элементов" -russianResultLocalisation DequeueExtractCountId = "общее количество извлеченных элементов" -russianResultLocalisation QueueLoadFactorId = "коэфф. загрузки (размер, поделенный на емкость)" -russianResultLocalisation EnqueueRateId = "количество попыток добавить на ед. времени" -russianResultLocalisation EnqueueStoreRateId = "количество сохраненных на ед. времени" -russianResultLocalisation DequeueRateId = "количество запросов на извлечение в ед. времени" -russianResultLocalisation DequeueExtractRateId = "количество извлеченных на ед. времени" -russianResultLocalisation QueueWaitTimeId = "время ожидания (сохранили -> извлекли)" -russianResultLocalisation QueueTotalWaitTimeId = "общее время ожидания (попытались добавить -> извлекли)" -russianResultLocalisation EnqueueWaitTimeId = "время ожидания добавления (попытались добавить -> сохранили)" -russianResultLocalisation DequeueWaitTimeId = "время ожидания извлечения (запросили извлечь -> извлекли)" -russianResultLocalisation QueueRateId = "усредненная скорость (как средняя длина очереди на среднее время ожидания)" -russianResultLocalisation ArrivalTimerId = "как долго обрабатываются заявки?" -russianResultLocalisation ArrivalProcessingTimeId = "время обработки заявки" -russianResultLocalisation ServerId = "сервер" -russianResultLocalisation ServerInitStateId = "начальное состояние" -russianResultLocalisation ServerStateId = "текущее состояние" -russianResultLocalisation ServerTotalInputWaitTimeId = "общее время блокировки в ожидании ввода" -russianResultLocalisation ServerTotalProcessingTimeId = "общее время, потраченное на саму обработку заданий" -russianResultLocalisation ServerTotalOutputWaitTimeId = "общее время блокировки при попытке доставить вывод" -russianResultLocalisation ServerInputWaitTimeId = "время блокировки в ожидании ввода" -russianResultLocalisation ServerProcessingTimeId = "время, потраченное на саму обработку заданий" -russianResultLocalisation ServerOutputWaitTimeId = "время блокировки при попытке доставить вывод" -russianResultLocalisation ServerInputWaitFactorId = "относительное время блокировки в ожидании ввода (от 0 до 1)" -russianResultLocalisation ServerProcessingFactorId = "относительное время, потраченное на саму обработку заданий (от 0 до 1)" -russianResultLocalisation ServerOutputWaitFactorId = "относительное время блокировки при попытке доставить вывод (от 0 до 1)" -russianResultLocalisation (UserDefinedResultId m) = m -russianResultLocalisation x@(LocalisedResultId m) = - lookupResultLocalisation russianResultLocale x - --- | The English localisation of the simulation results. -englishResultLocalisation :: ResultLocalisation -englishResultLocalisation TimeId = "simulation time" -englishResultLocalisation VectorId = "vector" -englishResultLocalisation (VectorItemId x) = "item #" ++ x -englishResultLocalisation SamplingStatsId = "statistics summary" -englishResultLocalisation SamplingStatsCountId = "count" -englishResultLocalisation SamplingStatsMinId = "minimum" -englishResultLocalisation SamplingStatsMaxId = "maximum" -englishResultLocalisation SamplingStatsMeanId = "mean" -englishResultLocalisation SamplingStatsMean2Id = "mean square" -englishResultLocalisation SamplingStatsVarianceId = "variance" -englishResultLocalisation SamplingStatsDeviationId = "deviation" -englishResultLocalisation TimingStatsId = "timing statistics" -englishResultLocalisation TimingStatsCountId = "count" -englishResultLocalisation TimingStatsMinId = "minimum" -englishResultLocalisation TimingStatsMaxId = "maximum" -englishResultLocalisation TimingStatsMeanId = "mean" -englishResultLocalisation TimingStatsVarianceId = "variance" -englishResultLocalisation TimingStatsDeviationId = "deviation" -englishResultLocalisation TimingStatsMinTimeId = "the time of minimum" -englishResultLocalisation TimingStatsMaxTimeId = "the time of maximum" -englishResultLocalisation TimingStatsStartTimeId = "the start time" -englishResultLocalisation TimingStatsLastTimeId = "the last time" -englishResultLocalisation TimingStatsSumId = "sum" -englishResultLocalisation TimingStatsSum2Id = "sum square" -englishResultLocalisation FiniteQueueId = "the finite queue" -englishResultLocalisation InfiniteQueueId = "the infinite queue" -englishResultLocalisation EnqueueStrategyId = "the enqueueing strategy" -englishResultLocalisation EnqueueStoringStrategyId = "the storing strategy" -englishResultLocalisation DequeueStrategyId = "the dequeueing strategy" -englishResultLocalisation QueueNullId = "is the queue empty?" -englishResultLocalisation QueueFullId = "is the queue full?" -englishResultLocalisation QueueMaxCountId = "the queue capacity" -englishResultLocalisation QueueCountId = "the current queue size" -englishResultLocalisation QueueCountStatsId = "the queue size statistics" -englishResultLocalisation EnqueueCountId = "a total number of attempts to enqueue the items" -englishResultLocalisation EnqueueLostCountId = "a total number of the lost items when trying to enqueue" -englishResultLocalisation EnqueueStoreCountId = "a total number of the stored items" -englishResultLocalisation DequeueCountId = "a total number of requests for dequeueing" -englishResultLocalisation DequeueExtractCountId = "a total number of the dequeued items" -englishResultLocalisation QueueLoadFactorId = "the queue load (its size divided by its capacity)" -englishResultLocalisation EnqueueRateId = "how many attempts to enqueue per time?" -englishResultLocalisation EnqueueStoreRateId = "how many items were stored per time?" -englishResultLocalisation DequeueRateId = "how many requests for dequeueing per time?" -englishResultLocalisation DequeueExtractRateId = "how many items were dequeued per time?" -englishResultLocalisation QueueWaitTimeId = "the wait time (stored -> dequeued)" -englishResultLocalisation QueueTotalWaitTimeId = "the total wait time (tried to enqueue -> dequeued)" -englishResultLocalisation EnqueueWaitTimeId = "the enqueue wait time (tried to enqueue -> stored)" -englishResultLocalisation DequeueWaitTimeId = "the dequeue wait time (requested for dequeueing -> dequeued)" -englishResultLocalisation QueueRateId = "the average queue rate (= queue size / wait time)" -englishResultLocalisation ArrivalTimerId = "how long the arrivals are processed?" -englishResultLocalisation ArrivalProcessingTimeId = "the processing time of arrivals" -englishResultLocalisation ServerId = "the server" -englishResultLocalisation ServerInitStateId = "the initial state" -englishResultLocalisation ServerStateId = "the current state" -englishResultLocalisation ServerTotalInputWaitTimeId = "the total time spent while waiting for input" -englishResultLocalisation ServerTotalProcessingTimeId = "the total time spent on actual processing the tasks" -englishResultLocalisation ServerTotalOutputWaitTimeId = "the total time spent on delivering the output" -englishResultLocalisation ServerInputWaitTimeId = "the time spent while waiting for input" -englishResultLocalisation ServerProcessingTimeId = "the time spent on processing the tasks" -englishResultLocalisation ServerOutputWaitTimeId = "the time spent on delivering the output" -englishResultLocalisation ServerInputWaitFactorId = "the relative time spent while waiting for input (from 0 to 1)" -englishResultLocalisation ServerProcessingFactorId = "the relative time spent on processing the tasks (from 0 to 1)" -englishResultLocalisation ServerOutputWaitFactorId = "the relative time spent on delivering the output (from 0 to 1)" -englishResultLocalisation (UserDefinedResultId m) = m -englishResultLocalisation x@(LocalisedResultId m) = - lookupResultLocalisation englishResultLocale x - --- | Lookup a localisation by the specified locale. -lookupResultLocalisation :: ResultLocale -> ResultLocalisation -lookupResultLocalisation loc (UserDefinedResultId m) = m -lookupResultLocalisation loc (LocalisedResultId m) = - case M.lookup loc m of - Just x -> x - Nothing -> - case M.lookup russianResultLocale m of - Just x -> x - Nothing -> - case M.lookup englishResultLocale m of - Just x -> x - Nothing -> "" -lookupResultLocalisation loc resultId = russianResultLocalisation resultId + +-- | +-- Module : Simulation.Aivika.Results.Locale +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines locales for outputting and printing the simulation results. +-- +module Simulation.Aivika.Results.Locale + (-- * Basic Types + ResultLocale, + ResultLocalisation, + ResultDescription, + -- * Locale Codes + russianResultLocale, + englishResultLocale, + -- * Localisations + lookupResultLocalisation, + russianResultLocalisation, + englishResultLocalisation, + -- * Unique Identifiers + ResultId(..)) where + +import qualified Data.Map as M + +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Statistics +import Simulation.Aivika.Statistics.Accumulator +import qualified Simulation.Aivika.Queue as Q +import qualified Simulation.Aivika.Queue.Infinite as IQ +import Simulation.Aivika.Arrival +import Simulation.Aivika.Server + +-- | A locale to output the simulation results. +-- +-- Examples are: @\"ru\", @\"en\" etc. +type ResultLocale = String + +-- | It localises the description of simulation results. +type ResultLocalisation = ResultId -> ResultDescription + +-- | A description used for describing the results when generating output. +type ResultDescription = String + +-- | The result entity identifier. +data ResultId = TimeId + -- ^ A 'time' computation. + | VectorId + -- ^ Describes a vector. + | VectorItemId String + -- ^ Describes a vector item with the specified subscript. + | SamplingStatsId + -- ^ A 'SamplingStats' value. + | SamplingStatsCountId + -- ^ Property 'samplingStatsCount'. + | SamplingStatsMinId + -- ^ Property 'samplingStatsMin'. + | SamplingStatsMaxId + -- ^ Property 'samplingStatsMax'. + | SamplingStatsMeanId + -- ^ Property 'samplingStatsMean'. + | SamplingStatsMean2Id + -- ^ Property 'samplingStatsMean2'. + | SamplingStatsVarianceId + -- ^ Property 'samplingStatsVariance'. + | SamplingStatsDeviationId + -- ^ Property 'samplingStatsDeviation'. + | TimingStatsId + -- ^ A 'TimingStats' value. + | TimingStatsCountId + -- ^ Property 'timingStatsCount'. + | TimingStatsMinId + -- ^ Property 'timingStatsMin'. + | TimingStatsMaxId + -- ^ Property 'timingStatsMax'. + | TimingStatsMeanId + -- ^ Property 'timingStatsMean'. + | TimingStatsVarianceId + -- ^ Property 'timingStatsVariance'. + | TimingStatsDeviationId + -- ^ Property 'timingStatsDeviation'. + | TimingStatsMinTimeId + -- ^ Property 'timingStatsMinTime'. + | TimingStatsMaxTimeId + -- ^ Property 'timingStatsMaxTime'. + | TimingStatsStartTimeId + -- ^ Property 'timingStatsStartTime'. + | TimingStatsLastTimeId + -- ^ Property 'timingStatsLastTime'. + | TimingStatsSumId + -- ^ Property 'timingStatsSum'. + | TimingStatsSum2Id + -- ^ Property 'timingStatsSum2'. + | FiniteQueueId + -- ^ A finite 'Q.Queue'. + | InfiniteQueueId + -- ^ An infinite 'IQ.Queue'. + | EnqueueStrategyId + -- ^ Property 'Q.enqueueStrategy'. + | EnqueueStoringStrategyId + -- ^ Property 'Q.enqueueStoringStrategy'. + | DequeueStrategyId + -- ^ Property 'Q.dequeueStrategy'. + | QueueNullId + -- ^ Property 'Q.queueNull'. + | QueueFullId + -- ^ Property 'Q.queueFull'. + | QueueMaxCountId + -- ^ Property 'Q.queueMaxCount'. + | QueueCountId + -- ^ Property 'Q.queueCount'. + | QueueCountStatsId + -- ^ Property 'Q.queueCountStats'. + | EnqueueCountId + -- ^ Property 'Q.enqueueCount'. + | EnqueueLostCountId + -- ^ Property 'Q.enqueueLostCount'. + | EnqueueStoreCountId + -- ^ Property 'Q.enqueueStoreCount'. + | DequeueCountId + -- ^ Property 'Q.dequeueCount'. + | DequeueExtractCountId + -- ^ Property 'Q.dequeueExtractCount'. + | QueueLoadFactorId + -- ^ Property 'Q.queueLoadFactor'. + | EnqueueRateId + -- ^ Property 'Q.enqueueRate'. + | EnqueueStoreRateId + -- ^ Property 'Q.enqueueStoreRate'. + | DequeueRateId + -- ^ Property 'Q.dequeueRate'. + | DequeueExtractRateId + -- ^ Property 'Q.dequeueExtractRate'. + | QueueWaitTimeId + -- ^ Property 'Q.queueWaitTime'. + | QueueTotalWaitTimeId + -- ^ Property 'Q.queueTotalWaitTime'. + | EnqueueWaitTimeId + -- ^ Property 'Q.enqueueWaitTime'. + | DequeueWaitTimeId + -- ^ Property 'Q.dequeueWaitTime'. + | QueueRateId + -- ^ Property 'Q.queueRate'. + | ArrivalTimerId + -- ^ An 'ArrivalTimer'. + | ArrivalProcessingTimeId + -- ^ Property 'arrivalProcessingTime'. + | ServerId + -- ^ Represents a 'Server'. + | ServerInitStateId + -- ^ Property 'serverInitState'. + | ServerStateId + -- ^ Property 'serverState'. + | ServerTotalInputWaitTimeId + -- ^ Property 'serverTotalInputWaitTime'. + | ServerTotalProcessingTimeId + -- ^ Property 'serverTotalProcessingTime'. + | ServerTotalOutputWaitTimeId + -- ^ Property 'serverTotalOutputWaitTime'. + | ServerInputWaitTimeId + -- ^ Property 'serverInputWaitTime'. + | ServerProcessingTimeId + -- ^ Property 'serverProcessingTime'. + | ServerOutputWaitTimeId + -- ^ Property 'serverOutputWaitTime'. + | ServerInputWaitFactorId + -- ^ Property 'serverInputWaitFactor'. + | ServerProcessingFactorId + -- ^ Property 'serverProcessingFactor'. + | ServerOutputWaitFactorId + -- ^ Property 'serverOutputWaitFactor'. + | UserDefinedResultId ResultDescription + -- ^ An user defined description. + | LocalisedResultId (M.Map ResultLocale ResultDescription) + -- ^ A localised property or object name. + deriving (Eq, Ord, Show) + +-- | The Russian locale. +russianResultLocale :: ResultLocale +russianResultLocale = "ru" + +-- | The English locale. +englishResultLocale :: ResultLocale +englishResultLocale = "en" + +-- | The Russian localisation of the simulation results. +russianResultLocalisation :: ResultLocalisation +russianResultLocalisation TimeId = "модельное время" +russianResultLocalisation VectorId = "вектор" +russianResultLocalisation (VectorItemId x) = "элемент с индексом " ++ x +russianResultLocalisation SamplingStatsId = "сводная статистика" +russianResultLocalisation SamplingStatsCountId = "количество" +russianResultLocalisation SamplingStatsMinId = "минимальное значение" +russianResultLocalisation SamplingStatsMaxId = "максимальное значение" +russianResultLocalisation SamplingStatsMeanId = "среднее значение" +russianResultLocalisation SamplingStatsMean2Id = "среднее квадратов" +russianResultLocalisation SamplingStatsVarianceId = "дисперсия" +russianResultLocalisation SamplingStatsDeviationId = "среднеквадратическое отклонение" +russianResultLocalisation TimingStatsId = "временная статистика" +russianResultLocalisation TimingStatsCountId = "количество" +russianResultLocalisation TimingStatsMinId = "минимальное значение" +russianResultLocalisation TimingStatsMaxId = "максимальное значение" +russianResultLocalisation TimingStatsMeanId = "среднее значение" +russianResultLocalisation TimingStatsVarianceId = "дисперсия" +russianResultLocalisation TimingStatsDeviationId = "среднеквадратическое отклонение" +russianResultLocalisation TimingStatsMinTimeId = "время достижения минимума" +russianResultLocalisation TimingStatsMaxTimeId = "время достижения максимума" +russianResultLocalisation TimingStatsStartTimeId = "начальное время сбора статистики" +russianResultLocalisation TimingStatsLastTimeId = "конечное время сбора статистики" +russianResultLocalisation TimingStatsSumId = "сумма" +russianResultLocalisation TimingStatsSum2Id = "сумма квадратов" +russianResultLocalisation FiniteQueueId = "конечная очередь" +russianResultLocalisation InfiniteQueueId = "бесконечная очередь" +russianResultLocalisation EnqueueStrategyId = "стратегия добавления элементов" +russianResultLocalisation EnqueueStoringStrategyId = "стратегия хранения элементов" +russianResultLocalisation DequeueStrategyId = "стратегия извлечения элементов" +russianResultLocalisation QueueNullId = "очередь пуста?" +russianResultLocalisation QueueFullId = "очередь заполнена?" +russianResultLocalisation QueueMaxCountId = "емкость очереди" +russianResultLocalisation QueueCountId = "текущий размер очереди" +russianResultLocalisation QueueCountStatsId = "статистика по размеру очереди" +russianResultLocalisation EnqueueCountId = "общее количество попыток добавить элементы" +russianResultLocalisation EnqueueLostCountId = "общее количество неудачных попыток добавить элементы" +russianResultLocalisation EnqueueStoreCountId = "общее количество сохраненных элементов" +russianResultLocalisation DequeueCountId = "общее количество запросов на извлечение элементов" +russianResultLocalisation DequeueExtractCountId = "общее количество извлеченных элементов" +russianResultLocalisation QueueLoadFactorId = "коэфф. загрузки (размер, поделенный на емкость)" +russianResultLocalisation EnqueueRateId = "количество попыток добавить на ед. времени" +russianResultLocalisation EnqueueStoreRateId = "количество сохраненных на ед. времени" +russianResultLocalisation DequeueRateId = "количество запросов на извлечение в ед. времени" +russianResultLocalisation DequeueExtractRateId = "количество извлеченных на ед. времени" +russianResultLocalisation QueueWaitTimeId = "время ожидания (сохранили -> извлекли)" +russianResultLocalisation QueueTotalWaitTimeId = "общее время ожидания (попытались добавить -> извлекли)" +russianResultLocalisation EnqueueWaitTimeId = "время ожидания добавления (попытались добавить -> сохранили)" +russianResultLocalisation DequeueWaitTimeId = "время ожидания извлечения (запросили извлечь -> извлекли)" +russianResultLocalisation QueueRateId = "усредненная скорость (как средняя длина очереди на среднее время ожидания)" +russianResultLocalisation ArrivalTimerId = "как долго обрабатываются заявки?" +russianResultLocalisation ArrivalProcessingTimeId = "время обработки заявки" +russianResultLocalisation ServerId = "сервер" +russianResultLocalisation ServerInitStateId = "начальное состояние" +russianResultLocalisation ServerStateId = "текущее состояние" +russianResultLocalisation ServerTotalInputWaitTimeId = "общее время блокировки в ожидании ввода" +russianResultLocalisation ServerTotalProcessingTimeId = "общее время, потраченное на саму обработку заданий" +russianResultLocalisation ServerTotalOutputWaitTimeId = "общее время блокировки при попытке доставить вывод" +russianResultLocalisation ServerInputWaitTimeId = "время блокировки в ожидании ввода" +russianResultLocalisation ServerProcessingTimeId = "время, потраченное на саму обработку заданий" +russianResultLocalisation ServerOutputWaitTimeId = "время блокировки при попытке доставить вывод" +russianResultLocalisation ServerInputWaitFactorId = "относительное время блокировки в ожидании ввода (от 0 до 1)" +russianResultLocalisation ServerProcessingFactorId = "относительное время, потраченное на саму обработку заданий (от 0 до 1)" +russianResultLocalisation ServerOutputWaitFactorId = "относительное время блокировки при попытке доставить вывод (от 0 до 1)" +russianResultLocalisation (UserDefinedResultId m) = m +russianResultLocalisation x@(LocalisedResultId m) = + lookupResultLocalisation russianResultLocale x + +-- | The English localisation of the simulation results. +englishResultLocalisation :: ResultLocalisation +englishResultLocalisation TimeId = "simulation time" +englishResultLocalisation VectorId = "vector" +englishResultLocalisation (VectorItemId x) = "item #" ++ x +englishResultLocalisation SamplingStatsId = "statistics summary" +englishResultLocalisation SamplingStatsCountId = "count" +englishResultLocalisation SamplingStatsMinId = "minimum" +englishResultLocalisation SamplingStatsMaxId = "maximum" +englishResultLocalisation SamplingStatsMeanId = "mean" +englishResultLocalisation SamplingStatsMean2Id = "mean square" +englishResultLocalisation SamplingStatsVarianceId = "variance" +englishResultLocalisation SamplingStatsDeviationId = "deviation" +englishResultLocalisation TimingStatsId = "timing statistics" +englishResultLocalisation TimingStatsCountId = "count" +englishResultLocalisation TimingStatsMinId = "minimum" +englishResultLocalisation TimingStatsMaxId = "maximum" +englishResultLocalisation TimingStatsMeanId = "mean" +englishResultLocalisation TimingStatsVarianceId = "variance" +englishResultLocalisation TimingStatsDeviationId = "deviation" +englishResultLocalisation TimingStatsMinTimeId = "the time of minimum" +englishResultLocalisation TimingStatsMaxTimeId = "the time of maximum" +englishResultLocalisation TimingStatsStartTimeId = "the start time" +englishResultLocalisation TimingStatsLastTimeId = "the last time" +englishResultLocalisation TimingStatsSumId = "sum" +englishResultLocalisation TimingStatsSum2Id = "sum square" +englishResultLocalisation FiniteQueueId = "the finite queue" +englishResultLocalisation InfiniteQueueId = "the infinite queue" +englishResultLocalisation EnqueueStrategyId = "the enqueueing strategy" +englishResultLocalisation EnqueueStoringStrategyId = "the storing strategy" +englishResultLocalisation DequeueStrategyId = "the dequeueing strategy" +englishResultLocalisation QueueNullId = "is the queue empty?" +englishResultLocalisation QueueFullId = "is the queue full?" +englishResultLocalisation QueueMaxCountId = "the queue capacity" +englishResultLocalisation QueueCountId = "the current queue size" +englishResultLocalisation QueueCountStatsId = "the queue size statistics" +englishResultLocalisation EnqueueCountId = "a total number of attempts to enqueue the items" +englishResultLocalisation EnqueueLostCountId = "a total number of the lost items when trying to enqueue" +englishResultLocalisation EnqueueStoreCountId = "a total number of the stored items" +englishResultLocalisation DequeueCountId = "a total number of requests for dequeueing" +englishResultLocalisation DequeueExtractCountId = "a total number of the dequeued items" +englishResultLocalisation QueueLoadFactorId = "the queue load (its size divided by its capacity)" +englishResultLocalisation EnqueueRateId = "how many attempts to enqueue per time?" +englishResultLocalisation EnqueueStoreRateId = "how many items were stored per time?" +englishResultLocalisation DequeueRateId = "how many requests for dequeueing per time?" +englishResultLocalisation DequeueExtractRateId = "how many items were dequeued per time?" +englishResultLocalisation QueueWaitTimeId = "the wait time (stored -> dequeued)" +englishResultLocalisation QueueTotalWaitTimeId = "the total wait time (tried to enqueue -> dequeued)" +englishResultLocalisation EnqueueWaitTimeId = "the enqueue wait time (tried to enqueue -> stored)" +englishResultLocalisation DequeueWaitTimeId = "the dequeue wait time (requested for dequeueing -> dequeued)" +englishResultLocalisation QueueRateId = "the average queue rate (= queue size / wait time)" +englishResultLocalisation ArrivalTimerId = "how long the arrivals are processed?" +englishResultLocalisation ArrivalProcessingTimeId = "the processing time of arrivals" +englishResultLocalisation ServerId = "the server" +englishResultLocalisation ServerInitStateId = "the initial state" +englishResultLocalisation ServerStateId = "the current state" +englishResultLocalisation ServerTotalInputWaitTimeId = "the total time spent while waiting for input" +englishResultLocalisation ServerTotalProcessingTimeId = "the total time spent on actual processing the tasks" +englishResultLocalisation ServerTotalOutputWaitTimeId = "the total time spent on delivering the output" +englishResultLocalisation ServerInputWaitTimeId = "the time spent while waiting for input" +englishResultLocalisation ServerProcessingTimeId = "the time spent on processing the tasks" +englishResultLocalisation ServerOutputWaitTimeId = "the time spent on delivering the output" +englishResultLocalisation ServerInputWaitFactorId = "the relative time spent while waiting for input (from 0 to 1)" +englishResultLocalisation ServerProcessingFactorId = "the relative time spent on processing the tasks (from 0 to 1)" +englishResultLocalisation ServerOutputWaitFactorId = "the relative time spent on delivering the output (from 0 to 1)" +englishResultLocalisation (UserDefinedResultId m) = m +englishResultLocalisation x@(LocalisedResultId m) = + lookupResultLocalisation englishResultLocale x + +-- | Lookup a localisation by the specified locale. +lookupResultLocalisation :: ResultLocale -> ResultLocalisation +lookupResultLocalisation loc (UserDefinedResultId m) = m +lookupResultLocalisation loc (LocalisedResultId m) = + case M.lookup loc m of + Just x -> x + Nothing -> + case M.lookup russianResultLocale m of + Just x -> x + Nothing -> + case M.lookup englishResultLocale m of + Just x -> x + Nothing -> "" +lookupResultLocalisation loc resultId = russianResultLocalisation resultId diff --git a/Simulation/Aivika/Server.hs b/Simulation/Aivika/Server.hs --- a/Simulation/Aivika/Server.hs +++ b/Simulation/Aivika/Server.hs @@ -1,510 +1,510 @@ - --- | --- Module : Simulation.Aivika.Server --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It models the server that prodives a service. -module Simulation.Aivika.Server - (-- * Server - Server, - newServer, - newStateServer, - -- * Processing - serverProcessor, - -- * Server Properties and Activities - serverInitState, - serverState, - serverTotalInputWaitTime, - serverTotalProcessingTime, - serverTotalOutputWaitTime, - serverInputWaitTime, - serverProcessingTime, - serverOutputWaitTime, - serverInputWaitFactor, - serverProcessingFactor, - serverOutputWaitFactor, - -- * Summary - serverSummary, - -- * Derived Signals for Properties - serverStateChanged, - serverStateChanged_, - serverTotalInputWaitTimeChanged, - serverTotalInputWaitTimeChanged_, - serverTotalProcessingTimeChanged, - serverTotalProcessingTimeChanged_, - serverTotalOutputWaitTimeChanged, - serverTotalOutputWaitTimeChanged_, - serverInputWaitTimeChanged, - serverInputWaitTimeChanged_, - serverProcessingTimeChanged, - serverProcessingTimeChanged_, - serverOutputWaitTimeChanged, - serverOutputWaitTimeChanged_, - serverInputWaitFactorChanged, - serverInputWaitFactorChanged_, - serverProcessingFactorChanged, - serverProcessingFactorChanged_, - serverOutputWaitFactorChanged, - serverOutputWaitFactorChanged_, - -- * Basic Signals - serverInputReceived, - serverTaskProcessed, - serverOutputProvided, - -- * Overall Signal - serverChanged_) where - -import Data.IORef -import Data.Monoid - -import Control.Monad.Trans -import Control.Arrow - -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Internal.Event -import Simulation.Aivika.Internal.Signal -import Simulation.Aivika.Resource -import Simulation.Aivika.Cont -import Simulation.Aivika.Process -import Simulation.Aivika.Processor -import Simulation.Aivika.Stream -import Simulation.Aivika.Statistics - --- | It models a server that takes @a@ and provides @b@ having state @s@. -data Server s a b = - Server { serverInitState :: s, - -- ^ The initial state of the server. - serverStateRef :: IORef s, - -- ^ The current state of the server. - serverProcess :: s -> a -> Process (s, b), - -- ^ Provide @b@ by specified @a@. - serverTotalInputWaitTimeRef :: IORef Double, - -- ^ The counted total time spent in awating the input. - serverTotalProcessingTimeRef :: IORef Double, - -- ^ The counted total time spent to process the input and prepare the output. - serverTotalOutputWaitTimeRef :: IORef Double, - -- ^ The counted total time spent for delivering the output. - serverInputWaitTimeRef :: IORef (SamplingStats Double), - -- ^ The statistics for the time spent in awaiting the input. - serverProcessingTimeRef :: IORef (SamplingStats Double), - -- ^ The statistics for the time spent to process the input and prepare the output. - serverOutputWaitTimeRef :: IORef (SamplingStats Double), - -- ^ The statistics for the time spent for delivering the output. - serverInputReceivedSource :: SignalSource a, - -- ^ A signal raised when the server recieves a new input to process. - serverTaskProcessedSource :: SignalSource (a, b), - -- ^ A signal raised when the input is processed and - -- the output is prepared for deliverying. - serverOutputProvidedSource :: SignalSource (a, b) - -- ^ A signal raised when the server has supplied the output. - } - --- | Create a new server that can provide output @b@ by input @a@. --- Also it returns the corresponded processor that being applied --- updates the server state. -newServer :: (a -> Process b) - -- ^ provide an output by the specified input - -> Simulation (Server () a b) -newServer provide = - flip newStateServer () $ \s a -> - do b <- provide a - return (s, b) - --- | Create a new server that can provide output @b@ by input @a@ --- starting from state @s@. Also it returns the corresponded processor --- that being applied updates the server state. -newStateServer :: (s -> a -> Process (s, b)) - -- ^ provide a new state and output by the specified - -- old state and input - -> s - -- ^ the initial state - -> Simulation (Server s a b) -newStateServer provide state = - do r0 <- liftIO $ newIORef state - r1 <- liftIO $ newIORef 0 - r2 <- liftIO $ newIORef 0 - r3 <- liftIO $ newIORef 0 - r4 <- liftIO $ newIORef emptySamplingStats - r5 <- liftIO $ newIORef emptySamplingStats - r6 <- liftIO $ newIORef emptySamplingStats - s1 <- newSignalSource - s2 <- newSignalSource - s3 <- newSignalSource - let server = Server { serverInitState = state, - serverStateRef = r0, - serverProcess = provide, - serverTotalInputWaitTimeRef = r1, - serverTotalProcessingTimeRef = r2, - serverTotalOutputWaitTimeRef = r3, - serverInputWaitTimeRef = r4, - serverProcessingTimeRef = r5, - serverOutputWaitTimeRef = r6, - serverInputReceivedSource = s1, - serverTaskProcessedSource = s2, - serverOutputProvidedSource = s3 } - return server - --- | Return a processor for the specified server. --- --- The processor updates the internal state of the server. The usual case is when --- the processor is applied only once in a chain of data processing. Otherwise; --- every time the processor is used, the state of the server changes. Sometimes --- it can be indeed useful if you want to aggregate the statistics for different --- servers simultaneously, but it would be more preferable to avoid this. --- --- If you connect different server processors returned by this function in a chain --- with help of '>>>' or other category combinator then this chain will act as one --- whole, where the first server will take a new task only after the last server --- finishes its current task and requests for the next one from the previous processor --- in the chain. This is not always that thing you might need. --- --- To model a sequence of the server processors working independently, you --- should separate them with help of the 'prefetchProcessor' that plays a role --- of a small one-place buffer in that case. --- --- The queue processors usually have the prefetching capabilities per se, where --- the items are already stored in the queue. Therefore, the server processor --- should not be prefetched if it is connected directly with the queue processor. -serverProcessor :: Server s a b -> Processor a b -serverProcessor server = - Processor $ \xs -> loop (serverInitState server) Nothing xs - where - loop s r xs = - Cons $ - do t0 <- liftDynamics time - liftEvent $ - case r of - Nothing -> return () - Just (t', a', b') -> - do liftIO $ - do modifyIORef' (serverTotalOutputWaitTimeRef server) (+ (t0 - t')) - modifyIORef' (serverOutputWaitTimeRef server) $ - addSamplingStats (t0 - t') - triggerSignal (serverOutputProvidedSource server) (a', b') - -- get input - (a, xs') <- runStream xs - t1 <- liftDynamics time - liftEvent $ - do liftIO $ - do modifyIORef' (serverTotalInputWaitTimeRef server) (+ (t1 - t0)) - modifyIORef' (serverInputWaitTimeRef server) $ - addSamplingStats (t1 - t0) - triggerSignal (serverInputReceivedSource server) a - -- provide the service - (s', b) <- serverProcess server s a - t2 <- liftDynamics time - liftEvent $ - do liftIO $ - do writeIORef (serverStateRef server) $! s' - modifyIORef' (serverTotalProcessingTimeRef server) (+ (t2 - t1)) - modifyIORef' (serverProcessingTimeRef server) $ - addSamplingStats (t2 - t1) - triggerSignal (serverTaskProcessedSource server) (a, b) - return (b, loop s' (Just (t2, a, b)) xs') - --- | Return the current state of the server. --- --- See also 'serverStateChanged' and 'serverStateChanged_'. -serverState :: Server s a b -> Event s -serverState server = - Event $ \p -> readIORef (serverStateRef server) - --- | Signal when the 'serverState' property value has changed. -serverStateChanged :: Server s a b -> Signal s -serverStateChanged server = - mapSignalM (const $ serverState server) (serverStateChanged_ server) - --- | Signal when the 'serverState' property value has changed. -serverStateChanged_ :: Server s a b -> Signal () -serverStateChanged_ server = - mapSignal (const ()) (serverTaskProcessed server) - --- | Return the counted total time when the server was locked while awaiting the input. --- --- The value returned changes discretely and it is usually delayed relative --- to the current simulation time. --- --- See also 'serverTotalInputWaitTimeChanged' and 'serverTotalInputWaitTimeChanged_'. -serverTotalInputWaitTime :: Server s a b -> Event Double -serverTotalInputWaitTime server = - Event $ \p -> readIORef (serverTotalInputWaitTimeRef server) - --- | Signal when the 'serverTotalInputWaitTime' property value has changed. -serverTotalInputWaitTimeChanged :: Server s a b -> Signal Double -serverTotalInputWaitTimeChanged server = - mapSignalM (const $ serverTotalInputWaitTime server) (serverTotalInputWaitTimeChanged_ server) - --- | Signal when the 'serverTotalInputWaitTime' property value has changed. -serverTotalInputWaitTimeChanged_ :: Server s a b -> Signal () -serverTotalInputWaitTimeChanged_ server = - mapSignal (const ()) (serverInputReceived server) - --- | Return the counted total time spent by the server while processing the tasks. --- --- The value returned changes discretely and it is usually delayed relative --- to the current simulation time. --- --- See also 'serverTotalProcessingTimeChanged' and 'serverTotalProcessingTimeChanged_'. -serverTotalProcessingTime :: Server s a b -> Event Double -serverTotalProcessingTime server = - Event $ \p -> readIORef (serverTotalProcessingTimeRef server) - --- | Signal when the 'serverTotalProcessingTime' property value has changed. -serverTotalProcessingTimeChanged :: Server s a b -> Signal Double -serverTotalProcessingTimeChanged server = - mapSignalM (const $ serverTotalProcessingTime server) (serverTotalProcessingTimeChanged_ server) - --- | Signal when the 'serverTotalProcessingTime' property value has changed. -serverTotalProcessingTimeChanged_ :: Server s a b -> Signal () -serverTotalProcessingTimeChanged_ server = - mapSignal (const ()) (serverTaskProcessed server) - --- | Return the counted total time when the server was locked while trying --- to deliver the output. --- --- The value returned changes discretely and it is usually delayed relative --- to the current simulation time. --- --- See also 'serverTotalOutputWaitTimeChanged' and 'serverTotalOutputWaitTimeChanged_'. -serverTotalOutputWaitTime :: Server s a b -> Event Double -serverTotalOutputWaitTime server = - Event $ \p -> readIORef (serverTotalOutputWaitTimeRef server) - --- | Signal when the 'serverTotalOutputWaitTime' property value has changed. -serverTotalOutputWaitTimeChanged :: Server s a b -> Signal Double -serverTotalOutputWaitTimeChanged server = - mapSignalM (const $ serverTotalOutputWaitTime server) (serverTotalOutputWaitTimeChanged_ server) - --- | Signal when the 'serverTotalOutputWaitTime' property value has changed. -serverTotalOutputWaitTimeChanged_ :: Server s a b -> Signal () -serverTotalOutputWaitTimeChanged_ server = - mapSignal (const ()) (serverOutputProvided server) - --- | Return the statistics of the time when the server was locked while awaiting the input. --- --- The value returned changes discretely and it is usually delayed relative --- to the current simulation time. --- --- See also 'serverInputWaitTimeChanged' and 'serverInputWaitTimeChanged_'. -serverInputWaitTime :: Server s a b -> Event (SamplingStats Double) -serverInputWaitTime server = - Event $ \p -> readIORef (serverInputWaitTimeRef server) - --- | Signal when the 'serverInputWaitTime' property value has changed. -serverInputWaitTimeChanged :: Server s a b -> Signal (SamplingStats Double) -serverInputWaitTimeChanged server = - mapSignalM (const $ serverInputWaitTime server) (serverInputWaitTimeChanged_ server) - --- | Signal when the 'serverInputWaitTime' property value has changed. -serverInputWaitTimeChanged_ :: Server s a b -> Signal () -serverInputWaitTimeChanged_ server = - mapSignal (const ()) (serverInputReceived server) - --- | Return the statistics of the time spent by the server while processing the tasks. --- --- The value returned changes discretely and it is usually delayed relative --- to the current simulation time. --- --- See also 'serverProcessingTimeChanged' and 'serverProcessingTimeChanged_'. -serverProcessingTime :: Server s a b -> Event (SamplingStats Double) -serverProcessingTime server = - Event $ \p -> readIORef (serverProcessingTimeRef server) - --- | Signal when the 'serverProcessingTime' property value has changed. -serverProcessingTimeChanged :: Server s a b -> Signal (SamplingStats Double) -serverProcessingTimeChanged server = - mapSignalM (const $ serverProcessingTime server) (serverProcessingTimeChanged_ server) - --- | Signal when the 'serverProcessingTime' property value has changed. -serverProcessingTimeChanged_ :: Server s a b -> Signal () -serverProcessingTimeChanged_ server = - mapSignal (const ()) (serverTaskProcessed server) - --- | Return the statistics of the time when the server was locked while trying --- to deliver the output. --- --- The value returned changes discretely and it is usually delayed relative --- to the current simulation time. --- --- See also 'serverOutputWaitTimeChanged' and 'serverOutputWaitTimeChanged_'. -serverOutputWaitTime :: Server s a b -> Event (SamplingStats Double) -serverOutputWaitTime server = - Event $ \p -> readIORef (serverOutputWaitTimeRef server) - --- | Signal when the 'serverOutputWaitTime' property value has changed. -serverOutputWaitTimeChanged :: Server s a b -> Signal (SamplingStats Double) -serverOutputWaitTimeChanged server = - mapSignalM (const $ serverOutputWaitTime server) (serverOutputWaitTimeChanged_ server) - --- | Signal when the 'serverOutputWaitTime' property value has changed. -serverOutputWaitTimeChanged_ :: Server s a b -> Signal () -serverOutputWaitTimeChanged_ server = - mapSignal (const ()) (serverOutputProvided server) - --- | It returns the factor changing from 0 to 1, which estimates how often --- the server was awaiting for the next input task. --- --- This factor is calculated as --- --- @ --- totalInputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime) --- @ --- --- As before in this module, the value returned changes discretely and --- it is usually delayed relative to the current simulation time. --- --- See also 'serverInputWaitFactorChanged' and 'serverInputWaitFactorChanged_'. -serverInputWaitFactor :: Server s a b -> Event Double -serverInputWaitFactor server = - Event $ \p -> - do x1 <- readIORef (serverTotalInputWaitTimeRef server) - x2 <- readIORef (serverTotalProcessingTimeRef server) - x3 <- readIORef (serverTotalOutputWaitTimeRef server) - return (x1 / (x1 + x2 + x3)) - --- | Signal when the 'serverInputWaitFactor' property value has changed. -serverInputWaitFactorChanged :: Server s a b -> Signal Double -serverInputWaitFactorChanged server = - mapSignalM (const $ serverInputWaitFactor server) (serverInputWaitFactorChanged_ server) - --- | Signal when the 'serverInputWaitFactor' property value has changed. -serverInputWaitFactorChanged_ :: Server s a b -> Signal () -serverInputWaitFactorChanged_ server = - mapSignal (const ()) (serverInputReceived server) <> - mapSignal (const ()) (serverTaskProcessed server) <> - mapSignal (const ()) (serverOutputProvided server) - --- | It returns the factor changing from 0 to 1, which estimates how often --- the server was busy with direct processing its tasks. --- --- This factor is calculated as --- --- @ --- totalProcessingTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime) --- @ --- --- As before in this module, the value returned changes discretely and --- it is usually delayed relative to the current simulation time. --- --- See also 'serverProcessingFactorChanged' and 'serverProcessingFactorChanged_'. -serverProcessingFactor :: Server s a b -> Event Double -serverProcessingFactor server = - Event $ \p -> - do x1 <- readIORef (serverTotalInputWaitTimeRef server) - x2 <- readIORef (serverTotalProcessingTimeRef server) - x3 <- readIORef (serverTotalOutputWaitTimeRef server) - return (x2 / (x1 + x2 + x3)) - --- | Signal when the 'serverProcessingFactor' property value has changed. -serverProcessingFactorChanged :: Server s a b -> Signal Double -serverProcessingFactorChanged server = - mapSignalM (const $ serverProcessingFactor server) (serverProcessingFactorChanged_ server) - --- | Signal when the 'serverProcessingFactor' property value has changed. -serverProcessingFactorChanged_ :: Server s a b -> Signal () -serverProcessingFactorChanged_ server = - mapSignal (const ()) (serverInputReceived server) <> - mapSignal (const ()) (serverTaskProcessed server) <> - mapSignal (const ()) (serverOutputProvided server) - --- | It returns the factor changing from 0 to 1, which estimates how often --- the server was locked trying to deliver the output after the task is finished. --- --- This factor is calculated as --- --- @ --- totalOutputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime) --- @ --- --- As before in this module, the value returned changes discretely and --- it is usually delayed relative to the current simulation time. --- --- See also 'serverOutputWaitFactorChanged' and 'serverOutputWaitFactorChanged_'. -serverOutputWaitFactor :: Server s a b -> Event Double -serverOutputWaitFactor server = - Event $ \p -> - do x1 <- readIORef (serverTotalInputWaitTimeRef server) - x2 <- readIORef (serverTotalProcessingTimeRef server) - x3 <- readIORef (serverTotalOutputWaitTimeRef server) - return (x3 / (x1 + x2 + x3)) - --- | Signal when the 'serverOutputWaitFactor' property value has changed. -serverOutputWaitFactorChanged :: Server s a b -> Signal Double -serverOutputWaitFactorChanged server = - mapSignalM (const $ serverOutputWaitFactor server) (serverOutputWaitFactorChanged_ server) - --- | Signal when the 'serverOutputWaitFactor' property value has changed. -serverOutputWaitFactorChanged_ :: Server s a b -> Signal () -serverOutputWaitFactorChanged_ server = - mapSignal (const ()) (serverInputReceived server) <> - mapSignal (const ()) (serverTaskProcessed server) <> - mapSignal (const ()) (serverOutputProvided server) - --- | Raised when the server receives a new input task. -serverInputReceived :: Server s a b -> Signal a -serverInputReceived = publishSignal . serverInputReceivedSource - --- | Raised when the server has just processed the task. -serverTaskProcessed :: Server s a b -> Signal (a, b) -serverTaskProcessed = publishSignal . serverTaskProcessedSource - --- | Raised when the server has just delivered the output. -serverOutputProvided :: Server s a b -> Signal (a, b) -serverOutputProvided = publishSignal . serverOutputProvidedSource - --- | Signal whenever any property of the server changes. -serverChanged_ :: Server s a b -> Signal () -serverChanged_ server = - mapSignal (const ()) (serverInputReceived server) <> - mapSignal (const ()) (serverTaskProcessed server) <> - mapSignal (const ()) (serverOutputProvided server) - --- | Return the summary for the server with desciption of its --- properties and activities using the specified indent. -serverSummary :: Server s a b -> Int -> Event ShowS -serverSummary server indent = - Event $ \p -> - do tx1 <- readIORef (serverTotalInputWaitTimeRef server) - tx2 <- readIORef (serverTotalProcessingTimeRef server) - tx3 <- readIORef (serverTotalOutputWaitTimeRef server) - let xf1 = tx1 / (tx1 + tx2 + tx3) - xf2 = tx2 / (tx1 + tx2 + tx3) - xf3 = tx3 / (tx1 + tx2 + tx3) - xs1 <- readIORef (serverInputWaitTimeRef server) - xs2 <- readIORef (serverProcessingTimeRef server) - xs3 <- readIORef (serverOutputWaitTimeRef server) - let tab = replicate indent ' ' - return $ - showString tab . - showString "total input wait time (locked while awaiting the input) = " . shows tx1 . - showString "\n" . - showString tab . - showString "total processing time = " . shows tx2 . - showString "\n" . - showString tab . - showString "total output wait time (locked while delivering the output) = " . shows tx3 . - showString "\n\n" . - showString tab . - showString "input wait factor (from 0 to 1) = " . shows xf1 . - showString "\n" . - showString tab . - showString "processing factor (from 0 to 1) = " . shows xf2 . - showString "\n" . - showString tab . - showString "output wait factor (from 0 to 1) = " . shows xf3 . - showString "\n\n" . - showString tab . - showString "input wait time (locked while awaiting the input):\n\n" . - samplingStatsSummary xs1 (2 + indent) . - showString "\n\n" . - showString tab . - showString "processing time:\n\n" . - samplingStatsSummary xs2 (2 + indent) . - showString "\n\n" . - showString tab . - showString "output wait time (locked while delivering the output):\n\n" . - samplingStatsSummary xs3 (2 + indent) + +-- | +-- Module : Simulation.Aivika.Server +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It models the server that prodives a service. +module Simulation.Aivika.Server + (-- * Server + Server, + newServer, + newStateServer, + -- * Processing + serverProcessor, + -- * Server Properties and Activities + serverInitState, + serverState, + serverTotalInputWaitTime, + serverTotalProcessingTime, + serverTotalOutputWaitTime, + serverInputWaitTime, + serverProcessingTime, + serverOutputWaitTime, + serverInputWaitFactor, + serverProcessingFactor, + serverOutputWaitFactor, + -- * Summary + serverSummary, + -- * Derived Signals for Properties + serverStateChanged, + serverStateChanged_, + serverTotalInputWaitTimeChanged, + serverTotalInputWaitTimeChanged_, + serverTotalProcessingTimeChanged, + serverTotalProcessingTimeChanged_, + serverTotalOutputWaitTimeChanged, + serverTotalOutputWaitTimeChanged_, + serverInputWaitTimeChanged, + serverInputWaitTimeChanged_, + serverProcessingTimeChanged, + serverProcessingTimeChanged_, + serverOutputWaitTimeChanged, + serverOutputWaitTimeChanged_, + serverInputWaitFactorChanged, + serverInputWaitFactorChanged_, + serverProcessingFactorChanged, + serverProcessingFactorChanged_, + serverOutputWaitFactorChanged, + serverOutputWaitFactorChanged_, + -- * Basic Signals + serverInputReceived, + serverTaskProcessed, + serverOutputProvided, + -- * Overall Signal + serverChanged_) where + +import Data.IORef +import Data.Monoid + +import Control.Monad.Trans +import Control.Arrow + +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Internal.Event +import Simulation.Aivika.Internal.Signal +import Simulation.Aivika.Resource +import Simulation.Aivika.Cont +import Simulation.Aivika.Process +import Simulation.Aivika.Processor +import Simulation.Aivika.Stream +import Simulation.Aivika.Statistics + +-- | It models a server that takes @a@ and provides @b@ having state @s@. +data Server s a b = + Server { serverInitState :: s, + -- ^ The initial state of the server. + serverStateRef :: IORef s, + -- ^ The current state of the server. + serverProcess :: s -> a -> Process (s, b), + -- ^ Provide @b@ by specified @a@. + serverTotalInputWaitTimeRef :: IORef Double, + -- ^ The counted total time spent in awating the input. + serverTotalProcessingTimeRef :: IORef Double, + -- ^ The counted total time spent to process the input and prepare the output. + serverTotalOutputWaitTimeRef :: IORef Double, + -- ^ The counted total time spent for delivering the output. + serverInputWaitTimeRef :: IORef (SamplingStats Double), + -- ^ The statistics for the time spent in awaiting the input. + serverProcessingTimeRef :: IORef (SamplingStats Double), + -- ^ The statistics for the time spent to process the input and prepare the output. + serverOutputWaitTimeRef :: IORef (SamplingStats Double), + -- ^ The statistics for the time spent for delivering the output. + serverInputReceivedSource :: SignalSource a, + -- ^ A signal raised when the server recieves a new input to process. + serverTaskProcessedSource :: SignalSource (a, b), + -- ^ A signal raised when the input is processed and + -- the output is prepared for deliverying. + serverOutputProvidedSource :: SignalSource (a, b) + -- ^ A signal raised when the server has supplied the output. + } + +-- | Create a new server that can provide output @b@ by input @a@. +-- Also it returns the corresponded processor that being applied +-- updates the server state. +newServer :: (a -> Process b) + -- ^ provide an output by the specified input + -> Simulation (Server () a b) +newServer provide = + flip newStateServer () $ \s a -> + do b <- provide a + return (s, b) + +-- | Create a new server that can provide output @b@ by input @a@ +-- starting from state @s@. Also it returns the corresponded processor +-- that being applied updates the server state. +newStateServer :: (s -> a -> Process (s, b)) + -- ^ provide a new state and output by the specified + -- old state and input + -> s + -- ^ the initial state + -> Simulation (Server s a b) +newStateServer provide state = + do r0 <- liftIO $ newIORef state + r1 <- liftIO $ newIORef 0 + r2 <- liftIO $ newIORef 0 + r3 <- liftIO $ newIORef 0 + r4 <- liftIO $ newIORef emptySamplingStats + r5 <- liftIO $ newIORef emptySamplingStats + r6 <- liftIO $ newIORef emptySamplingStats + s1 <- newSignalSource + s2 <- newSignalSource + s3 <- newSignalSource + let server = Server { serverInitState = state, + serverStateRef = r0, + serverProcess = provide, + serverTotalInputWaitTimeRef = r1, + serverTotalProcessingTimeRef = r2, + serverTotalOutputWaitTimeRef = r3, + serverInputWaitTimeRef = r4, + serverProcessingTimeRef = r5, + serverOutputWaitTimeRef = r6, + serverInputReceivedSource = s1, + serverTaskProcessedSource = s2, + serverOutputProvidedSource = s3 } + return server + +-- | Return a processor for the specified server. +-- +-- The processor updates the internal state of the server. The usual case is when +-- the processor is applied only once in a chain of data processing. Otherwise; +-- every time the processor is used, the state of the server changes. Sometimes +-- it can be indeed useful if you want to aggregate the statistics for different +-- servers simultaneously, but it would be more preferable to avoid this. +-- +-- If you connect different server processors returned by this function in a chain +-- with help of '>>>' or other category combinator then this chain will act as one +-- whole, where the first server will take a new task only after the last server +-- finishes its current task and requests for the next one from the previous processor +-- in the chain. This is not always that thing you might need. +-- +-- To model a sequence of the server processors working independently, you +-- should separate them with help of the 'prefetchProcessor' that plays a role +-- of a small one-place buffer in that case. +-- +-- The queue processors usually have the prefetching capabilities per se, where +-- the items are already stored in the queue. Therefore, the server processor +-- should not be prefetched if it is connected directly with the queue processor. +serverProcessor :: Server s a b -> Processor a b +serverProcessor server = + Processor $ \xs -> loop (serverInitState server) Nothing xs + where + loop s r xs = + Cons $ + do t0 <- liftDynamics time + liftEvent $ + case r of + Nothing -> return () + Just (t', a', b') -> + do liftIO $ + do modifyIORef' (serverTotalOutputWaitTimeRef server) (+ (t0 - t')) + modifyIORef' (serverOutputWaitTimeRef server) $ + addSamplingStats (t0 - t') + triggerSignal (serverOutputProvidedSource server) (a', b') + -- get input + (a, xs') <- runStream xs + t1 <- liftDynamics time + liftEvent $ + do liftIO $ + do modifyIORef' (serverTotalInputWaitTimeRef server) (+ (t1 - t0)) + modifyIORef' (serverInputWaitTimeRef server) $ + addSamplingStats (t1 - t0) + triggerSignal (serverInputReceivedSource server) a + -- provide the service + (s', b) <- serverProcess server s a + t2 <- liftDynamics time + liftEvent $ + do liftIO $ + do writeIORef (serverStateRef server) $! s' + modifyIORef' (serverTotalProcessingTimeRef server) (+ (t2 - t1)) + modifyIORef' (serverProcessingTimeRef server) $ + addSamplingStats (t2 - t1) + triggerSignal (serverTaskProcessedSource server) (a, b) + return (b, loop s' (Just (t2, a, b)) xs') + +-- | Return the current state of the server. +-- +-- See also 'serverStateChanged' and 'serverStateChanged_'. +serverState :: Server s a b -> Event s +serverState server = + Event $ \p -> readIORef (serverStateRef server) + +-- | Signal when the 'serverState' property value has changed. +serverStateChanged :: Server s a b -> Signal s +serverStateChanged server = + mapSignalM (const $ serverState server) (serverStateChanged_ server) + +-- | Signal when the 'serverState' property value has changed. +serverStateChanged_ :: Server s a b -> Signal () +serverStateChanged_ server = + mapSignal (const ()) (serverTaskProcessed server) + +-- | Return the counted total time when the server was locked while awaiting the input. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverTotalInputWaitTimeChanged' and 'serverTotalInputWaitTimeChanged_'. +serverTotalInputWaitTime :: Server s a b -> Event Double +serverTotalInputWaitTime server = + Event $ \p -> readIORef (serverTotalInputWaitTimeRef server) + +-- | Signal when the 'serverTotalInputWaitTime' property value has changed. +serverTotalInputWaitTimeChanged :: Server s a b -> Signal Double +serverTotalInputWaitTimeChanged server = + mapSignalM (const $ serverTotalInputWaitTime server) (serverTotalInputWaitTimeChanged_ server) + +-- | Signal when the 'serverTotalInputWaitTime' property value has changed. +serverTotalInputWaitTimeChanged_ :: Server s a b -> Signal () +serverTotalInputWaitTimeChanged_ server = + mapSignal (const ()) (serverInputReceived server) + +-- | Return the counted total time spent by the server while processing the tasks. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverTotalProcessingTimeChanged' and 'serverTotalProcessingTimeChanged_'. +serverTotalProcessingTime :: Server s a b -> Event Double +serverTotalProcessingTime server = + Event $ \p -> readIORef (serverTotalProcessingTimeRef server) + +-- | Signal when the 'serverTotalProcessingTime' property value has changed. +serverTotalProcessingTimeChanged :: Server s a b -> Signal Double +serverTotalProcessingTimeChanged server = + mapSignalM (const $ serverTotalProcessingTime server) (serverTotalProcessingTimeChanged_ server) + +-- | Signal when the 'serverTotalProcessingTime' property value has changed. +serverTotalProcessingTimeChanged_ :: Server s a b -> Signal () +serverTotalProcessingTimeChanged_ server = + mapSignal (const ()) (serverTaskProcessed server) + +-- | Return the counted total time when the server was locked while trying +-- to deliver the output. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverTotalOutputWaitTimeChanged' and 'serverTotalOutputWaitTimeChanged_'. +serverTotalOutputWaitTime :: Server s a b -> Event Double +serverTotalOutputWaitTime server = + Event $ \p -> readIORef (serverTotalOutputWaitTimeRef server) + +-- | Signal when the 'serverTotalOutputWaitTime' property value has changed. +serverTotalOutputWaitTimeChanged :: Server s a b -> Signal Double +serverTotalOutputWaitTimeChanged server = + mapSignalM (const $ serverTotalOutputWaitTime server) (serverTotalOutputWaitTimeChanged_ server) + +-- | Signal when the 'serverTotalOutputWaitTime' property value has changed. +serverTotalOutputWaitTimeChanged_ :: Server s a b -> Signal () +serverTotalOutputWaitTimeChanged_ server = + mapSignal (const ()) (serverOutputProvided server) + +-- | Return the statistics of the time when the server was locked while awaiting the input. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverInputWaitTimeChanged' and 'serverInputWaitTimeChanged_'. +serverInputWaitTime :: Server s a b -> Event (SamplingStats Double) +serverInputWaitTime server = + Event $ \p -> readIORef (serverInputWaitTimeRef server) + +-- | Signal when the 'serverInputWaitTime' property value has changed. +serverInputWaitTimeChanged :: Server s a b -> Signal (SamplingStats Double) +serverInputWaitTimeChanged server = + mapSignalM (const $ serverInputWaitTime server) (serverInputWaitTimeChanged_ server) + +-- | Signal when the 'serverInputWaitTime' property value has changed. +serverInputWaitTimeChanged_ :: Server s a b -> Signal () +serverInputWaitTimeChanged_ server = + mapSignal (const ()) (serverInputReceived server) + +-- | Return the statistics of the time spent by the server while processing the tasks. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverProcessingTimeChanged' and 'serverProcessingTimeChanged_'. +serverProcessingTime :: Server s a b -> Event (SamplingStats Double) +serverProcessingTime server = + Event $ \p -> readIORef (serverProcessingTimeRef server) + +-- | Signal when the 'serverProcessingTime' property value has changed. +serverProcessingTimeChanged :: Server s a b -> Signal (SamplingStats Double) +serverProcessingTimeChanged server = + mapSignalM (const $ serverProcessingTime server) (serverProcessingTimeChanged_ server) + +-- | Signal when the 'serverProcessingTime' property value has changed. +serverProcessingTimeChanged_ :: Server s a b -> Signal () +serverProcessingTimeChanged_ server = + mapSignal (const ()) (serverTaskProcessed server) + +-- | Return the statistics of the time when the server was locked while trying +-- to deliver the output. +-- +-- The value returned changes discretely and it is usually delayed relative +-- to the current simulation time. +-- +-- See also 'serverOutputWaitTimeChanged' and 'serverOutputWaitTimeChanged_'. +serverOutputWaitTime :: Server s a b -> Event (SamplingStats Double) +serverOutputWaitTime server = + Event $ \p -> readIORef (serverOutputWaitTimeRef server) + +-- | Signal when the 'serverOutputWaitTime' property value has changed. +serverOutputWaitTimeChanged :: Server s a b -> Signal (SamplingStats Double) +serverOutputWaitTimeChanged server = + mapSignalM (const $ serverOutputWaitTime server) (serverOutputWaitTimeChanged_ server) + +-- | Signal when the 'serverOutputWaitTime' property value has changed. +serverOutputWaitTimeChanged_ :: Server s a b -> Signal () +serverOutputWaitTimeChanged_ server = + mapSignal (const ()) (serverOutputProvided server) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the server was awaiting for the next input task. +-- +-- This factor is calculated as +-- +-- @ +-- totalInputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime) +-- @ +-- +-- As before in this module, the value returned changes discretely and +-- it is usually delayed relative to the current simulation time. +-- +-- See also 'serverInputWaitFactorChanged' and 'serverInputWaitFactorChanged_'. +serverInputWaitFactor :: Server s a b -> Event Double +serverInputWaitFactor server = + Event $ \p -> + do x1 <- readIORef (serverTotalInputWaitTimeRef server) + x2 <- readIORef (serverTotalProcessingTimeRef server) + x3 <- readIORef (serverTotalOutputWaitTimeRef server) + return (x1 / (x1 + x2 + x3)) + +-- | Signal when the 'serverInputWaitFactor' property value has changed. +serverInputWaitFactorChanged :: Server s a b -> Signal Double +serverInputWaitFactorChanged server = + mapSignalM (const $ serverInputWaitFactor server) (serverInputWaitFactorChanged_ server) + +-- | Signal when the 'serverInputWaitFactor' property value has changed. +serverInputWaitFactorChanged_ :: Server s a b -> Signal () +serverInputWaitFactorChanged_ server = + mapSignal (const ()) (serverInputReceived server) <> + mapSignal (const ()) (serverTaskProcessed server) <> + mapSignal (const ()) (serverOutputProvided server) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the server was busy with direct processing its tasks. +-- +-- This factor is calculated as +-- +-- @ +-- totalProcessingTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime) +-- @ +-- +-- As before in this module, the value returned changes discretely and +-- it is usually delayed relative to the current simulation time. +-- +-- See also 'serverProcessingFactorChanged' and 'serverProcessingFactorChanged_'. +serverProcessingFactor :: Server s a b -> Event Double +serverProcessingFactor server = + Event $ \p -> + do x1 <- readIORef (serverTotalInputWaitTimeRef server) + x2 <- readIORef (serverTotalProcessingTimeRef server) + x3 <- readIORef (serverTotalOutputWaitTimeRef server) + return (x2 / (x1 + x2 + x3)) + +-- | Signal when the 'serverProcessingFactor' property value has changed. +serverProcessingFactorChanged :: Server s a b -> Signal Double +serverProcessingFactorChanged server = + mapSignalM (const $ serverProcessingFactor server) (serverProcessingFactorChanged_ server) + +-- | Signal when the 'serverProcessingFactor' property value has changed. +serverProcessingFactorChanged_ :: Server s a b -> Signal () +serverProcessingFactorChanged_ server = + mapSignal (const ()) (serverInputReceived server) <> + mapSignal (const ()) (serverTaskProcessed server) <> + mapSignal (const ()) (serverOutputProvided server) + +-- | It returns the factor changing from 0 to 1, which estimates how often +-- the server was locked trying to deliver the output after the task is finished. +-- +-- This factor is calculated as +-- +-- @ +-- totalOutputWaitTime \/ (totalInputWaitTime + totalProcessingTime + totalOutputWaitTime) +-- @ +-- +-- As before in this module, the value returned changes discretely and +-- it is usually delayed relative to the current simulation time. +-- +-- See also 'serverOutputWaitFactorChanged' and 'serverOutputWaitFactorChanged_'. +serverOutputWaitFactor :: Server s a b -> Event Double +serverOutputWaitFactor server = + Event $ \p -> + do x1 <- readIORef (serverTotalInputWaitTimeRef server) + x2 <- readIORef (serverTotalProcessingTimeRef server) + x3 <- readIORef (serverTotalOutputWaitTimeRef server) + return (x3 / (x1 + x2 + x3)) + +-- | Signal when the 'serverOutputWaitFactor' property value has changed. +serverOutputWaitFactorChanged :: Server s a b -> Signal Double +serverOutputWaitFactorChanged server = + mapSignalM (const $ serverOutputWaitFactor server) (serverOutputWaitFactorChanged_ server) + +-- | Signal when the 'serverOutputWaitFactor' property value has changed. +serverOutputWaitFactorChanged_ :: Server s a b -> Signal () +serverOutputWaitFactorChanged_ server = + mapSignal (const ()) (serverInputReceived server) <> + mapSignal (const ()) (serverTaskProcessed server) <> + mapSignal (const ()) (serverOutputProvided server) + +-- | Raised when the server receives a new input task. +serverInputReceived :: Server s a b -> Signal a +serverInputReceived = publishSignal . serverInputReceivedSource + +-- | Raised when the server has just processed the task. +serverTaskProcessed :: Server s a b -> Signal (a, b) +serverTaskProcessed = publishSignal . serverTaskProcessedSource + +-- | Raised when the server has just delivered the output. +serverOutputProvided :: Server s a b -> Signal (a, b) +serverOutputProvided = publishSignal . serverOutputProvidedSource + +-- | Signal whenever any property of the server changes. +serverChanged_ :: Server s a b -> Signal () +serverChanged_ server = + mapSignal (const ()) (serverInputReceived server) <> + mapSignal (const ()) (serverTaskProcessed server) <> + mapSignal (const ()) (serverOutputProvided server) + +-- | Return the summary for the server with desciption of its +-- properties and activities using the specified indent. +serverSummary :: Server s a b -> Int -> Event ShowS +serverSummary server indent = + Event $ \p -> + do tx1 <- readIORef (serverTotalInputWaitTimeRef server) + tx2 <- readIORef (serverTotalProcessingTimeRef server) + tx3 <- readIORef (serverTotalOutputWaitTimeRef server) + let xf1 = tx1 / (tx1 + tx2 + tx3) + xf2 = tx2 / (tx1 + tx2 + tx3) + xf3 = tx3 / (tx1 + tx2 + tx3) + xs1 <- readIORef (serverInputWaitTimeRef server) + xs2 <- readIORef (serverProcessingTimeRef server) + xs3 <- readIORef (serverOutputWaitTimeRef server) + let tab = replicate indent ' ' + return $ + showString tab . + showString "total input wait time (locked while awaiting the input) = " . shows tx1 . + showString "\n" . + showString tab . + showString "total processing time = " . shows tx2 . + showString "\n" . + showString tab . + showString "total output wait time (locked while delivering the output) = " . shows tx3 . + showString "\n\n" . + showString tab . + showString "input wait factor (from 0 to 1) = " . shows xf1 . + showString "\n" . + showString tab . + showString "processing factor (from 0 to 1) = " . shows xf2 . + showString "\n" . + showString tab . + showString "output wait factor (from 0 to 1) = " . shows xf3 . + showString "\n\n" . + showString tab . + showString "input wait time (locked while awaiting the input):\n\n" . + samplingStatsSummary xs1 (2 + indent) . + showString "\n\n" . + showString tab . + showString "processing time:\n\n" . + samplingStatsSummary xs2 (2 + indent) . + showString "\n\n" . + showString tab . + showString "output wait time (locked while delivering the output):\n\n" . + samplingStatsSummary xs3 (2 + indent) diff --git a/Simulation/Aivika/Signal.hs b/Simulation/Aivika/Signal.hs --- a/Simulation/Aivika/Signal.hs +++ b/Simulation/Aivika/Signal.hs @@ -1,53 +1,53 @@ - --- | --- Module : Simulation.Aivika.Signal --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines the signal which we can subscribe handlers to. --- These handlers can be disposed. The signal is triggered in the --- current time point actuating the corresponded computations from --- the handlers. --- -module Simulation.Aivika.Signal - (-- * Handling and Triggering Signal - Signal(..), - handleSignal_, - SignalSource, - newSignalSource, - publishSignal, - triggerSignal, - -- * Useful Combinators - mapSignal, - mapSignalM, - apSignal, - filterSignal, - filterSignalM, - emptySignal, - merge2Signals, - merge3Signals, - merge4Signals, - merge5Signals, - -- * Signal Arriving - arrivalSignal, - -- * Creating Signal in Time Points - newSignalInTimes, - newSignalInIntegTimes, - newSignalInStartTime, - newSignalInStopTime, - -- * Signal History - SignalHistory, - signalHistorySignal, - newSignalHistory, - newSignalHistoryStartingWith, - readSignalHistory, - -- * Signalable Computations - Signalable(..), - signalableChanged, - emptySignalable, - appendSignalable) where - -import Simulation.Aivika.Internal.Signal + +-- | +-- Module : Simulation.Aivika.Signal +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the signal which we can subscribe handlers to. +-- These handlers can be disposed. The signal is triggered in the +-- current time point actuating the corresponded computations from +-- the handlers. +-- +module Simulation.Aivika.Signal + (-- * Handling and Triggering Signal + Signal(..), + handleSignal_, + SignalSource, + newSignalSource, + publishSignal, + triggerSignal, + -- * Useful Combinators + mapSignal, + mapSignalM, + apSignal, + filterSignal, + filterSignalM, + emptySignal, + merge2Signals, + merge3Signals, + merge4Signals, + merge5Signals, + -- * Signal Arriving + arrivalSignal, + -- * Creating Signal in Time Points + newSignalInTimes, + newSignalInIntegTimes, + newSignalInStartTime, + newSignalInStopTime, + -- * Signal History + SignalHistory, + signalHistorySignal, + newSignalHistory, + newSignalHistoryStartingWith, + readSignalHistory, + -- * Signalable Computations + Signalable(..), + signalableChanged, + emptySignalable, + appendSignalable) where + +import Simulation.Aivika.Internal.Signal diff --git a/Simulation/Aivika/Simulation.hs b/Simulation/Aivika/Simulation.hs --- a/Simulation/Aivika/Simulation.hs +++ b/Simulation/Aivika/Simulation.hs @@ -1,25 +1,25 @@ - --- | --- Module : Simulation.Aivika.Simulation --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines the 'Simulation' monad that represents a simulation run. --- -module Simulation.Aivika.Simulation - (-- * Simulation - Simulation, - SimulationLift(..), - runSimulation, - runSimulations, - -- * Error Handling - catchSimulation, - finallySimulation, - throwSimulation, - -- * Memoization - memoSimulation) where - -import Simulation.Aivika.Internal.Simulation + +-- | +-- Module : Simulation.Aivika.Simulation +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines the 'Simulation' monad that represents a simulation run. +-- +module Simulation.Aivika.Simulation + (-- * Simulation + Simulation, + SimulationLift(..), + runSimulation, + runSimulations, + -- * Error Handling + catchSimulation, + finallySimulation, + throwSimulation, + -- * Memoization + memoSimulation) where + +import Simulation.Aivika.Internal.Simulation diff --git a/Simulation/Aivika/Specs.hs b/Simulation/Aivika/Specs.hs --- a/Simulation/Aivika/Specs.hs +++ b/Simulation/Aivika/Specs.hs @@ -1,25 +1,25 @@ - --- | --- Module : Simulation.Aivika.Specs --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It defines the simulation specs and functions for this data type. -module Simulation.Aivika.Specs - (-- * Simulation Specs - Specs(..), - Method(..), - -- * Auxiliary Functions - basicTime, - integIterationBnds, - integIterationHiBnd, - integIterationLoBnd, - integPhaseBnds, - integPhaseHiBnd, - integPhaseLoBnd, - integTimes) where - -import Simulation.Aivika.Internal.Specs + +-- | +-- Module : Simulation.Aivika.Specs +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It defines the simulation specs and functions for this data type. +module Simulation.Aivika.Specs + (-- * Simulation Specs + Specs(..), + Method(..), + -- * Auxiliary Functions + basicTime, + integIterationBnds, + integIterationHiBnd, + integIterationLoBnd, + integPhaseBnds, + integPhaseHiBnd, + integPhaseLoBnd, + integTimes) where + +import Simulation.Aivika.Internal.Specs diff --git a/Simulation/Aivika/Statistics.hs b/Simulation/Aivika/Statistics.hs --- a/Simulation/Aivika/Statistics.hs +++ b/Simulation/Aivika/Statistics.hs @@ -1,417 +1,417 @@ - --- | --- Module : Simulation.Aivika.Statistics --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- Represents statistics. --- - -module Simulation.Aivika.Statistics - (-- * Simple Statistics - SamplingStats(..), - SamplingData(..), - combineSamplingStatsEither, - samplingStatsVariance, - samplingStatsDeviation, - samplingStatsSummary, - returnSamplingStats, - listSamplingStats, - fromIntSamplingStats, - -- * Timing Statistics - TimingStats(..), - TimingData(..), - timingStatsDeviation, - timingStatsSummary, - returnTimingStats, - fromIntTimingStats) where - -import Data.Monoid - --- | Defines data types that can be converted to 'Double'. -class Ord a => ConvertableToDouble a where - - -- | Convert the value to 'Double'. - convertToDouble :: a -> Double - -instance ConvertableToDouble Double where - convertToDouble = id - -instance ConvertableToDouble Int where - convertToDouble = fromIntegral - --- | Describes when the statistics consists of only samples --- not bound to the simulation time. -data SamplingStats a = - SamplingStats { samplingStatsCount :: !Int, - -- ^ The total number of samples. - samplingStatsMin :: !a, - -- ^ The minimum value among the samples. - samplingStatsMax :: !a, - -- ^ The maximum value among the samples. - samplingStatsMean :: !Double, - -- ^ The average value. - samplingStatsMean2 :: !Double - -- ^ The average square value. - } - deriving (Eq, Ord) - --- | Specifies data type from which values we can gather the statistics. -class SamplingData a where - - -- | An empty statistics that has no samples. - emptySamplingStats :: SamplingStats a - - -- | Add a new sample to the statistics. - addSamplingStats :: a -> SamplingStats a -> SamplingStats a - - -- | Combine two statistics. - combineSamplingStats :: SamplingStats a -> SamplingStats a -> SamplingStats a - -instance SamplingData a => Monoid (SamplingStats a) where - - mempty = emptySamplingStats - - mappend = combineSamplingStats - -instance SamplingData Double where - - emptySamplingStats = - SamplingStats { samplingStatsCount = 0, - samplingStatsMin = 1 / 0, - samplingStatsMax = (-1) / 0, - samplingStatsMean = 0 / 0, - samplingStatsMean2 = 0 / 0 } - - addSamplingStats = addSamplingStatsGeneric - - combineSamplingStats = combineSamplingStatsGeneric - -instance SamplingData Int where - - emptySamplingStats = - SamplingStats { samplingStatsCount = 0, - samplingStatsMin = maxBound, - samplingStatsMax = minBound, - samplingStatsMean = 0 / 0, - samplingStatsMean2 = 0 / 0 } - - addSamplingStats = addSamplingStatsGeneric - - combineSamplingStats = combineSamplingStatsGeneric - -addSamplingStatsGeneric :: ConvertableToDouble a => a -> SamplingStats a -> SamplingStats a -addSamplingStatsGeneric a stats - | isNaN x = stats - | count == 1 = SamplingStats { samplingStatsCount = 1, - samplingStatsMin = a, - samplingStatsMax = a, - samplingStatsMean = x, - samplingStatsMean2 = x * x } - | otherwise = SamplingStats { samplingStatsCount = count, - samplingStatsMin = minX, - samplingStatsMax = maxX, - samplingStatsMean = meanX, - samplingStatsMean2 = meanX2 } - where count = 1 + samplingStatsCount stats - minX = a `seq` min a (samplingStatsMin stats) - maxX = a `seq` max a (samplingStatsMax stats) - meanX = k1 * x + k2 * samplingStatsMean stats - meanX2 = k1 * x * x + k2 * samplingStatsMean2 stats - n = fromIntegral count - x = convertToDouble a - k1 = 1.0 / n - k2 = (n - 1.0) / n - -combineSamplingStatsGeneric :: ConvertableToDouble a => - SamplingStats a -> SamplingStats a -> SamplingStats a -combineSamplingStatsGeneric stats1 stats2 - | c1 == 0 = stats2 - | c2 == 0 = stats1 - | otherwise = SamplingStats { samplingStatsCount = c, - samplingStatsMin = minZ, - samplingStatsMax = maxZ, - samplingStatsMean = meanZ, - samplingStatsMean2 = meanZ2 } - where c1 = samplingStatsCount stats1 - c2 = samplingStatsCount stats2 - c = c1 + c2 - n1 = fromIntegral c1 - n2 = fromIntegral c2 - n = n1 + n2 - minX = samplingStatsMin stats1 - minY = samplingStatsMin stats2 - minZ = min minX minY - maxX = samplingStatsMax stats1 - maxY = samplingStatsMax stats2 - maxZ = max maxX maxY - meanX = samplingStatsMean stats1 - meanY = samplingStatsMean stats2 - meanZ = k1 * meanX + k2 * meanY - meanX2 = samplingStatsMean2 stats1 - meanY2 = samplingStatsMean2 stats2 - meanZ2 = k1 * meanX2 + k2 * meanY2 - k1 = n1 / n - k2 = n2 / n - --- | If allows combining statistics more efficiently if we know that the first argument can be a scalar. -combineSamplingStatsEither :: SamplingData a => Either a (SamplingStats a) -> SamplingStats a -> SamplingStats a -combineSamplingStatsEither (Left a) stats2 = addSamplingStats a stats2 -combineSamplingStatsEither (Right stats1) stats2 = combineSamplingStats stats1 stats2 - --- | Return the variance. -samplingStatsVariance :: SamplingStats a -> Double -samplingStatsVariance stats - | count == 1 = 0 - | otherwise = (meanX2 - meanX * meanX) * (n / (n - 1)) - where count = samplingStatsCount stats - meanX = samplingStatsMean stats - meanX2 = samplingStatsMean2 stats - n = fromIntegral count - --- | Return the deviation. -samplingStatsDeviation :: SamplingStats a -> Double -samplingStatsDeviation = sqrt . samplingStatsVariance - --- | Return the statistics by a single sample. -returnSamplingStats :: SamplingData a => a -> SamplingStats a -returnSamplingStats x = addSamplingStats x emptySamplingStats - --- | Create the statistics by the specified list of data. -listSamplingStats :: SamplingData a => [a] -> SamplingStats a -listSamplingStats = foldr addSamplingStats emptySamplingStats - --- | Convert the statistics from integer to double values. -fromIntSamplingStats :: SamplingStats Int -> SamplingStats Double -fromIntSamplingStats stats = - stats { samplingStatsMin = fromIntegral $ samplingStatsMin stats, - samplingStatsMax = fromIntegral $ samplingStatsMax stats } - --- | Show the summary of the statistics. -showSamplingStats :: (Show a) => SamplingStats a -> ShowS -showSamplingStats stats = - showString "{ count = " . shows (samplingStatsCount stats) . - showString ", mean = " . shows (samplingStatsMean stats) . - showString ", std = " . shows (samplingStatsDeviation stats) . - showString ", min = " . shows (samplingStatsMin stats) . - showString ", max = " . shows (samplingStatsMax stats) . - showString " }" - -instance Show a => Show (SamplingStats a) where - showsPrec prec = showSamplingStats - --- | Show the summary of the statistics using the specified indent. -samplingStatsSummary :: (Show a) => SamplingStats a -> Int -> ShowS -samplingStatsSummary stats indent = - let tab = replicate indent ' ' - in showString tab . - showString "count = " . shows (samplingStatsCount stats) . - showString "\n" . - showString tab . - showString "mean = " . shows (samplingStatsMean stats) . - showString "\n" . - showString tab . - showString "std = " . shows (samplingStatsDeviation stats) . - showString "\n" . - showString tab . - showString "min = " . shows (samplingStatsMin stats) . - showString "\n" . - showString tab . - showString "max = " . shows (samplingStatsMax stats) - --- | This is the timing statistics where data are bound to the time. -data TimingStats a = - TimingStats { timingStatsCount :: !Int, - -- ^ Return the number of samples. - timingStatsMin :: !a, - -- ^ Return the minimum value. - timingStatsMax :: !a, - -- ^ Return the maximum value. - timingStatsMinTime :: !Double, - -- ^ Return the time at which the minimum is attained. - timingStatsMaxTime :: !Double, - -- ^ Return the time at which the maximum is attained. - timingStatsStartTime :: !Double, - -- ^ Return the start time of sampling. - timingStatsLastTime :: !Double, - -- ^ Return the last time of sampling. - timingStatsSum :: !Double, - -- ^ Return the sum of values. - timingStatsSum2 :: !Double - -- ^ Return the sum of square values. - } deriving (Eq, Ord) - --- | Defines the data type from which values we can gather the timing statistics. -class TimingData a where - - -- | An empty statistics that has no samples. - emptyTimingStats :: TimingStats a - - -- | Add a sample with the specified time to the statistics. - addTimingStats :: Double -> a -> TimingStats a -> TimingStats a - - -- | Return the average value. - timingStatsMean :: TimingStats a -> Double - - -- | Return the variance. - timingStatsVariance :: TimingStats a -> Double - -instance TimingData Double where - - emptyTimingStats = - TimingStats { timingStatsCount = 0, - timingStatsMin = 1 / 0, - timingStatsMax = (-1) / 0, - timingStatsMinTime = 1 / 0, - timingStatsMaxTime = (-1) / 0, - timingStatsStartTime = 1 / 0, - timingStatsLastTime = (-1) / 0, - timingStatsSum = 0 / 0, - timingStatsSum2 = 0 / 0 } - - addTimingStats = addTimingStatsGeneric - timingStatsMean = timingStatsMeanGeneric - timingStatsVariance = timingStatsVarianceGeneric - -instance TimingData Int where - - emptyTimingStats = - TimingStats { timingStatsCount = 0, - timingStatsMin = maxBound, - timingStatsMax = minBound, - timingStatsMinTime = 1 / 0, - timingStatsMaxTime = (-1) / 0, - timingStatsStartTime = 1 / 0, - timingStatsLastTime = (-1) / 0, - timingStatsSum = 0 / 0, - timingStatsSum2 = 0 / 0 } - - addTimingStats = addTimingStatsGeneric - timingStatsMean = timingStatsMeanGeneric - timingStatsVariance = timingStatsVarianceGeneric - -addTimingStatsGeneric :: ConvertableToDouble a => Double -> a -> TimingStats a -> TimingStats a -addTimingStatsGeneric t a stats - | t < t' = error "The current time cannot be less than the previous one: addTimingStats" - | isNaN x = stats - | count == 1 = TimingStats { timingStatsCount = 1, - timingStatsMin = a, - timingStatsMax = a, - timingStatsMinTime = t, - timingStatsMaxTime = t, - timingStatsStartTime = t, - timingStatsLastTime = t, - timingStatsSum = 0, - timingStatsSum2 = 0 } - | otherwise = TimingStats { timingStatsCount = count, - timingStatsMin = minX, - timingStatsMax = maxX, - timingStatsMinTime = minT, - timingStatsMaxTime = maxT, - timingStatsStartTime = t0, - timingStatsLastTime = t, - timingStatsSum = sumX, - timingStatsSum2 = sumX2 } - where count = 1 + timingStatsCount stats - minX' = timingStatsMin stats - maxX' = timingStatsMax stats - minX = a `seq` min a minX' - maxX = a `seq` max a maxX' - minT | a < minX' = t - | otherwise = timingStatsMinTime stats - maxT | a > maxX' = t - | otherwise = timingStatsMaxTime stats - t0 = timingStatsStartTime stats - t' = timingStatsLastTime stats - x = convertToDouble a - sumX' = timingStatsSum stats - sumX = sumX' + (t - t') * x - sumX2' = timingStatsSum2 stats - sumX2 = sumX2' + (t - t') * x * x - -timingStatsMeanGeneric :: ConvertableToDouble a => TimingStats a -> Double -timingStatsMeanGeneric stats - | count == 0 = 0 / 0 - | t1 > t0 = sumX / (t1 - t0) - | otherwise = minX - where t0 = timingStatsStartTime stats - t1 = timingStatsLastTime stats - sumX = timingStatsSum stats - minX = convertToDouble $ timingStatsMin stats - count = timingStatsCount stats - -timingStatsMean2Generic :: ConvertableToDouble a => TimingStats a -> Double -timingStatsMean2Generic stats - | count == 0 = 0 / 0 - | t1 > t0 = sumX2 / (t1 - t0) - | otherwise = minX * minX - where t0 = timingStatsStartTime stats - t1 = timingStatsLastTime stats - sumX2 = timingStatsSum2 stats - minX = convertToDouble $ timingStatsMin stats - count = timingStatsCount stats - -timingStatsVarianceGeneric :: ConvertableToDouble a => TimingStats a -> Double -timingStatsVarianceGeneric stats = ex2 - ex * ex - where ex = timingStatsMeanGeneric stats - ex2 = timingStatsMean2Generic stats - --- | Return the deviation. -timingStatsDeviation :: TimingData a => TimingStats a -> Double -timingStatsDeviation = sqrt . timingStatsVariance - --- | Return the statistics by single timing data. -returnTimingStats :: TimingData a => Double -> a -> TimingStats a -returnTimingStats t a = addTimingStats t a emptyTimingStats - --- | Convert the statistics from integer to double values. -fromIntTimingStats :: TimingStats Int -> TimingStats Double -fromIntTimingStats stats = - stats { timingStatsMin = fromIntegral $ timingStatsMin stats, - timingStatsMax = fromIntegral $ timingStatsMax stats } - --- | Show the summary of the statistics. -showTimingStats :: (Show a, TimingData a) => TimingStats a -> ShowS -showTimingStats stats = - showString "{ count = " . shows (timingStatsCount stats) . - showString ", mean = " . shows (timingStatsMean stats) . - showString ", std = " . shows (timingStatsDeviation stats) . - showString ", min = " . shows (timingStatsMin stats) . - showString " (t = " . shows (timingStatsMinTime stats) . - showString "), max = " . shows (timingStatsMax stats) . - showString " (t = " . shows (timingStatsMaxTime stats) . - showString "), t in [" . shows (timingStatsStartTime stats) . - showString ", " . shows (timingStatsLastTime stats) . - showString "] }" - -instance (Show a, TimingData a) => Show (TimingStats a) where - showsPrec prec = showTimingStats - --- | Show the summary of the statistics using the specified indent. -timingStatsSummary :: (Show a, TimingData a) => TimingStats a -> Int -> ShowS -timingStatsSummary stats indent = - let tab = replicate indent ' ' - in showString tab . - showString "count = " . shows (timingStatsCount stats) . - showString "\n" . - showString tab . - showString "mean = " . shows (timingStatsMean stats) . - showString "\n" . - showString tab . - showString "std = " . shows (timingStatsDeviation stats) . - showString "\n" . - showString tab . - showString "min = " . shows (timingStatsMin stats) . - showString " (t = " . shows (timingStatsMinTime stats) . - showString ")\n" . - showString tab . - showString "max = " . shows (timingStatsMax stats) . - showString " (t = " . shows (timingStatsMaxTime stats) . - showString ")\n" . - showString tab . - showString "t in [" . shows (timingStatsStartTime stats) . - showString ", " . shows (timingStatsLastTime stats) . - showString "]" + +-- | +-- Module : Simulation.Aivika.Statistics +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- Represents statistics. +-- + +module Simulation.Aivika.Statistics + (-- * Simple Statistics + SamplingStats(..), + SamplingData(..), + combineSamplingStatsEither, + samplingStatsVariance, + samplingStatsDeviation, + samplingStatsSummary, + returnSamplingStats, + listSamplingStats, + fromIntSamplingStats, + -- * Timing Statistics + TimingStats(..), + TimingData(..), + timingStatsDeviation, + timingStatsSummary, + returnTimingStats, + fromIntTimingStats) where + +import Data.Monoid + +-- | Defines data types that can be converted to 'Double'. +class Ord a => ConvertableToDouble a where + + -- | Convert the value to 'Double'. + convertToDouble :: a -> Double + +instance ConvertableToDouble Double where + convertToDouble = id + +instance ConvertableToDouble Int where + convertToDouble = fromIntegral + +-- | Describes when the statistics consists of only samples +-- not bound to the simulation time. +data SamplingStats a = + SamplingStats { samplingStatsCount :: !Int, + -- ^ The total number of samples. + samplingStatsMin :: !a, + -- ^ The minimum value among the samples. + samplingStatsMax :: !a, + -- ^ The maximum value among the samples. + samplingStatsMean :: !Double, + -- ^ The average value. + samplingStatsMean2 :: !Double + -- ^ The average square value. + } + deriving (Eq, Ord) + +-- | Specifies data type from which values we can gather the statistics. +class SamplingData a where + + -- | An empty statistics that has no samples. + emptySamplingStats :: SamplingStats a + + -- | Add a new sample to the statistics. + addSamplingStats :: a -> SamplingStats a -> SamplingStats a + + -- | Combine two statistics. + combineSamplingStats :: SamplingStats a -> SamplingStats a -> SamplingStats a + +instance SamplingData a => Monoid (SamplingStats a) where + + mempty = emptySamplingStats + + mappend = combineSamplingStats + +instance SamplingData Double where + + emptySamplingStats = + SamplingStats { samplingStatsCount = 0, + samplingStatsMin = 1 / 0, + samplingStatsMax = (-1) / 0, + samplingStatsMean = 0 / 0, + samplingStatsMean2 = 0 / 0 } + + addSamplingStats = addSamplingStatsGeneric + + combineSamplingStats = combineSamplingStatsGeneric + +instance SamplingData Int where + + emptySamplingStats = + SamplingStats { samplingStatsCount = 0, + samplingStatsMin = maxBound, + samplingStatsMax = minBound, + samplingStatsMean = 0 / 0, + samplingStatsMean2 = 0 / 0 } + + addSamplingStats = addSamplingStatsGeneric + + combineSamplingStats = combineSamplingStatsGeneric + +addSamplingStatsGeneric :: ConvertableToDouble a => a -> SamplingStats a -> SamplingStats a +addSamplingStatsGeneric a stats + | isNaN x = stats + | count == 1 = SamplingStats { samplingStatsCount = 1, + samplingStatsMin = a, + samplingStatsMax = a, + samplingStatsMean = x, + samplingStatsMean2 = x * x } + | otherwise = SamplingStats { samplingStatsCount = count, + samplingStatsMin = minX, + samplingStatsMax = maxX, + samplingStatsMean = meanX, + samplingStatsMean2 = meanX2 } + where count = 1 + samplingStatsCount stats + minX = a `seq` min a (samplingStatsMin stats) + maxX = a `seq` max a (samplingStatsMax stats) + meanX = k1 * x + k2 * samplingStatsMean stats + meanX2 = k1 * x * x + k2 * samplingStatsMean2 stats + n = fromIntegral count + x = convertToDouble a + k1 = 1.0 / n + k2 = (n - 1.0) / n + +combineSamplingStatsGeneric :: ConvertableToDouble a => + SamplingStats a -> SamplingStats a -> SamplingStats a +combineSamplingStatsGeneric stats1 stats2 + | c1 == 0 = stats2 + | c2 == 0 = stats1 + | otherwise = SamplingStats { samplingStatsCount = c, + samplingStatsMin = minZ, + samplingStatsMax = maxZ, + samplingStatsMean = meanZ, + samplingStatsMean2 = meanZ2 } + where c1 = samplingStatsCount stats1 + c2 = samplingStatsCount stats2 + c = c1 + c2 + n1 = fromIntegral c1 + n2 = fromIntegral c2 + n = n1 + n2 + minX = samplingStatsMin stats1 + minY = samplingStatsMin stats2 + minZ = min minX minY + maxX = samplingStatsMax stats1 + maxY = samplingStatsMax stats2 + maxZ = max maxX maxY + meanX = samplingStatsMean stats1 + meanY = samplingStatsMean stats2 + meanZ = k1 * meanX + k2 * meanY + meanX2 = samplingStatsMean2 stats1 + meanY2 = samplingStatsMean2 stats2 + meanZ2 = k1 * meanX2 + k2 * meanY2 + k1 = n1 / n + k2 = n2 / n + +-- | If allows combining statistics more efficiently if we know that the first argument can be a scalar. +combineSamplingStatsEither :: SamplingData a => Either a (SamplingStats a) -> SamplingStats a -> SamplingStats a +combineSamplingStatsEither (Left a) stats2 = addSamplingStats a stats2 +combineSamplingStatsEither (Right stats1) stats2 = combineSamplingStats stats1 stats2 + +-- | Return the variance. +samplingStatsVariance :: SamplingStats a -> Double +samplingStatsVariance stats + | count == 1 = 0 + | otherwise = (meanX2 - meanX * meanX) * (n / (n - 1)) + where count = samplingStatsCount stats + meanX = samplingStatsMean stats + meanX2 = samplingStatsMean2 stats + n = fromIntegral count + +-- | Return the deviation. +samplingStatsDeviation :: SamplingStats a -> Double +samplingStatsDeviation = sqrt . samplingStatsVariance + +-- | Return the statistics by a single sample. +returnSamplingStats :: SamplingData a => a -> SamplingStats a +returnSamplingStats x = addSamplingStats x emptySamplingStats + +-- | Create the statistics by the specified list of data. +listSamplingStats :: SamplingData a => [a] -> SamplingStats a +listSamplingStats = foldr addSamplingStats emptySamplingStats + +-- | Convert the statistics from integer to double values. +fromIntSamplingStats :: SamplingStats Int -> SamplingStats Double +fromIntSamplingStats stats = + stats { samplingStatsMin = fromIntegral $ samplingStatsMin stats, + samplingStatsMax = fromIntegral $ samplingStatsMax stats } + +-- | Show the summary of the statistics. +showSamplingStats :: (Show a) => SamplingStats a -> ShowS +showSamplingStats stats = + showString "{ count = " . shows (samplingStatsCount stats) . + showString ", mean = " . shows (samplingStatsMean stats) . + showString ", std = " . shows (samplingStatsDeviation stats) . + showString ", min = " . shows (samplingStatsMin stats) . + showString ", max = " . shows (samplingStatsMax stats) . + showString " }" + +instance Show a => Show (SamplingStats a) where + showsPrec prec = showSamplingStats + +-- | Show the summary of the statistics using the specified indent. +samplingStatsSummary :: (Show a) => SamplingStats a -> Int -> ShowS +samplingStatsSummary stats indent = + let tab = replicate indent ' ' + in showString tab . + showString "count = " . shows (samplingStatsCount stats) . + showString "\n" . + showString tab . + showString "mean = " . shows (samplingStatsMean stats) . + showString "\n" . + showString tab . + showString "std = " . shows (samplingStatsDeviation stats) . + showString "\n" . + showString tab . + showString "min = " . shows (samplingStatsMin stats) . + showString "\n" . + showString tab . + showString "max = " . shows (samplingStatsMax stats) + +-- | This is the timing statistics where data are bound to the time. +data TimingStats a = + TimingStats { timingStatsCount :: !Int, + -- ^ Return the number of samples. + timingStatsMin :: !a, + -- ^ Return the minimum value. + timingStatsMax :: !a, + -- ^ Return the maximum value. + timingStatsMinTime :: !Double, + -- ^ Return the time at which the minimum is attained. + timingStatsMaxTime :: !Double, + -- ^ Return the time at which the maximum is attained. + timingStatsStartTime :: !Double, + -- ^ Return the start time of sampling. + timingStatsLastTime :: !Double, + -- ^ Return the last time of sampling. + timingStatsSum :: !Double, + -- ^ Return the sum of values. + timingStatsSum2 :: !Double + -- ^ Return the sum of square values. + } deriving (Eq, Ord) + +-- | Defines the data type from which values we can gather the timing statistics. +class TimingData a where + + -- | An empty statistics that has no samples. + emptyTimingStats :: TimingStats a + + -- | Add a sample with the specified time to the statistics. + addTimingStats :: Double -> a -> TimingStats a -> TimingStats a + + -- | Return the average value. + timingStatsMean :: TimingStats a -> Double + + -- | Return the variance. + timingStatsVariance :: TimingStats a -> Double + +instance TimingData Double where + + emptyTimingStats = + TimingStats { timingStatsCount = 0, + timingStatsMin = 1 / 0, + timingStatsMax = (-1) / 0, + timingStatsMinTime = 1 / 0, + timingStatsMaxTime = (-1) / 0, + timingStatsStartTime = 1 / 0, + timingStatsLastTime = (-1) / 0, + timingStatsSum = 0 / 0, + timingStatsSum2 = 0 / 0 } + + addTimingStats = addTimingStatsGeneric + timingStatsMean = timingStatsMeanGeneric + timingStatsVariance = timingStatsVarianceGeneric + +instance TimingData Int where + + emptyTimingStats = + TimingStats { timingStatsCount = 0, + timingStatsMin = maxBound, + timingStatsMax = minBound, + timingStatsMinTime = 1 / 0, + timingStatsMaxTime = (-1) / 0, + timingStatsStartTime = 1 / 0, + timingStatsLastTime = (-1) / 0, + timingStatsSum = 0 / 0, + timingStatsSum2 = 0 / 0 } + + addTimingStats = addTimingStatsGeneric + timingStatsMean = timingStatsMeanGeneric + timingStatsVariance = timingStatsVarianceGeneric + +addTimingStatsGeneric :: ConvertableToDouble a => Double -> a -> TimingStats a -> TimingStats a +addTimingStatsGeneric t a stats + | t < t' = error "The current time cannot be less than the previous one: addTimingStats" + | isNaN x = stats + | count == 1 = TimingStats { timingStatsCount = 1, + timingStatsMin = a, + timingStatsMax = a, + timingStatsMinTime = t, + timingStatsMaxTime = t, + timingStatsStartTime = t, + timingStatsLastTime = t, + timingStatsSum = 0, + timingStatsSum2 = 0 } + | otherwise = TimingStats { timingStatsCount = count, + timingStatsMin = minX, + timingStatsMax = maxX, + timingStatsMinTime = minT, + timingStatsMaxTime = maxT, + timingStatsStartTime = t0, + timingStatsLastTime = t, + timingStatsSum = sumX, + timingStatsSum2 = sumX2 } + where count = 1 + timingStatsCount stats + minX' = timingStatsMin stats + maxX' = timingStatsMax stats + minX = a `seq` min a minX' + maxX = a `seq` max a maxX' + minT | a < minX' = t + | otherwise = timingStatsMinTime stats + maxT | a > maxX' = t + | otherwise = timingStatsMaxTime stats + t0 = timingStatsStartTime stats + t' = timingStatsLastTime stats + x = convertToDouble a + sumX' = timingStatsSum stats + sumX = sumX' + (t - t') * x + sumX2' = timingStatsSum2 stats + sumX2 = sumX2' + (t - t') * x * x + +timingStatsMeanGeneric :: ConvertableToDouble a => TimingStats a -> Double +timingStatsMeanGeneric stats + | count == 0 = 0 / 0 + | t1 > t0 = sumX / (t1 - t0) + | otherwise = minX + where t0 = timingStatsStartTime stats + t1 = timingStatsLastTime stats + sumX = timingStatsSum stats + minX = convertToDouble $ timingStatsMin stats + count = timingStatsCount stats + +timingStatsMean2Generic :: ConvertableToDouble a => TimingStats a -> Double +timingStatsMean2Generic stats + | count == 0 = 0 / 0 + | t1 > t0 = sumX2 / (t1 - t0) + | otherwise = minX * minX + where t0 = timingStatsStartTime stats + t1 = timingStatsLastTime stats + sumX2 = timingStatsSum2 stats + minX = convertToDouble $ timingStatsMin stats + count = timingStatsCount stats + +timingStatsVarianceGeneric :: ConvertableToDouble a => TimingStats a -> Double +timingStatsVarianceGeneric stats = ex2 - ex * ex + where ex = timingStatsMeanGeneric stats + ex2 = timingStatsMean2Generic stats + +-- | Return the deviation. +timingStatsDeviation :: TimingData a => TimingStats a -> Double +timingStatsDeviation = sqrt . timingStatsVariance + +-- | Return the statistics by single timing data. +returnTimingStats :: TimingData a => Double -> a -> TimingStats a +returnTimingStats t a = addTimingStats t a emptyTimingStats + +-- | Convert the statistics from integer to double values. +fromIntTimingStats :: TimingStats Int -> TimingStats Double +fromIntTimingStats stats = + stats { timingStatsMin = fromIntegral $ timingStatsMin stats, + timingStatsMax = fromIntegral $ timingStatsMax stats } + +-- | Show the summary of the statistics. +showTimingStats :: (Show a, TimingData a) => TimingStats a -> ShowS +showTimingStats stats = + showString "{ count = " . shows (timingStatsCount stats) . + showString ", mean = " . shows (timingStatsMean stats) . + showString ", std = " . shows (timingStatsDeviation stats) . + showString ", min = " . shows (timingStatsMin stats) . + showString " (t = " . shows (timingStatsMinTime stats) . + showString "), max = " . shows (timingStatsMax stats) . + showString " (t = " . shows (timingStatsMaxTime stats) . + showString "), t in [" . shows (timingStatsStartTime stats) . + showString ", " . shows (timingStatsLastTime stats) . + showString "] }" + +instance (Show a, TimingData a) => Show (TimingStats a) where + showsPrec prec = showTimingStats + +-- | Show the summary of the statistics using the specified indent. +timingStatsSummary :: (Show a, TimingData a) => TimingStats a -> Int -> ShowS +timingStatsSummary stats indent = + let tab = replicate indent ' ' + in showString tab . + showString "count = " . shows (timingStatsCount stats) . + showString "\n" . + showString tab . + showString "mean = " . shows (timingStatsMean stats) . + showString "\n" . + showString tab . + showString "std = " . shows (timingStatsDeviation stats) . + showString "\n" . + showString tab . + showString "min = " . shows (timingStatsMin stats) . + showString " (t = " . shows (timingStatsMinTime stats) . + showString ")\n" . + showString tab . + showString "max = " . shows (timingStatsMax stats) . + showString " (t = " . shows (timingStatsMaxTime stats) . + showString ")\n" . + showString tab . + showString "t in [" . shows (timingStatsStartTime stats) . + showString ", " . shows (timingStatsLastTime stats) . + showString "]" diff --git a/Simulation/Aivika/Statistics/Accumulator.hs b/Simulation/Aivika/Statistics/Accumulator.hs --- a/Simulation/Aivika/Statistics/Accumulator.hs +++ b/Simulation/Aivika/Statistics/Accumulator.hs @@ -1,44 +1,44 @@ - --- | --- Module : Simulation.Aivika.Statistics.Accumulator --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- This small utility module allows accumulating the timing statistics based on 'Signalable' data --- such as the queue size or the number of lost items in the queue. --- - -module Simulation.Aivika.Statistics.Accumulator - (-- * Timing Statistics Accumulator - TimingStatsAccumulator, - newTimingStatsAccumulator, - timingStatsAccumulated) where - -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Ref -import Simulation.Aivika.Statistics -import Simulation.Aivika.Signal - --- | Represents an accumulator for the timing statistics. -newtype TimingStatsAccumulator a = - TimingStatsAccumulator { timingStatsAccumulatedRef :: Ref (TimingStats a) } - --- | Return the accumulated statistics. -timingStatsAccumulated :: TimingStatsAccumulator a -> Event (TimingStats a) -timingStatsAccumulated = readRef . timingStatsAccumulatedRef - --- | Start gathering the timing statistics from the current simulation time. -newTimingStatsAccumulator :: TimingData a => Signalable a -> Event (TimingStatsAccumulator a) -newTimingStatsAccumulator x = - do t0 <- liftDynamics time - a0 <- readSignalable x - r <- liftSimulation $ newRef (returnTimingStats t0 a0) - handleSignal_ (signalableChanged x) $ \a -> - do t <- liftDynamics time - modifyRef r $ addTimingStats t a - return TimingStatsAccumulator { timingStatsAccumulatedRef = r } + +-- | +-- Module : Simulation.Aivika.Statistics.Accumulator +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This small utility module allows accumulating the timing statistics based on 'Signalable' data +-- such as the queue size or the number of lost items in the queue. +-- + +module Simulation.Aivika.Statistics.Accumulator + (-- * Timing Statistics Accumulator + TimingStatsAccumulator, + newTimingStatsAccumulator, + timingStatsAccumulated) where + +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Event +import Simulation.Aivika.Ref +import Simulation.Aivika.Statistics +import Simulation.Aivika.Signal + +-- | Represents an accumulator for the timing statistics. +newtype TimingStatsAccumulator a = + TimingStatsAccumulator { timingStatsAccumulatedRef :: Ref (TimingStats a) } + +-- | Return the accumulated statistics. +timingStatsAccumulated :: TimingStatsAccumulator a -> Event (TimingStats a) +timingStatsAccumulated = readRef . timingStatsAccumulatedRef + +-- | Start gathering the timing statistics from the current simulation time. +newTimingStatsAccumulator :: TimingData a => Signalable a -> Event (TimingStatsAccumulator a) +newTimingStatsAccumulator x = + do t0 <- liftDynamics time + a0 <- readSignalable x + r <- liftSimulation $ newRef (returnTimingStats t0 a0) + handleSignal_ (signalableChanged x) $ \a -> + do t <- liftDynamics time + modifyRef r $ addTimingStats t a + return TimingStatsAccumulator { timingStatsAccumulatedRef = r } diff --git a/Simulation/Aivika/Stream.hs b/Simulation/Aivika/Stream.hs --- a/Simulation/Aivika/Stream.hs +++ b/Simulation/Aivika/Stream.hs @@ -1,534 +1,534 @@ - --- | --- Module : Simulation.Aivika.Stream --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The infinite stream of data in time. --- -module Simulation.Aivika.Stream - (-- * Stream Type - Stream(..), - -- * Merging and Splitting Stream - emptyStream, - mergeStreams, - mergeQueuedStreams, - mergePriorityStreams, - concatStreams, - concatQueuedStreams, - concatPriorityStreams, - splitStream, - splitStreamQueueing, - splitStreamPrioritising, - -- * Specifying Identifier - streamUsingId, - -- * Prefetching and Delaying Stream - prefetchStream, - delayStream, - -- * Stream Arriving - arrivalStream, - -- * Memoizing, Zipping and Uzipping Stream - memoStream, - zipStreamSeq, - zipStreamParallel, - zip3StreamSeq, - zip3StreamParallel, - unzipStream, - streamSeq, - streamParallel, - -- * Consuming and Sinking Stream - consumeStream, - sinkStream, - -- * Useful Combinators - repeatProcess, - mapStream, - mapStreamM, - apStreamDataFirst, - apStreamDataLater, - apStreamParallel, - filterStream, - filterStreamM, - -- * Integrating with Signals - signalStream, - streamSignal, - -- * Utilities - leftStream, - rightStream, - replaceLeftStream, - replaceRightStream, - partitionEitherStream) where - -import Data.IORef -import Data.Maybe -import Data.Monoid - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Cont -import Simulation.Aivika.Process -import Simulation.Aivika.Signal -import Simulation.Aivika.Resource -import Simulation.Aivika.QueueStrategy -import Simulation.Aivika.Queue.Infinite -import Simulation.Aivika.Internal.Arrival - --- | Represents an infinite stream of data in time, --- some kind of the cons cell. -newtype Stream a = Cons { runStream :: Process (a, Stream a) - -- ^ Run the stream. - } - -instance Functor Stream where - - fmap f (Cons s) = Cons y where - y = do ~(x, xs) <- s - return (f x, fmap f xs) - -instance Monoid (Stream a) where - - mempty = emptyStream - - mappend = mergeStreams - - mconcat = concatStreams - --- | Create a stream that will use the specified process identifier. --- It can be useful to refer to the underlying 'Process' computation which --- can be passivated, interrupted, canceled and so on. See also the --- 'processUsingId' function for more details. -streamUsingId :: ProcessId -> Stream a -> Stream a -streamUsingId pid (Cons s) = - Cons $ processUsingId pid s - --- | Memoize the stream so that it would always return the same data --- within the simulation run. -memoStream :: Stream a -> Simulation (Stream a) -memoStream (Cons s) = - do p <- memoProcess $ - do ~(x, xs) <- s - xs' <- liftSimulation $ memoStream xs - return (x, xs') - return (Cons p) - --- | Zip two streams trying to get data sequentially. -zipStreamSeq :: Stream a -> Stream b -> Stream (a, b) -zipStreamSeq (Cons sa) (Cons sb) = Cons y where - y = do ~(x, xs) <- sa - ~(y, ys) <- sb - return ((x, y), zipStreamSeq xs ys) - --- | Zip two streams trying to get data as soon as possible, --- launching the sub-processes in parallel. -zipStreamParallel :: Stream a -> Stream b -> Stream (a, b) -zipStreamParallel (Cons sa) (Cons sb) = Cons y where - y = do ~((x, xs), (y, ys)) <- zipProcessParallel sa sb - return ((x, y), zipStreamParallel xs ys) - --- | Zip three streams trying to get data sequentially. -zip3StreamSeq :: Stream a -> Stream b -> Stream c -> Stream (a, b, c) -zip3StreamSeq (Cons sa) (Cons sb) (Cons sc) = Cons y where - y = do ~(x, xs) <- sa - ~(y, ys) <- sb - ~(z, zs) <- sc - return ((x, y, z), zip3StreamSeq xs ys zs) - --- | Zip three streams trying to get data as soon as possible, --- launching the sub-processes in parallel. -zip3StreamParallel :: Stream a -> Stream b -> Stream c -> Stream (a, b, c) -zip3StreamParallel (Cons sa) (Cons sb) (Cons sc) = Cons y where - y = do ~((x, xs), (y, ys), (z, zs)) <- zip3ProcessParallel sa sb sc - return ((x, y, z), zip3StreamParallel xs ys zs) - --- | Unzip the stream. -unzipStream :: Stream (a, b) -> Simulation (Stream a, Stream b) -unzipStream s = - do s' <- memoStream s - let sa = mapStream fst s' - sb = mapStream snd s' - return (sa, sb) - --- | To form each new portion of data for the output stream, --- read data sequentially from the input streams. --- --- This is a generalization of 'zipStreamSeq'. -streamSeq :: [Stream a] -> Stream [a] -streamSeq xs = Cons y where - y = do ps <- forM xs runStream - return (map fst ps, streamSeq $ map snd ps) - --- | To form each new portion of data for the output stream, --- read data from the input streams in parallel. --- --- This is a generalization of 'zipStreamParallel'. -streamParallel :: [Stream a] -> Stream [a] -streamParallel xs = Cons y where - y = do ps <- processParallel $ map runStream xs - return (map fst ps, streamParallel $ map snd ps) - --- | Return a stream of values generated by the specified process. -repeatProcess :: Process a -> Stream a -repeatProcess p = Cons y where - y = do a <- p - return (a, repeatProcess p) - --- | Map the stream according the specified function. -mapStream :: (a -> b) -> Stream a -> Stream b -mapStream = fmap - --- | Compose the stream. -mapStreamM :: (a -> Process b) -> Stream a -> Stream b -mapStreamM f (Cons s) = Cons y where - y = do (a, xs) <- s - b <- f a - return (b, mapStreamM f xs) - --- | Transform the stream getting the transformation function after data have come. -apStreamDataFirst :: Process (a -> b) -> Stream a -> Stream b -apStreamDataFirst f (Cons s) = Cons y where - y = do ~(a, xs) <- s - g <- f - return (g a, apStreamDataFirst f xs) - --- | Transform the stream getting the transformation function before requesting for data. -apStreamDataLater :: Process (a -> b) -> Stream a -> Stream b -apStreamDataLater f (Cons s) = Cons y where - y = do g <- f - ~(a, xs) <- s - return (g a, apStreamDataLater f xs) - --- | Transform the stream trying to get the transformation function as soon as possible --- at the same time when requesting for the next portion of data. -apStreamParallel :: Process (a -> b) -> Stream a -> Stream b -apStreamParallel f (Cons s) = Cons y where - y = do ~(g, (a, xs)) <- zipProcessParallel f s - return (g a, apStreamParallel f xs) - --- | Filter only those data values that satisfy to the specified predicate. -filterStream :: (a -> Bool) -> Stream a -> Stream a -filterStream p (Cons s) = Cons y where - y = do (a, xs) <- s - if p a - then return (a, filterStream p xs) - else let Cons z = filterStream p xs in z - --- | Filter only those data values that satisfy to the specified predicate. -filterStreamM :: (a -> Process Bool) -> Stream a -> Stream a -filterStreamM p (Cons s) = Cons y where - y = do (a, xs) <- s - b <- p a - if b - then return (a, filterStreamM p xs) - else let Cons z = filterStreamM p xs in z - --- | The stream of 'Left' values. -leftStream :: Stream (Either a b) -> Stream a -leftStream (Cons s) = Cons y where - y = do (a, xs) <- s - case a of - Left a -> return (a, leftStream xs) - Right _ -> let Cons z = leftStream xs in z - --- | The stream of 'Right' values. -rightStream :: Stream (Either a b) -> Stream b -rightStream (Cons s) = Cons y where - y = do (a, xs) <- s - case a of - Left _ -> let Cons z = rightStream xs in z - Right a -> return (a, rightStream xs) - --- | Replace the 'Left' values. -replaceLeftStream :: Stream (Either a b) -> Stream c -> Stream (Either c b) -replaceLeftStream (Cons sab) (ys0 @ ~(Cons sc)) = Cons z where - z = do (a, xs) <- sab - case a of - Left _ -> - do (b, ys) <- sc - return (Left b, replaceLeftStream xs ys) - Right a -> - return (Right a, replaceLeftStream xs ys0) - --- | Replace the 'Right' values. -replaceRightStream :: Stream (Either a b) -> Stream c -> Stream (Either a c) -replaceRightStream (Cons sab) (ys0 @ ~(Cons sc)) = Cons z where - z = do (a, xs) <- sab - case a of - Right _ -> - do (b, ys) <- sc - return (Right b, replaceRightStream xs ys) - Left a -> - return (Left a, replaceRightStream xs ys0) - --- | Partition the stream of 'Either' values into two streams. -partitionEitherStream :: Stream (Either a b) -> Simulation (Stream a, Stream b) -partitionEitherStream s = - do s' <- memoStream s - return (leftStream s', rightStream s') - --- | Split the input stream into the specified number of output streams --- after applying the 'FCFS' strategy for enqueuing the output requests. -splitStream :: Int -> Stream a -> Simulation [Stream a] -splitStream = splitStreamQueueing FCFS - --- | Split the input stream into the specified number of output streams. --- --- If you don't know what the strategy to apply, then you probably --- need the 'FCFS' strategy, or function 'splitStream' that --- does namely this. -splitStreamQueueing :: EnqueueStrategy s q - => s - -- ^ the strategy applied for enqueuing the output requests - -> Int - -- ^ the number of output streams - -> Stream a - -- ^ the input stream - -> Simulation [Stream a] - -- ^ the splitted output streams -splitStreamQueueing s n x = - do ref <- liftIO $ newIORef x - res <- newResource s 1 - let reader = - usingResource res $ - do p <- liftIO $ readIORef ref - (a, xs) <- runStream p - liftIO $ writeIORef ref xs - return a - return $ map (\i -> repeatProcess reader) [1..n] - --- | Split the input stream into a list of output streams --- using the specified priorities. -splitStreamPrioritising :: PriorityQueueStrategy s q p - => s - -- ^ the strategy applied for enqueuing the output requests - -> [Stream p] - -- ^ the streams of priorities - -> Stream a - -- ^ the input stream - -> Simulation [Stream a] - -- ^ the splitted output streams -splitStreamPrioritising s ps x = - do ref <- liftIO $ newIORef x - res <- newResource s 1 - let stream (Cons p) = Cons z where - z = do (p', ps) <- p - a <- usingResourceWithPriority res p' $ - do p <- liftIO $ readIORef ref - (a, xs) <- runStream p - liftIO $ writeIORef ref xs - return a - return (a, stream ps) - return $ map stream ps - --- | Concatenate the input streams applying the 'FCFS' strategy and --- producing one output stream. -concatStreams :: [Stream a] -> Stream a -concatStreams = concatQueuedStreams FCFS - --- | Concatenate the input streams producing one output stream. --- --- If you don't know what the strategy to apply, then you probably --- need the 'FCFS' strategy, or function 'concatStreams' that --- does namely this. -concatQueuedStreams :: EnqueueStrategy s q - => s - -- ^ the strategy applied for enqueuing the input data - -> [Stream a] - -- ^ the input stream - -> Stream a - -- ^ the combined output stream -concatQueuedStreams s streams = Cons z where - z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - writing <- liftSimulation $ newResourceWithMaxCount s 1 (Just 1) - conting <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - ref <- liftIO $ newIORef Nothing - let writer p = - do (a, xs) <- runStream p - requestResource writing - liftIO $ writeIORef ref (Just a) - releaseResource reading - requestResource conting - writer xs - reader = - do requestResource reading - Just a <- liftIO $ readIORef ref - liftIO $ writeIORef ref Nothing - releaseResource writing - return a - forM_ streams $ spawnProcess CancelTogether . writer - a <- reader - let xs = repeatProcess (releaseResource conting >> reader) - return (a, xs) - --- | Concatenate the input priority streams producing one output stream. -concatPriorityStreams :: PriorityQueueStrategy s q p - => s - -- ^ the strategy applied for enqueuing the input data - -> [Stream (p, a)] - -- ^ the input stream - -> Stream a - -- ^ the combined output stream -concatPriorityStreams s streams = Cons z where - z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - writing <- liftSimulation $ newResourceWithMaxCount s 1 (Just 1) - conting <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - ref <- liftIO $ newIORef Nothing - let writer p = - do ((priority, a), xs) <- runStream p - requestResourceWithPriority writing priority - liftIO $ writeIORef ref (Just a) - releaseResource reading - requestResource conting - writer xs - reader = - do requestResource reading - Just a <- liftIO $ readIORef ref - liftIO $ writeIORef ref Nothing - releaseResource writing - return a - forM_ streams $ spawnProcess CancelTogether . writer - a <- reader - let xs = repeatProcess (releaseResource conting >> reader) - return (a, xs) - --- | Merge two streams applying the 'FCFS' strategy for enqueuing the input data. -mergeStreams :: Stream a -> Stream a -> Stream a -mergeStreams = mergeQueuedStreams FCFS - --- | Merge two streams. --- --- If you don't know what the strategy to apply, then you probably --- need the 'FCFS' strategy, or function 'mergeStreams' that --- does namely this. -mergeQueuedStreams :: EnqueueStrategy s q - => s - -- ^ the strategy applied for enqueuing the input data - -> Stream a - -- ^ the fist input stream - -> Stream a - -- ^ the second input stream - -> Stream a - -- ^ the output combined stream -mergeQueuedStreams s x y = concatQueuedStreams s [x, y] - --- | Merge two priority streams. -mergePriorityStreams :: PriorityQueueStrategy s q p - => s - -- ^ the strategy applied for enqueuing the input data - -> Stream (p, a) - -- ^ the fist input stream - -> Stream (p, a) - -- ^ the second input stream - -> Stream a - -- ^ the output combined stream -mergePriorityStreams s x y = concatPriorityStreams s [x, y] - --- | An empty stream that never returns data. -emptyStream :: Stream a -emptyStream = Cons neverProcess - --- | Consume the stream. It returns a process that infinitely reads data --- from the stream and then redirects them to the provided function. --- It is useful for modeling the process of enqueueing data in the queue --- from the input stream. -consumeStream :: (a -> Process ()) -> Stream a -> Process () -consumeStream f = p where - p (Cons s) = do (a, xs) <- s - f a - p xs - --- | Sink the stream. It returns a process that infinitely reads data --- from the stream. The resulting computation can be a moving force --- to simulate the whole system of the interconnected streams and --- processors. -sinkStream :: Stream a -> Process () -sinkStream = p where - p (Cons s) = do (a, xs) <- s - p xs - --- | Prefetch the input stream requesting for one more data item in advance --- while the last received item is not yet fully processed in the chain of --- streams, usually by the processors. --- --- You can think of this as the prefetched stream could place its latest --- data item in some temporary space for later use, which is very useful --- for modeling a sequence of separate and independent work places. -prefetchStream :: Stream a -> Stream a -prefetchStream s = Cons z where - z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) - writing <- liftSimulation $ newResourceWithMaxCount FCFS 1 (Just 1) - ref <- liftIO $ newIORef Nothing - let writer p = - do (a, xs) <- runStream p - requestResource writing - liftIO $ writeIORef ref (Just a) - releaseResource reading - writer xs - reader = - do requestResource reading - Just a <- liftIO $ readIORef ref - liftIO $ writeIORef ref Nothing - releaseResource writing - return a - spawnProcess CancelTogether $ writer s - runStream $ repeatProcess reader - --- | Return a stream of values triggered by the specified signal. --- --- Since the time at which the values of the stream are requested for may differ from --- the time at which the signal is triggered, it can be useful to apply the 'arrivalSignal' --- function to add the information about the time points at which the signal was --- actually received. --- --- The point is that the 'Stream' is requested outside, while the 'Signal' is triggered --- inside. They are different by nature. The former is passive, while the latter is active. --- --- The resulting stream may be a root of space leak as it uses an internal queue to store --- the values received from the signal. The oldest value is dequeued each time we request --- the stream and it is returned within the computation. --- --- Cancel the stream's process to unsubscribe from the specified signal. -signalStream :: Signal a -> Process (Stream a) -signalStream s = - do q <- liftEvent newFCFSQueue - h <- liftEvent $ - handleSignal s $ - enqueue q - whenCancellingProcess $ disposeEvent h - return $ repeatProcess $ dequeue q - --- | Return a computation of the signal that triggers values from the specified stream, --- each time the next value of the stream is received within the underlying 'Process' --- computation. --- --- Cancel the returned process to stop reading from the specified stream. -streamSignal :: Stream a -> Process (Signal a) -streamSignal z = - do s <- liftSimulation newSignalSource - spawnProcess CancelTogether $ - consumeStream (liftEvent . triggerSignal s) z - return $ publishSignal s - --- | Transform a stream so that the resulting stream returns a sequence of arrivals --- saving the information about the time points at which the original stream items --- were received by demand. -arrivalStream :: Stream a -> Stream (Arrival a) -arrivalStream s = Cons $ loop s Nothing where - loop s t0 = do (a, xs) <- runStream s - t <- liftDynamics time - let b = Arrival { arrivalValue = a, - arrivalTime = t, - arrivalDelay = - case t0 of - Nothing -> Nothing - Just t0 -> Just (t - t0) } - return (b, Cons $ loop xs (Just t)) - --- | Delay the stream by one step using the specified initial value. -delayStream :: a -> Stream a -> Stream a -delayStream a0 s = Cons $ return (a0, s) + +-- | +-- Module : Simulation.Aivika.Stream +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The infinite stream of data in time. +-- +module Simulation.Aivika.Stream + (-- * Stream Type + Stream(..), + -- * Merging and Splitting Stream + emptyStream, + mergeStreams, + mergeQueuedStreams, + mergePriorityStreams, + concatStreams, + concatQueuedStreams, + concatPriorityStreams, + splitStream, + splitStreamQueueing, + splitStreamPrioritising, + -- * Specifying Identifier + streamUsingId, + -- * Prefetching and Delaying Stream + prefetchStream, + delayStream, + -- * Stream Arriving + arrivalStream, + -- * Memoizing, Zipping and Uzipping Stream + memoStream, + zipStreamSeq, + zipStreamParallel, + zip3StreamSeq, + zip3StreamParallel, + unzipStream, + streamSeq, + streamParallel, + -- * Consuming and Sinking Stream + consumeStream, + sinkStream, + -- * Useful Combinators + repeatProcess, + mapStream, + mapStreamM, + apStream, + apStreamM, + filterStream, + filterStreamM, + -- * Integrating with Signals + signalStream, + streamSignal, + -- * Utilities + leftStream, + rightStream, + replaceLeftStream, + replaceRightStream, + partitionEitherStream) where + +import Data.IORef +import Data.Maybe +import Data.Monoid + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Event +import Simulation.Aivika.Cont +import Simulation.Aivika.Process +import Simulation.Aivika.Signal +import Simulation.Aivika.Resource +import Simulation.Aivika.QueueStrategy +import Simulation.Aivika.Queue.Infinite +import Simulation.Aivika.Internal.Arrival + +-- | Represents an infinite stream of data in time, +-- some kind of the cons cell. +newtype Stream a = Cons { runStream :: Process (a, Stream a) + -- ^ Run the stream. + } + +instance Functor Stream where + + fmap = mapStream + +instance Applicative Stream where + + pure a = let y = Cons (return (a, y)) in y + + (<*>) = apStream + +instance Monoid (Stream a) where + + mempty = emptyStream + + mappend = mergeStreams + + mconcat = concatStreams + +-- | Create a stream that will use the specified process identifier. +-- It can be useful to refer to the underlying 'Process' computation which +-- can be passivated, interrupted, canceled and so on. See also the +-- 'processUsingId' function for more details. +streamUsingId :: ProcessId -> Stream a -> Stream a +streamUsingId pid (Cons s) = + Cons $ processUsingId pid s + +-- | Memoize the stream so that it would always return the same data +-- within the simulation run. +memoStream :: Stream a -> Simulation (Stream a) +memoStream (Cons s) = + do p <- memoProcess $ + do ~(x, xs) <- s + xs' <- liftSimulation $ memoStream xs + return (x, xs') + return (Cons p) + +-- | Zip two streams trying to get data sequentially. +zipStreamSeq :: Stream a -> Stream b -> Stream (a, b) +zipStreamSeq (Cons sa) (Cons sb) = Cons y where + y = do ~(x, xs) <- sa + ~(y, ys) <- sb + return ((x, y), zipStreamSeq xs ys) + +-- | Zip two streams trying to get data as soon as possible, +-- launching the sub-processes in parallel. +zipStreamParallel :: Stream a -> Stream b -> Stream (a, b) +zipStreamParallel (Cons sa) (Cons sb) = Cons y where + y = do ~((x, xs), (y, ys)) <- zipProcessParallel sa sb + return ((x, y), zipStreamParallel xs ys) + +-- | Zip three streams trying to get data sequentially. +zip3StreamSeq :: Stream a -> Stream b -> Stream c -> Stream (a, b, c) +zip3StreamSeq (Cons sa) (Cons sb) (Cons sc) = Cons y where + y = do ~(x, xs) <- sa + ~(y, ys) <- sb + ~(z, zs) <- sc + return ((x, y, z), zip3StreamSeq xs ys zs) + +-- | Zip three streams trying to get data as soon as possible, +-- launching the sub-processes in parallel. +zip3StreamParallel :: Stream a -> Stream b -> Stream c -> Stream (a, b, c) +zip3StreamParallel (Cons sa) (Cons sb) (Cons sc) = Cons y where + y = do ~((x, xs), (y, ys), (z, zs)) <- zip3ProcessParallel sa sb sc + return ((x, y, z), zip3StreamParallel xs ys zs) + +-- | Unzip the stream. +unzipStream :: Stream (a, b) -> Simulation (Stream a, Stream b) +unzipStream s = + do s' <- memoStream s + let sa = mapStream fst s' + sb = mapStream snd s' + return (sa, sb) + +-- | To form each new portion of data for the output stream, +-- read data sequentially from the input streams. +-- +-- This is a generalization of 'zipStreamSeq'. +streamSeq :: [Stream a] -> Stream [a] +streamSeq xs = Cons y where + y = do ps <- forM xs runStream + return (map fst ps, streamSeq $ map snd ps) + +-- | To form each new portion of data for the output stream, +-- read data from the input streams in parallel. +-- +-- This is a generalization of 'zipStreamParallel'. +streamParallel :: [Stream a] -> Stream [a] +streamParallel xs = Cons y where + y = do ps <- processParallel $ map runStream xs + return (map fst ps, streamParallel $ map snd ps) + +-- | Return a stream of values generated by the specified process. +repeatProcess :: Process a -> Stream a +repeatProcess p = Cons y where + y = do a <- p + return (a, repeatProcess p) + +-- | Map the stream according the specified function. +mapStream :: (a -> b) -> Stream a -> Stream b +mapStream f (Cons s) = Cons y where + y = do (a, xs) <- s + return (f a, mapStream f xs) + +-- | Compose the stream. +mapStreamM :: (a -> Process b) -> Stream a -> Stream b +mapStreamM f (Cons s) = Cons y where + y = do (a, xs) <- s + b <- f a + return (b, mapStreamM f xs) + +-- | Sequential application. +apStream :: Stream (a -> b) -> Stream a -> Stream b +apStream (Cons sf) (Cons sa) = Cons y where + y = do (f, sf') <- sf + (a, sa') <- sa + return (f a, apStream sf' sa') + +-- | Sequential application. +apStreamM :: Stream (a -> Process b) -> Stream a -> Stream b +apStreamM (Cons sf) (Cons sa) = Cons y where + y = do (f, sf') <- sf + (a, sa') <- sa + x <- f a + return (x, apStreamM sf' sa') + +-- | Filter only those data values that satisfy to the specified predicate. +filterStream :: (a -> Bool) -> Stream a -> Stream a +filterStream p (Cons s) = Cons y where + y = do (a, xs) <- s + if p a + then return (a, filterStream p xs) + else let Cons z = filterStream p xs in z + +-- | Filter only those data values that satisfy to the specified predicate. +filterStreamM :: (a -> Process Bool) -> Stream a -> Stream a +filterStreamM p (Cons s) = Cons y where + y = do (a, xs) <- s + b <- p a + if b + then return (a, filterStreamM p xs) + else let Cons z = filterStreamM p xs in z + +-- | The stream of 'Left' values. +leftStream :: Stream (Either a b) -> Stream a +leftStream (Cons s) = Cons y where + y = do (a, xs) <- s + case a of + Left a -> return (a, leftStream xs) + Right _ -> let Cons z = leftStream xs in z + +-- | The stream of 'Right' values. +rightStream :: Stream (Either a b) -> Stream b +rightStream (Cons s) = Cons y where + y = do (a, xs) <- s + case a of + Left _ -> let Cons z = rightStream xs in z + Right a -> return (a, rightStream xs) + +-- | Replace the 'Left' values. +replaceLeftStream :: Stream (Either a b) -> Stream c -> Stream (Either c b) +replaceLeftStream (Cons sab) (ys0 @ ~(Cons sc)) = Cons z where + z = do (a, xs) <- sab + case a of + Left _ -> + do (b, ys) <- sc + return (Left b, replaceLeftStream xs ys) + Right a -> + return (Right a, replaceLeftStream xs ys0) + +-- | Replace the 'Right' values. +replaceRightStream :: Stream (Either a b) -> Stream c -> Stream (Either a c) +replaceRightStream (Cons sab) (ys0 @ ~(Cons sc)) = Cons z where + z = do (a, xs) <- sab + case a of + Right _ -> + do (b, ys) <- sc + return (Right b, replaceRightStream xs ys) + Left a -> + return (Left a, replaceRightStream xs ys0) + +-- | Partition the stream of 'Either' values into two streams. +partitionEitherStream :: Stream (Either a b) -> Simulation (Stream a, Stream b) +partitionEitherStream s = + do s' <- memoStream s + return (leftStream s', rightStream s') + +-- | Split the input stream into the specified number of output streams +-- after applying the 'FCFS' strategy for enqueuing the output requests. +splitStream :: Int -> Stream a -> Simulation [Stream a] +splitStream = splitStreamQueueing FCFS + +-- | Split the input stream into the specified number of output streams. +-- +-- If you don't know what the strategy to apply, then you probably +-- need the 'FCFS' strategy, or function 'splitStream' that +-- does namely this. +splitStreamQueueing :: EnqueueStrategy s + => s + -- ^ the strategy applied for enqueuing the output requests + -> Int + -- ^ the number of output streams + -> Stream a + -- ^ the input stream + -> Simulation [Stream a] + -- ^ the splitted output streams +splitStreamQueueing s n x = + do ref <- liftIO $ newIORef x + res <- newResource s 1 + let reader = + usingResource res $ + do p <- liftIO $ readIORef ref + (a, xs) <- runStream p + liftIO $ writeIORef ref xs + return a + return $ map (\i -> repeatProcess reader) [1..n] + +-- | Split the input stream into a list of output streams +-- using the specified priorities. +splitStreamPrioritising :: PriorityQueueStrategy s p + => s + -- ^ the strategy applied for enqueuing the output requests + -> [Stream p] + -- ^ the streams of priorities + -> Stream a + -- ^ the input stream + -> Simulation [Stream a] + -- ^ the splitted output streams +splitStreamPrioritising s ps x = + do ref <- liftIO $ newIORef x + res <- newResource s 1 + let stream (Cons p) = Cons z where + z = do (p', ps) <- p + a <- usingResourceWithPriority res p' $ + do p <- liftIO $ readIORef ref + (a, xs) <- runStream p + liftIO $ writeIORef ref xs + return a + return (a, stream ps) + return $ map stream ps + +-- | Concatenate the input streams applying the 'FCFS' strategy and +-- producing one output stream. +concatStreams :: [Stream a] -> Stream a +concatStreams = concatQueuedStreams FCFS + +-- | Concatenate the input streams producing one output stream. +-- +-- If you don't know what the strategy to apply, then you probably +-- need the 'FCFS' strategy, or function 'concatStreams' that +-- does namely this. +concatQueuedStreams :: EnqueueStrategy s + => s + -- ^ the strategy applied for enqueuing the input data + -> [Stream a] + -- ^ the input stream + -> Stream a + -- ^ the combined output stream +concatQueuedStreams s streams = Cons z where + z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + writing <- liftSimulation $ newResourceWithMaxCount s 1 (Just 1) + conting <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + ref <- liftIO $ newIORef Nothing + let writer p = + do (a, xs) <- runStream p + requestResource writing + liftIO $ writeIORef ref (Just a) + releaseResource reading + requestResource conting + writer xs + reader = + do requestResource reading + Just a <- liftIO $ readIORef ref + liftIO $ writeIORef ref Nothing + releaseResource writing + return a + forM_ streams $ spawnProcess CancelTogether . writer + a <- reader + let xs = repeatProcess (releaseResource conting >> reader) + return (a, xs) + +-- | Concatenate the input priority streams producing one output stream. +concatPriorityStreams :: PriorityQueueStrategy s p + => s + -- ^ the strategy applied for enqueuing the input data + -> [Stream (p, a)] + -- ^ the input stream + -> Stream a + -- ^ the combined output stream +concatPriorityStreams s streams = Cons z where + z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + writing <- liftSimulation $ newResourceWithMaxCount s 1 (Just 1) + conting <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + ref <- liftIO $ newIORef Nothing + let writer p = + do ((priority, a), xs) <- runStream p + requestResourceWithPriority writing priority + liftIO $ writeIORef ref (Just a) + releaseResource reading + requestResource conting + writer xs + reader = + do requestResource reading + Just a <- liftIO $ readIORef ref + liftIO $ writeIORef ref Nothing + releaseResource writing + return a + forM_ streams $ spawnProcess CancelTogether . writer + a <- reader + let xs = repeatProcess (releaseResource conting >> reader) + return (a, xs) + +-- | Merge two streams applying the 'FCFS' strategy for enqueuing the input data. +mergeStreams :: Stream a -> Stream a -> Stream a +mergeStreams = mergeQueuedStreams FCFS + +-- | Merge two streams. +-- +-- If you don't know what the strategy to apply, then you probably +-- need the 'FCFS' strategy, or function 'mergeStreams' that +-- does namely this. +mergeQueuedStreams :: EnqueueStrategy s + => s + -- ^ the strategy applied for enqueuing the input data + -> Stream a + -- ^ the fist input stream + -> Stream a + -- ^ the second input stream + -> Stream a + -- ^ the output combined stream +mergeQueuedStreams s x y = concatQueuedStreams s [x, y] + +-- | Merge two priority streams. +mergePriorityStreams :: PriorityQueueStrategy s p + => s + -- ^ the strategy applied for enqueuing the input data + -> Stream (p, a) + -- ^ the fist input stream + -> Stream (p, a) + -- ^ the second input stream + -> Stream a + -- ^ the output combined stream +mergePriorityStreams s x y = concatPriorityStreams s [x, y] + +-- | An empty stream that never returns data. +emptyStream :: Stream a +emptyStream = Cons neverProcess + +-- | Consume the stream. It returns a process that infinitely reads data +-- from the stream and then redirects them to the provided function. +-- It is useful for modeling the process of enqueueing data in the queue +-- from the input stream. +consumeStream :: (a -> Process ()) -> Stream a -> Process () +consumeStream f = p where + p (Cons s) = do (a, xs) <- s + f a + p xs + +-- | Sink the stream. It returns a process that infinitely reads data +-- from the stream. The resulting computation can be a moving force +-- to simulate the whole system of the interconnected streams and +-- processors. +sinkStream :: Stream a -> Process () +sinkStream = p where + p (Cons s) = do (a, xs) <- s + p xs + +-- | Prefetch the input stream requesting for one more data item in advance +-- while the last received item is not yet fully processed in the chain of +-- streams, usually by the processors. +-- +-- You can think of this as the prefetched stream could place its latest +-- data item in some temporary space for later use, which is very useful +-- for modeling a sequence of separate and independent work places. +prefetchStream :: Stream a -> Stream a +prefetchStream s = Cons z where + z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + writing <- liftSimulation $ newResourceWithMaxCount FCFS 1 (Just 1) + ref <- liftIO $ newIORef Nothing + let writer p = + do (a, xs) <- runStream p + requestResource writing + liftIO $ writeIORef ref (Just a) + releaseResource reading + writer xs + reader = + do requestResource reading + Just a <- liftIO $ readIORef ref + liftIO $ writeIORef ref Nothing + releaseResource writing + return a + spawnProcess CancelTogether $ writer s + runStream $ repeatProcess reader + +-- | Return a stream of values triggered by the specified signal. +-- +-- Since the time at which the values of the stream are requested for may differ from +-- the time at which the signal is triggered, it can be useful to apply the 'arrivalSignal' +-- function to add the information about the time points at which the signal was +-- actually received. +-- +-- The point is that the 'Stream' is requested outside, while the 'Signal' is triggered +-- inside. They are different by nature. The former is passive, while the latter is active. +-- +-- The resulting stream may be a root of space leak as it uses an internal queue to store +-- the values received from the signal. The oldest value is dequeued each time we request +-- the stream and it is returned within the computation. +-- +-- Cancel the stream's process to unsubscribe from the specified signal. +signalStream :: Signal a -> Process (Stream a) +signalStream s = + do q <- liftEvent newFCFSQueue + h <- liftEvent $ + handleSignal s $ + enqueue q + whenCancellingProcess $ disposeEvent h + return $ repeatProcess $ dequeue q + +-- | Return a computation of the signal that triggers values from the specified stream, +-- each time the next value of the stream is received within the underlying 'Process' +-- computation. +-- +-- Cancel the returned process to stop reading from the specified stream. +streamSignal :: Stream a -> Process (Signal a) +streamSignal z = + do s <- liftSimulation newSignalSource + spawnProcess CancelTogether $ + consumeStream (liftEvent . triggerSignal s) z + return $ publishSignal s + +-- | Transform a stream so that the resulting stream returns a sequence of arrivals +-- saving the information about the time points at which the original stream items +-- were received by demand. +arrivalStream :: Stream a -> Stream (Arrival a) +arrivalStream s = Cons $ loop s Nothing where + loop s t0 = do (a, xs) <- runStream s + t <- liftDynamics time + let b = Arrival { arrivalValue = a, + arrivalTime = t, + arrivalDelay = + case t0 of + Nothing -> Nothing + Just t0 -> Just (t - t0) } + return (b, Cons $ loop xs (Just t)) + +-- | Delay the stream by one step using the specified initial value. +delayStream :: a -> Stream a -> Stream a +delayStream a0 s = Cons $ return (a0, s) diff --git a/Simulation/Aivika/Stream/Random.hs b/Simulation/Aivika/Stream/Random.hs --- a/Simulation/Aivika/Stream/Random.hs +++ b/Simulation/Aivika/Stream/Random.hs @@ -1,153 +1,153 @@ - --- | --- Module : Simulation.Aivika.Stream.Random --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- This module defines random streams of events, which are useful --- for describing the input of the model. --- - -module Simulation.Aivika.Stream.Random - (-- * Stream of Random Events - randomStream, - randomUniformStream, - randomUniformIntStream, - randomNormalStream, - randomExponentialStream, - randomErlangStream, - randomPoissonStream, - randomBinomialStream) where - -import System.Random - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Parameter -import Simulation.Aivika.Parameter.Random -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Process -import Simulation.Aivika.Processor -import Simulation.Aivika.Stream -import Simulation.Aivika.Statistics -import Simulation.Aivika.Ref -import Simulation.Aivika.Arrival - --- | Return a sream of random events that arrive with the specified delay. -randomStream :: Parameter (Double, a) - -- ^ compute a pair of the delay and event of type @a@ - -> Stream (Arrival a) - -- ^ a stream of delayed events -randomStream delay = Cons $ loop Nothing where - loop t0 = - do t1 <- liftDynamics time - case t0 of - Nothing -> return () - Just t0 -> - when (t1 /= t0) $ - error $ - "The time of requesting for a new random event is different from " ++ - "the time when the previous event has arrived. Probably, your model " ++ - "contains a logical error. The random events should be requested permanently. " ++ - "At least, they can be lost, for example, when trying to enqueue them, but " ++ - "the random stream itself must always work: randomStream." - (delay, a) <- liftParameter delay - holdProcess delay - t2 <- liftDynamics time - let arrival = Arrival { arrivalValue = a, - arrivalTime = t2, - arrivalDelay = - case t0 of - Nothing -> Nothing - Just t0 -> Just delay } - return (arrival, Cons $ loop (Just t2)) - --- | Create a new stream with delays distributed uniformly. -randomUniformStream :: Double - -- ^ the minimum delay - -> Double - -- ^ the maximum delay - -> Stream (Arrival Double) - -- ^ the stream of random events with the delays generated -randomUniformStream min max = - randomStream $ - randomUniform min max >>= \x -> - return (x, x) - --- | Create a new stream with integer delays distributed uniformly. -randomUniformIntStream :: Int - -- ^ the minimum delay - -> Int - -- ^ the maximum delay - -> Stream (Arrival Int) - -- ^ the stream of random events with the delays generated -randomUniformIntStream min max = - randomStream $ - randomUniformInt min max >>= \x -> - return (fromIntegral x, x) - --- | Create a new stream with delays distributed normally. -randomNormalStream :: Double - -- ^ the mean delay - -> Double - -- ^ the delay deviation - -> Stream (Arrival Double) - -- ^ the stream of random events with the delays generated -randomNormalStream mu nu = - randomStream $ - randomNormal mu nu >>= \x -> - return (x, x) - --- | Return a new stream with delays distibuted exponentially with the specified mean --- (the reciprocal of the rate). -randomExponentialStream :: Double - -- ^ the mean delay (the reciprocal of the rate) - -> Stream (Arrival Double) - -- ^ the stream of random events with the delays generated -randomExponentialStream mu = - randomStream $ - randomExponential mu >>= \x -> - return (x, x) - --- | Return a new stream with delays having the Erlang distribution with the specified --- scale (the reciprocal of the rate) and shape parameters. -randomErlangStream :: Double - -- ^ the scale (the reciprocal of the rate) - -> Int - -- ^ the shape - -> Stream (Arrival Double) - -- ^ the stream of random events with the delays generated -randomErlangStream beta m = - randomStream $ - randomErlang beta m >>= \x -> - return (x, x) - --- | Return a new stream with delays having the Poisson distribution with --- the specified mean. -randomPoissonStream :: Double - -- ^ the mean delay - -> Stream (Arrival Int) - -- ^ the stream of random events with the delays generated -randomPoissonStream mu = - randomStream $ - randomPoisson mu >>= \x -> - return (fromIntegral x, x) - --- | Return a new stream with delays having the binomial distribution with the specified --- probability and trials. -randomBinomialStream :: Double - -- ^ the probability - -> Int - -- ^ the number of trials - -> Stream (Arrival Int) - -- ^ the stream of random events with the delays generated -randomBinomialStream prob trials = - randomStream $ - randomBinomial prob trials >>= \x -> - return (fromIntegral x, x) + +-- | +-- Module : Simulation.Aivika.Stream.Random +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines random streams of events, which are useful +-- for describing the input of the model. +-- + +module Simulation.Aivika.Stream.Random + (-- * Stream of Random Events + randomStream, + randomUniformStream, + randomUniformIntStream, + randomNormalStream, + randomExponentialStream, + randomErlangStream, + randomPoissonStream, + randomBinomialStream) where + +import System.Random + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Parameter +import Simulation.Aivika.Parameter.Random +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Event +import Simulation.Aivika.Process +import Simulation.Aivika.Processor +import Simulation.Aivika.Stream +import Simulation.Aivika.Statistics +import Simulation.Aivika.Ref +import Simulation.Aivika.Arrival + +-- | Return a sream of random events that arrive with the specified delay. +randomStream :: Parameter (Double, a) + -- ^ compute a pair of the delay and event of type @a@ + -> Stream (Arrival a) + -- ^ a stream of delayed events +randomStream delay = Cons $ loop Nothing where + loop t0 = + do t1 <- liftDynamics time + case t0 of + Nothing -> return () + Just t0 -> + when (t1 /= t0) $ + error $ + "The time of requesting for a new random event is different from " ++ + "the time when the previous event has arrived. Probably, your model " ++ + "contains a logical error. The random events should be requested permanently. " ++ + "At least, they can be lost, for example, when trying to enqueue them, but " ++ + "the random stream itself must always work: randomStream." + (delay, a) <- liftParameter delay + holdProcess delay + t2 <- liftDynamics time + let arrival = Arrival { arrivalValue = a, + arrivalTime = t2, + arrivalDelay = + case t0 of + Nothing -> Nothing + Just t0 -> Just delay } + return (arrival, Cons $ loop (Just t2)) + +-- | Create a new stream with delays distributed uniformly. +randomUniformStream :: Double + -- ^ the minimum delay + -> Double + -- ^ the maximum delay + -> Stream (Arrival Double) + -- ^ the stream of random events with the delays generated +randomUniformStream min max = + randomStream $ + randomUniform min max >>= \x -> + return (x, x) + +-- | Create a new stream with integer delays distributed uniformly. +randomUniformIntStream :: Int + -- ^ the minimum delay + -> Int + -- ^ the maximum delay + -> Stream (Arrival Int) + -- ^ the stream of random events with the delays generated +randomUniformIntStream min max = + randomStream $ + randomUniformInt min max >>= \x -> + return (fromIntegral x, x) + +-- | Create a new stream with delays distributed normally. +randomNormalStream :: Double + -- ^ the mean delay + -> Double + -- ^ the delay deviation + -> Stream (Arrival Double) + -- ^ the stream of random events with the delays generated +randomNormalStream mu nu = + randomStream $ + randomNormal mu nu >>= \x -> + return (x, x) + +-- | Return a new stream with delays distibuted exponentially with the specified mean +-- (the reciprocal of the rate). +randomExponentialStream :: Double + -- ^ the mean delay (the reciprocal of the rate) + -> Stream (Arrival Double) + -- ^ the stream of random events with the delays generated +randomExponentialStream mu = + randomStream $ + randomExponential mu >>= \x -> + return (x, x) + +-- | Return a new stream with delays having the Erlang distribution with the specified +-- scale (the reciprocal of the rate) and shape parameters. +randomErlangStream :: Double + -- ^ the scale (the reciprocal of the rate) + -> Int + -- ^ the shape + -> Stream (Arrival Double) + -- ^ the stream of random events with the delays generated +randomErlangStream beta m = + randomStream $ + randomErlang beta m >>= \x -> + return (x, x) + +-- | Return a new stream with delays having the Poisson distribution with +-- the specified mean. +randomPoissonStream :: Double + -- ^ the mean delay + -> Stream (Arrival Int) + -- ^ the stream of random events with the delays generated +randomPoissonStream mu = + randomStream $ + randomPoisson mu >>= \x -> + return (fromIntegral x, x) + +-- | Return a new stream with delays having the binomial distribution with the specified +-- probability and trials. +randomBinomialStream :: Double + -- ^ the probability + -> Int + -- ^ the number of trials + -> Stream (Arrival Int) + -- ^ the stream of random events with the delays generated +randomBinomialStream prob trials = + randomStream $ + randomBinomial prob trials >>= \x -> + return (fromIntegral x, x) diff --git a/Simulation/Aivika/SystemDynamics.hs b/Simulation/Aivika/SystemDynamics.hs --- a/Simulation/Aivika/SystemDynamics.hs +++ b/Simulation/Aivika/SystemDynamics.hs @@ -1,708 +1,708 @@ - -{-# LANGUAGE BangPatterns, RecursiveDo #-} - --- | --- Module : Simulation.Aivika.SystemDynamics --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines integrals and other functions of System Dynamics. --- - -module Simulation.Aivika.SystemDynamics - (-- * Equality and Ordering - (.==.), - (./=.), - (.<.), - (.>=.), - (.>.), - (.<=.), - maxDynamics, - minDynamics, - ifDynamics, - -- * Ordinary Differential Equations - integ, - smoothI, - smooth, - smooth3I, - smooth3, - smoothNI, - smoothN, - delay1I, - delay1, - delay3I, - delay3, - delayNI, - delayN, - forecast, - trend, - -- * Difference Equations - diffsum, - -- * Table Functions - lookupDynamics, - lookupStepwiseDynamics, - -- * Discrete Functions - delay, - delayI, - step, - pulse, - pulseP, - ramp, - -- * Financial Functions - npv, - npve) where - -import Data.Array -import Data.Array.IO.Safe -import Data.IORef -import Control.Monad -import Control.Monad.Trans - -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 -import Simulation.Aivika.Table - -import qualified Simulation.Aivika.Dynamics.Memo as M -import qualified Simulation.Aivika.Dynamics.Memo.Unboxed as MU - --- --- Equality and Ordering --- - --- | Compare for equality. -(.==.) :: (Eq a) => Dynamics a -> Dynamics a -> Dynamics Bool -(.==.) = liftM2 (==) - --- | Compare for inequality. -(./=.) :: (Eq a) => Dynamics a -> Dynamics a -> Dynamics Bool -(./=.) = liftM2 (/=) - --- | Compare for ordering. -(.<.) :: (Ord a) => Dynamics a -> Dynamics a -> Dynamics Bool -(.<.) = liftM2 (<) - --- | Compare for ordering. -(.>=.) :: (Ord a) => Dynamics a -> Dynamics a -> Dynamics Bool -(.>=.) = liftM2 (>=) - --- | Compare for ordering. -(.>.) :: (Ord a) => Dynamics a -> Dynamics a -> Dynamics Bool -(.>.) = liftM2 (>) - --- | Compare for ordering. -(.<=.) :: (Ord a) => Dynamics a -> Dynamics a -> Dynamics Bool -(.<=.) = liftM2 (<=) - --- | Return the maximum. -maxDynamics :: (Ord a) => Dynamics a -> Dynamics a -> Dynamics a -maxDynamics = liftM2 max - --- | Return the minimum. -minDynamics :: (Ord a) => Dynamics a -> Dynamics a -> Dynamics a -minDynamics = liftM2 min - --- | Implement the if-then-else operator. -ifDynamics :: Dynamics Bool -> Dynamics a -> Dynamics a -> Dynamics a -ifDynamics cond x y = - do a <- cond - if a then x else y - --- --- Ordinary Differential Equations --- - -integEuler :: Dynamics Double - -> Dynamics Double - -> Dynamics Double - -> Point -> IO Double -integEuler (Dynamics f) (Dynamics i) (Dynamics y) p = - case pointIteration p of - 0 -> - i p - n -> do - let sc = pointSpecs p - ty = basicTime sc (n - 1) 0 - py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } - a <- y py - b <- f py - let !v = a + spcDT (pointSpecs p) * b - return v - -integRK2 :: Dynamics Double - -> Dynamics Double - -> Dynamics Double - -> Point -> IO Double -integRK2 (Dynamics f) (Dynamics i) (Dynamics y) p = - case pointPhase p of - 0 -> case pointIteration p of - 0 -> - i p - n -> do - let sc = pointSpecs p - ty = basicTime sc (n - 1) 0 - t1 = ty - t2 = basicTime sc (n - 1) 1 - py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } - p1 = py - p2 = p { pointTime = t2, pointIteration = n - 1, pointPhase = 1 } - vy <- y py - k1 <- f p1 - k2 <- f p2 - let !v = vy + spcDT sc / 2.0 * (k1 + k2) - return v - 1 -> do - let sc = pointSpecs p - n = pointIteration p - ty = basicTime sc n 0 - t1 = ty - py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } - p1 = py - vy <- y py - k1 <- f p1 - let !v = vy + spcDT sc * k1 - return v - _ -> - error "Incorrect phase: integRK2" - -integRK4 :: Dynamics Double - -> Dynamics Double - -> Dynamics Double - -> Point -> IO Double -integRK4 (Dynamics f) (Dynamics i) (Dynamics y) p = - case pointPhase p of - 0 -> case pointIteration p of - 0 -> - i p - n -> do - let sc = pointSpecs p - ty = basicTime sc (n - 1) 0 - t1 = ty - t2 = basicTime sc (n - 1) 1 - t3 = basicTime sc (n - 1) 2 - t4 = basicTime sc (n - 1) 3 - py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } - p1 = py - p2 = p { pointTime = t2, pointIteration = n - 1, pointPhase = 1 } - p3 = p { pointTime = t3, pointIteration = n - 1, pointPhase = 2 } - p4 = p { pointTime = t4, pointIteration = n - 1, pointPhase = 3 } - vy <- y py - k1 <- f p1 - k2 <- f p2 - k3 <- f p3 - k4 <- f p4 - let !v = vy + spcDT sc / 6.0 * (k1 + 2.0 * k2 + 2.0 * k3 + k4) - return v - 1 -> do - let sc = pointSpecs p - n = pointIteration p - ty = basicTime sc n 0 - t1 = ty - py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } - p1 = py - vy <- y py - k1 <- f p1 - let !v = vy + spcDT sc / 2.0 * k1 - return v - 2 -> do - let sc = pointSpecs p - n = pointIteration p - ty = basicTime sc n 0 - t2 = basicTime sc n 1 - py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } - p2 = p { pointTime = t2, pointIteration = n, pointPhase = 1 } - vy <- y py - k2 <- f p2 - let !v = vy + spcDT sc / 2.0 * k2 - return v - 3 -> do - let sc = pointSpecs p - n = pointIteration p - ty = basicTime sc n 0 - t3 = basicTime sc n 2 - py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } - p3 = p { pointTime = t3, pointIteration = n, pointPhase = 2 } - vy <- y py - k3 <- f p3 - let !v = vy + spcDT sc * k3 - return v - _ -> - error "Incorrect phase: integRK4" - --- | Return an integral with the specified derivative and initial value. --- --- To create a loopback, you should use the recursive do-notation. --- It allows defining the differential equations unordered as --- in mathematics: --- --- @ --- model :: Simulation [Double] --- model = --- mdo a <- integ (- ka * a) 100 --- b <- integ (ka * a - kb * b) 0 --- c <- integ (kb * b) 0 --- let ka = 1 --- kb = 1 --- runDynamicsInStopTime $ sequence [a, b, c] --- @ -integ :: Dynamics Double -- ^ the derivative - -> Dynamics Double -- ^ the initial value - -> Simulation (Dynamics Double) -- ^ the integral -integ diff i = - mdo y <- MU.memoDynamics z - z <- Simulation $ \r -> - case spcMethod (runSpecs r) of - Euler -> return $ Dynamics $ integEuler diff i y - RungeKutta2 -> return $ Dynamics $ integRK2 diff i y - RungeKutta4 -> return $ Dynamics $ integRK4 diff i y - return y - --- | Return the first order exponential smooth. --- --- To create a loopback, you should use the recursive do-notation --- with help of which the function itself is defined: --- --- @ --- smoothI x t i = --- mdo y <- integ ((x - y) \/ t) i --- return y --- @ -smoothI :: Dynamics Double -- ^ the value to smooth over time - -> Dynamics Double -- ^ time - -> Dynamics Double -- ^ the initial value - -> Simulation (Dynamics Double) -- ^ the first order exponential smooth -smoothI x t i = - mdo y <- integ ((x - y) / t) i - return y - --- | Return the first order exponential smooth. --- --- This is a simplified version of the 'smoothI' function --- without specifing the initial value. -smooth :: Dynamics Double -- ^ the value to smooth over time - -> Dynamics Double -- ^ time - -> Simulation (Dynamics Double) -- ^ the first order exponential smooth -smooth x t = smoothI x t x - --- | Return the third order exponential smooth. --- --- To create a loopback, you should use the recursive do-notation --- with help of which the function itself is defined: --- --- @ --- smooth3I x t i = --- mdo y <- integ ((s2 - y) \/ t') i --- s2 <- integ ((s1 - s2) \/ t') i --- s1 <- integ ((x - s1) \/ t') i --- let t' = t \/ 3.0 --- return y --- @ -smooth3I :: Dynamics Double -- ^ the value to smooth over time - -> Dynamics Double -- ^ time - -> Dynamics Double -- ^ the initial value - -> Simulation (Dynamics Double) -- ^ the third order exponential smooth -smooth3I x t i = - mdo y <- integ ((s2 - y) / t') i - s2 <- integ ((s1 - s2) / t') i - s1 <- integ ((x - s1) / t') i - let t' = t / 3.0 - return y - --- | Return the third order exponential smooth. --- --- This is a simplified version of the 'smooth3I' function --- without specifying the initial value. -smooth3 :: Dynamics Double -- ^ the value to smooth over time - -> Dynamics Double -- ^ time - -> Simulation (Dynamics Double) -- ^ the third order exponential smooth -smooth3 x t = smooth3I x t x - --- | Return the n'th order exponential smooth. --- --- The result is not discrete in that sense that it may change within the integration time --- interval depending on the integration method used. Probably, you should apply --- the 'discreteDynamics' function to the result if you want to achieve an effect when --- the value is not changed within the time interval, which is used sometimes. -smoothNI :: Dynamics Double -- ^ the value to smooth over time - -> Dynamics Double -- ^ time - -> Int -- ^ the order - -> Dynamics Double -- ^ the initial value - -> Simulation (Dynamics Double) -- ^ the n'th order exponential smooth -smoothNI x t n i = - mdo s <- forM [1 .. n] $ \k -> - if k == 1 - then integ ((x - a ! 1) / t') i - else integ ((a ! (k - 1) - a ! k) / t') i - let a = listArray (1, n) s - t' = t / fromIntegral n - return $ a ! n - --- | Return the n'th order exponential smooth. --- --- This is a simplified version of the 'smoothNI' function --- without specifying the initial value. -smoothN :: Dynamics Double -- ^ the value to smooth over time - -> Dynamics Double -- ^ time - -> Int -- ^ the order - -> Simulation (Dynamics Double) -- ^ the n'th order exponential smooth -smoothN x t n = smoothNI x t n x - --- | Return the first order exponential delay. --- --- To create a loopback, you should use the recursive do-notation --- with help of which the function itself is defined: --- --- @ --- delay1I x t i = --- mdo y <- integ (x - y \/ t) (i * t) --- return $ y \/ t --- @ -delay1I :: Dynamics Double -- ^ the value to conserve - -> Dynamics Double -- ^ time - -> Dynamics Double -- ^ the initial value - -> Simulation (Dynamics Double) -- ^ the first order exponential delay -delay1I x t i = - mdo y <- integ (x - y / t) (i * t) - return $ y / t - --- | Return the first order exponential delay. --- --- This is a simplified version of the 'delay1I' function --- without specifying the initial value. -delay1 :: Dynamics Double -- ^ the value to conserve - -> Dynamics Double -- ^ time - -> Simulation (Dynamics Double) -- ^ the first order exponential delay -delay1 x t = delay1I x t x - --- | Return the third order exponential delay. -delay3I :: Dynamics Double -- ^ the value to conserve - -> Dynamics Double -- ^ time - -> Dynamics Double -- ^ the initial value - -> Simulation (Dynamics Double) -- ^ the third order exponential delay -delay3I x t i = - mdo y <- integ (s2 / t' - y / t') (i * t') - s2 <- integ (s1 / t' - s2 / t') (i * t') - s1 <- integ (x - s1 / t') (i * t') - let t' = t / 3.0 - return $ y / t' - --- | Return the third order exponential delay. --- --- This is a simplified version of the 'delay3I' function --- without specifying the initial value. -delay3 :: Dynamics Double -- ^ the value to conserve - -> Dynamics Double -- ^ time - -> Simulation (Dynamics Double) -- ^ the third order exponential delay -delay3 x t = delay3I x t x - --- | Return the n'th order exponential delay. -delayNI :: Dynamics Double -- ^ the value to conserve - -> Dynamics Double -- ^ time - -> Int -- ^ the order - -> Dynamics Double -- ^ the initial value - -> Simulation (Dynamics Double) -- ^ the n'th order exponential delay -delayNI x t n i = - mdo s <- forM [1 .. n] $ \k -> - if k == 1 - then integ (x - (a ! 1) / t') (i * t') - else integ ((a ! (k - 1)) / t' - (a ! k) / t') (i * t') - let a = listArray (1, n) s - t' = t / fromIntegral n - return $ (a ! n) / t' - --- | Return the n'th order exponential delay. --- --- This is a simplified version of the 'delayNI' function --- without specifying the initial value. -delayN :: Dynamics Double -- ^ the value to conserve - -> Dynamics Double -- ^ time - -> Int -- ^ the order - -> Simulation (Dynamics Double) -- ^ the n'th order exponential delay -delayN x t n = delayNI x t n x - --- | Return the forecast. --- --- The function has the following definition: --- --- @ --- forecast x at hz = --- do y <- smooth x at --- return $ x * (1.0 + (x \/ y - 1.0) \/ at * hz) --- @ -forecast :: Dynamics Double -- ^ the value to forecast - -> Dynamics Double -- ^ the average time - -> Dynamics Double -- ^ the time horizon - -> Simulation (Dynamics Double) -- ^ the forecast -forecast x at hz = - do y <- smooth x at - return $ x * (1.0 + (x / y - 1.0) / at * hz) - --- | Return the trend. --- --- The function has the following definition: --- --- @ --- trend x at i = --- do y <- smoothI x at (x \/ (1.0 + i * at)) --- return $ (x \/ y - 1.0) \/ at --- @ -trend :: Dynamics Double -- ^ the value for which the trend is calculated - -> Dynamics Double -- ^ the average time - -> Dynamics Double -- ^ the initial value - -> Simulation (Dynamics Double) -- ^ the fractional change rate -trend x at i = - do y <- smoothI x at (x / (1.0 + i * at)) - return $ (x / y - 1.0) / at - --- --- Difference Equations --- - --- | Retun the sum for the difference equation. --- It is like an integral returned by the 'integ' function, only now --- the difference is used instead of derivative. --- --- As usual, to create a loopback, you should use the recursive do-notation. -diffsum :: (Num a, Unboxed a) - => Dynamics a -- ^ the difference - -> Dynamics a -- ^ the initial value - -> Simulation (Dynamics a) -- ^ the sum -diffsum (Dynamics diff) (Dynamics i) = - mdo y <- - MU.memo0Dynamics $ - Dynamics $ \p -> - case pointIteration p of - 0 -> i p - n -> do - let Dynamics m = y - sc = pointSpecs p - ty = basicTime sc (n - 1) 0 - py = p { pointTime = ty, - pointIteration = n - 1, - pointPhase = 0 } - a <- m py - b <- diff py - let !v = a + b - return v - return y - --- --- Table Functions --- - --- | Lookup @x@ in a table of pairs @(x, y)@ using linear interpolation. -lookupDynamics :: Dynamics Double -> Array Int (Double, Double) -> Dynamics Double -lookupDynamics (Dynamics m) tbl = - Dynamics $ \p -> - do a <- m p - return $ tableLookup a tbl - --- | Lookup @x@ in a table of pairs @(x, y)@ using stepwise function. -lookupStepwiseDynamics :: Dynamics Double -> Array Int (Double, Double) -> Dynamics Double -lookupStepwiseDynamics (Dynamics m) tbl = - Dynamics $ \p -> - do a <- m p - return $ tableLookupStepwise a tbl - --- --- Discrete Functions --- - --- | Return the delayed value using the specified lag time. -delay :: Dynamics a -- ^ the value to delay - -> Dynamics Double -- ^ the lag time - -> Dynamics a -- ^ the delayed value -delay (Dynamics x) (Dynamics d) = discreteDynamics $ Dynamics r - where - r p = do - let t = pointTime p - sc = pointSpecs p - n = pointIteration p - a <- d p - let t' = t - a - n' = fromIntegral $ floor $ (t' - spcStartTime sc) / spcDT sc - y | n' < 0 = x $ p { pointTime = spcStartTime sc, - pointIteration = 0, - pointPhase = 0 } - | n' < n = x $ p { pointTime = t', - pointIteration = n', - pointPhase = -1 } - | n' > n = error $ - "Cannot return the future data: delay. " ++ - "The lag time cannot be negative." - | otherwise = error $ - "Cannot return the current data: delay. " ++ - "The lag time is too small." - y - --- | Return the delayed value using the specified lag time and initial value. --- Because of the latter, it allows creating a loop back. -delayI :: Dynamics a -- ^ the value to delay - -> Dynamics Double -- ^ the lag time - -> Dynamics a -- ^ the initial value - -> Simulation (Dynamics a) -- ^ the delayed value -delayI (Dynamics x) (Dynamics d) (Dynamics i) = M.memo0Dynamics $ Dynamics r - where - r p = do - let t = pointTime p - sc = pointSpecs p - n = pointIteration p - a <- d p - let t' = t - a - n' = fromIntegral $ floor $ (t' - spcStartTime sc) / spcDT sc - y | n' < 0 = i $ p { pointTime = spcStartTime sc, - pointIteration = 0, - pointPhase = 0 } - | n' < n = x $ p { pointTime = t', - pointIteration = n', - pointPhase = -1 } - | n' > n = error $ - "Cannot return the future data: delay. " ++ - "The lag time cannot be negative." - | otherwise = error $ - "Cannot return the current data: delay. " ++ - "The lag time is too small." - y - --- --- Financial Functions --- - --- | Return the Net Present Value (NPV) of the stream computed using the specified --- discount rate, the initial value and some factor (usually 1). --- --- It is defined in the following way: --- --- @ --- npv stream rate init factor = --- mdo let dt' = liftParameter dt --- df <- integ (- df * rate) 1 --- accum <- integ (stream * df) init --- return $ (accum + dt' * stream * df) * factor --- @ -npv :: Dynamics Double -- ^ the stream - -> Dynamics Double -- ^ the discount rate - -> Dynamics Double -- ^ the initial value - -> Dynamics Double -- ^ factor - -> Simulation (Dynamics Double) -- ^ the Net Present Value (NPV) -npv stream rate init factor = - mdo let dt' = liftParameter dt - df <- integ (- df * rate) 1 - accum <- integ (stream * df) init - return $ (accum + dt' * stream * df) * factor - --- | Return the Net Present Value End of period (NPVE) of the stream computed --- using the specified discount rate, the initial value and some factor. --- --- It is defined in the following way: --- --- @ --- npve stream rate init factor = --- mdo let dt' = liftParameter dt --- df <- integ (- df * rate \/ (1 + rate * dt')) (1 \/ (1 + rate * dt')) --- accum <- integ (stream * df) init --- return $ (accum + dt' * stream * df) * factor --- @ -npve :: Dynamics Double -- ^ the stream - -> Dynamics Double -- ^ the discount rate - -> Dynamics Double -- ^ the initial value - -> Dynamics Double -- ^ factor - -> Simulation (Dynamics Double) -- ^ the Net Present Value End (NPVE) -npve stream rate init factor = - mdo let dt' = liftParameter dt - df <- integ (- df * rate / (1 + rate * dt')) (1 / (1 + rate * dt')) - accum <- integ (stream * df) init - return $ (accum + dt' * stream * df) * factor - --- | Computation that returns 0 until the step time and then returns the specified height. -step :: Dynamics Double - -- ^ the height - -> Dynamics Double - -- ^ the step time - -> Dynamics Double -step h st = - discreteDynamics $ - Dynamics $ \p -> - do let sc = pointSpecs p - t = pointTime p - st' <- invokeDynamics p st - let t' = t + spcDT sc / 2 - if st' < t' - then invokeDynamics p h - else return 0 - --- | Computation that returns 1, starting at the time start, and lasting for the interval --- width; 0 is returned at all other times. -pulse :: Dynamics Double - -- ^ the time start - -> Dynamics Double - -- ^ the interval width - -> Dynamics Double -pulse st w = - discreteDynamics $ - Dynamics $ \p -> - do let sc = pointSpecs p - t = pointTime p - st' <- invokeDynamics p st - let t' = t + spcDT sc / 2 - if st' < t' - then do w' <- invokeDynamics p w - return $ if t' < st' + w' then 1 else 0 - else return 0 - --- | Computation that returns 1, starting at the time start, and lasting for the interval --- width and then repeats this pattern with the specified period; 0 is returned at all --- other times. -pulseP :: Dynamics Double - -- ^ the time start - -> Dynamics Double - -- ^ the interval width - -> Dynamics Double - -- ^ the time period - -> Dynamics Double -pulseP st w period = - discreteDynamics $ - Dynamics $ \p -> - do let sc = pointSpecs p - t = pointTime p - p' <- invokeDynamics p period - st' <- invokeDynamics p st - let y' = if (p' > 0) && (t > st') - then fromIntegral (floor $ (t - st') / p') * p' - else 0 - let st' = st' + y' - let t' = t + spcDT sc / 2 - if st' < t' - then do w' <- invokeDynamics p w - return $ if t' < st' + w' then 1 else 0 - else return 0 - --- | Computation that returns 0 until the specified time start and then --- slopes upward until the end time and then holds constant. -ramp :: Dynamics Double - -- ^ the slope parameter - -> Dynamics Double - -- ^ the time start - -> Dynamics Double - -- ^ the end time - -> Dynamics Double -ramp slope st e = - discreteDynamics $ - Dynamics $ \p -> - do let sc = pointSpecs p - t = pointTime p - st' <- invokeDynamics p st - if st' < t - then do slope' <- invokeDynamics p slope - e' <- invokeDynamics p e - if t < e' - then return $ slope' * (t - st') - else return $ slope' * (e' - st') - else return 0 - + +{-# LANGUAGE BangPatterns, RecursiveDo #-} + +-- | +-- Module : Simulation.Aivika.SystemDynamics +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines integrals and other functions of System Dynamics. +-- + +module Simulation.Aivika.SystemDynamics + (-- * Equality and Ordering + (.==.), + (./=.), + (.<.), + (.>=.), + (.>.), + (.<=.), + maxDynamics, + minDynamics, + ifDynamics, + -- * Ordinary Differential Equations + integ, + smoothI, + smooth, + smooth3I, + smooth3, + smoothNI, + smoothN, + delay1I, + delay1, + delay3I, + delay3, + delayNI, + delayN, + forecast, + trend, + -- * Difference Equations + diffsum, + -- * Table Functions + lookupDynamics, + lookupStepwiseDynamics, + -- * Discrete Functions + delay, + delayI, + step, + pulse, + pulseP, + ramp, + -- * Financial Functions + npv, + npve) where + +import Data.Array +import Data.Array.IO.Safe +import Data.IORef +import Control.Monad +import Control.Monad.Trans + +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 +import Simulation.Aivika.Table + +import qualified Simulation.Aivika.Dynamics.Memo as M +import qualified Simulation.Aivika.Dynamics.Memo.Unboxed as MU + +-- +-- Equality and Ordering +-- + +-- | Compare for equality. +(.==.) :: (Eq a) => Dynamics a -> Dynamics a -> Dynamics Bool +(.==.) = liftM2 (==) + +-- | Compare for inequality. +(./=.) :: (Eq a) => Dynamics a -> Dynamics a -> Dynamics Bool +(./=.) = liftM2 (/=) + +-- | Compare for ordering. +(.<.) :: (Ord a) => Dynamics a -> Dynamics a -> Dynamics Bool +(.<.) = liftM2 (<) + +-- | Compare for ordering. +(.>=.) :: (Ord a) => Dynamics a -> Dynamics a -> Dynamics Bool +(.>=.) = liftM2 (>=) + +-- | Compare for ordering. +(.>.) :: (Ord a) => Dynamics a -> Dynamics a -> Dynamics Bool +(.>.) = liftM2 (>) + +-- | Compare for ordering. +(.<=.) :: (Ord a) => Dynamics a -> Dynamics a -> Dynamics Bool +(.<=.) = liftM2 (<=) + +-- | Return the maximum. +maxDynamics :: (Ord a) => Dynamics a -> Dynamics a -> Dynamics a +maxDynamics = liftM2 max + +-- | Return the minimum. +minDynamics :: (Ord a) => Dynamics a -> Dynamics a -> Dynamics a +minDynamics = liftM2 min + +-- | Implement the if-then-else operator. +ifDynamics :: Dynamics Bool -> Dynamics a -> Dynamics a -> Dynamics a +ifDynamics cond x y = + do a <- cond + if a then x else y + +-- +-- Ordinary Differential Equations +-- + +integEuler :: Dynamics Double + -> Dynamics Double + -> Dynamics Double + -> Point -> IO Double +integEuler (Dynamics f) (Dynamics i) (Dynamics y) p = + case pointIteration p of + 0 -> + i p + n -> do + let sc = pointSpecs p + ty = basicTime sc (n - 1) 0 + py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } + a <- y py + b <- f py + let !v = a + spcDT (pointSpecs p) * b + return v + +integRK2 :: Dynamics Double + -> Dynamics Double + -> Dynamics Double + -> Point -> IO Double +integRK2 (Dynamics f) (Dynamics i) (Dynamics y) p = + case pointPhase p of + 0 -> case pointIteration p of + 0 -> + i p + n -> do + let sc = pointSpecs p + ty = basicTime sc (n - 1) 0 + t1 = ty + t2 = basicTime sc (n - 1) 1 + py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } + p1 = py + p2 = p { pointTime = t2, pointIteration = n - 1, pointPhase = 1 } + vy <- y py + k1 <- f p1 + k2 <- f p2 + let !v = vy + spcDT sc / 2.0 * (k1 + k2) + return v + 1 -> do + let sc = pointSpecs p + n = pointIteration p + ty = basicTime sc n 0 + t1 = ty + py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } + p1 = py + vy <- y py + k1 <- f p1 + let !v = vy + spcDT sc * k1 + return v + _ -> + error "Incorrect phase: integRK2" + +integRK4 :: Dynamics Double + -> Dynamics Double + -> Dynamics Double + -> Point -> IO Double +integRK4 (Dynamics f) (Dynamics i) (Dynamics y) p = + case pointPhase p of + 0 -> case pointIteration p of + 0 -> + i p + n -> do + let sc = pointSpecs p + ty = basicTime sc (n - 1) 0 + t1 = ty + t2 = basicTime sc (n - 1) 1 + t3 = basicTime sc (n - 1) 2 + t4 = basicTime sc (n - 1) 3 + py = p { pointTime = ty, pointIteration = n - 1, pointPhase = 0 } + p1 = py + p2 = p { pointTime = t2, pointIteration = n - 1, pointPhase = 1 } + p3 = p { pointTime = t3, pointIteration = n - 1, pointPhase = 2 } + p4 = p { pointTime = t4, pointIteration = n - 1, pointPhase = 3 } + vy <- y py + k1 <- f p1 + k2 <- f p2 + k3 <- f p3 + k4 <- f p4 + let !v = vy + spcDT sc / 6.0 * (k1 + 2.0 * k2 + 2.0 * k3 + k4) + return v + 1 -> do + let sc = pointSpecs p + n = pointIteration p + ty = basicTime sc n 0 + t1 = ty + py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } + p1 = py + vy <- y py + k1 <- f p1 + let !v = vy + spcDT sc / 2.0 * k1 + return v + 2 -> do + let sc = pointSpecs p + n = pointIteration p + ty = basicTime sc n 0 + t2 = basicTime sc n 1 + py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } + p2 = p { pointTime = t2, pointIteration = n, pointPhase = 1 } + vy <- y py + k2 <- f p2 + let !v = vy + spcDT sc / 2.0 * k2 + return v + 3 -> do + let sc = pointSpecs p + n = pointIteration p + ty = basicTime sc n 0 + t3 = basicTime sc n 2 + py = p { pointTime = ty, pointIteration = n, pointPhase = 0 } + p3 = p { pointTime = t3, pointIteration = n, pointPhase = 2 } + vy <- y py + k3 <- f p3 + let !v = vy + spcDT sc * k3 + return v + _ -> + error "Incorrect phase: integRK4" + +-- | Return an integral with the specified derivative and initial value. +-- +-- To create a loopback, you should use the recursive do-notation. +-- It allows defining the differential equations unordered as +-- in mathematics: +-- +-- @ +-- model :: Simulation [Double] +-- model = +-- mdo a <- integ (- ka * a) 100 +-- b <- integ (ka * a - kb * b) 0 +-- c <- integ (kb * b) 0 +-- let ka = 1 +-- kb = 1 +-- runDynamicsInStopTime $ sequence [a, b, c] +-- @ +integ :: Dynamics Double -- ^ the derivative + -> Dynamics Double -- ^ the initial value + -> Simulation (Dynamics Double) -- ^ the integral +integ diff i = + mdo y <- MU.memoDynamics z + z <- Simulation $ \r -> + case spcMethod (runSpecs r) of + Euler -> return $ Dynamics $ integEuler diff i y + RungeKutta2 -> return $ Dynamics $ integRK2 diff i y + RungeKutta4 -> return $ Dynamics $ integRK4 diff i y + return y + +-- | Return the first order exponential smooth. +-- +-- To create a loopback, you should use the recursive do-notation +-- with help of which the function itself is defined: +-- +-- @ +-- smoothI x t i = +-- mdo y <- integ ((x - y) \/ t) i +-- return y +-- @ +smoothI :: Dynamics Double -- ^ the value to smooth over time + -> Dynamics Double -- ^ time + -> Dynamics Double -- ^ the initial value + -> Simulation (Dynamics Double) -- ^ the first order exponential smooth +smoothI x t i = + mdo y <- integ ((x - y) / t) i + return y + +-- | Return the first order exponential smooth. +-- +-- This is a simplified version of the 'smoothI' function +-- without specifing the initial value. +smooth :: Dynamics Double -- ^ the value to smooth over time + -> Dynamics Double -- ^ time + -> Simulation (Dynamics Double) -- ^ the first order exponential smooth +smooth x t = smoothI x t x + +-- | Return the third order exponential smooth. +-- +-- To create a loopback, you should use the recursive do-notation +-- with help of which the function itself is defined: +-- +-- @ +-- smooth3I x t i = +-- mdo y <- integ ((s2 - y) \/ t') i +-- s2 <- integ ((s1 - s2) \/ t') i +-- s1 <- integ ((x - s1) \/ t') i +-- let t' = t \/ 3.0 +-- return y +-- @ +smooth3I :: Dynamics Double -- ^ the value to smooth over time + -> Dynamics Double -- ^ time + -> Dynamics Double -- ^ the initial value + -> Simulation (Dynamics Double) -- ^ the third order exponential smooth +smooth3I x t i = + mdo y <- integ ((s2 - y) / t') i + s2 <- integ ((s1 - s2) / t') i + s1 <- integ ((x - s1) / t') i + let t' = t / 3.0 + return y + +-- | Return the third order exponential smooth. +-- +-- This is a simplified version of the 'smooth3I' function +-- without specifying the initial value. +smooth3 :: Dynamics Double -- ^ the value to smooth over time + -> Dynamics Double -- ^ time + -> Simulation (Dynamics Double) -- ^ the third order exponential smooth +smooth3 x t = smooth3I x t x + +-- | Return the n'th order exponential smooth. +-- +-- The result is not discrete in that sense that it may change within the integration time +-- interval depending on the integration method used. Probably, you should apply +-- the 'discreteDynamics' function to the result if you want to achieve an effect when +-- the value is not changed within the time interval, which is used sometimes. +smoothNI :: Dynamics Double -- ^ the value to smooth over time + -> Dynamics Double -- ^ time + -> Int -- ^ the order + -> Dynamics Double -- ^ the initial value + -> Simulation (Dynamics Double) -- ^ the n'th order exponential smooth +smoothNI x t n i = + mdo s <- forM [1 .. n] $ \k -> + if k == 1 + then integ ((x - a ! 1) / t') i + else integ ((a ! (k - 1) - a ! k) / t') i + let a = listArray (1, n) s + t' = t / fromIntegral n + return $ a ! n + +-- | Return the n'th order exponential smooth. +-- +-- This is a simplified version of the 'smoothNI' function +-- without specifying the initial value. +smoothN :: Dynamics Double -- ^ the value to smooth over time + -> Dynamics Double -- ^ time + -> Int -- ^ the order + -> Simulation (Dynamics Double) -- ^ the n'th order exponential smooth +smoothN x t n = smoothNI x t n x + +-- | Return the first order exponential delay. +-- +-- To create a loopback, you should use the recursive do-notation +-- with help of which the function itself is defined: +-- +-- @ +-- delay1I x t i = +-- mdo y <- integ (x - y \/ t) (i * t) +-- return $ y \/ t +-- @ +delay1I :: Dynamics Double -- ^ the value to conserve + -> Dynamics Double -- ^ time + -> Dynamics Double -- ^ the initial value + -> Simulation (Dynamics Double) -- ^ the first order exponential delay +delay1I x t i = + mdo y <- integ (x - y / t) (i * t) + return $ y / t + +-- | Return the first order exponential delay. +-- +-- This is a simplified version of the 'delay1I' function +-- without specifying the initial value. +delay1 :: Dynamics Double -- ^ the value to conserve + -> Dynamics Double -- ^ time + -> Simulation (Dynamics Double) -- ^ the first order exponential delay +delay1 x t = delay1I x t x + +-- | Return the third order exponential delay. +delay3I :: Dynamics Double -- ^ the value to conserve + -> Dynamics Double -- ^ time + -> Dynamics Double -- ^ the initial value + -> Simulation (Dynamics Double) -- ^ the third order exponential delay +delay3I x t i = + mdo y <- integ (s2 / t' - y / t') (i * t') + s2 <- integ (s1 / t' - s2 / t') (i * t') + s1 <- integ (x - s1 / t') (i * t') + let t' = t / 3.0 + return $ y / t' + +-- | Return the third order exponential delay. +-- +-- This is a simplified version of the 'delay3I' function +-- without specifying the initial value. +delay3 :: Dynamics Double -- ^ the value to conserve + -> Dynamics Double -- ^ time + -> Simulation (Dynamics Double) -- ^ the third order exponential delay +delay3 x t = delay3I x t x + +-- | Return the n'th order exponential delay. +delayNI :: Dynamics Double -- ^ the value to conserve + -> Dynamics Double -- ^ time + -> Int -- ^ the order + -> Dynamics Double -- ^ the initial value + -> Simulation (Dynamics Double) -- ^ the n'th order exponential delay +delayNI x t n i = + mdo s <- forM [1 .. n] $ \k -> + if k == 1 + then integ (x - (a ! 1) / t') (i * t') + else integ ((a ! (k - 1)) / t' - (a ! k) / t') (i * t') + let a = listArray (1, n) s + t' = t / fromIntegral n + return $ (a ! n) / t' + +-- | Return the n'th order exponential delay. +-- +-- This is a simplified version of the 'delayNI' function +-- without specifying the initial value. +delayN :: Dynamics Double -- ^ the value to conserve + -> Dynamics Double -- ^ time + -> Int -- ^ the order + -> Simulation (Dynamics Double) -- ^ the n'th order exponential delay +delayN x t n = delayNI x t n x + +-- | Return the forecast. +-- +-- The function has the following definition: +-- +-- @ +-- forecast x at hz = +-- do y <- smooth x at +-- return $ x * (1.0 + (x \/ y - 1.0) \/ at * hz) +-- @ +forecast :: Dynamics Double -- ^ the value to forecast + -> Dynamics Double -- ^ the average time + -> Dynamics Double -- ^ the time horizon + -> Simulation (Dynamics Double) -- ^ the forecast +forecast x at hz = + do y <- smooth x at + return $ x * (1.0 + (x / y - 1.0) / at * hz) + +-- | Return the trend. +-- +-- The function has the following definition: +-- +-- @ +-- trend x at i = +-- do y <- smoothI x at (x \/ (1.0 + i * at)) +-- return $ (x \/ y - 1.0) \/ at +-- @ +trend :: Dynamics Double -- ^ the value for which the trend is calculated + -> Dynamics Double -- ^ the average time + -> Dynamics Double -- ^ the initial value + -> Simulation (Dynamics Double) -- ^ the fractional change rate +trend x at i = + do y <- smoothI x at (x / (1.0 + i * at)) + return $ (x / y - 1.0) / at + +-- +-- Difference Equations +-- + +-- | Retun the sum for the difference equation. +-- It is like an integral returned by the 'integ' function, only now +-- the difference is used instead of derivative. +-- +-- As usual, to create a loopback, you should use the recursive do-notation. +diffsum :: (Num a, Unboxed a) + => Dynamics a -- ^ the difference + -> Dynamics a -- ^ the initial value + -> Simulation (Dynamics a) -- ^ the sum +diffsum (Dynamics diff) (Dynamics i) = + mdo y <- + MU.memo0Dynamics $ + Dynamics $ \p -> + case pointIteration p of + 0 -> i p + n -> do + let Dynamics m = y + sc = pointSpecs p + ty = basicTime sc (n - 1) 0 + py = p { pointTime = ty, + pointIteration = n - 1, + pointPhase = 0 } + a <- m py + b <- diff py + let !v = a + b + return v + return y + +-- +-- Table Functions +-- + +-- | Lookup @x@ in a table of pairs @(x, y)@ using linear interpolation. +lookupDynamics :: Dynamics Double -> Array Int (Double, Double) -> Dynamics Double +lookupDynamics (Dynamics m) tbl = + Dynamics $ \p -> + do a <- m p + return $ tableLookup a tbl + +-- | Lookup @x@ in a table of pairs @(x, y)@ using stepwise function. +lookupStepwiseDynamics :: Dynamics Double -> Array Int (Double, Double) -> Dynamics Double +lookupStepwiseDynamics (Dynamics m) tbl = + Dynamics $ \p -> + do a <- m p + return $ tableLookupStepwise a tbl + +-- +-- Discrete Functions +-- + +-- | Return the delayed value using the specified lag time. +delay :: Dynamics a -- ^ the value to delay + -> Dynamics Double -- ^ the lag time + -> Dynamics a -- ^ the delayed value +delay (Dynamics x) (Dynamics d) = discreteDynamics $ Dynamics r + where + r p = do + let t = pointTime p + sc = pointSpecs p + n = pointIteration p + a <- d p + let t' = t - a + n' = fromIntegral $ floor $ (t' - spcStartTime sc) / spcDT sc + y | n' < 0 = x $ p { pointTime = spcStartTime sc, + pointIteration = 0, + pointPhase = 0 } + | n' < n = x $ p { pointTime = t', + pointIteration = n', + pointPhase = -1 } + | n' > n = error $ + "Cannot return the future data: delay. " ++ + "The lag time cannot be negative." + | otherwise = error $ + "Cannot return the current data: delay. " ++ + "The lag time is too small." + y + +-- | Return the delayed value using the specified lag time and initial value. +-- Because of the latter, it allows creating a loop back. +delayI :: Dynamics a -- ^ the value to delay + -> Dynamics Double -- ^ the lag time + -> Dynamics a -- ^ the initial value + -> Simulation (Dynamics a) -- ^ the delayed value +delayI (Dynamics x) (Dynamics d) (Dynamics i) = M.memo0Dynamics $ Dynamics r + where + r p = do + let t = pointTime p + sc = pointSpecs p + n = pointIteration p + a <- d p + let t' = t - a + n' = fromIntegral $ floor $ (t' - spcStartTime sc) / spcDT sc + y | n' < 0 = i $ p { pointTime = spcStartTime sc, + pointIteration = 0, + pointPhase = 0 } + | n' < n = x $ p { pointTime = t', + pointIteration = n', + pointPhase = -1 } + | n' > n = error $ + "Cannot return the future data: delay. " ++ + "The lag time cannot be negative." + | otherwise = error $ + "Cannot return the current data: delay. " ++ + "The lag time is too small." + y + +-- +-- Financial Functions +-- + +-- | Return the Net Present Value (NPV) of the stream computed using the specified +-- discount rate, the initial value and some factor (usually 1). +-- +-- It is defined in the following way: +-- +-- @ +-- npv stream rate init factor = +-- mdo let dt' = liftParameter dt +-- df <- integ (- df * rate) 1 +-- accum <- integ (stream * df) init +-- return $ (accum + dt' * stream * df) * factor +-- @ +npv :: Dynamics Double -- ^ the stream + -> Dynamics Double -- ^ the discount rate + -> Dynamics Double -- ^ the initial value + -> Dynamics Double -- ^ factor + -> Simulation (Dynamics Double) -- ^ the Net Present Value (NPV) +npv stream rate init factor = + mdo let dt' = liftParameter dt + df <- integ (- df * rate) 1 + accum <- integ (stream * df) init + return $ (accum + dt' * stream * df) * factor + +-- | Return the Net Present Value End of period (NPVE) of the stream computed +-- using the specified discount rate, the initial value and some factor. +-- +-- It is defined in the following way: +-- +-- @ +-- npve stream rate init factor = +-- mdo let dt' = liftParameter dt +-- df <- integ (- df * rate \/ (1 + rate * dt')) (1 \/ (1 + rate * dt')) +-- accum <- integ (stream * df) init +-- return $ (accum + dt' * stream * df) * factor +-- @ +npve :: Dynamics Double -- ^ the stream + -> Dynamics Double -- ^ the discount rate + -> Dynamics Double -- ^ the initial value + -> Dynamics Double -- ^ factor + -> Simulation (Dynamics Double) -- ^ the Net Present Value End (NPVE) +npve stream rate init factor = + mdo let dt' = liftParameter dt + df <- integ (- df * rate / (1 + rate * dt')) (1 / (1 + rate * dt')) + accum <- integ (stream * df) init + return $ (accum + dt' * stream * df) * factor + +-- | Computation that returns 0 until the step time and then returns the specified height. +step :: Dynamics Double + -- ^ the height + -> Dynamics Double + -- ^ the step time + -> Dynamics Double +step h st = + discreteDynamics $ + Dynamics $ \p -> + do let sc = pointSpecs p + t = pointTime p + st' <- invokeDynamics p st + let t' = t + spcDT sc / 2 + if st' < t' + then invokeDynamics p h + else return 0 + +-- | Computation that returns 1, starting at the time start, and lasting for the interval +-- width; 0 is returned at all other times. +pulse :: Dynamics Double + -- ^ the time start + -> Dynamics Double + -- ^ the interval width + -> Dynamics Double +pulse st w = + discreteDynamics $ + Dynamics $ \p -> + do let sc = pointSpecs p + t = pointTime p + st' <- invokeDynamics p st + let t' = t + spcDT sc / 2 + if st' < t' + then do w' <- invokeDynamics p w + return $ if t' < st' + w' then 1 else 0 + else return 0 + +-- | Computation that returns 1, starting at the time start, and lasting for the interval +-- width and then repeats this pattern with the specified period; 0 is returned at all +-- other times. +pulseP :: Dynamics Double + -- ^ the time start + -> Dynamics Double + -- ^ the interval width + -> Dynamics Double + -- ^ the time period + -> Dynamics Double +pulseP st w period = + discreteDynamics $ + Dynamics $ \p -> + do let sc = pointSpecs p + t = pointTime p + p' <- invokeDynamics p period + st' <- invokeDynamics p st + let y' = if (p' > 0) && (t > st') + then fromIntegral (floor $ (t - st') / p') * p' + else 0 + let st' = st' + y' + let t' = t + spcDT sc / 2 + if st' < t' + then do w' <- invokeDynamics p w + return $ if t' < st' + w' then 1 else 0 + else return 0 + +-- | Computation that returns 0 until the specified time start and then +-- slopes upward until the end time and then holds constant. +ramp :: Dynamics Double + -- ^ the slope parameter + -> Dynamics Double + -- ^ the time start + -> Dynamics Double + -- ^ the end time + -> Dynamics Double +ramp slope st e = + discreteDynamics $ + Dynamics $ \p -> + do let sc = pointSpecs p + t = pointTime p + st' <- invokeDynamics p st + if st' < t + then do slope' <- invokeDynamics p slope + e' <- invokeDynamics p e + if t < e' + then return $ slope' * (t - st') + else return $ slope' * (e' - st') + else return 0 + diff --git a/Simulation/Aivika/Table.hs b/Simulation/Aivika/Table.hs --- a/Simulation/Aivika/Table.hs +++ b/Simulation/Aivika/Table.hs @@ -1,64 +1,64 @@ - --- | --- Module : Simulation.Aivika.Table --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- It defines the table functions. --- -module Simulation.Aivika.Table - (tableLookup, - tableLookupStepwise) where - -import Data.Array - --- | Lookup @x@ in a table of pairs @(x, y)@ using linear interpolation. -tableLookup :: Double -> Array Int (Double, Double) -> Double -tableLookup x tbl = find first last x - where - (first, last) = bounds tbl - find left right x = - if left > right then - error "Incorrect index: tableLookup" - else - let index = (left + 1 + right) `div` 2 - x1 = fst $ tbl ! index - in if x1 <= x then - let y | index < right = find index right x - | right == last = snd $ tbl ! right - | otherwise = - let x2 = fst $ tbl ! (index + 1) - y1 = snd $ tbl ! index - y2 = snd $ tbl ! (index + 1) - in y1 + (y2 - y1) * (x - x1) / (x2 - x1) - in y - else - let y | left < index = find left (index - 1) x - | left == first = snd $ tbl ! left - | otherwise = error "Incorrect index: tableLookup" - in y - --- | Lookup @x@ in a table of pairs @(x, y)@ using stepwise function. -tableLookupStepwise :: Double -> Array Int (Double, Double) -> Double -tableLookupStepwise x tbl = find first last x - where - (first, last) = bounds tbl - find left right x = - if left > right then - error "Incorrect index: tableLookupStepwise" - else - let index = (left + 1 + right) `div` 2 - x1 = fst $ tbl ! index - in if x1 <= x then - let y | index < right = find index right x - | right == last = snd $ tbl ! right - | otherwise = snd $ tbl ! right - in y - else - let y | left < index = find left (index - 1) x - | left == first = snd $ tbl ! left - | otherwise = error "Incorrect index: tableLookupStepwise" - in y + +-- | +-- Module : Simulation.Aivika.Table +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- It defines the table functions. +-- +module Simulation.Aivika.Table + (tableLookup, + tableLookupStepwise) where + +import Data.Array + +-- | Lookup @x@ in a table of pairs @(x, y)@ using linear interpolation. +tableLookup :: Double -> Array Int (Double, Double) -> Double +tableLookup x tbl = find first last x + where + (first, last) = bounds tbl + find left right x = + if left > right then + error "Incorrect index: tableLookup" + else + let index = (left + 1 + right) `div` 2 + x1 = fst $ tbl ! index + in if x1 <= x then + let y | index < right = find index right x + | right == last = snd $ tbl ! right + | otherwise = + let x2 = fst $ tbl ! (index + 1) + y1 = snd $ tbl ! index + y2 = snd $ tbl ! (index + 1) + in y1 + (y2 - y1) * (x - x1) / (x2 - x1) + in y + else + let y | left < index = find left (index - 1) x + | left == first = snd $ tbl ! left + | otherwise = error "Incorrect index: tableLookup" + in y + +-- | Lookup @x@ in a table of pairs @(x, y)@ using stepwise function. +tableLookupStepwise :: Double -> Array Int (Double, Double) -> Double +tableLookupStepwise x tbl = find first last x + where + (first, last) = bounds tbl + find left right x = + if left > right then + error "Incorrect index: tableLookupStepwise" + else + let index = (left + 1 + right) `div` 2 + x1 = fst $ tbl ! index + in if x1 <= x then + let y | index < right = find index right x + | right == last = snd $ tbl ! right + | otherwise = snd $ tbl ! right + in y + else + let y | left < index = find left (index - 1) x + | left == first = snd $ tbl ! left + | otherwise = error "Incorrect index: tableLookupStepwise" + in y diff --git a/Simulation/Aivika/Task.hs b/Simulation/Aivika/Task.hs --- a/Simulation/Aivika/Task.hs +++ b/Simulation/Aivika/Task.hs @@ -1,168 +1,168 @@ - --- | --- Module : Simulation.Aivika.Task --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The 'Task' value represents a process that was already started in background. --- We can check the completion of the task, receive notifications about changing --- its state and even suspend an outer process awaiting the final result of the task. --- It complements the 'Process' monad as it allows immediately continuing the main --- computation without suspension. --- -module Simulation.Aivika.Task - (-- * Task - Task, - TaskResult(..), - taskId, - tryGetTaskResult, - taskResult, - taskResultReceived, - taskProcess, - cancelTask, - taskCancelled, - -- * Running Task - runTask, - runTaskUsingId, - -- * Spawning Tasks - spawnTask, - spawnTaskUsingId, - -- * Enqueueing Task - enqueueTask, - enqueueTaskUsingId) where - -import Data.IORef -import Data.Monoid - -import Control.Monad -import Control.Monad.Trans -import Control.Exception - -import Simulation.Aivika.Internal.Simulation -import Simulation.Aivika.Internal.Dynamics -import Simulation.Aivika.Internal.Event -import Simulation.Aivika.Internal.Cont -import Simulation.Aivika.Internal.Process -import Simulation.Aivika.Internal.Signal - --- | The task represents a process that was already started in background. -data Task a = - Task { taskId :: ProcessId, - -- ^ Return an identifier for the process that was launched - -- in background for this task. - taskResultRef :: IORef (Maybe (TaskResult a)), - -- ^ It contains the result of the computation. - taskResultReceived :: Signal (TaskResult a) - -- ^ Return a signal that notifies about receiving - -- the result of the task. - } - --- | Represents the result of the task. -data TaskResult a = TaskCompleted a - -- ^ the task was successfully completed and - -- it returned the specified result - | TaskError IOException - -- ^ the specified exception was raised when performing the task. - | TaskCancelled - -- ^ the task was cancelled - --- | Try to get the task result immediately without suspension. -tryGetTaskResult :: Task a -> Event (Maybe (TaskResult a)) -tryGetTaskResult t = - Event $ \p -> readIORef (taskResultRef t) - --- | Return the task result suspending the outer process if required. -taskResult :: Task a -> Process (TaskResult a) -taskResult t = - do x <- liftIO $ readIORef (taskResultRef t) - case x of - Just x -> return x - Nothing -> processAwait (taskResultReceived t) - --- | Cancel the task. -cancelTask :: Task a -> Event () -cancelTask t = - cancelProcessWithId (taskId t) - --- | Test whether the task was cancelled. -taskCancelled :: Task a -> Event Bool -taskCancelled t = - processCancelled (taskId t) - --- | Create a task by the specified process and its identifier. -newTaskUsingId :: ProcessId -> Process a -> Event (Task a, Process ()) -newTaskUsingId pid p = - do r <- liftIO $ newIORef Nothing - s <- liftSimulation newSignalSource - let t = Task { taskId = pid, - taskResultRef = r, - taskResultReceived = publishSignal s } - let m = - do v <- liftIO $ newIORef TaskCancelled - finallyProcess - (catchProcess - (do a <- p - liftIO $ writeIORef v (TaskCompleted a)) - (\e -> - liftIO $ writeIORef v (TaskError e))) - (liftEvent $ - do x <- liftIO $ readIORef v - liftIO $ writeIORef r (Just x) - triggerSignal s x) - return (t, m) - --- | Run the process with the specified identifier in background and --- return the corresponded task immediately. -runTaskUsingId :: ProcessId -> Process a -> Event (Task a) -runTaskUsingId pid p = - do (t, m) <- newTaskUsingId pid p - runProcessUsingId pid m - return t - --- | Run the process in background and return the corresponded task immediately. -runTask :: Process a -> Event (Task a) -runTask p = - do pid <- liftSimulation newProcessId - runTaskUsingId pid p - --- | Enqueue the process that will be started at the specified time with the given --- identifier from the event queue. It returns the corresponded task immediately. -enqueueTaskUsingId :: Double -> ProcessId -> Process a -> Event (Task a) -enqueueTaskUsingId time pid p = - do (t, m) <- newTaskUsingId pid p - enqueueProcessUsingId time pid m - return t - --- | Enqueue the process that will be started at the specified time from the event queue. --- It returns the corresponded task immediately. -enqueueTask :: Double -> Process a -> Event (Task a) -enqueueTask time p = - do pid <- liftSimulation newProcessId - enqueueTaskUsingId time pid p - --- | Run using the specified identifier a child process in background and return --- immediately the corresponded task. -spawnTaskUsingId :: ContCancellation -> ProcessId -> Process a -> Process (Task a) -spawnTaskUsingId cancellation pid p = - do (t, m) <- liftEvent $ newTaskUsingId pid p - spawnProcessUsingId cancellation pid m - return t - --- | Run a child process in background and return immediately the corresponded task. -spawnTask :: ContCancellation -> Process a -> Process (Task a) -spawnTask cancellation p = - do pid <- liftSimulation newProcessId - spawnTaskUsingId cancellation pid p - --- | Return an outer process that behaves like the task itself except for one thing: --- if the outer process is cancelled then it is not enough to cancel the task. -taskProcess :: Task a -> Process a -taskProcess t = - do x <- taskResult t - case x of - TaskCompleted a -> return a - TaskError e -> throwProcess e - TaskCancelled -> cancelProcess + +-- | +-- Module : Simulation.Aivika.Task +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The 'Task' value represents a process that was already started in background. +-- We can check the completion of the task, receive notifications about changing +-- its state and even suspend an outer process awaiting the final result of the task. +-- It complements the 'Process' monad as it allows immediately continuing the main +-- computation without suspension. +-- +module Simulation.Aivika.Task + (-- * Task + Task, + TaskResult(..), + taskId, + tryGetTaskResult, + taskResult, + taskResultReceived, + taskProcess, + cancelTask, + taskCancelled, + -- * Running Task + runTask, + runTaskUsingId, + -- * Spawning Tasks + spawnTask, + spawnTaskUsingId, + -- * Enqueueing Task + enqueueTask, + enqueueTaskUsingId) where + +import Data.IORef +import Data.Monoid + +import Control.Monad +import Control.Monad.Trans +import Control.Exception + +import Simulation.Aivika.Internal.Simulation +import Simulation.Aivika.Internal.Dynamics +import Simulation.Aivika.Internal.Event +import Simulation.Aivika.Internal.Cont +import Simulation.Aivika.Internal.Process +import Simulation.Aivika.Internal.Signal + +-- | The task represents a process that was already started in background. +data Task a = + Task { taskId :: ProcessId, + -- ^ Return an identifier for the process that was launched + -- in background for this task. + taskResultRef :: IORef (Maybe (TaskResult a)), + -- ^ It contains the result of the computation. + taskResultReceived :: Signal (TaskResult a) + -- ^ Return a signal that notifies about receiving + -- the result of the task. + } + +-- | Represents the result of the task. +data TaskResult a = TaskCompleted a + -- ^ the task was successfully completed and + -- it returned the specified result + | TaskError IOException + -- ^ the specified exception was raised when performing the task. + | TaskCancelled + -- ^ the task was cancelled + +-- | Try to get the task result immediately without suspension. +tryGetTaskResult :: Task a -> Event (Maybe (TaskResult a)) +tryGetTaskResult t = + Event $ \p -> readIORef (taskResultRef t) + +-- | Return the task result suspending the outer process if required. +taskResult :: Task a -> Process (TaskResult a) +taskResult t = + do x <- liftIO $ readIORef (taskResultRef t) + case x of + Just x -> return x + Nothing -> processAwait (taskResultReceived t) + +-- | Cancel the task. +cancelTask :: Task a -> Event () +cancelTask t = + cancelProcessWithId (taskId t) + +-- | Test whether the task was cancelled. +taskCancelled :: Task a -> Event Bool +taskCancelled t = + processCancelled (taskId t) + +-- | Create a task by the specified process and its identifier. +newTaskUsingId :: ProcessId -> Process a -> Event (Task a, Process ()) +newTaskUsingId pid p = + do r <- liftIO $ newIORef Nothing + s <- liftSimulation newSignalSource + let t = Task { taskId = pid, + taskResultRef = r, + taskResultReceived = publishSignal s } + let m = + do v <- liftIO $ newIORef TaskCancelled + finallyProcess + (catchProcess + (do a <- p + liftIO $ writeIORef v (TaskCompleted a)) + (\e -> + liftIO $ writeIORef v (TaskError e))) + (liftEvent $ + do x <- liftIO $ readIORef v + liftIO $ writeIORef r (Just x) + triggerSignal s x) + return (t, m) + +-- | Run the process with the specified identifier in background and +-- return the corresponded task immediately. +runTaskUsingId :: ProcessId -> Process a -> Event (Task a) +runTaskUsingId pid p = + do (t, m) <- newTaskUsingId pid p + runProcessUsingId pid m + return t + +-- | Run the process in background and return the corresponded task immediately. +runTask :: Process a -> Event (Task a) +runTask p = + do pid <- liftSimulation newProcessId + runTaskUsingId pid p + +-- | Enqueue the process that will be started at the specified time with the given +-- identifier from the event queue. It returns the corresponded task immediately. +enqueueTaskUsingId :: Double -> ProcessId -> Process a -> Event (Task a) +enqueueTaskUsingId time pid p = + do (t, m) <- newTaskUsingId pid p + enqueueProcessUsingId time pid m + return t + +-- | Enqueue the process that will be started at the specified time from the event queue. +-- It returns the corresponded task immediately. +enqueueTask :: Double -> Process a -> Event (Task a) +enqueueTask time p = + do pid <- liftSimulation newProcessId + enqueueTaskUsingId time pid p + +-- | Run using the specified identifier a child process in background and return +-- immediately the corresponded task. +spawnTaskUsingId :: ContCancellation -> ProcessId -> Process a -> Process (Task a) +spawnTaskUsingId cancellation pid p = + do (t, m) <- liftEvent $ newTaskUsingId pid p + spawnProcessUsingId cancellation pid m + return t + +-- | Run a child process in background and return immediately the corresponded task. +spawnTask :: ContCancellation -> Process a -> Process (Task a) +spawnTask cancellation p = + do pid <- liftSimulation newProcessId + spawnTaskUsingId cancellation pid p + +-- | Return an outer process that behaves like the task itself except for one thing: +-- if the outer process is cancelled then it is not enough to cancel the task. +taskProcess :: Task a -> Process a +taskProcess t = + do x <- taskResult t + case x of + TaskCompleted a -> return a + TaskError e -> throwProcess e + TaskCancelled -> cancelProcess diff --git a/Simulation/Aivika/Transform.hs b/Simulation/Aivika/Transform.hs --- a/Simulation/Aivika/Transform.hs +++ b/Simulation/Aivika/Transform.hs @@ -1,30 +1,126 @@ - --- | --- Module : Simulation.Aivika.Transform --- Copyright : Copyright (c) 2009-2014, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The module defines a transform of one time varying function to another --- usually specified in the integration time points and then interpolated in --- other time points with help of one of the memoization functions --- like 'memo0Dynamics'. --- -module Simulation.Aivika.Transform - (Transform(..)) where - -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Dynamics.Memo - --- | The transform of one time varying function to another usually --- specified in the integration time points and then interpolated in --- other time points with help of one of the memoization functions --- like 'memo0Dynamics'. --- -newtype Transform a b = - Transform { runTransform :: Dynamics a -> Simulation (Dynamics b) - -- ^ Run the transform. - } + +{-# LANGUAGE RecursiveDo #-} + +-- | +-- Module : Simulation.Aivika.Transform +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines something which is most close to the notion of +-- analogous circuit as an opposite to the digital one. +-- +module Simulation.Aivika.Transform + (-- * The Transform Arrow + Transform(..), + -- * Delaying the Transform + delayTransform, + -- * The Time Transform + timeTransform, + -- * Differential and Difference Equations + integTransform, + sumTransform) where + +import qualified Control.Category as C +import Control.Arrow +import Control.Monad + +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Dynamics.Memo +import Simulation.Aivika.Unboxed +import Simulation.Aivika.SystemDynamics + +-- | It allows representing an analogous circuit as an opposite to +-- the digital one. +-- +-- This is a transform of one time varying function to another usually +-- specified in the integration time points and then interpolated in +-- other time points with help of one of the memoization functions +-- like 'memo0Dynamics'. +-- +newtype Transform a b = + Transform { runTransform :: Dynamics a -> Simulation (Dynamics b) + -- ^ Run the transform. + } + +instance C.Category Transform where + + id = Transform return + + (Transform g) . (Transform f) = + Transform $ \a -> f a >>= g + +instance Arrow Transform where + + arr f = Transform $ return . fmap f + + first (Transform f) = + Transform $ \bd -> + do (b, d) <- unzip0Dynamics bd + c <- f b + return $ liftM2 (,) c d + + second (Transform f) = + Transform $ \db -> + do (d, b) <- unzip0Dynamics db + c <- f b + return $ liftM2 (,) d c + + (Transform f) *** (Transform g) = + Transform $ \bb' -> + do (b, b') <- unzip0Dynamics bb' + c <- f b + c' <- g b' + return $ liftM2 (,) c c' + + (Transform f) &&& (Transform g) = + Transform $ \b -> + do c <- f b + c' <- g b + return $ liftM2 (,) c c' + +instance ArrowLoop Transform where + + loop (Transform f) = + Transform $ \b -> + mdo let bd = liftM2 (,) b d + cd <- f bd + (c, d) <- unzip0Dynamics cd + return c + +-- | A transform that returns the current modeling time. +timeTransform :: Transform a Double +timeTransform = Transform $ const $ return time + +-- | Return a delayed transform by the specified lag time and initial value. +-- +-- This is actually the 'delayI' function wrapped in the 'Transform' type. +delayTransform :: Dynamics Double -- ^ the lag time + -> Dynamics a -- ^ the initial value + -> Transform a a -- ^ the delayed transform +delayTransform lagTime init = + Transform $ \a -> delayI a lagTime init + +-- | Return a transform that maps the derivative to an integral +-- by the specified initial value. +-- +-- This is actually the 'integ' function wrapped in the 'Transform' type. +integTransform :: Dynamics Double + -- ^ the initial value + -> Transform Double Double + -- ^ map the derivative to an integral +integTransform = Transform . integ + +-- | Return a transform that maps the difference to a sum +-- by the specified initial value. +-- +-- This is actually the 'diffsum' function wrapped in the 'Transform' type. +sumTransform :: (Num a, Unboxed a) => + Dynamics a + -- ^ the initial value + -> Transform a a + -- ^ map the difference to a sum +sumTransform = Transform . diffsum diff --git a/Simulation/Aivika/Transform/Extra.hs b/Simulation/Aivika/Transform/Extra.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Transform/Extra.hs @@ -0,0 +1,54 @@ + +-- | +-- Module : Simulation.Aivika.Transform.Extra +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines auxiliary computations such as interpolation ones +-- that complement the memoization, for example. There are scan computations too. +-- + +module Simulation.Aivika.Transform.Extra + (-- * Interpolation + initTransform, + discreteTransform, + interpolatingTransform, + -- * Scans + scanTransform, + scan1Transform) where + +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Dynamics.Extra +import Simulation.Aivika.Transform +import Simulation.Aivika.Transform.Memo + +-- | A transform that returns the initial value. +initTransform :: Transform a a +initTransform = Transform $ return . initDynamics + +-- | A transform that discretizes the computation in the integration time points. +discreteTransform :: Transform a a +discreteTransform = Transform $ return . discreteDynamics + +-- | A tranform that interpolates the computation based on the integration time points only. +-- Unlike the 'discreteTransform' computation it knows about the intermediate +-- time points that are used in the Runge-Kutta method. +interpolatingTransform :: Transform a a +interpolatingTransform = Transform $ return . interpolateDynamics + +-- | Like the standard 'scanl1' function but applied to values in +-- the integration time points. The accumulator values are transformed +-- according to the second argument, which should be either +-- 'memo0Transform' or its unboxed version. +scan1Transform :: (a -> a -> a) -> Transform a a -> Transform a a +scan1Transform f (Transform tr) = Transform $ scan1Dynamics f tr + +-- | Like the standard 'scanl' function but applied to values in +-- the integration time points. The accumulator values are transformed +-- according to the third argument, which should be either +-- 'memo0Transform' or its unboxed version. +scanTransform :: (a -> b -> a) -> a -> Transform a a -> Transform b a +scanTransform f acc (Transform tr) = Transform $ scanDynamics f acc tr diff --git a/Simulation/Aivika/Transform/Memo.hs b/Simulation/Aivika/Transform/Memo.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Transform/Memo.hs @@ -0,0 +1,45 @@ + +-- | +-- Module : Simulation.Aivika.Transform.Memo +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines memoization transforms. The memoization creates such 'Dynamics' +-- computations, which values are cached in the integration time points. Then +-- these values are interpolated in all other time points. +-- + +module Simulation.Aivika.Transform.Memo + (memoTransform, + memo0Transform, + iteratingTransform) where + +import Simulation.Aivika.Parameter +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Dynamics.Extra +import Simulation.Aivika.Dynamics.Memo +import Simulation.Aivika.Transform + +-- | A transform that memoizes and order the computation in the integration time points +-- using the interpolation that knows of the Runge-Kutta method. The values are +-- calculated sequentially starting from 'starttime'. +memoTransform :: Transform e e +memoTransform = Transform memoDynamics + +-- | A transform that memoizes and order the computation in the integration time points using +-- the 'discreteDynamics' interpolation. It consumes less memory than the 'memoTransform' +-- computation but it is not aware of the Runge-Kutta method. There is a subtle +-- difference when we request for values in the intermediate time points +-- that are used by this method to integrate. In general case you should +-- prefer the 'memo0Transform' computation above 'memoTransform'. +memo0Transform :: Transform e e +memo0Transform = Transform memo0Dynamics + +-- | A transform that iterates sequentially the dynamic process with side effects in +-- the integration time points. It is equivalent to the 'memo0Transform' computation +-- but significantly more efficient, for the internal array is not created. +iteratingTransform :: Transform () () +iteratingTransform = Transform iterateDynamics diff --git a/Simulation/Aivika/Transform/Memo/Unboxed.hs b/Simulation/Aivika/Transform/Memo/Unboxed.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Transform/Memo/Unboxed.hs @@ -0,0 +1,41 @@ + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Transform.Memo.Unboxed +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines the unboxed memoization transforms. The memoization creates such 'Dynamics' +-- computations, which values are cached in the integration time points. Then +-- these values are interpolated in all other time points. +-- + +module Simulation.Aivika.Transform.Memo.Unboxed + (memoTransform, + memo0Transform) where + +import Simulation.Aivika.Parameter +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Dynamics.Extra +import Simulation.Aivika.Dynamics.Memo.Unboxed +import Simulation.Aivika.Transform +import Simulation.Aivika.Unboxed + +-- | A transform that memoizes and order the computation in the integration time points +-- using the interpolation that knows of the Runge-Kutta method. The values are +-- calculated sequentially starting from 'starttime'. +memoTransform :: Unboxed e => Transform e e +memoTransform = Transform memoDynamics + +-- | A transform that memoizes and order the computation in the integration time points using +-- the 'discreteDynamics' interpolation. It consumes less memory than the 'memoTransform' +-- computation but it is not aware of the Runge-Kutta method. There is a subtle +-- difference when we request for values in the intermediate time points +-- that are used by this method to integrate. In general case you should +-- prefer the 'memo0Transform' computation above 'memoTransform'. +memo0Transform :: Unboxed e => Transform e e +memo0Transform = Transform memo0Dynamics diff --git a/Simulation/Aivika/Unboxed.hs b/Simulation/Aivika/Unboxed.hs --- a/Simulation/Aivika/Unboxed.hs +++ b/Simulation/Aivika/Unboxed.hs @@ -1,48 +1,48 @@ - -{-# LANGUAGE CPP, FlexibleContexts #-} - --- | --- Module : Simulation.Aivika.Unboxed --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- The 'Unboxed' class allows creating unboxed arrays in monad 'IO'. --- - -module Simulation.Aivika.Unboxed - (Unboxed(..)) where - -import Data.Array -import Data.Array.IO.Safe -import Data.Int -import Data.Word - --- | The type which values can be contained in an unboxed array. -class MArray IOUArray e IO => Unboxed e where - - -- | Create an unboxed array with default values. - newUnboxedArray_ :: Ix i => (i, i) -> IO (IOUArray i e) - newUnboxedArray_ = newArray_ - -instance Unboxed Bool -instance Unboxed Char -instance Unboxed Double -instance Unboxed Float -instance Unboxed Int -instance Unboxed Int8 -instance Unboxed Int16 -instance Unboxed Int32 -instance Unboxed Word -instance Unboxed Word8 -instance Unboxed Word16 -instance Unboxed Word32 - -#ifndef __HASTE__ - -instance Unboxed Int64 -instance Unboxed Word64 - -#endif + +{-# LANGUAGE CPP, FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Unboxed +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The 'Unboxed' class allows creating unboxed arrays in monad 'IO'. +-- + +module Simulation.Aivika.Unboxed + (Unboxed(..)) where + +import Data.Array +import Data.Array.IO.Safe +import Data.Int +import Data.Word + +-- | The type which values can be contained in an unboxed array. +class MArray IOUArray e IO => Unboxed e where + + -- | Create an unboxed array with default values. + newUnboxedArray_ :: Ix i => (i, i) -> IO (IOUArray i e) + newUnboxedArray_ = newArray_ + +instance Unboxed Bool +instance Unboxed Char +instance Unboxed Double +instance Unboxed Float +instance Unboxed Int +instance Unboxed Int8 +instance Unboxed Int16 +instance Unboxed Int32 +instance Unboxed Word +instance Unboxed Word8 +instance Unboxed Word16 +instance Unboxed Word32 + +#ifndef __HASTE__ + +instance Unboxed Int64 +instance Unboxed Word64 + +#endif diff --git a/Simulation/Aivika/Var.hs b/Simulation/Aivika/Var.hs --- a/Simulation/Aivika/Var.hs +++ b/Simulation/Aivika/Var.hs @@ -1,150 +1,188 @@ - --- | --- Module : Simulation.Aivika.Var --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- This module defines a variable that is bound up with the event queue and --- that keeps the history of changes storing the values in an array, which --- allows using the variable in differential and difference equations under --- some conditions. --- -module Simulation.Aivika.Var - (Var, - varChanged, - varChanged_, - newVar, - readVar, - writeVar, - modifyVar, - freezeVar) where - -import Data.Array -import Data.Array.IO.Safe -import Data.IORef - -import Simulation.Aivika.Internal.Specs -import Simulation.Aivika.Internal.Simulation -import Simulation.Aivika.Internal.Event -import Simulation.Aivika.Internal.Signal -import Simulation.Aivika.Signal - -import qualified Simulation.Aivika.Vector as V -import qualified Simulation.Aivika.Vector.Unboxed as UV - --- | Like the 'Ref' reference but keeps the history of changes in --- different time points. The 'Var' variable is usually safe in the hybrid --- simulation, for example, when it can be used in the differential or --- difference equations unless you update the variable twice in the --- same integration time point. Only this variable is much slower than --- the reference. -data Var a = - Var { varXS :: UV.Vector Double, - varYS :: V.Vector a, - varChangedSource :: SignalSource a } - --- | Create a new variable. -newVar :: a -> Simulation (Var a) -newVar a = - Simulation $ \r -> - do xs <- UV.newVector - ys <- V.newVector - UV.appendVector xs $ spcStartTime $ runSpecs r - V.appendVector ys a - s <- invokeSimulation r newSignalSource - return Var { varXS = xs, - varYS = ys, - varChangedSource = s } - --- | Read the value of a variable. --- --- It is safe to run the resulting computation with help of the 'runEventWith' --- function using modes 'CurrentEventsOrFromPast' and 'EarlierEventsOrFromPast', --- which is necessary if you are going to use the variable in the differential --- or difference equations. Only it is preferrable if the variable is not updated twice --- in the same integration time point; otherwise, different values can be returned --- for the same point. -readVar :: Var a -> Event a -readVar v = - Event $ \p -> - do let xs = varXS v - ys = varYS v - t = pointTime p - count <- UV.vectorCount xs - let i = count - 1 - x <- UV.readVector xs i - if x <= t - then V.readVector ys i - else do i <- UV.vectorBinarySearch xs t - if i >= 0 - then V.readVector ys i - else V.readVector ys $ - (i + 1) - 1 - --- | Write a new value into the variable. -writeVar :: Var a -> a -> Event () -writeVar v a = - Event $ \p -> - do let xs = varXS v - ys = varYS v - t = pointTime p - s = varChangedSource v - count <- UV.vectorCount xs - let i = count - 1 - x <- UV.readVector xs i - if t < x - then error "Cannot update the past data: writeVar." - else if t == x - then V.writeVector ys i $! a - else do UV.appendVector xs t - V.appendVector ys $! a - invokeEvent p $ triggerSignal s a - --- | Mutate the contents of the variable. -modifyVar :: Var a -> (a -> a) -> Event () -modifyVar v f = - Event $ \p -> - do let xs = varXS v - ys = varYS v - t = pointTime p - s = varChangedSource v - count <- UV.vectorCount xs - let i = count - 1 - x <- UV.readVector xs i - if t < x - then error "Cannot update the past data: modifyVar." - else if t == x - then do a <- V.readVector ys i - let b = f a - V.writeVector ys i $! b - invokeEvent p $ triggerSignal s b - else do a <- V.readVector ys i - let b = f a - UV.appendVector xs t - V.appendVector ys $! b - invokeEvent p $ triggerSignal s b - --- | Freeze the variable and return in arrays the time points and corresponded --- values when the variable had changed in different time points: (1) the last --- actual value per each time point is provided and (2) the time points are --- sorted in ascending order. --- --- If you need to get all changes including those ones that correspond to the same --- simulation time points then you can use the 'newSignalHistory' function passing --- in the 'varChanged' signal to it and then call function 'readSignalHistory'. -freezeVar :: Var a -> Event (Array Int Double, Array Int a) -freezeVar v = - Event $ \p -> - do xs <- UV.freezeVector (varXS v) - ys <- V.freezeVector (varYS v) - return (xs, ys) - --- | Return a signal that notifies about every change of the variable state. -varChanged :: Var a -> Signal a -varChanged v = publishSignal (varChangedSource v) - --- | Return a signal that notifies about every change of the variable state. -varChanged_ :: Var a -> Signal () -varChanged_ v = mapSignal (const ()) $ varChanged v + +-- | +-- Module : Simulation.Aivika.Var +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines a variable that is bound up with the event queue and +-- that keeps the history of changes storing the values in arrays, which +-- allows using the variable in differential and difference equations of +-- System Dynamics within hybrid discrete-continuous simulation. +-- +module Simulation.Aivika.Var + (Var, + varChanged, + varChanged_, + newVar, + readVar, + varMemo, + writeVar, + modifyVar, + freezeVar) where + +import Data.Array +import Data.Array.IO.Safe + +import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Simulation +import Simulation.Aivika.Internal.Dynamics +import Simulation.Aivika.Internal.Event +import Simulation.Aivika.Internal.Signal +import Simulation.Aivika.Ref +import Simulation.Aivika.Signal + +import qualified Simulation.Aivika.Vector as V +import qualified Simulation.Aivika.Vector.Unboxed as UV + +-- | Like the 'Ref' reference but keeps the history of changes in +-- different time points. The 'Var' variable is safe to be used in +-- the hybrid discrete-continuous simulation. +-- +-- For example, the memoised values of a variable can be used in +-- the differential or difference equations of System Dynamics, while +-- the variable iself can be updated wihin the discrete event simulation. +-- +-- Only this variable is much slower than the reference. +data Var a = + Var { varXS :: UV.Vector Double, + varMS :: V.Vector a, + varYS :: V.Vector a, + varChangedSource :: SignalSource a } + +-- | Create a new variable. +newVar :: a -> Simulation (Var a) +newVar a = + Simulation $ \r -> + do xs <- UV.newVector + ms <- V.newVector + ys <- V.newVector + UV.appendVector xs $ spcStartTime $ runSpecs r + V.appendVector ms a + V.appendVector ys a + s <- invokeSimulation r newSignalSource + return Var { varXS = xs, + varMS = ms, + varYS = ms, + varChangedSource = s } + +-- | Read the first actual, i.e. memoised, value of a variable for the requested time +-- actuating the current events from the queue if needed. +-- +-- This computation can be used in the ordinary differential and +-- difference equations of System Dynamics. +varMemo :: Var a -> Dynamics a +varMemo v = + runEventWith CurrentEventsOrFromPast $ + Event $ \p -> + do let xs = varXS v + ms = varMS v + ys = varYS v + t = pointTime p + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if x < t + then do a <- V.readVector ys i + UV.appendVector xs t + V.appendVector ms a + V.appendVector ys a + return a + else if x == t + then V.readVector ms i + else do i <- UV.vectorBinarySearch xs t + if i >= 0 + then V.readVector ms i + else V.readVector ms $ - (i + 1) - 1 + +-- | Read the recent actual value of a variable for the requested time. +-- +-- This computation is destined for using within discrete event simulation. +readVar :: Var a -> Event a +readVar v = + Event $ \p -> + do let xs = varXS v + ys = varYS v + t = pointTime p + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if x <= t + then V.readVector ys i + else do i <- UV.vectorBinarySearch xs t + if i >= 0 + then V.readVector ys i + else V.readVector ys $ - (i + 1) - 1 + +-- | Write a new value into the variable. +writeVar :: Var a -> a -> Event () +writeVar v a = + Event $ \p -> + do let xs = varXS v + ms = varMS v + ys = varYS v + t = pointTime p + s = varChangedSource v + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if t < x + then error "Cannot update the past data: writeVar." + else if t == x + then V.writeVector ys i $! a + else do UV.appendVector xs t + V.appendVector ms $! a + V.appendVector ys $! a + invokeEvent p $ triggerSignal s a + +-- | Mutate the contents of the variable. +modifyVar :: Var a -> (a -> a) -> Event () +modifyVar v f = + Event $ \p -> + do let xs = varXS v + ms = varMS v + ys = varYS v + t = pointTime p + s = varChangedSource v + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if t < x + then error "Cannot update the past data: modifyVar." + else if t == x + then do a <- V.readVector ys i + let b = f a + V.writeVector ys i $! b + invokeEvent p $ triggerSignal s b + else do a <- V.readVector ys i + let b = f a + UV.appendVector xs t + V.appendVector ms $! b + V.appendVector ys $! b + invokeEvent p $ triggerSignal s b + +-- | Freeze the variable and return in arrays the time points and corresponded +-- first and last values when the variable had changed or had been memoised in +-- different time points: (1) the time points are sorted in ascending order; +-- (2) the first and last actual values per each time point are provided. +-- +-- If you need to get all changes including those ones that correspond to the same +-- simulation time points then you can use the 'newSignalHistory' function passing +-- in the 'varChanged' signal to it and then call function 'readSignalHistory'. +freezeVar :: Var a -> Event (Array Int Double, Array Int a, Array Int a) +freezeVar v = + Event $ \p -> + do xs <- UV.freezeVector (varXS v) + ms <- V.freezeVector (varMS v) + ys <- V.freezeVector (varYS v) + return (xs, ms, ys) + +-- | Return a signal that notifies about every change of the variable state. +varChanged :: Var a -> Signal a +varChanged v = publishSignal (varChangedSource v) + +-- | Return a signal that notifies about every change of the variable state. +varChanged_ :: Var a -> Signal () +varChanged_ v = mapSignal (const ()) $ varChanged v diff --git a/Simulation/Aivika/Var/Unboxed.hs b/Simulation/Aivika/Var/Unboxed.hs --- a/Simulation/Aivika/Var/Unboxed.hs +++ b/Simulation/Aivika/Var/Unboxed.hs @@ -1,157 +1,188 @@ - --- | --- Module : Simulation.Aivika.Var.Unboxed --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- This module defines an unboxed variable that is bound up with the event queue and --- that keeps the history of changes storing the values in an unboxed array, which --- allows using the variable in differential and difference equations under --- some conditions. --- -module Simulation.Aivika.Var.Unboxed - (Var, - varChanged, - varChanged_, - newVar, - readVar, - writeVar, - modifyVar, - freezeVar) where - -import Data.Array -import Data.Array.IO.Safe -import Data.IORef - -import Simulation.Aivika.Internal.Specs -import Simulation.Aivika.Internal.Simulation -import Simulation.Aivika.Internal.Event -import Simulation.Aivika.Internal.Signal -import Simulation.Aivika.Signal -import Simulation.Aivika.Unboxed - -import qualified Simulation.Aivika.Vector.Unboxed as UV - --- | Like the 'Ref' reference but keeps the history of changes in --- different time points. The 'Var' variable is usually safe in the hybrid --- simulation, for example, when it can be used in the differential or --- difference equations unless you update the variable twice in the --- same integration time point. Only this variable is much slower than --- the reference. -data Var a = - Var { varXS :: UV.Vector Double, - varYS :: UV.Vector a, - varChangedSource :: SignalSource a } - --- | Create a new variable. -newVar :: Unboxed a => a -> Simulation (Var a) -newVar a = - Simulation $ \r -> - do xs <- UV.newVector - ys <- UV.newVector - UV.appendVector xs $ spcStartTime $ runSpecs r - UV.appendVector ys a - s <- invokeSimulation r newSignalSource - return Var { varXS = xs, - varYS = ys, - varChangedSource = s } - --- | Read the value of a variable. --- --- It is safe to run the resulting computation with help of the 'runEventWith' --- function using modes 'CurrentEventsOrFromPast' and 'EarlierEventsOrFromPast', --- which is necessary if you are going to use the variable in the differential --- or difference equations. Only it is preferrable if the variable is not updated twice --- in the same integration time point; otherwise, different values can be returned --- for the same point. -readVar :: Unboxed a => Var a -> Event a -readVar v = - Event $ \p -> - do let xs = varXS v - ys = varYS v - t = pointTime p - count <- UV.vectorCount xs - let i = count - 1 - x <- UV.readVector xs i - if x <= t - then UV.readVector ys i - else do i <- UV.vectorBinarySearch xs t - if i >= 0 - then UV.readVector ys i - else UV.readVector ys $ - (i + 1) - 1 - --- | Write a new value into the variable. -writeVar :: Unboxed a => Var a -> a -> Event () -writeVar v a = - Event $ \p -> - do let xs = varXS v - ys = varYS v - t = pointTime p - s = varChangedSource v - count <- UV.vectorCount xs - let i = count - 1 - x <- UV.readVector xs i - if t < x - then error "Cannot update the past data: writeVar." - else if t == x - then UV.writeVector ys i $! a - else do UV.appendVector xs t - UV.appendVector ys $! a - invokeEvent p $ triggerSignal s a - --- | Mutate the contents of the variable. -modifyVar :: Unboxed a => Var a -> (a -> a) -> Event () -modifyVar v f = - Event $ \p -> - do let xs = varXS v - ys = varYS v - t = pointTime p - s = varChangedSource v - count <- UV.vectorCount xs - let i = count - 1 - x <- UV.readVector xs i - if t < x - then error "Cannot update the past data: modifyVar." - else if t == x - then do a <- UV.readVector ys i - let b = f a - UV.writeVector ys i $! b - invokeEvent p $ triggerSignal s b - else do i <- UV.vectorBinarySearch xs t - if i >= 0 - then do a <- UV.readVector ys i - let b = f a - UV.appendVector xs t - UV.appendVector ys $! b - invokeEvent p $ triggerSignal s b - else do a <- UV.readVector ys $ - (i + 1) - 1 - let b = f a - UV.appendVector xs t - UV.appendVector ys $! b - invokeEvent p $ triggerSignal s b - --- | Freeze the variable and return in arrays the time points and corresponded --- values when the variable had changed in different time points: (1) the last --- actual value per each time point is provided and (2) the time points are --- sorted in ascending order. --- --- If you need to get all changes including those ones that correspond to the same --- simulation time points then you can use the 'newSignalHistory' function passing --- in the 'varChanged' signal to it and then call function 'readSignalHistory'. -freezeVar :: Unboxed a => Var a -> Event (Array Int Double, Array Int a) -freezeVar v = - Event $ \p -> - do xs <- UV.freezeVector (varXS v) - ys <- UV.freezeVector (varYS v) - return (xs, ys) - --- | Return a signal that notifies about every change of the variable state. -varChanged :: Var a -> Signal a -varChanged v = publishSignal (varChangedSource v) - --- | Return a signal that notifies about every change of the variable state. -varChanged_ :: Var a -> Signal () -varChanged_ v = mapSignal (const ()) $ varChanged v + +-- | +-- Module : Simulation.Aivika.Var.Unboxed +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- This module defines an unboxed variable that is bound up with the event queue and +-- that keeps the history of changes storing the values in unboxed arrays, which +-- allows using the variable in differential and difference equations of +-- System Dynamics within hybrid discrete-continuous simulation. +-- +module Simulation.Aivika.Var.Unboxed + (Var, + varChanged, + varChanged_, + newVar, + readVar, + varMemo, + writeVar, + modifyVar, + freezeVar) where + +import Data.Array +import Data.Array.IO.Safe + +import Simulation.Aivika.Internal.Specs +import Simulation.Aivika.Internal.Simulation +import Simulation.Aivika.Internal.Dynamics +import Simulation.Aivika.Internal.Event +import Simulation.Aivika.Internal.Signal +import Simulation.Aivika.Ref +import Simulation.Aivika.Signal +import Simulation.Aivika.Unboxed + +import qualified Simulation.Aivika.Vector.Unboxed as UV + +-- | Like the 'Ref' reference but keeps the history of changes in +-- different time points. The 'Var' variable is safe to be used in +-- the hybrid discrete-continuous simulation. +-- +-- For example, the memoised values of a variable can be used in +-- the differential or difference equations of System Dynamics, while +-- the variable iself can be updated wihin the discrete event simulation. +-- +-- Only this variable is much slower than the reference. +data Var a = + Var { varXS :: UV.Vector Double, + varMS :: UV.Vector a, + varYS :: UV.Vector a, + varChangedSource :: SignalSource a } + +-- | Create a new variable. +newVar :: Unboxed a => a -> Simulation (Var a) +newVar a = + Simulation $ \r -> + do xs <- UV.newVector + ms <- UV.newVector + ys <- UV.newVector + UV.appendVector xs $ spcStartTime $ runSpecs r + UV.appendVector ms a + UV.appendVector ys a + s <- invokeSimulation r newSignalSource + return Var { varXS = xs, + varMS = ms, + varYS = ms, + varChangedSource = s } + +-- | Read the first actual, i.e. memoised, value of a variable for the requested time +-- actuating the current events from the queue if needed. +-- +-- This computation can be used in the ordinary differential and +-- difference equations of System Dynamics. +varMemo :: Unboxed a => Var a -> Dynamics a +varMemo v = + runEventWith CurrentEventsOrFromPast $ + Event $ \p -> + do let xs = varXS v + ms = varMS v + ys = varYS v + t = pointTime p + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if x < t + then do a <- UV.readVector ys i + UV.appendVector xs t + UV.appendVector ms a + UV.appendVector ys a + return a + else if x == t + then UV.readVector ms i + else do i <- UV.vectorBinarySearch xs t + if i >= 0 + then UV.readVector ms i + else UV.readVector ms $ - (i + 1) - 1 + +-- | Read the recent actual value of a variable for the requested time. +-- +-- This computation is destined for using within discrete event simulation. +readVar :: Unboxed a => Var a -> Event a +readVar v = + Event $ \p -> + do let xs = varXS v + ys = varYS v + t = pointTime p + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if x <= t + then UV.readVector ys i + else do i <- UV.vectorBinarySearch xs t + if i >= 0 + then UV.readVector ys i + else UV.readVector ys $ - (i + 1) - 1 + +-- | Write a new value into the variable. +writeVar :: Unboxed a => Var a -> a -> Event () +writeVar v a = + Event $ \p -> + do let xs = varXS v + ms = varMS v + ys = varYS v + t = pointTime p + s = varChangedSource v + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if t < x + then error "Cannot update the past data: writeVar." + else if t == x + then UV.writeVector ys i $! a + else do UV.appendVector xs t + UV.appendVector ms $! a + UV.appendVector ys $! a + invokeEvent p $ triggerSignal s a + +-- | Mutate the contents of the variable. +modifyVar :: Unboxed a => Var a -> (a -> a) -> Event () +modifyVar v f = + Event $ \p -> + do let xs = varXS v + ms = varMS v + ys = varYS v + t = pointTime p + s = varChangedSource v + count <- UV.vectorCount xs + let i = count - 1 + x <- UV.readVector xs i + if t < x + then error "Cannot update the past data: modifyVar." + else if t == x + then do a <- UV.readVector ys i + let b = f a + UV.writeVector ys i $! b + invokeEvent p $ triggerSignal s b + else do a <- UV.readVector ys i + let b = f a + UV.appendVector xs t + UV.appendVector ms $! b + UV.appendVector ys $! b + invokeEvent p $ triggerSignal s b + +-- | Freeze the variable and return in arrays the time points and corresponded +-- first and last values when the variable had changed or had been memoised in +-- different time points: (1) the time points are sorted in ascending order; +-- (2) the first and last actual values per each time point are provided. +-- +-- If you need to get all changes including those ones that correspond to the same +-- simulation time points then you can use the 'newSignalHistory' function passing +-- in the 'varChanged' signal to it and then call function 'readSignalHistory'. +freezeVar :: Unboxed a => Var a -> Event (Array Int Double, Array Int a, Array Int a) +freezeVar v = + Event $ \p -> + do xs <- UV.freezeVector (varXS v) + ms <- UV.freezeVector (varMS v) + ys <- UV.freezeVector (varYS v) + return (xs, ms, ys) + +-- | Return a signal that notifies about every change of the variable state. +varChanged :: Var a -> Signal a +varChanged v = publishSignal (varChangedSource v) + +-- | Return a signal that notifies about every change of the variable state. +varChanged_ :: Var a -> Signal () +varChanged_ v = mapSignal (const ()) $ varChanged v diff --git a/Simulation/Aivika/Vector.hs b/Simulation/Aivika/Vector.hs --- a/Simulation/Aivika/Vector.hs +++ b/Simulation/Aivika/Vector.hs @@ -1,183 +1,183 @@ - --- | --- Module : Simulation.Aivika.Vector --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.8.3 --- --- An imperative vector. --- -module Simulation.Aivika.Vector - (Vector, - newVector, - copyVector, - vectorCount, - appendVector, - readVector, - writeVector, - vectorBinarySearch, - vectorInsert, - vectorDeleteAt, - vectorIndex, - freezeVector) where - -import Data.Array -import Data.Array.MArray.Safe -import Data.Array.IO.Safe -import Data.IORef -import Control.Monad - --- | Represents a resizable vector. -data Vector a = Vector { vectorArrayRef :: IORef (IOArray Int a), - vectorCountRef :: IORef Int, - vectorCapacityRef :: IORef Int } - --- | Create a new vector. -newVector :: IO (Vector a) -newVector = - do array <- newArray_ (0, 4 - 1) - arrayRef <- newIORef array - countRef <- newIORef 0 - capacityRef <- newIORef 4 - return Vector { vectorArrayRef = arrayRef, - vectorCountRef = countRef, - vectorCapacityRef = capacityRef } - --- | Copy the vector. -copyVector :: Vector a -> IO (Vector a) -copyVector vector = - do array <- readIORef (vectorArrayRef vector) - count <- readIORef (vectorCountRef vector) - array' <- newArray_ (0, count - 1) - arrayRef' <- newIORef array' - countRef' <- newIORef count - capacityRef' <- newIORef count - forM_ [0 .. count - 1] $ \i -> - do x <- readArray array i - writeArray array' i x - return Vector { vectorArrayRef = arrayRef', - vectorCountRef = countRef', - vectorCapacityRef = capacityRef' } - --- | Ensure that the vector has the specified capacity. -vectorEnsureCapacity :: Vector a -> Int -> IO () -vectorEnsureCapacity vector capacity = - do capacity' <- readIORef (vectorCapacityRef vector) - when (capacity' < capacity) $ - do array' <- readIORef (vectorArrayRef vector) - count' <- readIORef (vectorCountRef vector) - let capacity'' = max (2 * capacity') capacity - array'' <- newArray_ (0, capacity'' - 1) - forM_ [0 .. count' - 1] $ \i -> - do x <- readArray array' i - writeArray array'' i x - writeIORef (vectorArrayRef vector) array'' - writeIORef (vectorCapacityRef vector) capacity'' - --- | Return the element count. -vectorCount :: Vector a -> IO Int -vectorCount vector = readIORef (vectorCountRef vector) - --- | Add the specified element to the end of the vector. -appendVector :: Vector a -> a -> IO () -appendVector vector item = - do count <- readIORef (vectorCountRef vector) - vectorEnsureCapacity vector (count + 1) - array <- readIORef (vectorArrayRef vector) - writeArray array count item - writeIORef (vectorCountRef vector) (count + 1) - --- | Read a value from the vector, where indices are started from 0. -readVector :: Vector a -> Int -> IO a -readVector vector index = - do array <- readIORef (vectorArrayRef vector) - readArray array index - --- | Set an array item at the specified index which is started from 0. -writeVector :: Vector a -> Int -> a -> IO () -writeVector vector index item = - do array <- readIORef (vectorArrayRef vector) - writeArray array index item - -vectorBinarySearch' :: Ord a => IOArray Int a -> a -> Int -> Int -> IO Int -vectorBinarySearch' array item left right = - if left > right - then return $ - (right + 1) - 1 - else - do let index = (left + right) `div` 2 - curr <- readArray array index - if item < curr - then vectorBinarySearch' array item left (index - 1) - else if item == curr - then return index - else vectorBinarySearch' array item (index + 1) right - --- | Return the index of the specified element using binary search; otherwise, --- a negated insertion index minus one: 0 -> -0 - 1, ..., i -> -i - 1, .... -vectorBinarySearch :: Ord a => Vector a -> a -> IO Int -vectorBinarySearch vector item = - do array <- readIORef (vectorArrayRef vector) - count <- readIORef (vectorCountRef vector) - vectorBinarySearch' array item 0 (count - 1) - --- | Return the elements of the vector in an immutable array. -freezeVector :: Vector a -> IO (Array Int a) -freezeVector vector = - do vector' <- copyVector vector - array <- readIORef (vectorArrayRef vector') - freeze array - --- | Insert the element in the vector at the specified index. -vectorInsert :: Vector a -> Int -> a -> IO () -vectorInsert vector index item = - do count <- readIORef (vectorCountRef vector) - when (index < 0) $ - error $ - "Index cannot be " ++ - "negative: vectorInsert." - when (index > count) $ - error $ - "Index cannot be greater " ++ - "than the count: vectorInsert." - vectorEnsureCapacity vector (count + 1) - array <- readIORef (vectorArrayRef vector) - forM_ [count, count - 1 .. index + 1] $ \i -> - do x <- readArray array (i - 1) - writeArray array i x - writeArray array index item - writeIORef (vectorCountRef vector) (count + 1) - --- | Delete the element at the specified index. -vectorDeleteAt :: Vector a -> Int -> IO () -vectorDeleteAt vector index = - do count <- readIORef (vectorCountRef vector) - when (index < 0) $ - error $ - "Index cannot be " ++ - "negative: vectorDeleteAt." - when (index >= count) $ - error $ - "Index must be less " ++ - "than the count: vectorDeleteAt." - array <- readIORef (vectorArrayRef vector) - forM_ [index, index + 1 .. count - 2] $ \i -> - do x <- readArray array (i + 1) - writeArray array i x - writeArray array (count - 1) undefined - writeIORef (vectorCountRef vector) (count - 1) - --- | Return the index of the item or -1. -vectorIndex :: Eq a => Vector a -> a -> IO Int -vectorIndex vector item = - do count <- readIORef (vectorCountRef vector) - array <- readIORef (vectorArrayRef vector) - let loop index = - if index >= count - then return $ -1 - else do x <- readArray array index - if item == x - then return index - else loop $ index + 1 - loop 0 + +-- | +-- Module : Simulation.Aivika.Vector +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- An imperative vector. +-- +module Simulation.Aivika.Vector + (Vector, + newVector, + copyVector, + vectorCount, + appendVector, + readVector, + writeVector, + vectorBinarySearch, + vectorInsert, + vectorDeleteAt, + vectorIndex, + freezeVector) where + +import Data.Array +import Data.Array.MArray.Safe +import Data.Array.IO.Safe +import Data.IORef +import Control.Monad + +-- | Represents a resizable vector. +data Vector a = Vector { vectorArrayRef :: IORef (IOArray Int a), + vectorCountRef :: IORef Int, + vectorCapacityRef :: IORef Int } + +-- | Create a new vector. +newVector :: IO (Vector a) +newVector = + do array <- newArray_ (0, 4 - 1) + arrayRef <- newIORef array + countRef <- newIORef 0 + capacityRef <- newIORef 4 + return Vector { vectorArrayRef = arrayRef, + vectorCountRef = countRef, + vectorCapacityRef = capacityRef } + +-- | Copy the vector. +copyVector :: Vector a -> IO (Vector a) +copyVector vector = + do array <- readIORef (vectorArrayRef vector) + count <- readIORef (vectorCountRef vector) + array' <- newArray_ (0, count - 1) + arrayRef' <- newIORef array' + countRef' <- newIORef count + capacityRef' <- newIORef count + forM_ [0 .. count - 1] $ \i -> + do x <- readArray array i + writeArray array' i x + return Vector { vectorArrayRef = arrayRef', + vectorCountRef = countRef', + vectorCapacityRef = capacityRef' } + +-- | Ensure that the vector has the specified capacity. +vectorEnsureCapacity :: Vector a -> Int -> IO () +vectorEnsureCapacity vector capacity = + do capacity' <- readIORef (vectorCapacityRef vector) + when (capacity' < capacity) $ + do array' <- readIORef (vectorArrayRef vector) + count' <- readIORef (vectorCountRef vector) + let capacity'' = max (2 * capacity') capacity + array'' <- newArray_ (0, capacity'' - 1) + forM_ [0 .. count' - 1] $ \i -> + do x <- readArray array' i + writeArray array'' i x + writeIORef (vectorArrayRef vector) array'' + writeIORef (vectorCapacityRef vector) capacity'' + +-- | Return the element count. +vectorCount :: Vector a -> IO Int +vectorCount vector = readIORef (vectorCountRef vector) + +-- | Add the specified element to the end of the vector. +appendVector :: Vector a -> a -> IO () +appendVector vector item = + do count <- readIORef (vectorCountRef vector) + vectorEnsureCapacity vector (count + 1) + array <- readIORef (vectorArrayRef vector) + writeArray array count item + writeIORef (vectorCountRef vector) (count + 1) + +-- | Read a value from the vector, where indices are started from 0. +readVector :: Vector a -> Int -> IO a +readVector vector index = + do array <- readIORef (vectorArrayRef vector) + readArray array index + +-- | Set an array item at the specified index which is started from 0. +writeVector :: Vector a -> Int -> a -> IO () +writeVector vector index item = + do array <- readIORef (vectorArrayRef vector) + writeArray array index item + +vectorBinarySearch' :: Ord a => IOArray Int a -> a -> Int -> Int -> IO Int +vectorBinarySearch' array item left right = + if left > right + then return $ - (right + 1) - 1 + else + do let index = (left + right) `div` 2 + curr <- readArray array index + if item < curr + then vectorBinarySearch' array item left (index - 1) + else if item == curr + then return index + else vectorBinarySearch' array item (index + 1) right + +-- | Return the index of the specified element using binary search; otherwise, +-- a negated insertion index minus one: 0 -> -0 - 1, ..., i -> -i - 1, .... +vectorBinarySearch :: Ord a => Vector a -> a -> IO Int +vectorBinarySearch vector item = + do array <- readIORef (vectorArrayRef vector) + count <- readIORef (vectorCountRef vector) + vectorBinarySearch' array item 0 (count - 1) + +-- | Return the elements of the vector in an immutable array. +freezeVector :: Vector a -> IO (Array Int a) +freezeVector vector = + do vector' <- copyVector vector + array <- readIORef (vectorArrayRef vector') + freeze array + +-- | Insert the element in the vector at the specified index. +vectorInsert :: Vector a -> Int -> a -> IO () +vectorInsert vector index item = + do count <- readIORef (vectorCountRef vector) + when (index < 0) $ + error $ + "Index cannot be " ++ + "negative: vectorInsert." + when (index > count) $ + error $ + "Index cannot be greater " ++ + "than the count: vectorInsert." + vectorEnsureCapacity vector (count + 1) + array <- readIORef (vectorArrayRef vector) + forM_ [count, count - 1 .. index + 1] $ \i -> + do x <- readArray array (i - 1) + writeArray array i x + writeArray array index item + writeIORef (vectorCountRef vector) (count + 1) + +-- | Delete the element at the specified index. +vectorDeleteAt :: Vector a -> Int -> IO () +vectorDeleteAt vector index = + do count <- readIORef (vectorCountRef vector) + when (index < 0) $ + error $ + "Index cannot be " ++ + "negative: vectorDeleteAt." + when (index >= count) $ + error $ + "Index must be less " ++ + "than the count: vectorDeleteAt." + array <- readIORef (vectorArrayRef vector) + forM_ [index, index + 1 .. count - 2] $ \i -> + do x <- readArray array (i + 1) + writeArray array i x + writeArray array (count - 1) undefined + writeIORef (vectorCountRef vector) (count - 1) + +-- | Return the index of the item or -1. +vectorIndex :: Eq a => Vector a -> a -> IO Int +vectorIndex vector item = + do count <- readIORef (vectorCountRef vector) + array <- readIORef (vectorArrayRef vector) + let loop index = + if index >= count + then return $ -1 + else do x <- readArray array index + if item == x + then return index + else loop $ index + 1 + loop 0 diff --git a/Simulation/Aivika/Vector/Unboxed.hs b/Simulation/Aivika/Vector/Unboxed.hs --- a/Simulation/Aivika/Vector/Unboxed.hs +++ b/Simulation/Aivika/Vector/Unboxed.hs @@ -1,186 +1,186 @@ - --- | --- Module : Simulation.Aivika.Vector.Unboxed --- Copyright : Copyright (c) 2009-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- An imperative unboxed vector. --- -module Simulation.Aivika.Vector.Unboxed - (Vector, - newVector, - copyVector, - vectorCount, - appendVector, - readVector, - writeVector, - vectorBinarySearch, - vectorInsert, - vectorDeleteAt, - vectorIndex, - freezeVector) where - -import Data.Array -import Data.Array.MArray.Safe -import Data.Array.IO.Safe -import Data.IORef -import Control.Monad - -import Simulation.Aivika.Unboxed - --- | Represents an unboxed resizable vector. -data Vector a = Vector { vectorArrayRef :: IORef (IOUArray Int a), - vectorCountRef :: IORef Int, - vectorCapacityRef :: IORef Int } - --- | Create a new vector. -newVector :: Unboxed a => IO (Vector a) -newVector = - do array <- newUnboxedArray_ (0, 4 - 1) - arrayRef <- newIORef array - countRef <- newIORef 0 - capacityRef <- newIORef 4 - return Vector { vectorArrayRef = arrayRef, - vectorCountRef = countRef, - vectorCapacityRef = capacityRef } - --- | Copy the vector. -copyVector :: Unboxed a => Vector a -> IO (Vector a) -copyVector vector = - do array <- readIORef (vectorArrayRef vector) - count <- readIORef (vectorCountRef vector) - array' <- newUnboxedArray_ (0, count - 1) - arrayRef' <- newIORef array' - countRef' <- newIORef count - capacityRef' <- newIORef count - forM_ [0 .. count - 1] $ \i -> - do x <- readArray array i - writeArray array' i x - return Vector { vectorArrayRef = arrayRef', - vectorCountRef = countRef', - vectorCapacityRef = capacityRef' } - --- | Ensure that the vector has the specified capacity. -vectorEnsureCapacity :: Unboxed a => Vector a -> Int -> IO () -vectorEnsureCapacity vector capacity = - do capacity' <- readIORef (vectorCapacityRef vector) - when (capacity' < capacity) $ - do array' <- readIORef (vectorArrayRef vector) - count' <- readIORef (vectorCountRef vector) - let capacity'' = max (2 * capacity') capacity - array'' <- newUnboxedArray_ (0, capacity'' - 1) - forM_ [0 .. count' - 1] $ \i -> - do x <- readArray array' i - writeArray array'' i x - writeIORef (vectorArrayRef vector) array'' - writeIORef (vectorCapacityRef vector) capacity'' - --- | Return the element count. -vectorCount :: Unboxed a => Vector a -> IO Int -vectorCount vector = readIORef (vectorCountRef vector) - --- | Add the specified element to the end of the vector. -appendVector :: Unboxed a => Vector a -> a -> IO () -appendVector vector item = - do count <- readIORef (vectorCountRef vector) - vectorEnsureCapacity vector (count + 1) - array <- readIORef (vectorArrayRef vector) - writeArray array count item - writeIORef (vectorCountRef vector) (count + 1) - --- | Read a value from the vector, where indices are started from 0. -readVector :: Unboxed a => Vector a -> Int -> IO a -readVector vector index = - do array <- readIORef (vectorArrayRef vector) - readArray array index - --- | Set an array item at the specified index which is started from 0. -writeVector :: Unboxed a => Vector a -> Int -> a -> IO () -writeVector vector index item = - do array <- readIORef (vectorArrayRef vector) - writeArray array index item - -vectorBinarySearch' :: (Unboxed a, Ord a) => IOUArray Int a -> a -> Int -> Int -> IO Int -vectorBinarySearch' array item left right = - if left > right - then return $ - (right + 1) - 1 - else - do let index = (left + right) `div` 2 - curr <- readArray array index - if item < curr - then vectorBinarySearch' array item left (index - 1) - else if item == curr - then return index - else vectorBinarySearch' array item (index + 1) right - --- | Return the index of the specified element using binary search; otherwise, --- a negated insertion index minus one: 0 -> -0 - 1, ..., i -> -i - 1, .... -vectorBinarySearch :: (Unboxed a, Ord a) => Vector a -> a -> IO Int -vectorBinarySearch vector item = - do array <- readIORef (vectorArrayRef vector) - count <- readIORef (vectorCountRef vector) - vectorBinarySearch' array item 0 (count - 1) - --- | Return the elements of the vector in an immutable array. -freezeVector :: Unboxed a => Vector a -> IO (Array Int a) -freezeVector vector = - do vector' <- copyVector vector - array <- readIORef (vectorArrayRef vector') - freeze array - --- | Insert the element in the vector at the specified index. -vectorInsert :: Unboxed a => Vector a -> Int -> a -> IO () -vectorInsert vector index item = - do count <- readIORef (vectorCountRef vector) - when (index < 0) $ - error $ - "Index cannot be " ++ - "negative: vectorInsert." - when (index > count) $ - error $ - "Index cannot be greater " ++ - "than the count: vectorInsert." - vectorEnsureCapacity vector (count + 1) - array <- readIORef (vectorArrayRef vector) - forM_ [count, count - 1 .. index + 1] $ \i -> - do x <- readArray array (i - 1) - writeArray array i x - writeArray array index item - writeIORef (vectorCountRef vector) (count + 1) - --- | Delete the element at the specified index. -vectorDeleteAt :: Unboxed a => Vector a -> Int -> IO () -vectorDeleteAt vector index = - do count <- readIORef (vectorCountRef vector) - when (index < 0) $ - error $ - "Index cannot be " ++ - "negative: vectorDeleteAt." - when (index >= count) $ - error $ - "Index must be less " ++ - "than the count: vectorDeleteAt." - array <- readIORef (vectorArrayRef vector) - forM_ [index, index + 1 .. count - 2] $ \i -> - do x <- readArray array (i + 1) - writeArray array i x - writeArray array (count - 1) undefined - writeIORef (vectorCountRef vector) (count - 1) - --- | Return the index of the item or -1. -vectorIndex :: (Unboxed a, Eq a) => Vector a -> a -> IO Int -vectorIndex vector item = - do count <- readIORef (vectorCountRef vector) - array <- readIORef (vectorArrayRef vector) - let loop index = - if index >= count - then return $ -1 - else do x <- readArray array index - if item == x - then return index - else loop $ index + 1 - loop 0 - + +-- | +-- Module : Simulation.Aivika.Vector.Unboxed +-- Copyright : Copyright (c) 2009-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- An imperative unboxed vector. +-- +module Simulation.Aivika.Vector.Unboxed + (Vector, + newVector, + copyVector, + vectorCount, + appendVector, + readVector, + writeVector, + vectorBinarySearch, + vectorInsert, + vectorDeleteAt, + vectorIndex, + freezeVector) where + +import Data.Array +import Data.Array.MArray.Safe +import Data.Array.IO.Safe +import Data.IORef +import Control.Monad + +import Simulation.Aivika.Unboxed + +-- | Represents an unboxed resizable vector. +data Vector a = Vector { vectorArrayRef :: IORef (IOUArray Int a), + vectorCountRef :: IORef Int, + vectorCapacityRef :: IORef Int } + +-- | Create a new vector. +newVector :: Unboxed a => IO (Vector a) +newVector = + do array <- newUnboxedArray_ (0, 4 - 1) + arrayRef <- newIORef array + countRef <- newIORef 0 + capacityRef <- newIORef 4 + return Vector { vectorArrayRef = arrayRef, + vectorCountRef = countRef, + vectorCapacityRef = capacityRef } + +-- | Copy the vector. +copyVector :: Unboxed a => Vector a -> IO (Vector a) +copyVector vector = + do array <- readIORef (vectorArrayRef vector) + count <- readIORef (vectorCountRef vector) + array' <- newUnboxedArray_ (0, count - 1) + arrayRef' <- newIORef array' + countRef' <- newIORef count + capacityRef' <- newIORef count + forM_ [0 .. count - 1] $ \i -> + do x <- readArray array i + writeArray array' i x + return Vector { vectorArrayRef = arrayRef', + vectorCountRef = countRef', + vectorCapacityRef = capacityRef' } + +-- | Ensure that the vector has the specified capacity. +vectorEnsureCapacity :: Unboxed a => Vector a -> Int -> IO () +vectorEnsureCapacity vector capacity = + do capacity' <- readIORef (vectorCapacityRef vector) + when (capacity' < capacity) $ + do array' <- readIORef (vectorArrayRef vector) + count' <- readIORef (vectorCountRef vector) + let capacity'' = max (2 * capacity') capacity + array'' <- newUnboxedArray_ (0, capacity'' - 1) + forM_ [0 .. count' - 1] $ \i -> + do x <- readArray array' i + writeArray array'' i x + writeIORef (vectorArrayRef vector) array'' + writeIORef (vectorCapacityRef vector) capacity'' + +-- | Return the element count. +vectorCount :: Unboxed a => Vector a -> IO Int +vectorCount vector = readIORef (vectorCountRef vector) + +-- | Add the specified element to the end of the vector. +appendVector :: Unboxed a => Vector a -> a -> IO () +appendVector vector item = + do count <- readIORef (vectorCountRef vector) + vectorEnsureCapacity vector (count + 1) + array <- readIORef (vectorArrayRef vector) + writeArray array count item + writeIORef (vectorCountRef vector) (count + 1) + +-- | Read a value from the vector, where indices are started from 0. +readVector :: Unboxed a => Vector a -> Int -> IO a +readVector vector index = + do array <- readIORef (vectorArrayRef vector) + readArray array index + +-- | Set an array item at the specified index which is started from 0. +writeVector :: Unboxed a => Vector a -> Int -> a -> IO () +writeVector vector index item = + do array <- readIORef (vectorArrayRef vector) + writeArray array index item + +vectorBinarySearch' :: (Unboxed a, Ord a) => IOUArray Int a -> a -> Int -> Int -> IO Int +vectorBinarySearch' array item left right = + if left > right + then return $ - (right + 1) - 1 + else + do let index = (left + right) `div` 2 + curr <- readArray array index + if item < curr + then vectorBinarySearch' array item left (index - 1) + else if item == curr + then return index + else vectorBinarySearch' array item (index + 1) right + +-- | Return the index of the specified element using binary search; otherwise, +-- a negated insertion index minus one: 0 -> -0 - 1, ..., i -> -i - 1, .... +vectorBinarySearch :: (Unboxed a, Ord a) => Vector a -> a -> IO Int +vectorBinarySearch vector item = + do array <- readIORef (vectorArrayRef vector) + count <- readIORef (vectorCountRef vector) + vectorBinarySearch' array item 0 (count - 1) + +-- | Return the elements of the vector in an immutable array. +freezeVector :: Unboxed a => Vector a -> IO (Array Int a) +freezeVector vector = + do vector' <- copyVector vector + array <- readIORef (vectorArrayRef vector') + freeze array + +-- | Insert the element in the vector at the specified index. +vectorInsert :: Unboxed a => Vector a -> Int -> a -> IO () +vectorInsert vector index item = + do count <- readIORef (vectorCountRef vector) + when (index < 0) $ + error $ + "Index cannot be " ++ + "negative: vectorInsert." + when (index > count) $ + error $ + "Index cannot be greater " ++ + "than the count: vectorInsert." + vectorEnsureCapacity vector (count + 1) + array <- readIORef (vectorArrayRef vector) + forM_ [count, count - 1 .. index + 1] $ \i -> + do x <- readArray array (i - 1) + writeArray array i x + writeArray array index item + writeIORef (vectorCountRef vector) (count + 1) + +-- | Delete the element at the specified index. +vectorDeleteAt :: Unboxed a => Vector a -> Int -> IO () +vectorDeleteAt vector index = + do count <- readIORef (vectorCountRef vector) + when (index < 0) $ + error $ + "Index cannot be " ++ + "negative: vectorDeleteAt." + when (index >= count) $ + error $ + "Index must be less " ++ + "than the count: vectorDeleteAt." + array <- readIORef (vectorArrayRef vector) + forM_ [index, index + 1 .. count - 2] $ \i -> + do x <- readArray array (i + 1) + writeArray array i x + writeArray array (count - 1) undefined + writeIORef (vectorCountRef vector) (count - 1) + +-- | Return the index of the item or -1. +vectorIndex :: (Unboxed a, Eq a) => Vector a -> a -> IO Int +vectorIndex vector item = + do count <- readIORef (vectorCountRef vector) + array <- readIORef (vectorArrayRef vector) + let loop index = + if index >= count + then return $ -1 + else do x <- readArray array index + if item == x + then return index + else loop $ index + 1 + loop 0 + diff --git a/aivika.cabal b/aivika.cabal --- a/aivika.cabal +++ b/aivika.cabal @@ -1,200 +1,203 @@ -name: aivika -version: 1.4 -synopsis: A multi-paradigm simulation library -description: - Aivika is a multi-paradigm simulation library with a strong emphasis - on Discrete Event Simulation (DES) and System Dynamics (SD). - . - The library has the following features: - . - * allows defining recursive stochastic differential equations of - System Dynamics (unordered as in maths via the recursive do-notation); - . - * supports the event-driven paradigm of DES as a basic core for - implementing other paradigms; - . - * supports extensively the process-oriented paradigm of DES - with an ability to resume, suspend and cancel - the discontinuous processes; - . - * allows working with the resources based on specified queue strategies - (FCFS\/FIFO, LCFS\/LIFO, SIRO, static priorities and so on); - . - * allows customizing the infinite and finite queues based on strategies too; - . - * allows defining a queue network based on infinite streams of data - and their processors, where we can define a complex enough - behaviour just in a few lines of code; - . - * allows simulating circuits with recursive links and delays; - . - * supports the activity-oriented paradigm of DES; - . - * supports the basic constructs for the agent-based modeling; - . - * allows creating combined discrete-continuous models as all parts - of the library are well integrated and this is reflected directly - in the type system; - . - * the arrays of simulation variables are inherently supported; - . - * supports the Monte-Carlo simulation; - . - * the simulation model can depend on external parameters; - . - * uses extensively signals for notification; - . - * allows gathering statistics in time points; - . - * hides technical details in high-level simulation computations - (monads and arrows). - . - Aivika itself is a light-weight engine with minimal dependencies. - However, it has additional packages Aivika Experiment [1] and - Aivika Experiment Chart [2] that offer the following features: - . - * automating the simulation experiments; - . - * saving the results in CSV files; - . - * plotting the deviation chart by rule 3-sigma, histogram, - time series, XY chart; - . - * collecting the summary of statistical data; - . - * parallel execution of the Monte-Carlo simulation; - . - * have an extensible architecture. - . - All three libraries were tested on Linux, Windows and OS X. - . - The PDF documentation is available on the Aivika Wiki [3] website. - . - \[1] - . - \[2] - . - \[3] - . - P.S. Aivika is actually a genuine female Mari name which is pronounced - with stress on the last syllable. -category: Simulation -license: BSD3 -license-file: LICENSE -copyright: (c) 2009-2014. David Sorokin -author: David Sorokin -maintainer: David Sorokin -homepage: http://github.com/dsorokin/aivika -cabal-version: >= 1.10 -build-type: Simple -tested-with: GHC == 7.8.3 - -extra-source-files: examples/BassDiffusion.hs - examples/ChemicalReaction.hs - examples/ChemicalReactionCircuit.hs - examples/FishBank.hs - examples/MachRep1.hs - examples/MachRep1EventDriven.hs - examples/MachRep1TimeDriven.hs - examples/MachRep2.hs - examples/MachRep3.hs - examples/Furnace.hs - examples/InspectionAdjustmentStations.hs - examples/WorkStationsInSeries.hs - examples/TimeOut.hs - examples/TimeOutInt.hs - examples/TimeOutWait.hs - -flag haste-inst - - description: The package is built using haste-inst - default: False - -library - - exposed-modules: Simulation.Aivika - Simulation.Aivika.Agent - Simulation.Aivika.Arrival - Simulation.Aivika.Circuit - Simulation.Aivika.Cont - Simulation.Aivika.DoubleLinkedList - Simulation.Aivika.Dynamics - Simulation.Aivika.Dynamics.Fold - Simulation.Aivika.Dynamics.Interpolate - Simulation.Aivika.Dynamics.Memo - Simulation.Aivika.Dynamics.Memo.Unboxed - Simulation.Aivika.Dynamics.Random - Simulation.Aivika.Event - Simulation.Aivika.Generator - Simulation.Aivika.Net - Simulation.Aivika.Parameter - Simulation.Aivika.Parameter.Random - Simulation.Aivika.PriorityQueue - Simulation.Aivika.Process - Simulation.Aivika.Processor - Simulation.Aivika.Processor.RoundRobbin - Simulation.Aivika.Queue - Simulation.Aivika.Queue.Infinite - Simulation.Aivika.QueueStrategy - Simulation.Aivika.Ref - Simulation.Aivika.Ref.Light - Simulation.Aivika.Resource - Simulation.Aivika.Results.Locale - Simulation.Aivika.Results - Simulation.Aivika.Results.IO - Simulation.Aivika.Server - Simulation.Aivika.Signal - Simulation.Aivika.Simulation - Simulation.Aivika.Specs - Simulation.Aivika.Statistics - Simulation.Aivika.Statistics.Accumulator - Simulation.Aivika.Stream - Simulation.Aivika.Stream.Random - Simulation.Aivika.SystemDynamics - Simulation.Aivika.Table - Simulation.Aivika.Task - Simulation.Aivika.Transform - Simulation.Aivika.Unboxed - Simulation.Aivika.Var - Simulation.Aivika.Var.Unboxed - Simulation.Aivika.Vector - Simulation.Aivika.Vector.Unboxed - - other-modules: Simulation.Aivika.Internal.Cont - Simulation.Aivika.Internal.Dynamics - Simulation.Aivika.Internal.Event - Simulation.Aivika.Internal.Parameter - Simulation.Aivika.Internal.Process - Simulation.Aivika.Internal.Signal - Simulation.Aivika.Internal.Simulation - Simulation.Aivika.Internal.Specs - Simulation.Aivika.Internal.Arrival - - build-depends: base >= 4.5.0.0 && < 6, - mtl >= 2.1.1, - array >= 0.3.0.0, - containers >= 0.4.0.0, - random >= 1.0.0.3 - - if !flag(haste-inst) - build-depends: vector >= 0.10.0.1 - - other-extensions: FlexibleContexts, - FlexibleInstances, - UndecidableInstances, - BangPatterns, - RecursiveDo, - Arrows, - MultiParamTypeClasses, - FunctionalDependencies, - ExistentialQuantification, - CPP - - ghc-options: -O2 - - default-language: Haskell2010 - -source-repository head - - type: git - location: https://github.com/dsorokin/aivika +name: aivika +version: 2.0 +synopsis: A multi-paradigm simulation library +description: + Aivika is a multi-paradigm simulation library with a strong emphasis + on Discrete Event Simulation (DES) and System Dynamics (SD). + . + The library has the following features: + . + * allows defining recursive stochastic differential equations of + System Dynamics (unordered as in maths via the recursive do-notation); + . + * supports the event-driven paradigm of DES as a basic core for + implementing other paradigms; + . + * supports extensively the process-oriented paradigm of DES + with an ability to resume, suspend and cancel + the discontinuous processes; + . + * allows working with the resources based on specified queue strategies + (FCFS\/FIFO, LCFS\/LIFO, SIRO, static priorities and so on); + . + * allows customizing the infinite and finite queues based on strategies too; + . + * allows defining a queue network based on infinite streams of data + and their processors, where we can define a complex enough + behaviour just in a few lines of code; + . + * allows simulating circuits with recursive links and delays; + . + * supports the activity-oriented paradigm of DES; + . + * supports the basic constructs for the agent-based modeling; + . + * allows creating combined discrete-continuous models as all parts + of the library are well integrated and this is reflected directly + in the type system; + . + * the arrays of simulation variables are inherently supported; + . + * supports the Monte-Carlo simulation; + . + * the simulation model can depend on external parameters; + . + * uses extensively signals for notification; + . + * allows gathering statistics in time points; + . + * hides technical details in high-level simulation computations + (monads and arrows). + . + Aivika itself is a light-weight engine with minimal dependencies. + However, it has additional packages Aivika Experiment [1] and + Aivika Experiment Chart [2] that offer the following features: + . + * automating the simulation experiments; + . + * saving the results in CSV files; + . + * plotting the deviation chart by rule 3-sigma, histogram, + time series, XY chart; + . + * collecting the summary of statistical data; + . + * parallel execution of the Monte-Carlo simulation; + . + * have an extensible architecture. + . + All three libraries were tested on Linux, Windows and OS X. + . + The PDF documentation is available on the Aivika Wiki [3] website. + . + \[1] + . + \[2] + . + \[3] + . + P.S. Aivika is actually a genuine female Mari name which is pronounced + with stress on the last syllable. +category: Simulation +license: BSD3 +license-file: LICENSE +copyright: (c) 2009-2014. David Sorokin +author: David Sorokin +maintainer: David Sorokin +homepage: http://github.com/dsorokin/aivika +cabal-version: >= 1.10 +build-type: Simple +tested-with: GHC == 7.8.3 + +extra-source-files: examples/BassDiffusion.hs + examples/ChemicalReaction.hs + examples/ChemicalReactionCircuit.hs + examples/FishBank.hs + examples/MachRep1.hs + examples/MachRep1EventDriven.hs + examples/MachRep1TimeDriven.hs + examples/MachRep2.hs + examples/MachRep3.hs + examples/Furnace.hs + examples/InspectionAdjustmentStations.hs + examples/WorkStationsInSeries.hs + examples/TimeOut.hs + examples/TimeOutInt.hs + examples/TimeOutWait.hs + +flag haste-inst + + description: The package is built using haste-inst + default: False + +library + + exposed-modules: Simulation.Aivika + Simulation.Aivika.Agent + Simulation.Aivika.Arrival + Simulation.Aivika.Circuit + Simulation.Aivika.Cont + Simulation.Aivika.DoubleLinkedList + Simulation.Aivika.Dynamics + Simulation.Aivika.Dynamics.Extra + Simulation.Aivika.Dynamics.Memo + Simulation.Aivika.Dynamics.Memo.Unboxed + Simulation.Aivika.Dynamics.Random + Simulation.Aivika.Event + Simulation.Aivika.Generator + Simulation.Aivika.Net + Simulation.Aivika.Parameter + Simulation.Aivika.Parameter.Random + Simulation.Aivika.PriorityQueue + Simulation.Aivika.Process + Simulation.Aivika.Processor + Simulation.Aivika.Processor.RoundRobbin + Simulation.Aivika.Queue + Simulation.Aivika.Queue.Infinite + Simulation.Aivika.QueueStrategy + Simulation.Aivika.Ref + Simulation.Aivika.Ref.Plain + Simulation.Aivika.Resource + Simulation.Aivika.Results.Locale + Simulation.Aivika.Results + Simulation.Aivika.Results.IO + Simulation.Aivika.Server + Simulation.Aivika.Signal + Simulation.Aivika.Simulation + Simulation.Aivika.Specs + Simulation.Aivika.Statistics + Simulation.Aivika.Statistics.Accumulator + Simulation.Aivika.Stream + Simulation.Aivika.Stream.Random + Simulation.Aivika.SystemDynamics + Simulation.Aivika.Table + Simulation.Aivika.Task + Simulation.Aivika.Transform + Simulation.Aivika.Transform.Extra + Simulation.Aivika.Transform.Memo + Simulation.Aivika.Transform.Memo.Unboxed + Simulation.Aivika.Unboxed + Simulation.Aivika.Var + Simulation.Aivika.Var.Unboxed + Simulation.Aivika.Vector + Simulation.Aivika.Vector.Unboxed + + other-modules: Simulation.Aivika.Internal.Cont + Simulation.Aivika.Internal.Dynamics + Simulation.Aivika.Internal.Event + Simulation.Aivika.Internal.Parameter + Simulation.Aivika.Internal.Process + Simulation.Aivika.Internal.Signal + Simulation.Aivika.Internal.Simulation + Simulation.Aivika.Internal.Specs + Simulation.Aivika.Internal.Arrival + + build-depends: base >= 4.5.0.0 && < 6, + mtl >= 2.1.1, + array >= 0.3.0.0, + containers >= 0.4.0.0, + random >= 1.0.0.3 + + if !flag(haste-inst) + build-depends: vector >= 0.10.0.1 + + other-extensions: FlexibleContexts, + FlexibleInstances, + UndecidableInstances, + BangPatterns, + RecursiveDo, + Arrows, + MultiParamTypeClasses, + FunctionalDependencies, + ExistentialQuantification, + TypeFamilies, + CPP + + ghc-options: -O2 + + default-language: Haskell2010 + +source-repository head + + type: git + location: https://github.com/dsorokin/aivika diff --git a/examples/BassDiffusion.hs b/examples/BassDiffusion.hs --- a/examples/BassDiffusion.hs +++ b/examples/BassDiffusion.hs @@ -1,104 +1,104 @@ - --- This is the Bass Diffusion model solved with help of --- the Agent-based Modeling as described in the AnyLogic --- documentation. - -import Data.Array - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika - -n = 500 -- the number of agents - -advertisingEffectiveness = 0.011 -contactRate = 100.0 -adoptionFraction = 0.015 - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 8.0, - spcDT = 0.1, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -data Person = Person { personAgent :: Agent, - personPotentialAdopter :: AgentState, - personAdopter :: AgentState } - -createPerson :: Simulation Person -createPerson = - do agent <- newAgent - potentialAdopter <- newState agent - adopter <- newState agent - return Person { personAgent = agent, - personPotentialAdopter = potentialAdopter, - personAdopter = adopter } - -createPersons :: Simulation (Array Int Person) -createPersons = - do list <- forM [1 .. n] $ \i -> - do p <- createPerson - return (i, p) - return $ array (1, n) list - -definePerson :: Person -> Array Int Person -> Ref Int -> Ref Int -> Simulation () -definePerson p ps potentialAdopters adopters = - do setStateActivation (personPotentialAdopter p) $ - do modifyRef potentialAdopters $ \a -> a + 1 - -- add a timeout - t <- liftParameter $ - randomExponential (1 / advertisingEffectiveness) - let st = personPotentialAdopter p - st' = personAdopter p - addTimeout st t $ selectState st' - setStateActivation (personAdopter p) $ - do modifyRef adopters $ \a -> a + 1 - -- add a timer that works while the state is active - let t = liftParameter $ - randomExponential (1 / contactRate) -- many times! - addTimer (personAdopter p) t $ - do i <- liftParameter $ - randomUniformInt 1 n - let p' = ps ! i - st <- selectedState (personAgent p') - when (st == Just (personPotentialAdopter p')) $ - do b <- liftParameter $ - randomTrue adoptionFraction - when b $ selectState (personAdopter p') - setStateDeactivation (personPotentialAdopter p) $ - modifyRef potentialAdopters $ \a -> a - 1 - setStateDeactivation (personAdopter p) $ - modifyRef adopters $ \a -> a - 1 - -definePersons :: Array Int Person -> Ref Int -> Ref Int -> Simulation () -definePersons ps potentialAdopters adopters = - forM_ (elems ps) $ \p -> - definePerson p ps potentialAdopters adopters - -activatePerson :: Person -> Event () -activatePerson p = selectState (personPotentialAdopter p) - -activatePersons :: Array Int Person -> Event () -activatePersons ps = - forM_ (elems ps) $ \p -> activatePerson p - -model :: Simulation Results -model = - do potentialAdopters <- newRef 0 - adopters <- newRef 0 - ps <- createPersons - definePersons ps potentialAdopters adopters - runEventInStartTime $ - activatePersons ps - return $ - results - [resultSource - "potentialAdopter" "potential adopters" potentialAdopters, - resultSource - "adopters" "adopters" adopters] - -main = - printSimulationResultsInIntegTimes - printResultSourceInEnglish - model specs + +-- This is the Bass Diffusion model solved with help of +-- the Agent-based Modeling as described in the AnyLogic +-- documentation. + +import Data.Array + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika + +n = 500 -- the number of agents + +advertisingEffectiveness = 0.011 +contactRate = 100.0 +adoptionFraction = 0.015 + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 8.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +data Person = Person { personAgent :: Agent, + personPotentialAdopter :: AgentState, + personAdopter :: AgentState } + +createPerson :: Simulation Person +createPerson = + do agent <- newAgent + potentialAdopter <- newState agent + adopter <- newState agent + return Person { personAgent = agent, + personPotentialAdopter = potentialAdopter, + personAdopter = adopter } + +createPersons :: Simulation (Array Int Person) +createPersons = + do list <- forM [1 .. n] $ \i -> + do p <- createPerson + return (i, p) + return $ array (1, n) list + +definePerson :: Person -> Array Int Person -> Ref Int -> Ref Int -> Simulation () +definePerson p ps potentialAdopters adopters = + do setStateActivation (personPotentialAdopter p) $ + do modifyRef potentialAdopters $ \a -> a + 1 + -- add a timeout + t <- liftParameter $ + randomExponential (1 / advertisingEffectiveness) + let st = personPotentialAdopter p + st' = personAdopter p + addTimeout st t $ selectState st' + setStateActivation (personAdopter p) $ + do modifyRef adopters $ \a -> a + 1 + -- add a timer that works while the state is active + let t = liftParameter $ + randomExponential (1 / contactRate) -- many times! + addTimer (personAdopter p) t $ + do i <- liftParameter $ + randomUniformInt 1 n + let p' = ps ! i + st <- selectedState (personAgent p') + when (st == Just (personPotentialAdopter p')) $ + do b <- liftParameter $ + randomTrue adoptionFraction + when b $ selectState (personAdopter p') + setStateDeactivation (personPotentialAdopter p) $ + modifyRef potentialAdopters $ \a -> a - 1 + setStateDeactivation (personAdopter p) $ + modifyRef adopters $ \a -> a - 1 + +definePersons :: Array Int Person -> Ref Int -> Ref Int -> Simulation () +definePersons ps potentialAdopters adopters = + forM_ (elems ps) $ \p -> + definePerson p ps potentialAdopters adopters + +activatePerson :: Person -> Event () +activatePerson p = selectState (personPotentialAdopter p) + +activatePersons :: Array Int Person -> Event () +activatePersons ps = + forM_ (elems ps) $ \p -> activatePerson p + +model :: Simulation Results +model = + do potentialAdopters <- newRef 0 + adopters <- newRef 0 + ps <- createPersons + definePersons ps potentialAdopters adopters + runEventInStartTime $ + activatePersons ps + return $ + results + [resultSource + "potentialAdopter" "potential adopters" potentialAdopters, + resultSource + "adopters" "adopters" adopters] + +main = + printSimulationResultsInIntegTimes + printResultSourceInEnglish + model specs diff --git a/examples/ChemicalReaction.hs b/examples/ChemicalReaction.hs --- a/examples/ChemicalReaction.hs +++ b/examples/ChemicalReaction.hs @@ -1,30 +1,30 @@ - -{-# LANGUAGE RecursiveDo #-} - -import Simulation.Aivika -import Simulation.Aivika.SystemDynamics - -import qualified Data.Vector as V - -specs = Specs { spcStartTime = 0, - spcStopTime = 13, - spcDT = 0.01, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: Simulation Results -model = - mdo a <- integ (- ka * a) 100 - b <- integ (ka * a - kb * b) 0 - c <- integ (kb * b) 0 - let ka = 1 - kb = 1 - return $ results - [resultSource "a" "variable A" a, - resultSource "b" "variable B" b, - resultSource "c" "variable C" c] - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - model specs + +{-# LANGUAGE RecursiveDo #-} + +import Simulation.Aivika +import Simulation.Aivika.SystemDynamics + +import qualified Data.Vector as V + +specs = Specs { spcStartTime = 0, + spcStopTime = 13, + spcDT = 0.01, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: Simulation Results +model = + mdo a <- integ (- ka * a) 100 + b <- integ (ka * a - kb * b) 0 + c <- integ (kb * b) 0 + let ka = 1 + kb = 1 + return $ results + [resultSource "a" "variable A" a, + resultSource "b" "variable B" b, + resultSource "c" "variable C" c] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + model specs diff --git a/examples/ChemicalReactionCircuit.hs b/examples/ChemicalReactionCircuit.hs --- a/examples/ChemicalReactionCircuit.hs +++ b/examples/ChemicalReactionCircuit.hs @@ -1,43 +1,43 @@ - --- Note that the integCircut function uses Euler's method regardless of --- the simulation specs specified. Therefore, to receieve almost the same --- results in the old example based on using the integ function, you should --- specify Euler's method in their specs in that file, although the Runge-Kutta --- method gives similar results too, which is expected. --- --- Finally, the integ function can be significantly faster than integCircuit, --- although they have different purposes. - -{-# LANGUAGE Arrows #-} - -import Control.Arrow - -import Simulation.Aivika - -specs = Specs { spcStartTime = 0, - spcStopTime = 13, - spcDT = 0.01, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -circuit :: Circuit () [Double] -circuit = - let ka = 1 - kb = 1 - in proc () -> do - rec let da = - ka * a - db = ka * a - kb * b - dc = kb * b - a <- integCircuit 100 -< da - b <- integCircuit 0 -< db - c <- integCircuit 0 -< dc - returnA -< [a, b, c] - -model :: Simulation [Double] -model = - do results <- - runTransform (circuitTransform circuit) $ - return () - runDynamicsInStopTime results - -main = runSimulation model specs >>= print + +-- Note that the integCircut function uses Euler's method regardless of +-- the simulation specs specified. Therefore, to receieve almost the same +-- results in the old example based on using the integ function, you should +-- specify Euler's method in their specs in that file, although the Runge-Kutta +-- method gives similar results too, which is expected. +-- +-- Finally, the integ function can be significantly faster than integCircuit, +-- although they have different purposes. + +{-# LANGUAGE Arrows #-} + +import Control.Arrow + +import Simulation.Aivika + +specs = Specs { spcStartTime = 0, + spcStopTime = 13, + spcDT = 0.01, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +circuit :: Circuit () [Double] +circuit = + let ka = 1 + kb = 1 + in proc () -> do + rec let da = - ka * a + db = ka * a - kb * b + dc = kb * b + a <- integCircuit 100 -< da + b <- integCircuit 0 -< db + c <- integCircuit 0 -< dc + returnA -< [a, b, c] + +model :: Simulation [Double] +model = + do results <- + runTransform (circuitTransform circuit) $ + return () + runDynamicsInStopTime results + +main = runSimulation model specs >>= print diff --git a/examples/FishBank.hs b/examples/FishBank.hs --- a/examples/FishBank.hs +++ b/examples/FishBank.hs @@ -1,60 +1,60 @@ - -{-# LANGUAGE RecursiveDo #-} - -import Data.Array - -import Simulation.Aivika -import Simulation.Aivika.SystemDynamics - -specs = Specs { spcStartTime = 0, - spcStopTime = 13, - spcDT = 0.01, - -- spcDT = 0.000005, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: Simulation Results -model = - mdo let annualProfit = profit - area = 100 - carryingCapacity = 1000 - catchPerShip = - lookupDynamics density $ - listArray (1, 11) [(0.0, -0.048), (1.2, 10.875), (2.4, 17.194), - (3.6, 20.548), (4.8, 22.086), (6.0, 23.344), - (7.2, 23.903), (8.4, 24.462), (9.6, 24.882), - (10.8, 25.301), (12.0, 25.86)] - deathFraction = - lookupDynamics (fish / carryingCapacity) $ - listArray (1, 11) [(0.0, 5.161), (0.1, 5.161), (0.2, 5.161), - (0.3, 5.161), (0.4, 5.161), (0.5, 5.161), - (0.6, 5.118), (0.7, 5.247), (0.8, 5.849), - (0.9, 6.151), (10.0, 6.194)] - density = fish / area - fish <- integ (fishHatchRate - fishDeathRate - totalCatchPerYear) 1000 - let fishDeathRate = maxDynamics 0 (fish * deathFraction) - fishHatchRate = maxDynamics 0 (fish * hatchFraction) - fishPrice = 20 - fractionInvested = 0.2 - hatchFraction = 6 - operatingCost = ships * 250 - profit = revenue - operatingCost - revenue = totalCatchPerYear * fishPrice - ships <- integ shipBuildingRate 10 - let shipBuildingRate = maxDynamics 0 (profit * fractionInvested / shipCost) - shipCost = 300 - totalProfit <- integ annualProfit 0 - let totalCatchPerYear = maxDynamics 0 (ships * catchPerShip) - -- results -- - return $ results - [resultSource "fish" "fish" fish, - resultSource "annualProfit" "the annual profit" annualProfit, - resultSource "totalProfit" "the total profit" totalProfit] - -main = - flip runSimulation specs $ - model >>= \results -> do - printResultsInStartTime - printResultSourceInEnglish results - printResultsInStopTime - printResultSourceInEnglish results + +{-# LANGUAGE RecursiveDo #-} + +import Data.Array + +import Simulation.Aivika +import Simulation.Aivika.SystemDynamics + +specs = Specs { spcStartTime = 0, + spcStopTime = 13, + spcDT = 0.01, + -- spcDT = 0.000005, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: Simulation Results +model = + mdo let annualProfit = profit + area = 100 + carryingCapacity = 1000 + catchPerShip = + lookupDynamics density $ + listArray (1, 11) [(0.0, -0.048), (1.2, 10.875), (2.4, 17.194), + (3.6, 20.548), (4.8, 22.086), (6.0, 23.344), + (7.2, 23.903), (8.4, 24.462), (9.6, 24.882), + (10.8, 25.301), (12.0, 25.86)] + deathFraction = + lookupDynamics (fish / carryingCapacity) $ + listArray (1, 11) [(0.0, 5.161), (0.1, 5.161), (0.2, 5.161), + (0.3, 5.161), (0.4, 5.161), (0.5, 5.161), + (0.6, 5.118), (0.7, 5.247), (0.8, 5.849), + (0.9, 6.151), (10.0, 6.194)] + density = fish / area + fish <- integ (fishHatchRate - fishDeathRate - totalCatchPerYear) 1000 + let fishDeathRate = maxDynamics 0 (fish * deathFraction) + fishHatchRate = maxDynamics 0 (fish * hatchFraction) + fishPrice = 20 + fractionInvested = 0.2 + hatchFraction = 6 + operatingCost = ships * 250 + profit = revenue - operatingCost + revenue = totalCatchPerYear * fishPrice + ships <- integ shipBuildingRate 10 + let shipBuildingRate = maxDynamics 0 (profit * fractionInvested / shipCost) + shipCost = 300 + totalProfit <- integ annualProfit 0 + let totalCatchPerYear = maxDynamics 0 (ships * catchPerShip) + -- results -- + return $ results + [resultSource "fish" "fish" fish, + resultSource "annualProfit" "the annual profit" annualProfit, + resultSource "totalProfit" "the total profit" totalProfit] + +main = + flip runSimulation specs $ + model >>= \results -> do + printResultsInStartTime + printResultSourceInEnglish results + printResultsInStopTime + printResultSourceInEnglish results diff --git a/examples/Furnace.hs b/examples/Furnace.hs --- a/examples/Furnace.hs +++ b/examples/Furnace.hs @@ -1,323 +1,323 @@ - --- This is a model of the Furnace. It is described in different sources [1, 2]. --- --- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. --- --- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 - -import Data.Maybe -import System.Random -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika -import Simulation.Aivika.Queue.Infinite - --- | The simulation specs. -specs = Specs { spcStartTime = 0.0, - -- spcStopTime = 1000.0, - spcStopTime = 300.0, - spcDT = 0.1, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - --- | Return a random initial temperature of the item. -randomTemp :: Parameter Double -randomTemp = randomUniform 400 600 - --- | Represents the furnace. -data Furnace = - Furnace { furnacePits :: [Pit], - -- ^ The pits for ingots. - furnacePitCount :: Ref Int, - -- ^ The count of active pits with ingots. - furnaceQueue :: FCFSQueue Ingot, - -- ^ The furnace queue. - furnaceUnloadedSource :: SignalSource (), - -- ^ Notifies when the ingots have been - -- unloaded from the furnace. - furnaceHeatingTime :: Ref (SamplingStats Double), - -- ^ The heating time for the ready ingots. - furnaceTemp :: Ref Double, - -- ^ The furnace temperature. - furnaceReadyCount :: Ref Int, - -- ^ The count of ready ingots. - furnaceReadyTemps :: Ref [Double] - -- ^ The temperatures of all ready ingots. - } - --- | Notifies when the ingots have been unloaded from the furnace. -furnaceUnloaded :: Furnace -> Signal () -furnaceUnloaded = publishSignal . furnaceUnloadedSource - --- | A pit in the furnace to place the ingots. -data Pit = - Pit { pitIngot :: Ref (Maybe Ingot), - -- ^ The ingot in the pit. - pitTemp :: Ref Double - -- ^ The ingot temperature in the pit. - } - -data Ingot = - Ingot { ingotFurnace :: Furnace, - -- ^ The furnace. - ingotReceiveTime :: Double, - -- ^ The time at which the ingot was received. - ingotReceiveTemp :: Double, - -- ^ The temperature with which the ingot was received. - ingotLoadTime :: Double, - -- ^ The time of loading in the furnace. - ingotLoadTemp :: Double, - -- ^ The temperature when the ingot was loaded in the furnace. - ingotCoeff :: Double - -- ^ The heating coefficient. - } - --- | Create a furnace. -newFurnace :: Simulation Furnace -newFurnace = - do pits <- sequence [newPit | i <- [1..10]] - pitCount <- newRef 0 - queue <- runEventInStartTime newFCFSQueue - heatingTime <- newRef emptySamplingStats - h <- newRef 1650.0 - readyCount <- newRef 0 - readyTemps <- newRef [] - s <- newSignalSource - return Furnace { furnacePits = pits, - furnacePitCount = pitCount, - furnaceQueue = queue, - furnaceUnloadedSource = s, - furnaceHeatingTime = heatingTime, - furnaceTemp = h, - furnaceReadyCount = readyCount, - furnaceReadyTemps = readyTemps } - --- | Create a new pit. -newPit :: Simulation Pit -newPit = - do ingot <- newRef Nothing - h' <- newRef 0.0 - return Pit { pitIngot = ingot, - pitTemp = h' } - --- | Create a new ingot. -newIngot :: Furnace -> Event Ingot -newIngot furnace = - do t <- liftDynamics time - xi <- liftParameter $ randomNormal 0.05 0.01 - h' <- liftParameter randomTemp - let c = 0.1 + xi - return Ingot { ingotFurnace = furnace, - ingotReceiveTime = t, - ingotReceiveTemp = h', - ingotLoadTime = t, - ingotLoadTemp = h', - ingotCoeff = c } - --- | Heat the ingot up in the pit if there is such an ingot. -heatPitUp :: Pit -> Event () -heatPitUp pit = - do ingot <- readRef (pitIngot pit) - case ingot of - Nothing -> - return () - Just ingot -> do - - -- update the temperature of the ingot. - let furnace = ingotFurnace ingot - dt' <- liftParameter dt - h' <- readRef (pitTemp pit) - h <- readRef (furnaceTemp furnace) - writeRef (pitTemp pit) $ - h' + dt' * (h - h') * ingotCoeff ingot - --- | Check whether there are ready ingots in the pits. -ingotsReady :: Furnace -> Event Bool -ingotsReady furnace = - fmap (not . null) $ - filterM (fmap (>= 2200.0) . readRef . pitTemp) $ - furnacePits furnace - --- | Try to unload the ready ingot from the specified pit. -tryUnloadPit :: Furnace -> Pit -> Event () -tryUnloadPit furnace pit = - do h' <- readRef (pitTemp pit) - when (h' >= 2000.0) $ - do Just ingot <- readRef (pitIngot pit) - unloadIngot furnace ingot pit - --- | Try to load an awaiting ingot in the specified empty pit. -tryLoadPit :: Furnace -> Pit -> Event () -tryLoadPit furnace pit = - do ingot <- tryDequeue (furnaceQueue furnace) - case ingot of - Nothing -> - return () - Just ingot -> - do t' <- liftDynamics time - loadIngot furnace (ingot { ingotLoadTime = t', - ingotLoadTemp = 400.0 }) pit - --- | Unload the ingot from the specified pit. -unloadIngot :: Furnace -> Ingot -> Pit -> Event () -unloadIngot furnace ingot pit = - do h' <- readRef (pitTemp pit) - writeRef (pitIngot pit) Nothing - writeRef (pitTemp pit) 0.0 - - -- count the active pits - modifyRef (furnacePitCount furnace) (+ (- 1)) - - -- how long did we heat the ingot up? - t' <- liftDynamics time - modifyRef (furnaceHeatingTime furnace) $ - addSamplingStats (t' - ingotLoadTime ingot) - - -- what is the temperature of the unloaded ingot? - modifyRef (furnaceReadyTemps furnace) (h' :) - - -- count the ready ingots - modifyRef (furnaceReadyCount furnace) (+ 1) - --- | Load the ingot in the specified pit -loadIngot :: Furnace -> Ingot -> Pit -> Event () -loadIngot furnace ingot pit = - do writeRef (pitIngot pit) $ Just ingot - writeRef (pitTemp pit) $ ingotLoadTemp ingot - - -- count the active pits - modifyRef (furnacePitCount furnace) (+ 1) - count <- readRef (furnacePitCount furnace) - - -- decrease the furnace temperature - h <- readRef (furnaceTemp furnace) - let h' = ingotLoadTemp ingot - dh = - (h - h') / fromIntegral count - writeRef (furnaceTemp furnace) $ h + dh - --- | Start iterating the furnace processing through the event queue. -startIteratingFurnace :: Furnace -> Event () -startIteratingFurnace furnace = - let pits = furnacePits furnace - in enqueueEventWithIntegTimes $ - do -- try to unload ready ingots - ready <- ingotsReady furnace - when ready $ - do mapM_ (tryUnloadPit furnace) pits - triggerSignal (furnaceUnloadedSource furnace) () - - -- heat up - mapM_ heatPitUp pits - - -- update the temperature of the furnace - dt' <- liftParameter dt - h <- readRef (furnaceTemp furnace) - writeRef (furnaceTemp furnace) $ - h + dt' * (2600.0 - h) * 0.2 - --- | Return all empty pits. -emptyPits :: Furnace -> Event [Pit] -emptyPits furnace = - filterM (fmap isNothing . readRef . pitIngot) $ - furnacePits furnace - --- | This process takes ingots from the queue and then --- loads them in the furnace. -loadingProcess :: Furnace -> Process () -loadingProcess furnace = - do ingot <- dequeue (furnaceQueue furnace) - let wait :: Process () - wait = - do count <- liftEvent $ readRef (furnacePitCount furnace) - when (count >= 10) $ - do processAwait (furnaceUnloaded furnace) - wait - wait - -- take any empty pit and load it - liftEvent $ - do pit: _ <- emptyPits furnace - loadIngot furnace ingot pit - -- repeat it again - loadingProcess furnace - --- | The input process that adds new ingots to the queue. -inputProcess :: Furnace -> Process () -inputProcess furnace = - do delay <- liftParameter $ - randomExponential 2.5 - holdProcess delay - -- we have got a new ingot - liftEvent $ - do ingot <- newIngot furnace - enqueue (furnaceQueue furnace) ingot - -- repeat it again - inputProcess furnace - --- | Initialize the furnace. -initializeFurnace :: Furnace -> Event () -initializeFurnace furnace = - do x1 <- newIngot furnace - x2 <- newIngot furnace - x3 <- newIngot furnace - x4 <- newIngot furnace - x5 <- newIngot furnace - x6 <- newIngot furnace - let p1 : p2 : p3 : p4 : p5 : p6 : ps = - furnacePits furnace - loadIngot furnace (x1 { ingotLoadTemp = 550.0 }) p1 - loadIngot furnace (x2 { ingotLoadTemp = 600.0 }) p2 - loadIngot furnace (x3 { ingotLoadTemp = 650.0 }) p3 - loadIngot furnace (x4 { ingotLoadTemp = 700.0 }) p4 - loadIngot furnace (x5 { ingotLoadTemp = 750.0 }) p5 - loadIngot furnace (x6 { ingotLoadTemp = 800.0 }) p6 - writeRef (furnaceTemp furnace) 1650.0 - --- | The simulation model. -model :: Simulation Results -model = - do furnace <- newFurnace - - -- initialize the furnace and start its iterating in start time - runEventInStartTime $ - do initializeFurnace furnace - startIteratingFurnace furnace - - -- generate randomly new input ingots - runProcessInStartTime $ - inputProcess furnace - - -- load permanently the input ingots in the furnace - runProcessInStartTime $ - loadingProcess furnace - - -- return the simulation results - return $ - resultSummary $ - results - [resultSource "inputIngotCount" "the input ingot count" $ - enqueueStoreCount (furnaceQueue furnace), - -- - resultSource "loadedIngotCount" "the loaded ingot count" $ - dequeueCount (furnaceQueue furnace), - -- - resultSource "outputIngotCount" "the output ingot count" $ - furnaceReadyCount furnace, - -- - resultSource "outputIngotTemp" "the output ingot temperature" $ - fmap listSamplingStats $ readRef $ furnaceReadyTemps furnace, - -- - resultSource "heatingTime" "the heating time" $ - furnaceHeatingTime furnace, - -- - resultSource "pitCount" "the number of ingots in pits" $ - furnacePitCount furnace, - -- - resultSource "furnaceQueue" "the furnace queue" $ - furnaceQueue furnace] - --- | The main program. -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - model specs + +-- This is a model of the Furnace. It is described in different sources [1, 2]. +-- +-- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. +-- +-- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 + +import Data.Maybe +import System.Random +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika +import Simulation.Aivika.Queue.Infinite + +-- | The simulation specs. +specs = Specs { spcStartTime = 0.0, + -- spcStopTime = 1000.0, + spcStopTime = 300.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +-- | Return a random initial temperature of the item. +randomTemp :: Parameter Double +randomTemp = randomUniform 400 600 + +-- | Represents the furnace. +data Furnace = + Furnace { furnacePits :: [Pit], + -- ^ The pits for ingots. + furnacePitCount :: Ref Int, + -- ^ The count of active pits with ingots. + furnaceQueue :: FCFSQueue Ingot, + -- ^ The furnace queue. + furnaceUnloadedSource :: SignalSource (), + -- ^ Notifies when the ingots have been + -- unloaded from the furnace. + furnaceHeatingTime :: Ref (SamplingStats Double), + -- ^ The heating time for the ready ingots. + furnaceTemp :: Ref Double, + -- ^ The furnace temperature. + furnaceReadyCount :: Ref Int, + -- ^ The count of ready ingots. + furnaceReadyTemps :: Ref [Double] + -- ^ The temperatures of all ready ingots. + } + +-- | Notifies when the ingots have been unloaded from the furnace. +furnaceUnloaded :: Furnace -> Signal () +furnaceUnloaded = publishSignal . furnaceUnloadedSource + +-- | A pit in the furnace to place the ingots. +data Pit = + Pit { pitIngot :: Ref (Maybe Ingot), + -- ^ The ingot in the pit. + pitTemp :: Ref Double + -- ^ The ingot temperature in the pit. + } + +data Ingot = + Ingot { ingotFurnace :: Furnace, + -- ^ The furnace. + ingotReceiveTime :: Double, + -- ^ The time at which the ingot was received. + ingotReceiveTemp :: Double, + -- ^ The temperature with which the ingot was received. + ingotLoadTime :: Double, + -- ^ The time of loading in the furnace. + ingotLoadTemp :: Double, + -- ^ The temperature when the ingot was loaded in the furnace. + ingotCoeff :: Double + -- ^ The heating coefficient. + } + +-- | Create a furnace. +newFurnace :: Simulation Furnace +newFurnace = + do pits <- sequence [newPit | i <- [1..10]] + pitCount <- newRef 0 + queue <- runEventInStartTime newFCFSQueue + heatingTime <- newRef emptySamplingStats + h <- newRef 1650.0 + readyCount <- newRef 0 + readyTemps <- newRef [] + s <- newSignalSource + return Furnace { furnacePits = pits, + furnacePitCount = pitCount, + furnaceQueue = queue, + furnaceUnloadedSource = s, + furnaceHeatingTime = heatingTime, + furnaceTemp = h, + furnaceReadyCount = readyCount, + furnaceReadyTemps = readyTemps } + +-- | Create a new pit. +newPit :: Simulation Pit +newPit = + do ingot <- newRef Nothing + h' <- newRef 0.0 + return Pit { pitIngot = ingot, + pitTemp = h' } + +-- | Create a new ingot. +newIngot :: Furnace -> Event Ingot +newIngot furnace = + do t <- liftDynamics time + xi <- liftParameter $ randomNormal 0.05 0.01 + h' <- liftParameter randomTemp + let c = 0.1 + xi + return Ingot { ingotFurnace = furnace, + ingotReceiveTime = t, + ingotReceiveTemp = h', + ingotLoadTime = t, + ingotLoadTemp = h', + ingotCoeff = c } + +-- | Heat the ingot up in the pit if there is such an ingot. +heatPitUp :: Pit -> Event () +heatPitUp pit = + do ingot <- readRef (pitIngot pit) + case ingot of + Nothing -> + return () + Just ingot -> do + + -- update the temperature of the ingot. + let furnace = ingotFurnace ingot + dt' <- liftParameter dt + h' <- readRef (pitTemp pit) + h <- readRef (furnaceTemp furnace) + writeRef (pitTemp pit) $ + h' + dt' * (h - h') * ingotCoeff ingot + +-- | Check whether there are ready ingots in the pits. +ingotsReady :: Furnace -> Event Bool +ingotsReady furnace = + fmap (not . null) $ + filterM (fmap (>= 2200.0) . readRef . pitTemp) $ + furnacePits furnace + +-- | Try to unload the ready ingot from the specified pit. +tryUnloadPit :: Furnace -> Pit -> Event () +tryUnloadPit furnace pit = + do h' <- readRef (pitTemp pit) + when (h' >= 2000.0) $ + do Just ingot <- readRef (pitIngot pit) + unloadIngot furnace ingot pit + +-- | Try to load an awaiting ingot in the specified empty pit. +tryLoadPit :: Furnace -> Pit -> Event () +tryLoadPit furnace pit = + do ingot <- tryDequeue (furnaceQueue furnace) + case ingot of + Nothing -> + return () + Just ingot -> + do t' <- liftDynamics time + loadIngot furnace (ingot { ingotLoadTime = t', + ingotLoadTemp = 400.0 }) pit + +-- | Unload the ingot from the specified pit. +unloadIngot :: Furnace -> Ingot -> Pit -> Event () +unloadIngot furnace ingot pit = + do h' <- readRef (pitTemp pit) + writeRef (pitIngot pit) Nothing + writeRef (pitTemp pit) 0.0 + + -- count the active pits + modifyRef (furnacePitCount furnace) (+ (- 1)) + + -- how long did we heat the ingot up? + t' <- liftDynamics time + modifyRef (furnaceHeatingTime furnace) $ + addSamplingStats (t' - ingotLoadTime ingot) + + -- what is the temperature of the unloaded ingot? + modifyRef (furnaceReadyTemps furnace) (h' :) + + -- count the ready ingots + modifyRef (furnaceReadyCount furnace) (+ 1) + +-- | Load the ingot in the specified pit +loadIngot :: Furnace -> Ingot -> Pit -> Event () +loadIngot furnace ingot pit = + do writeRef (pitIngot pit) $ Just ingot + writeRef (pitTemp pit) $ ingotLoadTemp ingot + + -- count the active pits + modifyRef (furnacePitCount furnace) (+ 1) + count <- readRef (furnacePitCount furnace) + + -- decrease the furnace temperature + h <- readRef (furnaceTemp furnace) + let h' = ingotLoadTemp ingot + dh = - (h - h') / fromIntegral count + writeRef (furnaceTemp furnace) $ h + dh + +-- | Start iterating the furnace processing through the event queue. +startIteratingFurnace :: Furnace -> Event () +startIteratingFurnace furnace = + let pits = furnacePits furnace + in enqueueEventWithIntegTimes $ + do -- try to unload ready ingots + ready <- ingotsReady furnace + when ready $ + do mapM_ (tryUnloadPit furnace) pits + triggerSignal (furnaceUnloadedSource furnace) () + + -- heat up + mapM_ heatPitUp pits + + -- update the temperature of the furnace + dt' <- liftParameter dt + h <- readRef (furnaceTemp furnace) + writeRef (furnaceTemp furnace) $ + h + dt' * (2600.0 - h) * 0.2 + +-- | Return all empty pits. +emptyPits :: Furnace -> Event [Pit] +emptyPits furnace = + filterM (fmap isNothing . readRef . pitIngot) $ + furnacePits furnace + +-- | This process takes ingots from the queue and then +-- loads them in the furnace. +loadingProcess :: Furnace -> Process () +loadingProcess furnace = + do ingot <- dequeue (furnaceQueue furnace) + let wait :: Process () + wait = + do count <- liftEvent $ readRef (furnacePitCount furnace) + when (count >= 10) $ + do processAwait (furnaceUnloaded furnace) + wait + wait + -- take any empty pit and load it + liftEvent $ + do pit: _ <- emptyPits furnace + loadIngot furnace ingot pit + -- repeat it again + loadingProcess furnace + +-- | The input process that adds new ingots to the queue. +inputProcess :: Furnace -> Process () +inputProcess furnace = + do delay <- liftParameter $ + randomExponential 2.5 + holdProcess delay + -- we have got a new ingot + liftEvent $ + do ingot <- newIngot furnace + enqueue (furnaceQueue furnace) ingot + -- repeat it again + inputProcess furnace + +-- | Initialize the furnace. +initializeFurnace :: Furnace -> Event () +initializeFurnace furnace = + do x1 <- newIngot furnace + x2 <- newIngot furnace + x3 <- newIngot furnace + x4 <- newIngot furnace + x5 <- newIngot furnace + x6 <- newIngot furnace + let p1 : p2 : p3 : p4 : p5 : p6 : ps = + furnacePits furnace + loadIngot furnace (x1 { ingotLoadTemp = 550.0 }) p1 + loadIngot furnace (x2 { ingotLoadTemp = 600.0 }) p2 + loadIngot furnace (x3 { ingotLoadTemp = 650.0 }) p3 + loadIngot furnace (x4 { ingotLoadTemp = 700.0 }) p4 + loadIngot furnace (x5 { ingotLoadTemp = 750.0 }) p5 + loadIngot furnace (x6 { ingotLoadTemp = 800.0 }) p6 + writeRef (furnaceTemp furnace) 1650.0 + +-- | The simulation model. +model :: Simulation Results +model = + do furnace <- newFurnace + + -- initialize the furnace and start its iterating in start time + runEventInStartTime $ + do initializeFurnace furnace + startIteratingFurnace furnace + + -- generate randomly new input ingots + runProcessInStartTime $ + inputProcess furnace + + -- load permanently the input ingots in the furnace + runProcessInStartTime $ + loadingProcess furnace + + -- return the simulation results + return $ + resultSummary $ + results + [resultSource "inputIngotCount" "the input ingot count" $ + enqueueStoreCount (furnaceQueue furnace), + -- + resultSource "loadedIngotCount" "the loaded ingot count" $ + dequeueCount (furnaceQueue furnace), + -- + resultSource "outputIngotCount" "the output ingot count" $ + furnaceReadyCount furnace, + -- + resultSource "outputIngotTemp" "the output ingot temperature" $ + fmap listSamplingStats $ readRef $ furnaceReadyTemps furnace, + -- + resultSource "heatingTime" "the heating time" $ + furnaceHeatingTime furnace, + -- + resultSource "pitCount" "the number of ingots in pits" $ + furnacePitCount furnace, + -- + resultSource "furnaceQueue" "the furnace queue" $ + furnaceQueue furnace] + +-- | The main program. +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + model specs diff --git a/examples/InspectionAdjustmentStations.hs b/examples/InspectionAdjustmentStations.hs --- a/examples/InspectionAdjustmentStations.hs +++ b/examples/InspectionAdjustmentStations.hs @@ -1,161 +1,161 @@ - -{-# LANGUAGE RecursiveDo, Arrows #-} - --- Example: Inspection and Adjustment Stations on a Production Line --- --- This is a model of the workflow with a loop. Also there are two infinite queues. --- --- It is described in different sources [1, 2]. So, this is chapter 8 of [2] and section 5.15 of [1]. --- --- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. --- --- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 - -import Prelude hiding (id, (.)) - -import Control.Monad -import Control.Monad.Trans -import Control.Arrow -import Control.Category (id, (.)) - -import Simulation.Aivika -import Simulation.Aivika.Queue.Infinite - --- | The simulation specs. -specs = Specs { spcStartTime = 0.0, - spcStopTime = 480.0, - spcDT = 0.1, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - --- the minimum delay of arriving the next TV set -minArrivalDelay = 3.5 - --- the maximum delay of arriving the next TV set -maxArrivalDelay = 7.5 - --- the minimum time to inspect the TV set -minInspectionTime = 6 - --- the maximum time to inspect the TV set -maxInspectionTime = 12 - --- the probability of passing the inspection phase -inspectionPassingProb = 0.85 - --- how many are inspection stations? -inspectionStationCount = 2 - --- the minimum time to adjust an improper TV set -minAdjustmentTime = 20 - --- the maximum time to adjust an improper TV set -maxAdjustmentTime = 40 - --- how many are adjustment stations? -adjustmentStationCount = 1 - --- create an inspection station (server) -newInspectionStation = - newServer $ \a -> - do holdProcess =<< - (liftParameter $ - randomUniform minInspectionTime maxInspectionTime) - passed <- - liftParameter $ - randomTrue inspectionPassingProb - if passed - then return $ Right a - else return $ Left a - --- create an adjustment station (server) -newAdjustmentStation = - newServer $ \a -> - do holdProcess =<< - (liftParameter $ - randomUniform minAdjustmentTime maxAdjustmentTime) - return a - -model :: Simulation Results -model = mdo - -- to count the arrived TV sets for inspecting and adjusting - inputArrivalTimer <- newArrivalTimer - -- it will gather the statistics of the processing time - outputArrivalTimer <- newArrivalTimer - -- define a stream of input events - let inputStream = - randomUniformStream minArrivalDelay maxArrivalDelay - -- create a queue before the inspection stations - inspectionQueue <- - runEventInStartTime newFCFSQueue - -- create a queue before the adjustment stations - adjustmentQueue <- - runEventInStartTime newFCFSQueue - -- create the inspection stations (servers) - inspectionStations <- - forM [1 .. inspectionStationCount] $ \_ -> - newInspectionStation - -- create the adjustment stations (servers) - adjustmentStations <- - forM [1 .. adjustmentStationCount] $ \_ -> - newAdjustmentStation - -- a processor loop for the inspection stations' queue - let inspectionQueueProcessorLoop = - queueProcessorLoopSeq - (liftEvent . enqueue inspectionQueue) - (dequeue inspectionQueue) - inspectionProcessor - (adjustmentQueueProcessor >>> adjustmentProcessor) - -- a processor for the adjustment stations' queue - let adjustmentQueueProcessor = - queueProcessor - (liftEvent . enqueue adjustmentQueue) - (dequeue adjustmentQueue) - -- a parallel work of the inspection stations - let inspectionProcessor = - processorParallel (map serverProcessor inspectionStations) - -- a parallel work of the adjustment stations - let adjustmentProcessor = - processorParallel (map serverProcessor adjustmentStations) - -- the entire processor from input to output - let entireProcessor = - arrivalTimerProcessor inputArrivalTimer >>> - inspectionQueueProcessorLoop >>> - arrivalTimerProcessor outputArrivalTimer - -- start simulating the model - runProcessInStartTime $ - sinkStream $ runProcessor entireProcessor inputStream - -- return the simulation results in start time - return $ - results - [resultSource - "inspectionQueue" "the inspection queue" - inspectionQueue, - -- - resultSource - "adjustmentQueue" "the adjustment queue" - adjustmentQueue, - -- - resultSource - "inputArrivalTimer" "the input arrival timer" - inputArrivalTimer, - -- - resultSource - "outputArrivalTimer" "the output arrival timer" - outputArrivalTimer, - -- - resultSource - "inspectionStations" "the inspection stations" - inspectionStations, - -- - resultSource - "adjustmentStations" "the adjustment stations" - adjustmentStations] - -modelSummary :: Simulation Results -modelSummary = fmap resultSummary model - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - modelSummary specs + +{-# LANGUAGE RecursiveDo, Arrows #-} + +-- Example: Inspection and Adjustment Stations on a Production Line +-- +-- This is a model of the workflow with a loop. Also there are two infinite queues. +-- +-- It is described in different sources [1, 2]. So, this is chapter 8 of [2] and section 5.15 of [1]. +-- +-- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. +-- +-- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 + +import Prelude hiding (id, (.)) + +import Control.Monad +import Control.Monad.Trans +import Control.Arrow +import Control.Category (id, (.)) + +import Simulation.Aivika +import Simulation.Aivika.Queue.Infinite + +-- | The simulation specs. +specs = Specs { spcStartTime = 0.0, + spcStopTime = 480.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +-- the minimum delay of arriving the next TV set +minArrivalDelay = 3.5 + +-- the maximum delay of arriving the next TV set +maxArrivalDelay = 7.5 + +-- the minimum time to inspect the TV set +minInspectionTime = 6 + +-- the maximum time to inspect the TV set +maxInspectionTime = 12 + +-- the probability of passing the inspection phase +inspectionPassingProb = 0.85 + +-- how many are inspection stations? +inspectionStationCount = 2 + +-- the minimum time to adjust an improper TV set +minAdjustmentTime = 20 + +-- the maximum time to adjust an improper TV set +maxAdjustmentTime = 40 + +-- how many are adjustment stations? +adjustmentStationCount = 1 + +-- create an inspection station (server) +newInspectionStation = + newServer $ \a -> + do holdProcess =<< + (liftParameter $ + randomUniform minInspectionTime maxInspectionTime) + passed <- + liftParameter $ + randomTrue inspectionPassingProb + if passed + then return $ Right a + else return $ Left a + +-- create an adjustment station (server) +newAdjustmentStation = + newServer $ \a -> + do holdProcess =<< + (liftParameter $ + randomUniform minAdjustmentTime maxAdjustmentTime) + return a + +model :: Simulation Results +model = mdo + -- to count the arrived TV sets for inspecting and adjusting + inputArrivalTimer <- newArrivalTimer + -- it will gather the statistics of the processing time + outputArrivalTimer <- newArrivalTimer + -- define a stream of input events + let inputStream = + randomUniformStream minArrivalDelay maxArrivalDelay + -- create a queue before the inspection stations + inspectionQueue <- + runEventInStartTime newFCFSQueue + -- create a queue before the adjustment stations + adjustmentQueue <- + runEventInStartTime newFCFSQueue + -- create the inspection stations (servers) + inspectionStations <- + forM [1 .. inspectionStationCount] $ \_ -> + newInspectionStation + -- create the adjustment stations (servers) + adjustmentStations <- + forM [1 .. adjustmentStationCount] $ \_ -> + newAdjustmentStation + -- a processor loop for the inspection stations' queue + let inspectionQueueProcessorLoop = + queueProcessorLoopSeq + (liftEvent . enqueue inspectionQueue) + (dequeue inspectionQueue) + inspectionProcessor + (adjustmentQueueProcessor >>> adjustmentProcessor) + -- a processor for the adjustment stations' queue + let adjustmentQueueProcessor = + queueProcessor + (liftEvent . enqueue adjustmentQueue) + (dequeue adjustmentQueue) + -- a parallel work of the inspection stations + let inspectionProcessor = + processorParallel (map serverProcessor inspectionStations) + -- a parallel work of the adjustment stations + let adjustmentProcessor = + processorParallel (map serverProcessor adjustmentStations) + -- the entire processor from input to output + let entireProcessor = + arrivalTimerProcessor inputArrivalTimer >>> + inspectionQueueProcessorLoop >>> + arrivalTimerProcessor outputArrivalTimer + -- start simulating the model + runProcessInStartTime $ + sinkStream $ runProcessor entireProcessor inputStream + -- return the simulation results in start time + return $ + results + [resultSource + "inspectionQueue" "the inspection queue" + inspectionQueue, + -- + resultSource + "adjustmentQueue" "the adjustment queue" + adjustmentQueue, + -- + resultSource + "inputArrivalTimer" "the input arrival timer" + inputArrivalTimer, + -- + resultSource + "outputArrivalTimer" "the output arrival timer" + outputArrivalTimer, + -- + resultSource + "inspectionStations" "the inspection stations" + inspectionStations, + -- + resultSource + "adjustmentStations" "the adjustment stations" + adjustmentStations] + +modelSummary :: Simulation Results +modelSummary = fmap resultSummary model + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + modelSummary specs diff --git a/examples/MachRep1.hs b/examples/MachRep1.hs --- a/examples/MachRep1.hs +++ b/examples/MachRep1.hs @@ -1,67 +1,67 @@ - --- It corresponds to model MachRep1 described in document --- Introduction to Discrete-Event Simulation and the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Two machines, which sometimes break down. --- Up time is exponentially distributed with mean 1.0, and repair time is --- exponentially distributed with mean 0.5. There are two repairpersons, --- so the two machines can be repaired simultaneously if they are down --- at the same time. --- --- Output is long-run proportion of up time. Should get value of about --- 0.66. - -import Control.Monad.Trans - -import Simulation.Aivika - -meanUpTime = 1.0 -meanRepairTime = 0.5 - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 1000.0, - spcDT = 1.0, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: Simulation Results -model = - do totalUpTime <- newRef 0.0 - - let machine :: Process () - machine = - do upTime <- - liftParameter $ - randomExponential meanUpTime - holdProcess upTime - liftEvent $ - modifyRef totalUpTime (+ upTime) - repairTime <- - liftParameter $ - randomExponential meanRepairTime - holdProcess repairTime - machine - - runProcessInStartTime machine - runProcessInStartTime machine - - let upTimeProp = - do x <- readRef totalUpTime - y <- liftDynamics time - return $ x / (2 * y) - - return $ - results - [resultSource - "upTimeProp" - "The long-run proportion of up time (~ 0.66)" - upTimeProp] - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - model specs + +-- It corresponds to model MachRep1 described in document +-- Introduction to Discrete-Event Simulation and the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Two machines, which sometimes break down. +-- Up time is exponentially distributed with mean 1.0, and repair time is +-- exponentially distributed with mean 0.5. There are two repairpersons, +-- so the two machines can be repaired simultaneously if they are down +-- at the same time. +-- +-- Output is long-run proportion of up time. Should get value of about +-- 0.66. + +import Control.Monad.Trans + +import Simulation.Aivika + +meanUpTime = 1.0 +meanRepairTime = 0.5 + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 1000.0, + spcDT = 1.0, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: Simulation Results +model = + do totalUpTime <- newRef 0.0 + + let machine :: Process () + machine = + do upTime <- + liftParameter $ + randomExponential meanUpTime + holdProcess upTime + liftEvent $ + modifyRef totalUpTime (+ upTime) + repairTime <- + liftParameter $ + randomExponential meanRepairTime + holdProcess repairTime + machine + + runProcessInStartTime machine + runProcessInStartTime machine + + let upTimeProp = + do x <- readRef totalUpTime + y <- liftDynamics time + return $ x / (2 * y) + + return $ + results + [resultSource + "upTimeProp" + "The long-run proportion of up time (~ 0.66)" + upTimeProp] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + model specs diff --git a/examples/MachRep1EventDriven.hs b/examples/MachRep1EventDriven.hs --- a/examples/MachRep1EventDriven.hs +++ b/examples/MachRep1EventDriven.hs @@ -1,81 +1,81 @@ - --- It corresponds to model MachRep1 described in document --- Introduction to Discrete-Event Simulation and the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Two machines, which sometimes break down. --- Up time is exponentially distributed with mean 1.0, and repair time is --- exponentially distributed with mean 0.5. There are two repairpersons, --- so the two machines can be repaired simultaneously if they are down --- at the same time. --- --- Output is long-run proportion of up time. Should get value of about --- 0.66. - -import Control.Monad.Trans - -import Simulation.Aivika - -meanUpTime = 1.0 -meanRepairTime = 0.5 - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 1000.0, - spcDT = 1.0, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: Simulation Results -model = - do totalUpTime <- newRef 0.0 - - let machineBroken :: Double -> Event () - machineBroken startUpTime = - - do finishUpTime <- liftDynamics time - modifyRef totalUpTime (+ (finishUpTime - startUpTime)) - repairTime <- - liftParameter $ - randomExponential meanRepairTime - - -- enqueue a new event - let t = finishUpTime + repairTime - enqueueEvent t machineRepaired - - machineRepaired :: Event () - machineRepaired = - - do startUpTime <- liftDynamics time - upTime <- - liftParameter $ - randomExponential meanUpTime - - -- enqueue a new event - let t = startUpTime + upTime - enqueueEvent t $ machineBroken startUpTime - - runEventInStartTime $ - do -- start the first machine - machineRepaired - -- start the second machine - machineRepaired - - let upTimeProp = - do x <- readRef totalUpTime - y <- liftDynamics time - return $ x / (2 * y) - - return $ - results - [resultSource - "upTimeProp" - "The long-run proportion of up time (~ 0.66)" - upTimeProp] - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - model specs + +-- It corresponds to model MachRep1 described in document +-- Introduction to Discrete-Event Simulation and the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Two machines, which sometimes break down. +-- Up time is exponentially distributed with mean 1.0, and repair time is +-- exponentially distributed with mean 0.5. There are two repairpersons, +-- so the two machines can be repaired simultaneously if they are down +-- at the same time. +-- +-- Output is long-run proportion of up time. Should get value of about +-- 0.66. + +import Control.Monad.Trans + +import Simulation.Aivika + +meanUpTime = 1.0 +meanRepairTime = 0.5 + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 1000.0, + spcDT = 1.0, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: Simulation Results +model = + do totalUpTime <- newRef 0.0 + + let machineBroken :: Double -> Event () + machineBroken startUpTime = + + do finishUpTime <- liftDynamics time + modifyRef totalUpTime (+ (finishUpTime - startUpTime)) + repairTime <- + liftParameter $ + randomExponential meanRepairTime + + -- enqueue a new event + let t = finishUpTime + repairTime + enqueueEvent t machineRepaired + + machineRepaired :: Event () + machineRepaired = + + do startUpTime <- liftDynamics time + upTime <- + liftParameter $ + randomExponential meanUpTime + + -- enqueue a new event + let t = startUpTime + upTime + enqueueEvent t $ machineBroken startUpTime + + runEventInStartTime $ + do -- start the first machine + machineRepaired + -- start the second machine + machineRepaired + + let upTimeProp = + do x <- readRef totalUpTime + y <- liftDynamics time + return $ x / (2 * y) + + return $ + results + [resultSource + "upTimeProp" + "The long-run proportion of up time (~ 0.66)" + upTimeProp] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + model specs diff --git a/examples/MachRep1TimeDriven.hs b/examples/MachRep1TimeDriven.hs --- a/examples/MachRep1TimeDriven.hs +++ b/examples/MachRep1TimeDriven.hs @@ -1,118 +1,118 @@ - --- It corresponds to model MachRep1 described in document --- Introduction to Discrete-Event Simulation and the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Two machines, which sometimes break down. --- Up time is exponentially distributed with mean 1.0, and repair time is --- exponentially distributed with mean 0.5. There are two repairpersons, --- so the two machines can be repaired simultaneously if they are down --- at the same time. --- --- Output is long-run proportion of up time. Should get value of about --- 0.66. - -import Control.Monad.Trans - -import Simulation.Aivika - -meanUpTime = 1.0 -meanRepairTime = 0.5 - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 1000.0, - spcDT = 0.05, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: Simulation Results -model = - do totalUpTime <- newRef 0.0 - - let machine :: Simulation (Event ()) - machine = - do startUpTime <- newRef 0.0 - - -- a number of iterations when - -- the machine works - upNum <- newRef (-1) - - -- a number of iterations when - -- the machine is broken - repairNum <- newRef (-1) - - -- create a simulation model - return $ - do upNum' <- readRef upNum - repairNum' <- readRef repairNum - - let untilBroken = - modifyRef upNum $ \a -> a - 1 - - untilRepaired = - modifyRef repairNum $ \a -> a - 1 - - broken = - do writeRef upNum (-1) - -- the machine is broken - startUpTime' <- readRef startUpTime - finishUpTime' <- liftDynamics time - dt' <- liftParameter dt - modifyRef totalUpTime $ - \a -> a + - (finishUpTime' - startUpTime') - repairTime' <- - liftParameter $ - randomExponential meanRepairTime - writeRef repairNum $ - round (repairTime' / dt') - - repaired = - do writeRef repairNum (-1) - -- the machine is repaired - t' <- liftDynamics time - dt' <- liftParameter dt - writeRef startUpTime t' - upTime' <- - liftParameter $ - randomExponential meanUpTime - writeRef upNum $ - round (upTime' / dt') - - result | upNum' > 0 = untilBroken - | upNum' == 0 = broken - | repairNum' > 0 = untilRepaired - | repairNum' == 0 = repaired - | otherwise = repaired - result - - -- create two machines with type Event () - m1 <- machine - m2 <- machine - - -- start the time-driven simulation of the machines - runEventInStartTime $ - -- in the integration time points - enqueueEventWithIntegTimes $ - do m1 - m2 - - let upTimeProp = - do x <- readRef totalUpTime - y <- liftDynamics time - return $ x / (2 * y) - - return $ - results - [resultSource - "upTimeProp" - "The long-run proportion of up time (~ 0.66)" - upTimeProp] - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - model specs + +-- It corresponds to model MachRep1 described in document +-- Introduction to Discrete-Event Simulation and the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Two machines, which sometimes break down. +-- Up time is exponentially distributed with mean 1.0, and repair time is +-- exponentially distributed with mean 0.5. There are two repairpersons, +-- so the two machines can be repaired simultaneously if they are down +-- at the same time. +-- +-- Output is long-run proportion of up time. Should get value of about +-- 0.66. + +import Control.Monad.Trans + +import Simulation.Aivika + +meanUpTime = 1.0 +meanRepairTime = 0.5 + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 1000.0, + spcDT = 0.05, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: Simulation Results +model = + do totalUpTime <- newRef 0.0 + + let machine :: Simulation (Event ()) + machine = + do startUpTime <- newRef 0.0 + + -- a number of iterations when + -- the machine works + upNum <- newRef (-1) + + -- a number of iterations when + -- the machine is broken + repairNum <- newRef (-1) + + -- create a simulation model + return $ + do upNum' <- readRef upNum + repairNum' <- readRef repairNum + + let untilBroken = + modifyRef upNum $ \a -> a - 1 + + untilRepaired = + modifyRef repairNum $ \a -> a - 1 + + broken = + do writeRef upNum (-1) + -- the machine is broken + startUpTime' <- readRef startUpTime + finishUpTime' <- liftDynamics time + dt' <- liftParameter dt + modifyRef totalUpTime $ + \a -> a + + (finishUpTime' - startUpTime') + repairTime' <- + liftParameter $ + randomExponential meanRepairTime + writeRef repairNum $ + round (repairTime' / dt') + + repaired = + do writeRef repairNum (-1) + -- the machine is repaired + t' <- liftDynamics time + dt' <- liftParameter dt + writeRef startUpTime t' + upTime' <- + liftParameter $ + randomExponential meanUpTime + writeRef upNum $ + round (upTime' / dt') + + result | upNum' > 0 = untilBroken + | upNum' == 0 = broken + | repairNum' > 0 = untilRepaired + | repairNum' == 0 = repaired + | otherwise = repaired + result + + -- create two machines with type Event () + m1 <- machine + m2 <- machine + + -- start the time-driven simulation of the machines + runEventInStartTime $ + -- in the integration time points + enqueueEventWithIntegTimes $ + do m1 + m2 + + let upTimeProp = + do x <- readRef totalUpTime + y <- liftDynamics time + return $ x / (2 * y) + + return $ + results + [resultSource + "upTimeProp" + "The long-run proportion of up time (~ 0.66)" + upTimeProp] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + model specs diff --git a/examples/MachRep2.hs b/examples/MachRep2.hs --- a/examples/MachRep2.hs +++ b/examples/MachRep2.hs @@ -1,104 +1,104 @@ - --- It corresponds to model MachRep2 described in document --- Introduction to Discrete-Event Simulation and the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Two machines, but sometimes break down. Up time is exponentially --- distributed with mean 1.0, and repair time is exponentially distributed --- with mean 0.5. In this example, there is only one repairperson, so --- the two machines cannot be repaired simultaneously if they are down --- at the same time. --- --- In addition to finding the long-run proportion of up time as in --- model MachRep1, let’s also find the long-run proportion of the time --- that a given machine does not have immediate access to the repairperson --- when the machine breaks down. Output values should be about 0.6 and 0.67. - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika - -meanUpTime = 1.0 -meanRepairTime = 0.5 - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 1000.0, - spcDT = 1.0, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: Simulation Results -model = - do -- number of times the machines have broken down - nRep <- newRef 0 - - -- number of breakdowns in which the machine - -- started repair service right away - nImmedRep <- newRef 0 - - -- total up time for all machines - totalUpTime <- newRef 0.0 - - repairPerson <- newFCFSResource 1 - - let machine :: Process () - machine = - do upTime <- - liftParameter $ - randomExponential meanUpTime - holdProcess upTime - liftEvent $ - modifyRef totalUpTime (+ upTime) - - -- check the resource availability - liftEvent $ - do modifyRef nRep (+ 1) - n <- resourceCount repairPerson - when (n == 1) $ - modifyRef nImmedRep (+ 1) - - requestResource repairPerson - repairTime <- - liftParameter $ - randomExponential meanRepairTime - holdProcess repairTime - releaseResource repairPerson - - machine - - runProcessInStartTime machine - runProcessInStartTime machine - - let upTimeProp = - do x <- readRef totalUpTime - y <- liftDynamics time - return $ x / (2 * y) - - immedProp :: Event Double - immedProp = - do n <- readRef nRep - nImmed <- readRef nImmedRep - return $ - fromIntegral nImmed / - fromIntegral n - - return $ - results - [resultSource - "upTimeProp" - "The long-run proportion of up time (~ 0.6)" - upTimeProp, - -- - resultSource - "immedProp" - "The proption of time of immediate access (~0.67)" - immedProp] - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - model specs + +-- It corresponds to model MachRep2 described in document +-- Introduction to Discrete-Event Simulation and the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Two machines, but sometimes break down. Up time is exponentially +-- distributed with mean 1.0, and repair time is exponentially distributed +-- with mean 0.5. In this example, there is only one repairperson, so +-- the two machines cannot be repaired simultaneously if they are down +-- at the same time. +-- +-- In addition to finding the long-run proportion of up time as in +-- model MachRep1, let’s also find the long-run proportion of the time +-- that a given machine does not have immediate access to the repairperson +-- when the machine breaks down. Output values should be about 0.6 and 0.67. + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika + +meanUpTime = 1.0 +meanRepairTime = 0.5 + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 1000.0, + spcDT = 1.0, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: Simulation Results +model = + do -- number of times the machines have broken down + nRep <- newRef 0 + + -- number of breakdowns in which the machine + -- started repair service right away + nImmedRep <- newRef 0 + + -- total up time for all machines + totalUpTime <- newRef 0.0 + + repairPerson <- newFCFSResource 1 + + let machine :: Process () + machine = + do upTime <- + liftParameter $ + randomExponential meanUpTime + holdProcess upTime + liftEvent $ + modifyRef totalUpTime (+ upTime) + + -- check the resource availability + liftEvent $ + do modifyRef nRep (+ 1) + n <- resourceCount repairPerson + when (n == 1) $ + modifyRef nImmedRep (+ 1) + + requestResource repairPerson + repairTime <- + liftParameter $ + randomExponential meanRepairTime + holdProcess repairTime + releaseResource repairPerson + + machine + + runProcessInStartTime machine + runProcessInStartTime machine + + let upTimeProp = + do x <- readRef totalUpTime + y <- liftDynamics time + return $ x / (2 * y) + + immedProp :: Event Double + immedProp = + do n <- readRef nRep + nImmed <- readRef nImmedRep + return $ + fromIntegral nImmed / + fromIntegral n + + return $ + results + [resultSource + "upTimeProp" + "The long-run proportion of up time (~ 0.6)" + upTimeProp, + -- + resultSource + "immedProp" + "The proption of time of immediate access (~0.67)" + immedProp] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + model specs diff --git a/examples/MachRep3.hs b/examples/MachRep3.hs --- a/examples/MachRep3.hs +++ b/examples/MachRep3.hs @@ -1,94 +1,94 @@ - --- It corresponds to model MachRep3 described in document --- Introduction to Discrete-Event Simulation and the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Variation of models MachRep1, MachRep2. Two machines, but --- sometimes break down. Up time is exponentially distributed with mean --- 1.0, and repair time is exponentially distributed with mean 0.5. In --- this example, there is only one repairperson, and she is not summoned --- until both machines are down. We find the proportion of up time. It --- should come out to about 0.45. - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika - -meanUpTime = 1.0 -meanRepairTime = 0.5 - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 1000.0, - spcDT = 1.0, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: Simulation Results -model = - do -- number of machines currently up - nUp <- newRef 2 - - -- total up time for all machines - totalUpTime <- newRef 0.0 - - repairPerson <- newResource FCFS 1 - - pid1 <- newProcessId - pid2 <- newProcessId - - let machine :: ProcessId -> Process () - machine pid = - do upTime <- - liftParameter $ - randomExponential meanUpTime - holdProcess upTime - liftEvent $ - modifyRef totalUpTime (+ upTime) - - liftEvent $ - modifyRef nUp (+ (-1)) - nUp' <- liftEvent $ readRef nUp - if nUp' == 1 - then passivateProcess - else liftEvent $ - do n <- resourceCount repairPerson - when (n == 1) $ - reactivateProcess pid - - requestResource repairPerson - repairTime <- - liftParameter $ - randomExponential meanRepairTime - holdProcess repairTime - liftEvent $ - modifyRef nUp (+ 1) - releaseResource repairPerson - - machine pid - - runProcessInStartTimeUsingId - pid1 (machine pid2) - - runProcessInStartTimeUsingId - pid2 (machine pid1) - - let upTimeProp = - do x <- readRef totalUpTime - y <- liftDynamics time - return $ x / (2 * y) - - return $ - results - [resultSource - "upTimeProp" - "The long-run proportion of up time (~ 0.45)" - upTimeProp] - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - model specs + +-- It corresponds to model MachRep3 described in document +-- Introduction to Discrete-Event Simulation and the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Variation of models MachRep1, MachRep2. Two machines, but +-- sometimes break down. Up time is exponentially distributed with mean +-- 1.0, and repair time is exponentially distributed with mean 0.5. In +-- this example, there is only one repairperson, and she is not summoned +-- until both machines are down. We find the proportion of up time. It +-- should come out to about 0.45. + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika + +meanUpTime = 1.0 +meanRepairTime = 0.5 + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 1000.0, + spcDT = 1.0, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: Simulation Results +model = + do -- number of machines currently up + nUp <- newRef 2 + + -- total up time for all machines + totalUpTime <- newRef 0.0 + + repairPerson <- newResource FCFS 1 + + pid1 <- newProcessId + pid2 <- newProcessId + + let machine :: ProcessId -> Process () + machine pid = + do upTime <- + liftParameter $ + randomExponential meanUpTime + holdProcess upTime + liftEvent $ + modifyRef totalUpTime (+ upTime) + + liftEvent $ + modifyRef nUp (+ (-1)) + nUp' <- liftEvent $ readRef nUp + if nUp' == 1 + then passivateProcess + else liftEvent $ + do n <- resourceCount repairPerson + when (n == 1) $ + reactivateProcess pid + + requestResource repairPerson + repairTime <- + liftParameter $ + randomExponential meanRepairTime + holdProcess repairTime + liftEvent $ + modifyRef nUp (+ 1) + releaseResource repairPerson + + machine pid + + runProcessInStartTimeUsingId + pid1 (machine pid2) + + runProcessInStartTimeUsingId + pid2 (machine pid1) + + let upTimeProp = + do x <- readRef totalUpTime + y <- liftDynamics time + return $ x / (2 * y) + + return $ + results + [resultSource + "upTimeProp" + "The long-run proportion of up time (~ 0.45)" + upTimeProp] + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + model specs diff --git a/examples/TimeOut.hs b/examples/TimeOut.hs --- a/examples/TimeOut.hs +++ b/examples/TimeOut.hs @@ -1,96 +1,96 @@ - --- It corresponds to model TimeOut described in document --- Advanced Features of the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/AdvancedSimPy.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Introductory example to illustrate the modeling of "competing --- events" such as timeouts, especially using the cancelProcess function. A --- network node sends a message but also sets a timeout period; if the --- node times out, it assumes the message it had sent was lost, and it --- will send again. The time to get an acknowledgement for a message is --- exponentially distributed with mean 1.0, and the timeout period is --- 0.5. Immediately after receiving an acknowledgement, the node sends --- out a new message. --- --- We find the proportion of messages which timeout. The output should --- be about 0.61. - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika - -ackRate = 1.0 / 1.0 -- reciprocal of the acknowledge mean time -toPeriod = 0.5 -- timeout period - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 10000.0, - spcDT = 1.0, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: Simulation Double -model = - do -- number of messages sent - nMsgs <- newRef 0 - - -- number of timeouts which have occured - nTimeOuts <- newRef 0 - - -- reactivatedCode will 1 if timeout occurred, - -- 2 ACK if received - reactivatedCode <- newRef 0 - - nodePid <- newProcessId - - let node :: Process () - node = - do liftEvent $ modifyRef nMsgs $ (+) 1 - -- create process IDs - timeoutPid <- liftSimulation newProcessId - ackPid <- liftSimulation newProcessId - -- set up the timeout - liftEvent $ runProcessUsingId timeoutPid (timeout ackPid) - -- set up the message send/ACK - liftEvent $ runProcessUsingId ackPid (acknowledge timeoutPid) - passivateProcess - liftEvent $ - do code <- readRef reactivatedCode - when (code == 1) $ - modifyRef nTimeOuts $ (+) 1 - writeRef reactivatedCode 0 - node - - timeout :: ProcessId -> Process () - timeout ackPid = - do holdProcess toPeriod - liftEvent $ - do writeRef reactivatedCode 1 - reactivateProcess nodePid - cancelProcessWithId ackPid - - acknowledge :: ProcessId -> Process () - acknowledge timeoutPid = - do ackTime <- - liftParameter $ - randomExponential (1 / ackRate) - holdProcess ackTime - liftEvent $ - do writeRef reactivatedCode 2 - reactivateProcess nodePid - cancelProcessWithId timeoutPid - - runProcessInStartTimeUsingId - nodePid node - - runEventInStopTime $ - do x <- readRef nTimeOuts - y <- readRef nMsgs - return $ x / y - -main = - do putStr "The percentage of timeout was " - runSimulation model specs >>= print + +-- It corresponds to model TimeOut described in document +-- Advanced Features of the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/AdvancedSimPy.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Introductory example to illustrate the modeling of "competing +-- events" such as timeouts, especially using the cancelProcess function. A +-- network node sends a message but also sets a timeout period; if the +-- node times out, it assumes the message it had sent was lost, and it +-- will send again. The time to get an acknowledgement for a message is +-- exponentially distributed with mean 1.0, and the timeout period is +-- 0.5. Immediately after receiving an acknowledgement, the node sends +-- out a new message. +-- +-- We find the proportion of messages which timeout. The output should +-- be about 0.61. + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika + +ackRate = 1.0 / 1.0 -- reciprocal of the acknowledge mean time +toPeriod = 0.5 -- timeout period + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 10000.0, + spcDT = 1.0, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: Simulation Double +model = + do -- number of messages sent + nMsgs <- newRef 0 + + -- number of timeouts which have occured + nTimeOuts <- newRef 0 + + -- reactivatedCode will 1 if timeout occurred, + -- 2 ACK if received + reactivatedCode <- newRef 0 + + nodePid <- newProcessId + + let node :: Process () + node = + do liftEvent $ modifyRef nMsgs $ (+) 1 + -- create process IDs + timeoutPid <- liftSimulation newProcessId + ackPid <- liftSimulation newProcessId + -- set up the timeout + liftEvent $ runProcessUsingId timeoutPid (timeout ackPid) + -- set up the message send/ACK + liftEvent $ runProcessUsingId ackPid (acknowledge timeoutPid) + passivateProcess + liftEvent $ + do code <- readRef reactivatedCode + when (code == 1) $ + modifyRef nTimeOuts $ (+) 1 + writeRef reactivatedCode 0 + node + + timeout :: ProcessId -> Process () + timeout ackPid = + do holdProcess toPeriod + liftEvent $ + do writeRef reactivatedCode 1 + reactivateProcess nodePid + cancelProcessWithId ackPid + + acknowledge :: ProcessId -> Process () + acknowledge timeoutPid = + do ackTime <- + liftParameter $ + randomExponential (1 / ackRate) + holdProcess ackTime + liftEvent $ + do writeRef reactivatedCode 2 + reactivateProcess nodePid + cancelProcessWithId timeoutPid + + runProcessInStartTimeUsingId + nodePid node + + runEventInStopTime $ + do x <- readRef nTimeOuts + y <- readRef nMsgs + return $ x / y + +main = + do putStr "The percentage of timeout was " + runSimulation model specs >>= print diff --git a/examples/TimeOutInt.hs b/examples/TimeOutInt.hs --- a/examples/TimeOutInt.hs +++ b/examples/TimeOutInt.hs @@ -1,77 +1,77 @@ - --- It corresponds to model TimeOutInt described in document --- Advanced Features of the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/AdvancedSimPy.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Same as TimeOut.hs but using interrupts. A network node sends a message --- but also sets a timeout period; if the node times out, it assumes the --- message it had sent was lost, and it will send again. The time to get --- an acknowledgement for a message is exponentially distributed with --- mean 1.0, and the timeout period is 0.5. Immediately after receiving --- an acknowledgement, the node sends out a new message. --- --- We find the proportion of messages which timeout. The output should --- be about 0.61. - -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika - -ackRate = 1.0 / 1.0 -- reciprocal of the acknowledge mean time -toPeriod = 0.5 -- timeout period - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 10000.0, - spcDT = 1.0, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: Simulation Double -model = - do -- number of messages sent - nMsgs <- newRef 0 - - -- number of timeouts which have occured - nTimeOuts <- newRef 0 - - nodePid <- newProcessId - - let node :: Process () - node = - do liftEvent $ modifyRef nMsgs $ (+) 1 - -- create the process ID - timeoutPid <- liftSimulation newProcessId - -- set up the timeout - liftEvent $ runProcessUsingId timeoutPid timeout - -- wait for ACK, but could be timeout - ackTime <- - liftParameter $ - randomExponential (1 / ackRate) - holdProcess ackTime - liftEvent $ - do interrupted <- processInterrupted nodePid - if interrupted - then modifyRef nTimeOuts $ (+) 1 - else cancelProcessWithId timeoutPid - node - - timeout :: Process () - timeout = - do holdProcess toPeriod - liftEvent $ interruptProcess nodePid - - runProcessInStartTimeUsingId - nodePid node - - runEventInStopTime $ - do x <- readRef nTimeOuts - y <- readRef nMsgs - return $ x / y - -main = - do putStr "The percentage of timeout was " - runSimulation model specs >>= print + +-- It corresponds to model TimeOutInt described in document +-- Advanced Features of the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/AdvancedSimPy.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Same as TimeOut.hs but using interrupts. A network node sends a message +-- but also sets a timeout period; if the node times out, it assumes the +-- message it had sent was lost, and it will send again. The time to get +-- an acknowledgement for a message is exponentially distributed with +-- mean 1.0, and the timeout period is 0.5. Immediately after receiving +-- an acknowledgement, the node sends out a new message. +-- +-- We find the proportion of messages which timeout. The output should +-- be about 0.61. + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika + +ackRate = 1.0 / 1.0 -- reciprocal of the acknowledge mean time +toPeriod = 0.5 -- timeout period + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 10000.0, + spcDT = 1.0, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: Simulation Double +model = + do -- number of messages sent + nMsgs <- newRef 0 + + -- number of timeouts which have occured + nTimeOuts <- newRef 0 + + nodePid <- newProcessId + + let node :: Process () + node = + do liftEvent $ modifyRef nMsgs $ (+) 1 + -- create the process ID + timeoutPid <- liftSimulation newProcessId + -- set up the timeout + liftEvent $ runProcessUsingId timeoutPid timeout + -- wait for ACK, but could be timeout + ackTime <- + liftParameter $ + randomExponential (1 / ackRate) + holdProcess ackTime + liftEvent $ + do interrupted <- processInterrupted nodePid + if interrupted + then modifyRef nTimeOuts $ (+) 1 + else cancelProcessWithId timeoutPid + node + + timeout :: Process () + timeout = + do holdProcess toPeriod + liftEvent $ interruptProcess nodePid + + runProcessInStartTimeUsingId + nodePid node + + runEventInStopTime $ + do x <- readRef nTimeOuts + y <- readRef nMsgs + return $ x / y + +main = + do putStr "The percentage of timeout was " + runSimulation model specs >>= print diff --git a/examples/TimeOutWait.hs b/examples/TimeOutWait.hs --- a/examples/TimeOutWait.hs +++ b/examples/TimeOutWait.hs @@ -1,70 +1,70 @@ - --- It corresponds to model TimeOut described in document --- Advanced Features of the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/AdvancedSimPy.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Introductory example to illustrate the modeling of "competing --- events" such as timeouts, especially using the timeoutProcess --- function. A network node starts a process within the specified --- timeout and receives a signal that notifies whether the process --- has finished successfully within the timeout; if the node --- times out, it assumes the message it had sent was lost, and it --- will send again. The time to get an acknowledgement for a message is --- exponentially distributed with mean 1.0, and the timeout period is --- 0.5. Immediately after receiving an acknowledgement, the node sends --- out a new message. --- --- We find the proportion of messages which timeout. The output should --- be about 0.61. - -import Control.Monad -import Control.Monad.Trans - -import Data.Maybe - -import Simulation.Aivika - -ackRate = 1.0 / 1.0 -- reciprocal of the acknowledge mean time -toPeriod = 0.5 -- timeout period - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 10000.0, - spcDT = 1.0, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - -model :: Simulation Double -model = - do -- number of messages sent - nMsgs <- newRef 0 - - -- number of timeouts which have occured - nTimeOuts <- newRef 0 - - let node :: Process () - node = - do liftEvent $ modifyRef nMsgs $ (+) 1 - result <- - timeoutProcess toPeriod $ - do ackTime <- - liftParameter $ - randomExponential (1 / ackRate) - holdProcess ackTime - liftEvent $ - when (isNothing result) $ - modifyRef nTimeOuts $ (+) 1 - node - - runProcessInStartTime node - - runEventInStopTime $ - do x <- readRef nTimeOuts - y <- readRef nMsgs - return $ x / y - -main = - do putStr "The percentage of timeout was " - runSimulation model specs >>= print + +-- It corresponds to model TimeOut described in document +-- Advanced Features of the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/AdvancedSimPy.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Introductory example to illustrate the modeling of "competing +-- events" such as timeouts, especially using the timeoutProcess +-- function. A network node starts a process within the specified +-- timeout and receives a signal that notifies whether the process +-- has finished successfully within the timeout; if the node +-- times out, it assumes the message it had sent was lost, and it +-- will send again. The time to get an acknowledgement for a message is +-- exponentially distributed with mean 1.0, and the timeout period is +-- 0.5. Immediately after receiving an acknowledgement, the node sends +-- out a new message. +-- +-- We find the proportion of messages which timeout. The output should +-- be about 0.61. + +import Control.Monad +import Control.Monad.Trans + +import Data.Maybe + +import Simulation.Aivika + +ackRate = 1.0 / 1.0 -- reciprocal of the acknowledge mean time +toPeriod = 0.5 -- timeout period + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 10000.0, + spcDT = 1.0, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: Simulation Double +model = + do -- number of messages sent + nMsgs <- newRef 0 + + -- number of timeouts which have occured + nTimeOuts <- newRef 0 + + let node :: Process () + node = + do liftEvent $ modifyRef nMsgs $ (+) 1 + result <- + timeoutProcess toPeriod $ + do ackTime <- + liftParameter $ + randomExponential (1 / ackRate) + holdProcess ackTime + liftEvent $ + when (isNothing result) $ + modifyRef nTimeOuts $ (+) 1 + node + + runProcessInStartTime node + + runEventInStopTime $ + do x <- readRef nTimeOuts + y <- readRef nMsgs + return $ x / y + +main = + do putStr "The percentage of timeout was " + runSimulation model specs >>= print diff --git a/examples/WorkStationsInSeries.hs b/examples/WorkStationsInSeries.hs --- a/examples/WorkStationsInSeries.hs +++ b/examples/WorkStationsInSeries.hs @@ -1,139 +1,139 @@ - --- Example: Work Stations in Series --- --- This is a model of two work stations connected in a series and separated by finite queues. --- --- It is described in different sources [1, 2]. So, this is chapter 7 of [2] and section 5.14 of [1]. --- --- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. --- --- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 - -import Prelude hiding (id, (.)) - -import Control.Monad -import Control.Monad.Trans -import Control.Arrow -import Control.Category (id, (.)) - -import Simulation.Aivika -import Simulation.Aivika.Queue - --- | The simulation specs. -specs = Specs { spcStartTime = 0.0, - spcStopTime = 300.0, - spcDT = 0.1, - spcMethod = RungeKutta4, - spcGeneratorType = SimpleGenerator } - --- the mean delay of the input arrivals distributed exponentially -meanOrderDelay = 0.4 - --- the capacity of the queue before the first work places -queueMaxCount1 = 4 - --- the capacity of the queue before the second work places -queueMaxCount2 = 2 - --- the mean processing time distributed exponentially in --- the first work stations -meanProcessingTime1 = 0.25 - --- the mean processing time distributed exponentially in --- the second work stations -meanProcessingTime2 = 0.5 - --- the number of the first work stations --- (in parallel but the commented code allocates them sequentially) -workStationCount1 = 1 - --- the number of the second work stations --- (in parallel but the commented code allocates them sequentially) -workStationCount2 = 1 - --- create a work station (server) with the exponential processing time -newWorkStationExponential meanTime = - newServer $ \a -> - do holdProcess =<< - (liftParameter $ - randomExponential meanTime) - return a - --- interpose the prefetch processor between two processors -interposePrefetchProcessor x y = - x >>> prefetchProcessor >>> y - -model :: Simulation Results -model = do - -- it will gather the statistics of the processing time - arrivalTimer <- newArrivalTimer - -- define a stream of input events - let inputStream = randomExponentialStream meanOrderDelay - -- create a queue before the first work stations - queue1 <- - runEventInStartTime $ - newFCFSQueue queueMaxCount1 - -- create a queue before the second work stations - queue2 <- - runEventInStartTime $ - newFCFSQueue queueMaxCount2 - -- create the first work stations (servers) - workStation1s <- forM [1 .. workStationCount1] $ \_ -> - newWorkStationExponential meanProcessingTime1 - -- create the second work stations (servers) - workStation2s <- forM [1 .. workStationCount2] $ \_ -> - newWorkStationExponential meanProcessingTime2 - -- processor for the queue before the first work station - let queueProcessor1 = - queueProcessor - (\a -> liftEvent $ enqueueOrLost_ queue1 a) - (dequeue queue1) - -- processor for the queue before the second work station - let queueProcessor2 = - queueProcessor - (enqueue queue2) - (dequeue queue2) - -- the entire processor from input to output - let entireProcessor = - queueProcessor1 >>> - processorParallel (map serverProcessor workStation1s) >>> - -- foldr1 interposePrefetchProcessor (map serverProcessor workStation1s) >>> - queueProcessor2 >>> - processorParallel (map serverProcessor workStation2s) >>> - -- foldr1 interposePrefetchProcessor (map serverProcessor workStation2s) >>> - arrivalTimerProcessor arrivalTimer - -- start simulating the model - runProcessInStartTime $ - sinkStream $ runProcessor entireProcessor inputStream - -- return the simulation results - return $ - results - [resultSource - "queue1" "Queue no. 1" - queue1, - -- - resultSource - "workStation1s" "Work Stations of line no. 1" - workStation1s, - -- - resultSource - "queue2" "Queue no. 2" - queue2, - -- - resultSource - "workStation2s" "Work Stations of line no. 2" - workStation2s, - -- - resultSource - "arrivalTimer" "The arrival timer" - arrivalTimer] - -modelSummary :: Simulation Results -modelSummary = - fmap resultSummary model - -main = - printSimulationResultsInStopTime - printResultSourceInEnglish - -- model specs - modelSummary specs + +-- Example: Work Stations in Series +-- +-- This is a model of two work stations connected in a series and separated by finite queues. +-- +-- It is described in different sources [1, 2]. So, this is chapter 7 of [2] and section 5.14 of [1]. +-- +-- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed. +-- +-- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006 + +import Prelude hiding (id, (.)) + +import Control.Monad +import Control.Monad.Trans +import Control.Arrow +import Control.Category (id, (.)) + +import Simulation.Aivika +import Simulation.Aivika.Queue + +-- | The simulation specs. +specs = Specs { spcStartTime = 0.0, + spcStopTime = 300.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +-- the mean delay of the input arrivals distributed exponentially +meanOrderDelay = 0.4 + +-- the capacity of the queue before the first work places +queueMaxCount1 = 4 + +-- the capacity of the queue before the second work places +queueMaxCount2 = 2 + +-- the mean processing time distributed exponentially in +-- the first work stations +meanProcessingTime1 = 0.25 + +-- the mean processing time distributed exponentially in +-- the second work stations +meanProcessingTime2 = 0.5 + +-- the number of the first work stations +-- (in parallel but the commented code allocates them sequentially) +workStationCount1 = 1 + +-- the number of the second work stations +-- (in parallel but the commented code allocates them sequentially) +workStationCount2 = 1 + +-- create a work station (server) with the exponential processing time +newWorkStationExponential meanTime = + newServer $ \a -> + do holdProcess =<< + (liftParameter $ + randomExponential meanTime) + return a + +-- interpose the prefetch processor between two processors +interposePrefetchProcessor x y = + x >>> prefetchProcessor >>> y + +model :: Simulation Results +model = do + -- it will gather the statistics of the processing time + arrivalTimer <- newArrivalTimer + -- define a stream of input events + let inputStream = randomExponentialStream meanOrderDelay + -- create a queue before the first work stations + queue1 <- + runEventInStartTime $ + newFCFSQueue queueMaxCount1 + -- create a queue before the second work stations + queue2 <- + runEventInStartTime $ + newFCFSQueue queueMaxCount2 + -- create the first work stations (servers) + workStation1s <- forM [1 .. workStationCount1] $ \_ -> + newWorkStationExponential meanProcessingTime1 + -- create the second work stations (servers) + workStation2s <- forM [1 .. workStationCount2] $ \_ -> + newWorkStationExponential meanProcessingTime2 + -- processor for the queue before the first work station + let queueProcessor1 = + queueProcessor + (\a -> liftEvent $ enqueueOrLost_ queue1 a) + (dequeue queue1) + -- processor for the queue before the second work station + let queueProcessor2 = + queueProcessor + (enqueue queue2) + (dequeue queue2) + -- the entire processor from input to output + let entireProcessor = + queueProcessor1 >>> + processorParallel (map serverProcessor workStation1s) >>> + -- foldr1 interposePrefetchProcessor (map serverProcessor workStation1s) >>> + queueProcessor2 >>> + processorParallel (map serverProcessor workStation2s) >>> + -- foldr1 interposePrefetchProcessor (map serverProcessor workStation2s) >>> + arrivalTimerProcessor arrivalTimer + -- start simulating the model + runProcessInStartTime $ + sinkStream $ runProcessor entireProcessor inputStream + -- return the simulation results + return $ + results + [resultSource + "queue1" "Queue no. 1" + queue1, + -- + resultSource + "workStation1s" "Work Stations of line no. 1" + workStation1s, + -- + resultSource + "queue2" "Queue no. 2" + queue2, + -- + resultSource + "workStation2s" "Work Stations of line no. 2" + workStation2s, + -- + resultSource + "arrivalTimer" "The arrival timer" + arrivalTimer] + +modelSummary :: Simulation Results +modelSummary = + fmap resultSummary model + +main = + printSimulationResultsInStopTime + printResultSourceInEnglish + -- model specs + modelSummary specs