diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,22 @@ +Version 3.1 +----- + +* Added functions failoverStream and failoverProcessor to model +servers with failures (temporary cancellation of the process with the +further repairing of the server). + +* Added functions joinStream and joinProcessor to simplify the +modeling of servers. + +* Checking the argument, i.e. time period, in the holdProcess +function. It must not be negative. + +* The taskProcess computation behaves exactly like the background + process, i.e. now its cancellation leads to immediate cancelling the background + process too. + +* Functions setStateActivation, setStateDeactivation and + setStateTransition are redefined as the Event computations instead + of Simulation computations. + +* Refactored and simplified module Results. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009, 2010, 2011, 2012, 2013, 2014 David Sorokin +Copyright (c) 2009-2015 David Sorokin All rights reserved. diff --git a/Simulation/Aivika.hs b/Simulation/Aivika.hs --- a/Simulation/Aivika.hs +++ b/Simulation/Aivika.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Activity.hs b/Simulation/Aivika/Activity.hs --- a/Simulation/Aivika/Activity.hs +++ b/Simulation/Aivika/Activity.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Activity --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -62,7 +62,7 @@ import Simulation.Aivika.Simulation import Simulation.Aivika.Dynamics import Simulation.Aivika.Internal.Event -import Simulation.Aivika.Internal.Signal +import Simulation.Aivika.Signal import Simulation.Aivika.Resource import Simulation.Aivika.Cont import Simulation.Aivika.Process diff --git a/Simulation/Aivika/Agent.hs b/Simulation/Aivika/Agent.hs --- a/Simulation/Aivika/Agent.hs +++ b/Simulation/Aivika/Agent.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Agent --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -33,7 +33,7 @@ import Simulation.Aivika.Internal.Specs import Simulation.Aivika.Internal.Simulation import Simulation.Aivika.Internal.Event -import Simulation.Aivika.Internal.Signal +import Simulation.Aivika.Signal -- -- Agent-based Modeling @@ -215,24 +215,24 @@ invokeEvent p $ traversePath x0 st -- | Set the activation computation for the specified state. -setStateActivation :: AgentState -> Event () -> Simulation () +setStateActivation :: AgentState -> Event () -> Event () setStateActivation st action = - Simulation $ \r -> + Event $ \p -> writeIORef (stateActivateRef st) action -- | Set the deactivation computation for the specified state. -setStateDeactivation :: AgentState -> Event () -> Simulation () +setStateDeactivation :: AgentState -> Event () -> Event () setStateDeactivation st action = - Simulation $ \r -> + Event $ \p -> 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 :: AgentState -> Event (Maybe AgentState) -> Event () setStateTransition st action = - Simulation $ \r -> + Event $ \p -> writeIORef (stateTransitRef st) action -- | Trigger the signal when the agent state changes. diff --git a/Simulation/Aivika/Arrival.hs b/Simulation/Aivika/Arrival.hs --- a/Simulation/Aivika/Arrival.hs +++ b/Simulation/Aivika/Arrival.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Arrival --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Circuit.hs b/Simulation/Aivika/Circuit.hs --- a/Simulation/Aivika/Circuit.hs +++ b/Simulation/Aivika/Circuit.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Circuit --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Cont.hs b/Simulation/Aivika/Cont.hs --- a/Simulation/Aivika/Cont.hs +++ b/Simulation/Aivika/Cont.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Cont --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/DoubleLinkedList.hs b/Simulation/Aivika/DoubleLinkedList.hs --- a/Simulation/Aivika/DoubleLinkedList.hs +++ b/Simulation/Aivika/DoubleLinkedList.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.DoubleLinkedList --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Dynamics.hs b/Simulation/Aivika/Dynamics.hs --- a/Simulation/Aivika/Dynamics.hs +++ b/Simulation/Aivika/Dynamics.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Dynamics --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Dynamics/Extra.hs b/Simulation/Aivika/Dynamics/Extra.hs --- a/Simulation/Aivika/Dynamics/Extra.hs +++ b/Simulation/Aivika/Dynamics/Extra.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Dynamics.Extra --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Dynamics.Memo --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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 @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Dynamics.Memo.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Dynamics.Random --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Event.hs b/Simulation/Aivika/Event.hs --- a/Simulation/Aivika/Event.hs +++ b/Simulation/Aivika/Event.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Event --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -9,6 +9,12 @@ -- -- 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. +-- +-- The @Dynamics@ computation is defined in all time points simultaneously, while +-- the @Event@ computation can be described in every time point differently and can change +-- in discrete steps. Therefore, the former is destined for differential and difference +-- equations of System Dynamics, while the latter is destined for discrete event simulation, +-- being its core actually. -- module Simulation.Aivika.Event (-- * Event Monad diff --git a/Simulation/Aivika/Generator.hs b/Simulation/Aivika/Generator.hs --- a/Simulation/Aivika/Generator.hs +++ b/Simulation/Aivika/Generator.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Generator --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Internal.Arrival --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,13 +1,15 @@ -- | -- Module : Simulation.Aivika.Internal.Cont --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, 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 +-- This is an internal implementation module that should never be used directly. +-- +-- 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. -- @@ -55,7 +57,7 @@ import Simulation.Aivika.Internal.Simulation import Simulation.Aivika.Internal.Dynamics import Simulation.Aivika.Internal.Event -import Simulation.Aivika.Internal.Signal +import Simulation.Aivika.Signal -- | It defines how the parent and child computations should be cancelled. data ContCancellation = CancelTogether @@ -161,7 +163,7 @@ writeIORef (contCancellationActivatedRef x) True invokeEvent p $ triggerSignal (contCancellationInitiatingSource x) () --- | The 'Cont' type is similar to the standard Cont monad +-- | 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 ()) 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 @@ -3,11 +3,13 @@ -- | -- Module : Simulation.Aivika.Internal.Dynamics --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental -- Tested with: GHC 7.8.3 +-- +-- This is an internal implementation module that should never be used directly. -- -- The module defines the 'Dynamics' monad representing a time varying polymorphic function. -- 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 @@ -3,14 +3,22 @@ -- | -- Module : Simulation.Aivika.Internal.Event --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental -- Tested with: GHC 7.8.3 -- +-- This is an internal implementation module that should never be used directly. +-- -- 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. +-- +-- The @Dynamics@ computation is defined in all time points simultaneously, while +-- the @Event@ computation can be described in every time point differently and can change +-- in discrete steps. Therefore, the former is destined for differential and difference +-- equations of System Dynamics, while the latter is destined for discrete event simulation, +-- being its core actually. -- module Simulation.Aivika.Internal.Event (-- * Event Monad 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 @@ -3,15 +3,17 @@ -- | -- Module : Simulation.Aivika.Internal.Parameter --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental -- Tested with: GHC 7.8.3 -- +-- This is an internal implementation module that should never be used directly. +-- -- 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. -- 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,12 +1,14 @@ -- | -- Module : Simulation.Aivika.Internal.Process --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental -- Tested with: GHC 7.8.3 -- +-- This is an internal implementation module that should never be used directly. +-- -- 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. @@ -17,6 +19,9 @@ -- -- 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.Internal.Process (-- * Process Monad ProcessId, @@ -95,7 +100,7 @@ import Simulation.Aivika.Internal.Dynamics import Simulation.Aivika.Internal.Event import Simulation.Aivika.Internal.Cont -import Simulation.Aivika.Internal.Signal +import Simulation.Aivika.Signal -- | Represents a process identifier. data ProcessId = @@ -130,7 +135,9 @@ Process $ \pid -> Cont $ \c -> Event $ \p -> - do let x = processInterruptCont pid + do when (dt < 0) $ + error "Time period dt < 0: holdProcess" + let x = processInterruptCont pid writeIORef x $ Just c writeIORef (processInterruptRef pid) False v <- readIORef (processInterruptVersion pid) diff --git a/Simulation/Aivika/Internal/Signal.hs b/Simulation/Aivika/Internal/Signal.hs deleted file mode 100644 --- a/Simulation/Aivika/Internal/Signal.hs +++ /dev/null @@ -1,388 +0,0 @@ - --- | --- 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, - -- * Debugging - traceSignal) 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) } - } - --- | Show the debug message with the current simulation time. -traceSignal :: String -> Signal a -> Signal a -traceSignal message m = - Signal { handleSignal = \h -> - handleSignal m $ traceEvent message . h } 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 @@ -3,14 +3,16 @@ -- | -- Module : Simulation.Aivika.Internal.Simulation --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, 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. +-- This is an internal implementation module that should never be used directly. +-- +-- The module defines the 'Simulation' monad that represents a computation within +-- the simulation run. -- module Simulation.Aivika.Internal.Simulation (-- * Simulation 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Internal.Specs --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Net.hs b/Simulation/Aivika/Net.hs --- a/Simulation/Aivika/Net.hs +++ b/Simulation/Aivika/Net.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Net --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Parameter.hs b/Simulation/Aivika/Parameter.hs --- a/Simulation/Aivika/Parameter.hs +++ b/Simulation/Aivika/Parameter.hs @@ -1,6 +1,6 @@ -- | -- Module : Simulation.Aivika.Parameter --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Parameter.Random --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/PriorityQueue.hs b/Simulation/Aivika/PriorityQueue.hs --- a/Simulation/Aivika/PriorityQueue.hs +++ b/Simulation/Aivika/PriorityQueue.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.PriorityQueue --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Process.hs b/Simulation/Aivika/Process.hs --- a/Simulation/Aivika/Process.hs +++ b/Simulation/Aivika/Process.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Process --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Processor.hs b/Simulation/Aivika/Processor.hs --- a/Simulation/Aivika/Processor.hs +++ b/Simulation/Aivika/Processor.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Processor --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -39,6 +39,10 @@ processorPrioritisingInputOutputParallel, -- * Arrival Processor arrivalProcessor, + -- * Utilities + joinProcessor, + -- * Failover + failoverProcessor, -- * Integrating with Signals signalProcessor, processorSignaling, @@ -458,6 +462,19 @@ -- | 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 + +-- | Removes one level of the computation, projecting its bound processor into the outer level. +joinProcessor :: Process (Processor a b) -> Processor a b +joinProcessor m = + Processor $ \xs -> + Cons $ + do Processor f <- m + runStream $ f xs + +-- | Takes the next processor from the list after the current processor fails because of cancelling the underlying process. +failoverProcessor :: [Processor a b] -> Processor a b +failoverProcessor ps = + Processor $ \xs -> failoverStream [runProcessor p xs | p <- ps] -- | Show the debug messages with the current simulation time. traceProcessor :: Maybe String 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Processor.RoundRobbin --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Queue.hs b/Simulation/Aivika/Queue.hs --- a/Simulation/Aivika/Queue.hs +++ b/Simulation/Aivika/Queue.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Queue --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -116,7 +116,6 @@ 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 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Queue.Infinite --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -80,7 +80,6 @@ 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 diff --git a/Simulation/Aivika/QueueStrategy.hs b/Simulation/Aivika/QueueStrategy.hs --- a/Simulation/Aivika/QueueStrategy.hs +++ b/Simulation/Aivika/QueueStrategy.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.QueueStrategy --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Ref.hs b/Simulation/Aivika/Ref.hs --- a/Simulation/Aivika/Ref.hs +++ b/Simulation/Aivika/Ref.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Ref --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -24,7 +24,6 @@ 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 diff --git a/Simulation/Aivika/Ref/Plain.hs b/Simulation/Aivika/Ref/Plain.hs --- a/Simulation/Aivika/Ref/Plain.hs +++ b/Simulation/Aivika/Ref/Plain.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Ref.Plain --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Resource.hs b/Simulation/Aivika/Resource.hs --- a/Simulation/Aivika/Resource.hs +++ b/Simulation/Aivika/Resource.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Resource --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Results.hs b/Simulation/Aivika/Results.hs --- a/Simulation/Aivika/Results.hs +++ b/Simulation/Aivika/Results.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Results --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -33,18 +33,18 @@ ResultVectorWithSubscript(..), #endif -- * Definitions Focused on Using the Library - ResultExtract(..), - extractIntResults, - extractIntListResults, - extractIntStatsResults, - extractIntStatsEitherResults, - extractIntTimingStatsResults, - extractDoubleResults, - extractDoubleListResults, - extractDoubleStatsResults, - extractDoubleStatsEitherResults, - extractDoubleTimingStatsResults, - extractStringResults, + ResultValue(..), + resultsToIntValues, + resultsToIntListValues, + resultsToIntStatsValues, + resultsToIntStatsEitherValues, + resultsToIntTimingStatsValues, + resultsToDoubleValues, + resultsToDoubleListValues, + resultsToDoubleStatsValues, + resultsToDoubleStatsEitherValues, + resultsToDoubleTimingStatsValues, + resultsToStringValues, ResultPredefinedSignals(..), newResultPredefinedSignals, resultSignal, @@ -54,16 +54,25 @@ ResultSource(..), ResultItem(..), ResultItemable(..), + resultItemAsIntStatsEitherValue, + resultItemAsDoubleStatsEitherValue, + resultItemToIntValue, + resultItemToIntListValue, + resultItemToIntStatsValue, resultItemToIntStatsEitherValue, + resultItemToIntTimingStatsValue, + resultItemToDoubleValue, + resultItemToDoubleListValue, + resultItemToDoubleStatsValue, resultItemToDoubleStatsEitherValue, + resultItemToDoubleTimingStatsValue, + resultItemToStringValue, ResultObject(..), ResultProperty(..), ResultVector(..), memoResultVectorSignal, memoResultVectorSummary, ResultSeparator(..), - ResultValue(..), - voidResultValue, ResultContainer(..), resultContainerPropertySource, resultContainerConstProperty, @@ -90,17 +99,6 @@ resultSourceToStringValues, resultSourceMap, resultSourceList, - resultsToIntValues, - resultsToIntListValues, - resultsToIntStatsValues, - resultsToIntStatsEitherValues, - resultsToIntTimingStatsValues, - resultsToDoubleValues, - resultsToDoubleListValues, - resultsToDoubleStatsValues, - resultsToDoubleStatsEitherValues, - resultsToDoubleTimingStatsValues, - resultsToStringValues, composeResults, computeResultValue) where @@ -190,59 +188,169 @@ -- properties. resultItemSummary :: a -> ResultSource - -- | Return integer numbers in time points. - resultItemToIntValue :: a -> ResultValue Int + -- | Try to return integer numbers in time points. + resultItemAsIntValue :: a -> Maybe (ResultValue Int) - -- | Return lists of integer numbers in time points. - resultItemToIntListValue :: a -> ResultValue [Int] + -- | Try to return lists of integer numbers in time points. + resultItemAsIntListValue :: a -> Maybe (ResultValue [Int]) - -- | Return statistics based on integer numbers. - resultItemToIntStatsValue :: a -> ResultValue (SamplingStats Int) + -- | Try to return statistics based on integer numbers. + resultItemAsIntStatsValue :: a -> Maybe (ResultValue (SamplingStats Int)) - -- | Return timing statistics based on integer numbers. - resultItemToIntTimingStatsValue :: a -> ResultValue (TimingStats Int) + -- | Try to return timing statistics based on integer numbers. + resultItemAsIntTimingStatsValue :: a -> Maybe (ResultValue (TimingStats Int)) - -- | Return double numbers in time points. - resultItemToDoubleValue :: a -> ResultValue Double + -- | Try to return double numbers in time points. + resultItemAsDoubleValue :: a -> Maybe (ResultValue Double) - -- | Return lists of double numbers in time points. - resultItemToDoubleListValue :: a -> ResultValue [Double] + -- | Try to return lists of double numbers in time points. + resultItemAsDoubleListValue :: a -> Maybe (ResultValue [Double]) - -- | Return statistics based on double numbers. - resultItemToDoubleStatsValue :: a -> ResultValue (SamplingStats Double) + -- | Try to return statistics based on double numbers. + resultItemAsDoubleStatsValue :: a -> Maybe (ResultValue (SamplingStats Double)) - -- | Return timing statistics based on integer numbers. - resultItemToDoubleTimingStatsValue :: a -> ResultValue (TimingStats Double) + -- | Try to return timing statistics based on integer numbers. + resultItemAsDoubleTimingStatsValue :: a -> Maybe (ResultValue (TimingStats Double)) - -- | Return string representations in time points. - resultItemToStringValue :: a -> ResultValue String + -- | Try to return string representations in time points. + resultItemAsStringValue :: a -> Maybe (ResultValue String) +-- | Try to return a version optimised for fast aggregation of the statistics based on integer numbers. +resultItemAsIntStatsEitherValue :: ResultItemable a => a -> Maybe (ResultValue (Either Int (SamplingStats Int))) +resultItemAsIntStatsEitherValue x = + case x1 of + Just a1 -> Just $ fmap Left a1 + Nothing -> + case x2 of + Just a2 -> Just $ fmap Right a2 + Nothing -> Nothing + where + x1 = resultItemAsIntValue x + x2 = resultItemAsIntStatsValue x + +-- | Try to return a version optimised for fast aggregation of the statistics based on double floating point numbers. +resultItemAsDoubleStatsEitherValue :: ResultItemable a => a -> Maybe (ResultValue (Either Double (SamplingStats Double))) +resultItemAsDoubleStatsEitherValue x = + case x1 of + Just a1 -> Just $ fmap Left a1 + Nothing -> + case x2 of + Just a2 -> Just $ fmap Right a2 + Nothing -> Nothing + where + x1 = resultItemAsDoubleValue x + x2 = resultItemAsDoubleStatsValue x + +-- | Return integer numbers in time points. +resultItemToIntValue :: ResultItemable a => a -> ResultValue Int +resultItemToIntValue x = + case resultItemAsIntValue x of + Just a -> a + Nothing -> + error $ + "Cannot represent " ++ resultItemName x ++ + " as a source of integer numbers: resultItemToIntValue" + +-- | Return lists of integer numbers in time points. +resultItemToIntListValue :: ResultItemable a => a -> ResultValue [Int] +resultItemToIntListValue x = + case resultItemAsIntListValue x of + Just a -> a + Nothing -> + error $ + "Cannot represent " ++ resultItemName x ++ + " as a source of lists of integer numbers: resultItemToIntListValue" + +-- | Return statistics based on integer numbers. +resultItemToIntStatsValue :: ResultItemable a => a -> ResultValue (SamplingStats Int) +resultItemToIntStatsValue x = + case resultItemAsIntStatsValue x of + Just a -> a + Nothing -> + error $ + "Cannot represent " ++ resultItemName x ++ + " as a source of statistics based on integer numbers: resultItemToIntStatsValue" + -- | 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 + case resultItemAsIntStatsEitherValue x of + Just a -> a Nothing -> - case resultValueData x2 of - Just a2 -> fmap Right x2 - Nothing -> voidResultValue x2 - where - x1 = resultItemToIntValue x - x2 = resultItemToIntStatsValue x + error $ + "Cannot represent " ++ resultItemName x ++ + " as an optimised source of statistics based on integer numbers: resultItemToIntStatsEitherValue" +-- | Return timing statistics based on integer numbers. +resultItemToIntTimingStatsValue :: ResultItemable a => a -> ResultValue (TimingStats Int) +resultItemToIntTimingStatsValue x = + case resultItemAsIntTimingStatsValue x of + Just a -> a + Nothing -> + error $ + "Cannot represent " ++ resultItemName x ++ + " as a source of timing statistics based on integer numbers: resultItemToIntTimingStatsValue" + +-- | Return double numbers in time points. +resultItemToDoubleValue :: ResultItemable a => a -> ResultValue Double +resultItemToDoubleValue x = + case resultItemAsDoubleValue x of + Just a -> a + Nothing -> + error $ + "Cannot represent " ++ resultItemName x ++ + " as a source of double-precision floating-point numbers: resultItemToDoubleValue" + +-- | Return lists of double numbers in time points. +resultItemToDoubleListValue :: ResultItemable a => a -> ResultValue [Double] +resultItemToDoubleListValue x = + case resultItemAsDoubleListValue x of + Just a -> a + Nothing -> + error $ + "Cannot represent " ++ resultItemName x ++ + " as a source of lists of double-precision floating-point numbers: resultItemToDoubleListValue" + +-- | Return statistics based on double numbers. +resultItemToDoubleStatsValue :: ResultItemable a => a -> ResultValue (SamplingStats Double) +resultItemToDoubleStatsValue x = + case resultItemAsDoubleStatsValue x of + Just a -> a + Nothing -> + error $ + "Cannot represent " ++ resultItemName x ++ + " as a source of statistics based on double-precision floating-point numbers: resultItemToDoubleStatsValue" + -- | 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 + case resultItemAsDoubleStatsEitherValue x of + Just a -> a Nothing -> - case resultValueData x2 of - Just a2 -> fmap Right x2 - Nothing -> voidResultValue x2 - where - x1 = resultItemToDoubleValue x - x2 = resultItemToDoubleStatsValue x + error $ + "Cannot represent " ++ resultItemName x ++ + " as an optimised source of statistics based on double-precision floating-point numbers: resultItemToDoubleStatsEitherValue" +-- | Return timing statistics based on integer numbers. +resultItemToDoubleTimingStatsValue :: ResultItemable a => a -> ResultValue (TimingStats Double) +resultItemToDoubleTimingStatsValue x = + case resultItemAsDoubleTimingStatsValue x of + Just a -> a + Nothing -> + error $ + "Cannot represent " ++ resultItemName x ++ + " as a source of timing statistics based on double-precision floating-point numbers: resultItemToDoubleTimingStatsValue" + +-- | Return string representations in time points. +resultItemToStringValue :: ResultItemable a => a -> ResultValue String +resultItemToStringValue x = + case resultItemAsStringValue x of + Just a -> a + Nothing -> + error $ + "Cannot represent " ++ resultItemName x ++ + " as a source of strings: resultItemToStringValue" + -- | The simulation results represented by an object having properties. data ResultObject = ResultObject { resultObjectName :: ResultName, @@ -322,11 +430,7 @@ } 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 } + fmap f x = x { resultValueData = fmap f (resultValueData x) } -- | A container of the simulation results such as queue, server or array. data ResultContainer e = @@ -381,7 +485,7 @@ resultPropertyLabel = name, resultPropertyId = i, resultPropertySource = - resultContainerPropertySource cont name i (Just . return . f) (const EmptyResultSignal) } + resultContainerPropertySource cont name i (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) @@ -399,7 +503,7 @@ resultPropertyLabel = name, resultPropertyId = i, resultPropertySource = - resultContainerPropertySource cont name i (Just . f) (const UnknownResultSignal) } + resultContainerPropertySource cont name i f (const UnknownResultSignal) } -- | Create a property by the specified container. resultContainerProperty :: ResultItemable (ResultValue b) @@ -419,7 +523,7 @@ resultPropertyLabel = name, resultPropertyId = i, resultPropertySource = - resultContainerPropertySource cont name i (Just . f) (ResultSignal . g) } + resultContainerPropertySource cont name i f (ResultSignal . g) } -- | Create by the specified container a mapped property which is recomputed each time again and again. resultContainerMapProperty :: ResultItemable (ResultValue b) @@ -437,7 +541,7 @@ resultPropertyLabel = name, resultPropertyId = i, resultPropertySource = - resultContainerPropertySource cont name i (fmap $ fmap f) (const $ resultContainerSignal cont) } + resultContainerPropertySource cont name i (fmap f) (const $ resultContainerSignal cont) } -- | Convert the result value to a container with the specified object identifier. resultValueToContainer :: ResultValue a -> ResultContainer (ResultData a) @@ -458,7 +562,7 @@ resultValueSignal = resultContainerSignal x } -- | Represents the very simulation results. -type ResultData e = Maybe (Event e) +type ResultData e = Event e -- | Whether an object containing the results emits a signal notifying about change of data. data ResultSignal = EmptyResultSignal @@ -502,17 +606,17 @@ resultItemId = resultValueId resultItemSignal = resultValueSignal - resultItemToIntValue = id - resultItemToIntListValue = fmap return - resultItemToIntStatsValue = fmap returnSamplingStats - resultItemToIntTimingStatsValue = voidResultValue + resultItemAsIntValue = Just + resultItemAsIntListValue = Just . fmap return + resultItemAsIntStatsValue = Just . fmap returnSamplingStats + resultItemAsIntTimingStatsValue = const Nothing - resultItemToDoubleValue = fmap fromIntegral - resultItemToDoubleListValue = fmap (return . fromIntegral) - resultItemToDoubleStatsValue = fmap (returnSamplingStats . fromIntegral) - resultItemToDoubleTimingStatsValue = voidResultValue + resultItemAsDoubleValue = Just . fmap fromIntegral + resultItemAsDoubleListValue = Just . fmap (return . fromIntegral) + resultItemAsDoubleStatsValue = Just . fmap (returnSamplingStats . fromIntegral) + resultItemAsDoubleTimingStatsValue = const Nothing - resultItemToStringValue = fmap show + resultItemAsStringValue = Just . fmap show resultItemExpansion = ResultItemSource . ResultItem resultItemSummary = ResultItemSource . ResultItem @@ -523,17 +627,17 @@ resultItemId = resultValueId resultItemSignal = resultValueSignal - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue + resultItemAsIntValue = const Nothing + resultItemAsIntListValue = const Nothing + resultItemAsIntStatsValue = const Nothing + resultItemAsIntTimingStatsValue = const Nothing - resultItemToDoubleValue = id - resultItemToDoubleListValue = fmap return - resultItemToDoubleStatsValue = fmap returnSamplingStats - resultItemToDoubleTimingStatsValue = voidResultValue + resultItemAsDoubleValue = Just + resultItemAsDoubleListValue = Just . fmap return + resultItemAsDoubleStatsValue = Just . fmap returnSamplingStats + resultItemAsDoubleTimingStatsValue = const Nothing - resultItemToStringValue = fmap show + resultItemAsStringValue = Just . fmap show resultItemExpansion = ResultItemSource . ResultItem resultItemSummary = ResultItemSource . ResultItem @@ -544,17 +648,17 @@ resultItemId = resultValueId resultItemSignal = resultValueSignal - resultItemToIntValue = voidResultValue - resultItemToIntListValue = id - resultItemToIntStatsValue = fmap listSamplingStats - resultItemToIntTimingStatsValue = voidResultValue + resultItemAsIntValue = const Nothing + resultItemAsIntListValue = Just + resultItemAsIntStatsValue = Just . fmap listSamplingStats + resultItemAsIntTimingStatsValue = const Nothing - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = fmap (map fromIntegral) - resultItemToDoubleStatsValue = fmap (fromIntSamplingStats . listSamplingStats) - resultItemToDoubleTimingStatsValue = voidResultValue + resultItemAsDoubleValue = const Nothing + resultItemAsDoubleListValue = Just . fmap (map fromIntegral) + resultItemAsDoubleStatsValue = Just . fmap (fromIntSamplingStats . listSamplingStats) + resultItemAsDoubleTimingStatsValue = const Nothing - resultItemToStringValue = fmap show + resultItemAsStringValue = Just . fmap show resultItemExpansion = ResultItemSource . ResultItem resultItemSummary = ResultItemSource . ResultItem @@ -565,17 +669,17 @@ resultItemId = resultValueId resultItemSignal = resultValueSignal - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue + resultItemAsIntValue = const Nothing + resultItemAsIntListValue = const Nothing + resultItemAsIntStatsValue = const Nothing + resultItemAsIntTimingStatsValue = const Nothing - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = id - resultItemToDoubleStatsValue = fmap listSamplingStats - resultItemToDoubleTimingStatsValue = voidResultValue + resultItemAsDoubleValue = const Nothing + resultItemAsDoubleListValue = Just + resultItemAsDoubleStatsValue = Just . fmap listSamplingStats + resultItemAsDoubleTimingStatsValue = const Nothing - resultItemToStringValue = fmap show + resultItemAsStringValue = Just . fmap show resultItemExpansion = ResultItemSource . ResultItem resultItemSummary = ResultItemSource . ResultItem @@ -586,17 +690,17 @@ resultItemId = resultValueId resultItemSignal = resultValueSignal - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = id - resultItemToIntTimingStatsValue = voidResultValue + resultItemAsIntValue = const Nothing + resultItemAsIntListValue = const Nothing + resultItemAsIntStatsValue = Just + resultItemAsIntTimingStatsValue = const Nothing - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = fmap fromIntSamplingStats - resultItemToDoubleTimingStatsValue = voidResultValue + resultItemAsDoubleValue = const Nothing + resultItemAsDoubleListValue = const Nothing + resultItemAsDoubleStatsValue = Just . fmap fromIntSamplingStats + resultItemAsDoubleTimingStatsValue = const Nothing - resultItemToStringValue = fmap show + resultItemAsStringValue = Just . fmap show resultItemExpansion = samplingStatsResultSource resultItemSummary = samplingStatsResultSummary @@ -607,17 +711,17 @@ resultItemId = resultValueId resultItemSignal = resultValueSignal - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue + resultItemAsIntValue = const Nothing + resultItemAsIntListValue = const Nothing + resultItemAsIntStatsValue = const Nothing + resultItemAsIntTimingStatsValue = const Nothing - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = id - resultItemToDoubleTimingStatsValue = voidResultValue + resultItemAsDoubleValue = const Nothing + resultItemAsDoubleListValue = const Nothing + resultItemAsDoubleStatsValue = Just + resultItemAsDoubleTimingStatsValue = const Nothing - resultItemToStringValue = fmap show + resultItemAsStringValue = Just . fmap show resultItemExpansion = samplingStatsResultSource resultItemSummary = samplingStatsResultSummary @@ -628,17 +732,17 @@ resultItemId = resultValueId resultItemSignal = resultValueSignal - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = id + resultItemAsIntValue = const Nothing + resultItemAsIntListValue = const Nothing + resultItemAsIntStatsValue = const Nothing + resultItemAsIntTimingStatsValue = Just - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = fmap fromIntTimingStats + resultItemAsDoubleValue = const Nothing + resultItemAsDoubleListValue = const Nothing + resultItemAsDoubleStatsValue = const Nothing + resultItemAsDoubleTimingStatsValue = Just . fmap fromIntTimingStats - resultItemToStringValue = fmap show + resultItemAsStringValue = Just . fmap show resultItemExpansion = timingStatsResultSource resultItemSummary = timingStatsResultSummary @@ -649,17 +753,17 @@ resultItemId = resultValueId resultItemSignal = resultValueSignal - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue + resultItemAsIntValue = const Nothing + resultItemAsIntListValue = const Nothing + resultItemAsIntStatsValue = const Nothing + resultItemAsIntTimingStatsValue = const Nothing - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = id + resultItemAsDoubleValue = const Nothing + resultItemAsDoubleListValue = const Nothing + resultItemAsDoubleStatsValue = const Nothing + resultItemAsDoubleTimingStatsValue = Just - resultItemToStringValue = fmap show + resultItemAsStringValue = Just . fmap show resultItemExpansion = timingStatsResultSource resultItemSummary = timingStatsResultSummary @@ -670,17 +774,17 @@ resultItemId = resultValueId resultItemSignal = resultValueSignal - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue + resultItemAsIntValue = const Nothing + resultItemAsIntListValue = const Nothing + resultItemAsIntStatsValue = const Nothing + resultItemAsIntTimingStatsValue = const Nothing - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue + resultItemAsDoubleValue = const Nothing + resultItemAsDoubleListValue = const Nothing + resultItemAsDoubleStatsValue = const Nothing + resultItemAsDoubleTimingStatsValue = const Nothing - resultItemToStringValue = fmap show + resultItemAsStringValue = Just . fmap show resultItemExpansion = ResultItemSource . ResultItem resultItemSummary = ResultItemSource . ResultItem @@ -691,17 +795,17 @@ resultItemId = resultValueId resultItemSignal = resultValueSignal - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue + resultItemAsIntValue = const Nothing + resultItemAsIntListValue = const Nothing + resultItemAsIntStatsValue = const Nothing + resultItemAsIntTimingStatsValue = const Nothing - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue + resultItemAsDoubleValue = const Nothing + resultItemAsDoubleListValue = const Nothing + resultItemAsDoubleStatsValue = const Nothing + resultItemAsDoubleTimingStatsValue = const Nothing - resultItemToStringValue = id + resultItemAsStringValue = Just resultItemExpansion = ResultItemSource . ResultItem resultItemSummary = ResultItemSource . ResultItem @@ -712,17 +816,17 @@ resultItemId = resultValueId resultItemSignal = resultValueSignal - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue + resultItemAsIntValue = const Nothing + resultItemAsIntListValue = const Nothing + resultItemAsIntStatsValue = const Nothing + resultItemAsIntTimingStatsValue = const Nothing - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue + resultItemAsDoubleValue = const Nothing + resultItemAsDoubleListValue = const Nothing + resultItemAsDoubleStatsValue = const Nothing + resultItemAsDoubleTimingStatsValue = const Nothing - resultItemToStringValue = fmap show + resultItemAsStringValue = Just . fmap show resultItemExpansion = ResultItemSource . ResultItem resultItemSummary = ResultItemSource . ResultItem @@ -733,17 +837,17 @@ resultItemId = resultValueId resultItemSignal = resultValueSignal - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue + resultItemAsIntValue = const Nothing + resultItemAsIntListValue = const Nothing + resultItemAsIntStatsValue = const Nothing + resultItemAsIntTimingStatsValue = const Nothing - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue + resultItemAsDoubleValue = const Nothing + resultItemAsDoubleListValue = const Nothing + resultItemAsDoubleStatsValue = const Nothing + resultItemAsDoubleTimingStatsValue = const Nothing - resultItemToStringValue = fmap show + resultItemAsStringValue = Just . fmap show resultItemExpansion = ResultItemSource . ResultItem resultItemSummary = ResultItemSource . ResultItem @@ -754,17 +858,17 @@ resultItemId = resultValueId resultItemSignal = resultValueSignal - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue + resultItemAsIntValue = const Nothing + resultItemAsIntListValue = const Nothing + resultItemAsIntStatsValue = const Nothing + resultItemAsIntTimingStatsValue = const Nothing - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue + resultItemAsDoubleValue = const Nothing + resultItemAsDoubleListValue = const Nothing + resultItemAsDoubleStatsValue = const Nothing + resultItemAsDoubleTimingStatsValue = const Nothing - resultItemToStringValue = fmap show + resultItemAsStringValue = Just . fmap show resultItemExpansion = ResultItemSource . ResultItem resultItemSummary = ResultItemSource . ResultItem @@ -775,17 +879,17 @@ resultItemId = resultValueId resultItemSignal = resultValueSignal - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue + resultItemAsIntValue = const Nothing + resultItemAsIntListValue = const Nothing + resultItemAsIntStatsValue = const Nothing + resultItemAsIntTimingStatsValue = const Nothing - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue + resultItemAsDoubleValue = const Nothing + resultItemAsDoubleListValue = const Nothing + resultItemAsDoubleStatsValue = const Nothing + resultItemAsDoubleTimingStatsValue = const Nothing - resultItemToStringValue = fmap show + resultItemAsStringValue = Just . fmap show resultItemExpansion = ResultItemSource . ResultItem resultItemSummary = ResultItemSource . ResultItem @@ -796,17 +900,17 @@ resultItemId = resultValueId resultItemSignal = resultValueSignal - resultItemToIntValue = voidResultValue - resultItemToIntListValue = voidResultValue - resultItemToIntStatsValue = voidResultValue - resultItemToIntTimingStatsValue = voidResultValue + resultItemAsIntValue = const Nothing + resultItemAsIntListValue = const Nothing + resultItemAsIntStatsValue = const Nothing + resultItemAsIntTimingStatsValue = const Nothing - resultItemToDoubleValue = voidResultValue - resultItemToDoubleListValue = voidResultValue - resultItemToDoubleStatsValue = voidResultValue - resultItemToDoubleTimingStatsValue = voidResultValue + resultItemAsDoubleValue = const Nothing + resultItemAsDoubleListValue = const Nothing + resultItemAsDoubleStatsValue = const Nothing + resultItemAsDoubleTimingStatsValue = const Nothing - resultItemToStringValue = fmap show + resultItemAsStringValue = Just . fmap show resultItemExpansion = ResultItemSource . ResultItem resultItemSummary = ResultItemSource . ResultItem @@ -1152,190 +1256,6 @@ 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 @@ -1376,42 +1296,42 @@ instance ResultComputing Parameter where - computeResultData = Just . liftParameter + computeResultData = liftParameter computeResultSignal = const UnknownResultSignal instance ResultComputing Simulation where - computeResultData = Just . liftSimulation + computeResultData = liftSimulation computeResultSignal = const UnknownResultSignal instance ResultComputing Dynamics where - computeResultData = Just . liftDynamics + computeResultData = liftDynamics computeResultSignal = const UnknownResultSignal instance ResultComputing Event where - computeResultData = Just . id + computeResultData = id computeResultSignal = const UnknownResultSignal instance ResultComputing Ref where - computeResultData = Just . readRef + computeResultData = readRef computeResultSignal = ResultSignal . refChanged_ instance ResultComputing LR.Ref where - computeResultData = Just . LR.readRef + computeResultData = LR.readRef computeResultSignal = const UnknownResultSignal instance ResultComputing Var where - computeResultData = Just . readVar + computeResultData = readVar computeResultSignal = ResultSignal . varChanged_ instance ResultComputing Signalable where - computeResultData = Just . readSignalable + computeResultData = readSignalable computeResultSignal = ResultSignal . signalableChanged_ -- | Return a source by the specified statistics. 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Results.IO --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -107,24 +107,18 @@ -- ^ 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" + do a <- resultValueData $ resultItemToStringValue x + 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 "" hPrintResultSourceIndentedLabelled h indent label loc (ResultVectorSource x) = do let tab = replicate indent ' ' liftIO $ @@ -229,24 +223,18 @@ -- ^ 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" + do a <- resultValueData $ resultItemToStringValue x + let tab = replicate indent ' ' + return $ + showString tab . + showString "-- " . + showString (loc $ resultItemId x) . + showString "\n" . + showString tab . + showString label . + showString " = " . + showString a . + showString "\n\n" showResultSourceIndentedLabelled indent label loc (ResultVectorSource x) = do let tab = replicate indent ' ' items = A.elems (resultVectorItems x) 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Results.Locale --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Server.hs b/Simulation/Aivika/Server.hs --- a/Simulation/Aivika/Server.hs +++ b/Simulation/Aivika/Server.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Server --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -71,7 +71,7 @@ import Simulation.Aivika.Simulation import Simulation.Aivika.Dynamics import Simulation.Aivika.Internal.Event -import Simulation.Aivika.Internal.Signal +import Simulation.Aivika.Signal import Simulation.Aivika.Resource import Simulation.Aivika.Cont import Simulation.Aivika.Process @@ -215,7 +215,7 @@ -- -- 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. +-- should not be prefetched if it is connected directly to the queue processor. serverProcessor :: Server s a b -> Processor a b serverProcessor server = Processor $ \xs -> loop (serverInitState server) Nothing xs diff --git a/Simulation/Aivika/Signal.hs b/Simulation/Aivika/Signal.hs --- a/Simulation/Aivika/Signal.hs +++ b/Simulation/Aivika/Signal.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Signal --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -52,4 +52,336 @@ -- * Debugging traceSignal) where -import Simulation.Aivika.Internal.Signal +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) } + } + +-- | Show the debug message with the current simulation time. +traceSignal :: String -> Signal a -> Signal a +traceSignal message m = + Signal { handleSignal = \h -> + handleSignal m $ traceEvent message . h } diff --git a/Simulation/Aivika/Simulation.hs b/Simulation/Aivika/Simulation.hs --- a/Simulation/Aivika/Simulation.hs +++ b/Simulation/Aivika/Simulation.hs @@ -1,13 +1,14 @@ -- | -- Module : Simulation.Aivika.Simulation --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, 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. +-- The module defines the 'Simulation' monad that represents a computation within +-- the simulation run. -- module Simulation.Aivika.Simulation (-- * Simulation diff --git a/Simulation/Aivika/Specs.hs b/Simulation/Aivika/Specs.hs --- a/Simulation/Aivika/Specs.hs +++ b/Simulation/Aivika/Specs.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Specs --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Statistics.hs b/Simulation/Aivika/Statistics.hs --- a/Simulation/Aivika/Statistics.hs +++ b/Simulation/Aivika/Statistics.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Statistics --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Statistics.Accumulator --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Stream.hs b/Simulation/Aivika/Stream.hs --- a/Simulation/Aivika/Stream.hs +++ b/Simulation/Aivika/Stream.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Stream --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -50,6 +50,10 @@ apStreamM, filterStream, filterStreamM, + singletonStream, + joinStream, + -- * Failover + failoverStream, -- * Integrating with Signals signalStream, streamSignal, @@ -97,6 +101,12 @@ (<*>) = apStream +instance Alternative Stream where + + empty = emptyStream + + (<|>) = mergeStreams + instance Monoid (Stream a) where mempty = emptyStream @@ -534,6 +544,57 @@ -- | Delay the stream by one step using the specified initial value. delayStream :: a -> Stream a -> Stream a delayStream a0 s = Cons $ return (a0, s) + +-- | Return a stream consisting of exactly one element and inifinite tail. +singletonStream :: a -> Stream a +singletonStream a = Cons $ return (a, emptyStream) + +-- | Removes one level of the computation, projecting its bound stream into the outer level. +joinStream :: Process (Stream a) -> Stream a +joinStream m = Cons $ m >>= runStream + +-- | Takes the next stream from the list after the current stream fails because of cancelling the underlying process. +failoverStream :: [Stream a] -> Stream a +failoverStream ps = Cons z where + z = do reading <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + writing <- liftSimulation $ newResourceWithMaxCount FCFS 0 (Just 1) + ref <- liftIO $ newIORef Nothing + pid <- processId + let writer p = + do requestResource writing + pid' <- processId + (a, xs) <- + finallyProcess (runStream p) $ + liftEvent $ + do cancelled' <- processCancelled pid' + when cancelled' $ + releaseResourceWithinEvent writing + liftIO $ writeIORef ref (Just a) + releaseResource reading + writer xs + reader = + do releaseResource writing + requestResource reading + Just a <- liftIO $ readIORef ref + liftIO $ writeIORef ref Nothing + return a + loop [] = return () + loop (p: ps) = + do pid' <- processId + h' <- liftEvent $ + handleSignal (processCancelling pid) $ \() -> + cancelProcessWithId pid' + finallyProcess (writer p) $ + liftEvent $ + do disposeEvent h' + cancelled <- processCancelled pid + unless cancelled $ + do cancelled' <- processCancelled pid' + unless cancelled' $ + error "Expected the sub-process to be cancelled: failoverStream" + runProcess $ loop ps + liftEvent $ runProcess $ loop ps + runStream $ repeatProcess reader -- | Show the debug messages with the current simulation time. traceStream :: Maybe String 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Stream.Random --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/SystemDynamics.hs b/Simulation/Aivika/SystemDynamics.hs --- a/Simulation/Aivika/SystemDynamics.hs +++ b/Simulation/Aivika/SystemDynamics.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.SystemDynamics --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Table.hs b/Simulation/Aivika/Table.hs --- a/Simulation/Aivika/Table.hs +++ b/Simulation/Aivika/Table.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Table --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Task.hs b/Simulation/Aivika/Task.hs --- a/Simulation/Aivika/Task.hs +++ b/Simulation/Aivika/Task.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Task --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -34,7 +34,10 @@ spawnTaskUsingIdWith, -- * Enqueueing Task enqueueTask, - enqueueTaskUsingId) where + enqueueTaskUsingId, + -- * Parallel Tasks + taskParallelResult, + taskParallelProcess) where import Data.IORef import Data.Monoid @@ -48,7 +51,7 @@ import Simulation.Aivika.Internal.Event import Simulation.Aivika.Internal.Cont import Simulation.Aivika.Internal.Process -import Simulation.Aivika.Internal.Signal +import Simulation.Aivika.Signal -- | The task represents a process that was already started in background. data Task a = @@ -168,12 +171,58 @@ do pid <- liftSimulation newProcessId spawnTaskUsingIdWith cancellation pid p --- | Return an outer process that behaves like the task itself except for one thing: --- if the outer process is cancelled then it is not enough to cancel the task. +-- | Return an outer process that behaves like the task itself, for example, +-- when the task is cancelled if the outer process is cancelled. taskProcess :: Task a -> Process a taskProcess t = - do x <- taskResult t + do x <- finallyProcess + (taskResult t) + (do pid <- processId + liftEvent $ + do cancelled <- processCancelled pid + when cancelled $ + cancelTask t) case x of TaskCompleted a -> return a TaskError e -> throwProcess e TaskCancelled -> cancelProcess + +-- | Return the result of two parallel tasks. +taskParallelResult :: Task a -> Task a -> Process (TaskResult a, Task a) +taskParallelResult t1 t2 = + do x1 <- liftIO $ readIORef (taskResultRef t1) + case x1 of + Just x1 -> return (x1, t2) + Nothing -> + do x2 <- liftIO $ readIORef (taskResultRef t2) + case x2 of + Just x2 -> return (x2, t1) + Nothing -> + do let s1 = fmap Left $ taskResultReceived t1 + s2 = fmap Right $ taskResultReceived t2 + x <- processAwait $ s1 <> s2 + case x of + Left x1 -> return (x1, t2) + Right x2 -> return (x2, t1) + +-- | Return an outer process for two parallel tasks returning the result of +-- the first finished task and the rest task in pair. +taskParallelProcess :: Task a -> Task a -> Process (a, Task a) +taskParallelProcess t1 t2 = + do (x, t) <- + finallyProcess + (taskParallelResult t1 t2) + (do pid <- processId + liftEvent $ + do cancelled <- processCancelled pid + when cancelled $ + do cancelTask t1 + cancelTask t2) + case x of + TaskCompleted a -> return (a, t) + TaskError e -> + do liftEvent $ cancelTask t + throwProcess e + TaskCancelled -> + do liftEvent $ cancelTask t + cancelProcess diff --git a/Simulation/Aivika/Transform.hs b/Simulation/Aivika/Transform.hs --- a/Simulation/Aivika/Transform.hs +++ b/Simulation/Aivika/Transform.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Transform --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Transform/Extra.hs b/Simulation/Aivika/Transform/Extra.hs --- a/Simulation/Aivika/Transform/Extra.hs +++ b/Simulation/Aivika/Transform/Extra.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Transform.Extra --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Transform/Memo.hs b/Simulation/Aivika/Transform/Memo.hs --- a/Simulation/Aivika/Transform/Memo.hs +++ b/Simulation/Aivika/Transform/Memo.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Transform.Memo --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Transform/Memo/Unboxed.hs b/Simulation/Aivika/Transform/Memo/Unboxed.hs --- a/Simulation/Aivika/Transform/Memo/Unboxed.hs +++ b/Simulation/Aivika/Transform/Memo/Unboxed.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Transform.Memo.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Unboxed.hs b/Simulation/Aivika/Unboxed.hs --- a/Simulation/Aivika/Unboxed.hs +++ b/Simulation/Aivika/Unboxed.hs @@ -3,7 +3,7 @@ -- | -- Module : Simulation.Aivika.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/Simulation/Aivika/Var.hs b/Simulation/Aivika/Var.hs --- a/Simulation/Aivika/Var.hs +++ b/Simulation/Aivika/Var.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Var --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -30,7 +30,6 @@ 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 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Var.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental @@ -30,7 +30,6 @@ 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 diff --git a/Simulation/Aivika/Vector.hs b/Simulation/Aivika/Vector.hs --- a/Simulation/Aivika/Vector.hs +++ b/Simulation/Aivika/Vector.hs @@ -1,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Vector --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental 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,7 +1,7 @@ -- | -- Module : Simulation.Aivika.Vector.Unboxed --- Copyright : Copyright (c) 2009-2014, David Sorokin +-- Copyright : Copyright (c) 2009-2015, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental diff --git a/aivika.cabal b/aivika.cabal --- a/aivika.cabal +++ b/aivika.cabal @@ -1,5 +1,5 @@ name: aivika -version: 3.0 +version: 3.1 synopsis: A multi-paradigm simulation library description: Aivika is a multi-paradigm simulation library with a strong emphasis @@ -81,7 +81,7 @@ category: Simulation license: BSD3 license-file: LICENSE -copyright: (c) 2009-2014. David Sorokin +copyright: (c) 2009-2015. David Sorokin author: David Sorokin maintainer: David Sorokin homepage: http://github.com/dsorokin/aivika @@ -108,6 +108,7 @@ examples/TimeOut.hs examples/TimeOutInt.hs examples/TimeOutWait.hs + CHANGELOG.md flag haste-inst @@ -172,7 +173,6 @@ 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 diff --git a/examples/BassDiffusion.hs b/examples/BassDiffusion.hs --- a/examples/BassDiffusion.hs +++ b/examples/BassDiffusion.hs @@ -42,7 +42,7 @@ return (i, p) return $ array (1, n) list -definePerson :: Person -> Array Int Person -> Ref Int -> Ref Int -> Simulation () +definePerson :: Person -> Array Int Person -> Ref Int -> Ref Int -> Event () definePerson p ps potentialAdopters adopters = do setStateActivation (personPotentialAdopter p) $ do modifyRef potentialAdopters $ \a -> a + 1 @@ -71,7 +71,7 @@ setStateDeactivation (personAdopter p) $ modifyRef adopters $ \a -> a - 1 -definePersons :: Array Int Person -> Ref Int -> Ref Int -> Simulation () +definePersons :: Array Int Person -> Ref Int -> Ref Int -> Event () definePersons ps potentialAdopters adopters = forM_ (elems ps) $ \p -> definePerson p ps potentialAdopters adopters @@ -88,13 +88,13 @@ do potentialAdopters <- newRef 0 adopters <- newRef 0 ps <- createPersons - definePersons ps potentialAdopters adopters runEventInStartTime $ - activatePersons ps + do definePersons ps potentialAdopters adopters + activatePersons ps return $ results [resultSource - "potentialAdopter" "potential adopters" potentialAdopters, + "potentialAdopters" "potential adopters" potentialAdopters, resultSource "adopters" "adopters" adopters] diff --git a/examples/InventorySystem.hs b/examples/InventorySystem.hs --- a/examples/InventorySystem.hs +++ b/examples/InventorySystem.hs @@ -69,7 +69,7 @@ lostSalesCount <- newRef (0 :: Int) -- whether the procurement initiated? procuring <- newRef False - -- the inventotyPosition + -- the inventory position let inventoryPosition = do x1 <- readRef radioStock x2 <- readRef orderCount diff --git a/examples/MachineBreakdowns.hs b/examples/MachineBreakdowns.hs --- a/examples/MachineBreakdowns.hs +++ b/examples/MachineBreakdowns.hs @@ -12,6 +12,7 @@ import Control.Category import Data.Monoid +import Data.List import Simulation.Aivika import qualified Simulation.Aivika.Queue.Infinite as IQ @@ -54,81 +55,99 @@ -- ^ the remaining processing time (may differ after return). } +-- | Return the remaining job after interruption. +remainingJobInput :: ServerInterruption (Arrival Job) -> Arrival Job +remainingJobInput x = a' + where + t1 = serverStartProcessingTime x + t2 = serverInterruptionTime x + dt = t2 - t1 + a = serverInterruptedInput x + a' = a { arrivalValue = job' } + job = arrivalValue a + job' = job { jobRemainingTime = + max 0 $ jobRemainingTime job - dt } + model :: Simulation Results model = do -- create an input queue - inputQueue <- runEventInStartTime $ IQ.newFCFSQueue + inputQueue <- runEventInStartTime IQ.newPriorityQueue -- a counter of jobs completed jobsCompleted <- newArrivalTimer + -- a counter of interrupted jobs but then returned for the further processing + jobsInterrupted <- newRef (0 :: Int) -- create an input stream let inputStream = traceStream Nothing (Just "taking a job from the queue") $ repeatProcess $ IQ.dequeue inputQueue -- create the setting up phase of processing machineSettingUp <- - newServer $ \a -> + newInterruptibleServer True $ \a -> do -- set up the machine setUpTime <- liftParameter $ randomUniform minSetUpTime maxSetUpTime - holdProcess setUpTime + traceProcess "setting up the machine" $ + holdProcess setUpTime return a -- create the processing phase itself machineProcessing <- newInterruptibleServer True $ \a -> do -- process the job let job = arrivalValue a - holdProcess $ jobRemainingTime job + traceProcess "processing the job" $ + holdProcess $ jobRemainingTime job -- return the completed job return a { arrivalValue = job { jobRemainingTime = 0 } } - -- define the network - let network = - traceProcessor Nothing (Just "the job completed") $ - serverProcessor machineSettingUp >>> - serverProcessor machineProcessing >>> - arrivalTimerProcessor jobsCompleted -- enqueue the interrupted jobs again runEventInStartTime $ - handleSignal_ (serverTaskInterrupted machineProcessing) $ \x -> - traceEvent "interrupting the job.." $ - do let t1 = serverStartProcessingTime x - t2 = serverInterruptionTime x - dt = t2 - t1 - a = serverInterruptedInput x - a' = a { arrivalValue = job' } - job = arrivalValue a - job' = job { jobRemainingTime = - max 0 $ jobRemainingTime job - dt } - IQ.enqueue inputQueue a' - -- launch the machine tool - let launch = do - -- breakdown the machine tool in time (a bound child process) - spawnProcess $ do - breakdownTime <- - liftParameter $ - randomNormal breakdownMu breakdownSigma - holdProcess breakdownTime - traceProcess "breakdown" $ - cancelProcess - -- model the machine tool itself - let loop = - -- process the jobs until interrupting - sinkStream $ - runProcessor network inputStream - -- model the repairing of the tool - let repair = do - -- at first repair the machine - repairTime <- liftParameter $ - randomErlang repairMu 3 - holdProcess repairTime - -- then launch it again (an independent process) - traceProcess "repaired" $ - liftEvent $ - runProcess launch - -- start simulating the machine tool with an ability to repair - finallyProcess loop repair + do handleSignal_ (serverTaskInterrupted machineSettingUp) $ \x -> + traceEvent "returning the job..." $ + do let a = serverInterruptedInput x + t = arrivalTime a + IQ.enqueueWithStoringPriority inputQueue t a + handleSignal_ (serverTaskInterrupted machineProcessing) $ \x -> + traceEvent "interrupting the job..." $ + do let a = remainingJobInput x + t = arrivalTime a + modifyRef jobsInterrupted (+ 1) + IQ.enqueueWithStoringPriority inputQueue t a + let -- launch the machine tool again and again + machineLaunch = + joinProcessor $ + do spawnProcess $ + do -- breakdown the machine tool in time (a bound child process) + breakdownTime <- + liftParameter $ + randomNormal breakdownMu breakdownSigma + when (breakdownTime > 0) $ + holdProcess breakdownTime + traceProcess "breakdown" $ + cancelProcess + return $ + serverProcessor machineSettingUp >>> + serverProcessor machineProcessing + -- repair the machine tool + machineRepair = + do repairTime <- liftParameter $ + randomErlang repairMu 3 + holdProcess repairTime + -- launch after repairing the machine tool + machineRepairAndLaunch = + joinProcessor $ + do machineRepair + traceProcess "repaired" $ + return machineLaunch + -- machine loop + machineLoop = machineLaunch : repeat machineRepairAndLaunch + -- the network + network = + traceProcessor Nothing (Just "the job completed") $ + failoverProcessor machineLoop >>> + arrivalTimerProcessor jobsCompleted -- start the machine tool - runProcessInStartTime launch + runProcessInStartTime $ + sinkStream $ runProcessor network inputStream -- model a stream of jobs let jobs = traceStream Nothing (Just "a new job") $ @@ -142,9 +161,10 @@ liftParameter $ randomNormal jobProcessingMu jobProcessingSigma -- enqueue the job - IQ.enqueue inputQueue $ - a { arrivalValue = - Job jobProcessingTime jobProcessingTime } + let t0 = arrivalTime a + dt = max 0 jobProcessingTime + IQ.enqueueWithStoringPriority inputQueue t0 $ + a { arrivalValue = Job dt dt } -- return the simulation results in start time return $ results @@ -159,6 +179,10 @@ resultSource "machineProcessing" "the machine tool (the processing phase)" machineProcessing, + -- + resultSource + "jobsInterrupted" "a counter of the interrupted jobs" + jobsInterrupted, -- resultSource "jobsCompleted" "a counter of the completed jobs" diff --git a/examples/WorkStationsInSeries.hs b/examples/WorkStationsInSeries.hs --- a/examples/WorkStationsInSeries.hs +++ b/examples/WorkStationsInSeries.hs @@ -59,10 +59,6 @@ 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 @@ -97,10 +93,10 @@ let entireProcessor = queueProcessor1 >>> processorParallel (map serverProcessor workStation1s) >>> - -- foldr1 interposePrefetchProcessor (map serverProcessor workStation1s) >>> + -- processorSeq (map serverProcessor workStation1s) >>> queueProcessor2 >>> processorParallel (map serverProcessor workStation2s) >>> - -- foldr1 interposePrefetchProcessor (map serverProcessor workStation2s) >>> + -- processorSeq (map serverProcessor workStation2s) >>> arrivalTimerProcessor arrivalTimer -- start simulating the model runProcessInStartTime $