aivika 2.1 → 3.0

raw patch · 25 files changed

+1113/−47 lines, 25 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Simulation/Aivika/Activity.hs +84/−8
• Simulation/Aivika/Circuit.hs +104/−4
• Simulation/Aivika/Dynamics.hs +3/−1
• Simulation/Aivika/Event.hs +3/−1
• Simulation/Aivika/Internal/Cont.hs +15/−1
• Simulation/Aivika/Internal/Dynamics.hs +12/−1
• Simulation/Aivika/Internal/Event.hs +13/−2
• Simulation/Aivika/Internal/Process.hs +10/−1
• Simulation/Aivika/Internal/Signal.hs +9/−1
• Simulation/Aivika/Internal/Simulation.hs +26/−2
• Simulation/Aivika/Internal/Specs.hs +17/−0
• Simulation/Aivika/Net.hs +45/−1
• Simulation/Aivika/Process.hs +3/−1
• Simulation/Aivika/Processor.hs +14/−1
• Simulation/Aivika/Results.hs +102/−2
• Simulation/Aivika/Results/Locale.hs +24/−0
• Simulation/Aivika/Server.hs +84/−8
• Simulation/Aivika/Signal.hs +3/−1
• Simulation/Aivika/Simulation.hs +4/−1
• Simulation/Aivika/Statistics.hs +110/−7
• Simulation/Aivika/Stream.hs +24/−1
• aivika.cabal +6/−2
• examples/BouncingBall.hs +60/−0
• examples/InventorySystem.hs +168/−0
• examples/MachineBreakdowns.hs +170/−0

@@ -12,8 +12,11 @@ module Simulation.Aivika.Activity        (-- * Activity         Activity,+        ActivityInterruption(..),         newActivity,         newStateActivity,+        newInterruptibleActivity,+        newInterruptibleStateActivity,         -- * Processing         activityNet,         -- * Activity Properties@@ -45,12 +48,14 @@         -- * Basic Signals         activityUtilising,         activityUtilised,+        activityInterrupted,         -- * Overall Signal         activityChanged_) where  import Data.IORef import Data.Monoid +import Control.Monad import Control.Monad.Trans import Control.Arrow @@ -74,6 +79,8 @@              -- ^ The current state of the activity.              activityProcess :: s -> a -> Process (s, b),              -- ^ Provide @b@ by specified @a@.+             activityProcessInterruptible :: Bool,+             -- ^ Whether the process is interruptible.              activityTotalUtilisationTimeRef :: IORef Double,              -- ^ The counted total time of utilising the activity.              activityTotalIdleTimeRef :: IORef Double,@@ -84,28 +91,68 @@              -- ^ The statistics for the time, when the activity was idle.              activityUtilisingSource :: SignalSource a,              -- ^ A signal raised when starting to utilise the activity.-             activityUtilisedSource :: SignalSource (a, b)+             activityUtilisedSource :: SignalSource (a, b),              -- ^ A signal raised when the activity has been utilised.+             activityInterruptedSource :: SignalSource (ActivityInterruption a)+             -- ^ A signal raised when the utilisation was interrupted.            } +-- | Contains data about the interrupted task.+data ActivityInterruption a =+  ActivityInterruption { activityInterruptedInput :: a,+                         -- ^ The input task that was interrupted.+                         activityStartProcessingTime :: Double,+                         -- ^ The start time of processing the task.+                         activityInterruptionTime :: Double+                         -- ^ The time of interrupting the task.+                       }+ -- | Create a new activity that can provide output @b@ by input @a@.+--+-- By default, it is assumed that the activity utilisation cannot be interrupted,+-- because the handling of possible task interruption is rather costly+-- operation. newActivity :: (a -> Process b)                -- ^ provide an output by the specified input                -> Simulation (Activity () a b)-newActivity provide =-  flip newStateActivity () $ \s a ->-  do b <- provide a-     return (s, b)+newActivity = newInterruptibleActivity False  -- | Create a new activity that can provide output @b@ by input @a@ -- starting from state @s@.+--+-- By default, it is assumed that the activity utilisation cannot be interrupted,+-- because the handling of possible task interruption is rather costly+-- operation. newStateActivity :: (s -> a -> Process (s, b))                     -- ^ provide a new state and output by the specified                      -- old state and input                     -> s                     -- ^ the initial state                     -> Simulation (Activity s a b)-newStateActivity provide state =+newStateActivity = newInterruptibleStateActivity False++-- | Create a new interruptible activity that can provide output @b@ by input @a@.+newInterruptibleActivity :: Bool+                            -- ^ whether the activity can be interrupted+                            -> (a -> Process b)+                            -- ^ provide an output by the specified input+                            -> Simulation (Activity () a b)+newInterruptibleActivity interruptible provide =+  flip (newInterruptibleStateActivity interruptible) () $ \s a ->+  do b <- provide a+     return (s, b)++-- | Create a new activity that can provide output @b@ by input @a@+-- starting from state @s@.+newInterruptibleStateActivity :: Bool+                                 -- ^ whether the activity can be interrupted+                                 -> (s -> a -> Process (s, b))+                                 -- ^ provide a new state and output by the specified +                                 -- old state and input+                                 -> s+                                 -- ^ the initial state+                              -> Simulation (Activity s a b)+newInterruptibleStateActivity interruptible provide state =   do r0 <- liftIO $ newIORef state      r1 <- liftIO $ newIORef 0      r2 <- liftIO $ newIORef 0@@ -113,15 +160,18 @@      r4 <- liftIO $ newIORef emptySamplingStats      s1 <- newSignalSource      s2 <- newSignalSource+     s3 <- newSignalSource      return Activity { activityInitState = state,                        activityStateRef = r0,                        activityProcess = provide,+                       activityProcessInterruptible = interruptible,                        activityTotalUtilisationTimeRef = r1,                        activityTotalIdleTimeRef = r2,                        activityUtilisationTimeRef = r3,                        activityIdleTimeRef = r4,                        activityUtilisingSource = s1,-                       activityUtilisedSource = s2 }+                       activityUtilisedSource = s2,+                       activityInterruptedSource = s3 }  -- | Return a network computation for the specified activity. --@@ -152,6 +202,9 @@               triggerSignal (activityUtilisingSource act) a          -- utilise the activity          (s', b) <- activityProcess act s a+         (s', b) <- if activityProcessInterruptible act+                    then activityProcessInterrupting act s a+                    else activityProcess act s a          t1 <- liftDynamics time          liftEvent $            do liftIO $@@ -162,6 +215,24 @@               triggerSignal (activityUtilisedSource act) (a, b)          return (b, Net $ loop s' (Just t1)) +-- | Process the input with ability to handle a possible interruption.+activityProcessInterrupting :: Activity s a b -> s -> a -> Process (s, b)+activityProcessInterrupting act s a =+  do pid <- processId+     t0  <- liftDynamics time+     finallyProcess+       (activityProcess act s a)+       (liftEvent $+        do cancelled <- processCancelled pid+           when cancelled $+             do t1 <- liftDynamics time+                liftIO $+                  do modifyIORef' (activityTotalUtilisationTimeRef act) (+ (t1 - t0))+                     modifyIORef' (activityUtilisationTimeRef act) $+                       addSamplingStats (t1 - t0)+                let x = ActivityInterruption a t0 t1+                triggerSignal (activityInterruptedSource act) x)+ -- | Return the current state of the activity. -- -- See also 'activityStateChanged' and 'activityStateChanged_'.@@ -329,11 +400,16 @@ activityUtilised :: Activity s a b -> Signal (a, b) activityUtilised = publishSignal . activityUtilisedSource +-- | Raised when the task utilisation by the activity was interrupted.+activityInterrupted :: Activity s a b -> Signal (ActivityInterruption a)+activityInterrupted = publishSignal . activityInterruptedSource+ -- | Signal whenever any property of the activity changes. activityChanged_ :: Activity s a b -> Signal () activityChanged_ act =   mapSignal (const ()) (activityUtilising act) <>-  mapSignal (const ()) (activityUtilised act)+  mapSignal (const ()) (activityUtilised act) <>+  mapSignal (const ()) (activityInterrupted act)  -- | Return the summary for the activity with desciption of its -- properties using the specified indent.

@@ -20,8 +20,12 @@         Circuit(..),         iterateCircuitInIntegTimes,         iterateCircuitInIntegTimes_,+        iterateCircuitInIntegTimesMaybe,+        iterateCircuitInIntegTimesEither,         iterateCircuitInTimes,         iterateCircuitInTimes_,+        iterateCircuitInTimesMaybe,+        iterateCircuitInTimesEither,         -- * Circuit Primitives         arrCircuit,         accumCircuit,@@ -46,7 +50,9 @@         sumCircuit,         sumCircuitEither,         -- * The Circuit Transform-        circuitTransform) where+        circuitTransform,+        -- * Debugging+        traceCircuit) where  import qualified Control.Category as C import Control.Arrow@@ -456,14 +462,15 @@            do (a', cir') <- invokeEvent p $ runCircuit cir a               invokeEvent p $ loop ps cir' a' source      source <- liftSimulation newSignalSource+     task <- runTask $ processAwait $ publishSignal source      loop ps cir a source-     runTask $ processAwait $ publishSignal source+     return task  -- | Iterate the circuit in the integration time points. iterateCircuitInIntegTimes_ :: Circuit a a -> a -> Event () iterateCircuitInIntegTimes_ cir a =   Event $ \p ->-  do let ps = integPoints $ pointRun p+  do let ps = integPointsStartingFrom p      invokeEvent p $         iterateCircuitInPoints_ ps cir a @@ -480,7 +487,7 @@ iterateCircuitInIntegTimes :: Circuit a a -> a -> Event (Task a) iterateCircuitInIntegTimes cir a =   Event $ \p ->-  do let ps = integPoints $ pointRun p+  do let ps = integPointsStartingFrom p      invokeEvent p $         iterateCircuitInPoints ps cir a @@ -492,3 +499,96 @@   do let ps = map (pointAt $ pointRun p) ts      invokeEvent p $         iterateCircuitInPoints ps cir a ++-- | Iterate the circuit in the specified time points, interrupting the iteration+-- immediately if 'Nothing' is returned within the 'Circuit' computation.+iterateCircuitInPointsMaybe :: [Point] -> Circuit a (Maybe a) -> a -> Event ()+iterateCircuitInPointsMaybe [] cir a = return ()+iterateCircuitInPointsMaybe (p : ps) cir a =+  enqueueEvent (pointTime p) $+  Event $ \p' ->+  do (a', cir') <- invokeEvent p $ runCircuit cir a+     case a' of+       Nothing -> return ()+       Just a' ->+         invokeEvent p $ iterateCircuitInPointsMaybe ps cir' a'++-- | Iterate the circuit in the integration time points, interrupting the iteration+-- immediately if 'Nothing' is returned within the 'Circuit' computation.+iterateCircuitInIntegTimesMaybe :: Circuit a (Maybe a) -> a -> Event ()+iterateCircuitInIntegTimesMaybe cir a =+  Event $ \p ->+  do let ps = integPointsStartingFrom p+     invokeEvent p $ +       iterateCircuitInPointsMaybe ps cir a++-- | Iterate the circuit in the specified time points, interrupting the iteration+-- immediately if 'Nothing' is returned within the 'Circuit' computation.+iterateCircuitInTimesMaybe :: [Double] -> Circuit a (Maybe a) -> a -> Event ()+iterateCircuitInTimesMaybe ts cir a =+  Event $ \p ->+  do let ps = map (pointAt $ pointRun p) ts+     invokeEvent p $ +       iterateCircuitInPointsMaybe ps cir a++-- | Iterate the circuit in the specified time points returning a task+-- that computes the final output of the circuit either after all points+-- are exhausted, or after the 'Left' result of type @b@ is received,+-- which interrupts the computation immediately.+iterateCircuitInPointsEither :: [Point] -> Circuit a (Either b a) -> a -> Event (Task (Either b a))+iterateCircuitInPointsEither ps cir a =+  do let loop [] cir ba source = triggerSignal source ba+         loop ps cir ba@(Left b) source = triggerSignal source ba +         loop (p : ps) cir (Right a) source =+           enqueueEvent (pointTime p) $+           Event $ \p' ->+           do (ba', cir') <- invokeEvent p $ runCircuit cir a+              invokeEvent p $ loop ps cir' ba' source+     source <- liftSimulation newSignalSource+     task <- runTask $ processAwait $ publishSignal source+     loop ps cir (Right a) source+     return task++-- | Iterate the circuit in the integration time points returning a task+-- that computes the final output of the circuit either after all points+-- are exhausted, or after the 'Left' result of type @b@ is received,+-- which interrupts the computation immediately.+iterateCircuitInIntegTimesEither :: Circuit a (Either b a) -> a -> Event (Task (Either b a))+iterateCircuitInIntegTimesEither cir a =+  Event $ \p ->+  do let ps = integPointsStartingFrom p+     invokeEvent p $ +       iterateCircuitInPointsEither ps cir a++-- | Iterate the circuit in the specified time points returning a task+-- that computes the final output of the circuit either after all points+-- are exhausted, or after the 'Left' result of type @b@ is received,+-- which interrupts the computation immediately.+iterateCircuitInTimesEither :: [Double] -> Circuit a (Either b a) -> a -> Event (Task (Either b a))+iterateCircuitInTimesEither ts cir a =+  Event $ \p ->+  do let ps = map (pointAt $ pointRun p) ts+     invokeEvent p $ +       iterateCircuitInPointsEither ps cir a++-- | Show the debug messages with the current simulation time.+traceCircuit :: Maybe String+                -- ^ the request message+                -> Maybe String+                -- ^ the response message+                -> Circuit a b+                -- ^ a circuit+                -> Circuit a b+traceCircuit request response cir = Circuit $ loop cir where+  loop cir a =+    do (b, cir') <-+         case request of+           Nothing -> runCircuit cir a+           Just message -> +             traceEvent message $+             runCircuit cir a+       case response of+         Nothing -> return (b, Circuit $ loop cir')+         Just message ->+           traceEvent message $+           return (b, Circuit $ loop cir') 

@@ -26,6 +26,8 @@         time,         isTimeInteg,         integIteration,-        integPhase) where+        integPhase,+        -- * Debugging+        traceDynamics) where  import Simulation.Aivika.Internal.Dynamics

@@ -39,6 +39,8 @@         memoEvent,         memoEventInTime,         -- * Disposable-        DisposableEvent(..)) where+        DisposableEvent(..),+        -- * Debugging+        traceEvent) where  import Simulation.Aivika.Internal.Event

@@ -35,7 +35,8 @@         resumeECont,         contCanceled,         contFreeze,-        contAwait) where+        contAwait,+        traceCont) where  import Data.IORef import Data.Array@@ -47,6 +48,8 @@ import Control.Monad.Trans import Control.Applicative +import Debug.Trace+ import Simulation.Aivika.Internal.Specs import Simulation.Aivika.Internal.Parameter import Simulation.Aivika.Internal.Simulation@@ -669,3 +672,14 @@                                   Just c  ->                                     invokeEvent p $ resumeCont c a      writeIORef r $ Just h          ++-- | Show the debug message with the current simulation time.+traceCont :: String -> Cont a -> Cont a+traceCont message (Cont m) =+  Cont $ \c ->+  Event $ \p ->+  do z <- contCanceled c+     if z+       then cancelCont p c+       else trace ("t = " ++ show (pointTime p) ++ ": " ++ message) $+            invokeEvent p $ m c

@@ -29,7 +29,9 @@         time,         isTimeInteg,         integIteration,-        integPhase) where+        integPhase,+        -- * Debugging+        traceDynamics) where  import Control.Exception import Control.Monad@@ -37,6 +39,8 @@ import Control.Monad.Fix import Control.Applicative +import Debug.Trace+ import Simulation.Aivika.Internal.Specs import Simulation.Aivika.Internal.Parameter import Simulation.Aivika.Internal.Simulation@@ -212,3 +216,10 @@ -- It is @(-1)@ for non-integration time points. integPhase :: Dynamics Int integPhase = Dynamics $ return . pointPhase++-- | Show the debug message with the current simulation time.+traceDynamics :: String -> Dynamics a -> Dynamics a+traceDynamics message m =+  Dynamics $ \p ->+  trace ("t = " ++ show (pointTime p) ++ ": " ++ message) $+  invokeDynamics p m

@@ -43,7 +43,9 @@         memoEvent,         memoEventInTime,         -- * Disposable-        DisposableEvent(..)) where+        DisposableEvent(..),+        -- * Debugging+        traceEvent) where  import Data.IORef import Data.Monoid@@ -54,6 +56,8 @@ import Control.Monad.Fix import Control.Applicative +import Debug.Trace (trace)+ import qualified Simulation.Aivika.PriorityQueue as PQ  import Simulation.Aivika.Internal.Specs@@ -304,7 +308,7 @@ enqueueEventWithIntegTimes :: Event () -> Event () enqueueEventWithIntegTimes e =   Event $ \p ->-  let points = integPoints $ pointRun p+  let points = integPointsStartingFrom p   in invokeEvent p $ enqueueEventWithPoints points e  -- | It allows cancelling the event.@@ -397,3 +401,10 @@    mempty = DisposableEvent $ return ()   mappend (DisposableEvent x) (DisposableEvent y) = DisposableEvent $ x >> y++-- | Show the debug message with the current simulation time.+traceEvent :: String -> Event a -> Event a+traceEvent message m =+  Event $ \p ->+  trace ("t = " ++ show (pointTime p) ++ ": " ++ message) $+  invokeEvent p m

@@ -77,7 +77,9 @@         -- * Memoizing Process         memoProcess,         -- * Never Ending Process-        neverProcess) where+        neverProcess,+        -- * Debugging+        traceProcess) where  import Data.Maybe import Data.IORef@@ -641,3 +643,10 @@   let signal = processCancelling pid   in handleSignal_ signal $ \_ ->      resumeCont c $ error "It must never be computed: neverProcess"++-- | Show the debug message with the current simulation time.+traceProcess :: String -> Process a -> Process a+traceProcess message m =+  Process $ \pid ->+  traceCont message $+  invokeProcess pid m

@@ -49,7 +49,9 @@         Signalable(..),         signalableChanged,         emptySignalable,-        appendSignalable) where+        appendSignalable,+        -- * Debugging+        traceSignal) where  import Data.IORef import Data.Monoid@@ -378,3 +380,9 @@                                        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 }

@@ -1,5 +1,5 @@ -{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE RecursiveDo, ExistentialQuantification, DeriveDataTypeable #-}  -- | -- Module     : Simulation.Aivika.Internal.Simulation@@ -26,7 +26,10 @@         -- * Utilities         simulationEventQueue,         -- * Memoization-        memoSimulation) where+        memoSimulation,+        -- * Exceptions+        SimulationException(..),+        SimulationAbort(..)) where  import Control.Exception import Control.Monad@@ -35,6 +38,7 @@ import Control.Applicative  import Data.IORef+import Data.Typeable  import Simulation.Aivika.Generator import Simulation.Aivika.Internal.Specs@@ -159,3 +163,23 @@               do v <- invokeSimulation r m                  writeIORef ref (Just v)                  return v++-- | The root of simulation exceptions.+data SimulationException = forall e . Exception e => SimulationException e+                           -- ^ A particular simulation exception.+                         deriving Typeable++instance Show SimulationException where+  show (SimulationException e) = show e++instance Exception SimulationException++-- | An exception that signals of aborting the simulation.+data SimulationAbort = SimulationAbort+                       -- ^ The exception to abort the simulation.+                     deriving (Show, Typeable)++instance Exception SimulationAbort where+  +  toException = toException . SimulationException+  fromException x = do { SimulationException a <- fromException x; cast a }

@@ -24,6 +24,7 @@         integPhaseLoBnd,         integTimes,         integPoints,+        integPointsStartingFrom,         integStartPoint,         integStopPoint,         pointAt) where@@ -221,3 +222,19 @@                     pointTime = t,                     pointIteration = n,                     pointPhase = -1 }++-- | Return the integration time points startin from the specified iteration.+integPointsStartingFrom :: Point -> [Point]+integPointsStartingFrom p = points+  where r  = pointRun p+        sc = runSpecs r+        (nl, nu) = integIterationBnds sc+        n0       = if pointPhase p == 0+                   then pointIteration p+                   else pointIteration p + 1+        points   = map point [n0 .. nu]+        point n  = Point { pointSpecs = sc,+                           pointRun = r,+                           pointTime = basicTime sc n 0,+                           pointIteration = n,+                           pointPhase = 0 }

@@ -28,6 +28,8 @@        (-- * Net Arrow         Net(..),         iterateNet,+        iterateNetMaybe,+        iterateNetEither,         -- * Net Primitives         emptyNet,         arrNet,@@ -40,7 +42,9 @@         delayNet,         -- * Interchanging Nets with Processors         netProcessor,-        processorNet) where+        processorNet,+        -- * Debugging+        traceNet) where  import qualified Control.Category as C import Control.Arrow@@ -247,3 +251,43 @@ iterateNet (Net f) a =   do (a', x) <- f a      iterateNet x a'++-- | Iterate the net using the specified initial value+-- until 'Nothing' is returned within the 'Net' computation.+iterateNetMaybe :: Net a (Maybe a) -> a -> Process ()+iterateNetMaybe (Net f) a =+  do (a', x) <- f a+     case a' of+       Nothing -> return ()+       Just a' -> iterateNetMaybe x a'++-- | Iterate the net using the specified initial value+-- until the 'Left' result is returned within the 'Net' computation.+iterateNetEither :: Net a (Either b a) -> a -> Process b+iterateNetEither (Net f) a =+  do (ba', x) <- f a+     case ba' of+       Left b'  -> return b'+       Right a' -> iterateNetEither x a'++-- | Show the debug messages with the current simulation time.+traceNet :: Maybe String+            -- ^ the request message+            -> Maybe String+            -- ^ the response message+            -> Net a b+            -- ^ a net+            -> Net a b+traceNet request response x = Net $ loop x where+  loop x a =+    do (b, x') <-+         case request of+           Nothing -> runNet x a+           Just message -> +             traceProcess message $+             runNet x a+       case response of+         Nothing -> return (b, Net $ loop x')+         Just message ->+           traceProcess message $+           return (b, Net $ loop x') 

@@ -79,6 +79,8 @@         -- * Memoizing Process         memoProcess,         -- * Never Ending Process-        neverProcess) where+        neverProcess,+        -- * Debugging+        traceProcess) where  import Simulation.Aivika.Internal.Process

@@ -41,7 +41,9 @@         arrivalProcessor,         -- * Integrating with Signals         signalProcessor,-        processorSignaling) where+        processorSignaling,+        -- * Debugging+        traceProcessor) where  import qualified Control.Category as C import Control.Arrow@@ -456,3 +458,14 @@ -- | 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++-- | Show the debug messages with the current simulation time.+traceProcessor :: Maybe String+                  -- ^ the request message+                  -> Maybe String+                  -- ^ the response message+                  -> Processor a b+                  -- ^ a processor+                  -> Processor a b+traceProcessor request response (Processor f) =+  Processor $ traceStream request response . f 

@@ -1483,6 +1483,86 @@                             -- ^ the statistics                             -> ResultSource timingStatsResultSummary = ResultItemSource . ResultItem . resultItemToStringValue+      +-- | Return a source by the specified counter.+samplingCounterResultSource :: (ResultItemable (ResultValue a),+                                ResultItemable (ResultValue (SamplingStats a)))+                               => ResultValue (SamplingCounter a)+                               -- ^ the counter+                               -> ResultSource+samplingCounterResultSource x =+  ResultObjectSource $+  ResultObject {+    resultObjectName      = resultValueName x,+    resultObjectId        = resultValueId x,+    resultObjectTypeId    = SamplingCounterId,+    resultObjectSignal    = resultValueSignal x,+    resultObjectSummary   = samplingCounterResultSummary x,+    resultObjectProperties = [+      resultContainerMapProperty c "value" SamplingCounterValueId samplingCounterValue,+      resultContainerMapProperty c "stats" SamplingCounterStatsId samplingCounterStats ] }+  where+    c = resultValueToContainer x+      +-- | Return a source by the specified counter.+samplingCounterResultSummary :: (ResultItemable (ResultValue a),+                                 ResultItemable (ResultValue (SamplingStats a)))+                                => ResultValue (SamplingCounter a)+                                -- ^ the counter+                                -> ResultSource+samplingCounterResultSummary x =+  ResultObjectSource $+  ResultObject {+    resultObjectName      = resultValueName x,+    resultObjectId        = resultValueId x,+    resultObjectTypeId    = SamplingCounterId,+    resultObjectSignal    = resultValueSignal x,+    resultObjectSummary   = samplingCounterResultSummary x,+    resultObjectProperties = [+      resultContainerMapProperty c "value" SamplingCounterValueId samplingCounterValue,+      resultContainerMapProperty c "stats" SamplingCounterStatsId samplingCounterStats ] }+  where+    c = resultValueToContainer x+      +-- | Return a source by the specified counter.+timingCounterResultSource :: (ResultItemable (ResultValue a),+                              ResultItemable (ResultValue (TimingStats a)))+                             => ResultValue (TimingCounter a)+                             -- ^ the counter+                             -> ResultSource+timingCounterResultSource x =+  ResultObjectSource $+  ResultObject {+    resultObjectName      = resultValueName x,+    resultObjectId        = resultValueId x,+    resultObjectTypeId    = TimingCounterId,+    resultObjectSignal    = resultValueSignal x,+    resultObjectSummary   = timingCounterResultSummary x,+    resultObjectProperties = [+      resultContainerMapProperty c "value" TimingCounterValueId timingCounterValue,+      resultContainerMapProperty c "stats" TimingCounterStatsId timingCounterStats ] }+  where+    c = resultValueToContainer x+      +-- | Return a source by the specified counter.+timingCounterResultSummary :: (ResultItemable (ResultValue a),+                               ResultItemable (ResultValue (TimingStats a)))+                              => ResultValue (TimingCounter a)+                              -- ^ the counter+                              -> ResultSource+timingCounterResultSummary x =+  ResultObjectSource $+  ResultObject {+    resultObjectName      = resultValueName x,+    resultObjectId        = resultValueId x,+    resultObjectTypeId    = TimingCounterId,+    resultObjectSignal    = resultValueSignal x,+    resultObjectSummary   = timingCounterResultSummary x,+    resultObjectProperties = [+      resultContainerMapProperty c "value" TimingCounterValueId timingCounterValue,+      resultContainerMapProperty c "stats" TimingCounterStatsId timingCounterStats ] }+  where+    c = resultValueToContainer x    -- | Return a source by the specified finite queue. queueResultSource :: (Show si, Show sm, Show so,@@ -1699,7 +1779,7 @@       resultContainerProperty c "utilisationTime" ActivityUtilisationTimeId activityUtilisationTime activityUtilisationTimeChanged_,       resultContainerProperty c "idleTime" ActivityIdleTimeId activityIdleTime activityIdleTimeChanged_,       resultContainerProperty c "utilisationFactor" ActivityUtilisationFactorId activityUtilisationFactor activityUtilisationFactorChanged_,-      resultContainerProperty c "idleFactor" ActivityIdleTimeId activityIdleFactor activityIdleFactorChanged_ ] }+      resultContainerProperty c "idleFactor" ActivityIdleFactorId activityIdleFactor activityIdleFactorChanged_ ] }  -- | Return a summary by the specified activity. activityResultSummary :: ResultContainer (Activity s a b)@@ -1717,7 +1797,7 @@       resultContainerProperty c "utilisationTime" ActivityUtilisationTimeId activityUtilisationTime activityUtilisationTimeChanged_,       resultContainerProperty c "idleTime" ActivityIdleTimeId activityIdleTime activityIdleTimeChanged_,       resultContainerProperty c "utilisationFactor" ActivityUtilisationFactorId activityUtilisationFactor activityUtilisationFactorChanged_,-      resultContainerProperty c "idleFactor" ActivityIdleTimeId activityIdleFactor activityIdleFactorChanged_ ] }+      resultContainerProperty c "idleFactor" ActivityIdleFactorId activityIdleFactor activityIdleFactorChanged_ ] }  -- | Return an arbitrary text as a separator source. textResultSource :: String -> ResultSource@@ -1753,6 +1833,16 @@   resultSource' name i m =     ResultItemSource $ ResultItem $ computeResultValue name i m +instance ResultComputing m => ResultProvider (m (SamplingCounter Double)) where++  resultSource' name i m =+    samplingCounterResultSource $ computeResultValue name i m++instance ResultComputing m => ResultProvider (m (TimingCounter Double)) where++  resultSource' name i m =+    timingCounterResultSource $ computeResultValue name i m+ instance ResultComputing m => ResultProvider (m Int) where    resultSource' name i m =@@ -1772,6 +1862,16 @@    resultSource' name i m =     ResultItemSource $ ResultItem $ computeResultValue name i m++instance ResultComputing m => ResultProvider (m (SamplingCounter Int)) where++  resultSource' name i m =+    samplingCounterResultSource $ computeResultValue name i m++instance ResultComputing m => ResultProvider (m (TimingCounter Int)) where++  resultSource' name i m =+    timingCounterResultSource $ computeResultValue name i m  instance ResultComputing m => ResultProvider (m String) where 

@@ -69,6 +69,12 @@                 -- ^ Property 'samplingStatsVariance'.               | SamplingStatsDeviationId                 -- ^ Property 'samplingStatsDeviation'.+              | SamplingCounterId+                -- ^ A 'SamplingCounter' value.+              | SamplingCounterValueId+                -- ^ Property 'samplingCounterValue'.+              | SamplingCounterStatsId+                -- ^ Property 'samplingCounterStats'.               | TimingStatsId                 -- ^ A 'TimingStats' value.               | TimingStatsCountId@@ -95,6 +101,12 @@                 -- ^ Property 'timingStatsSum'.               | TimingStatsSum2Id                 -- ^ Property 'timingStatsSum2'.+              | TimingCounterId+                -- ^ A 'TimingCounter' value.+              | TimingCounterValueId+                -- ^ Property 'timingCounterValue'.+              | TimingCounterStatsId+                -- ^ Property 'timingCounterStats'.               | FiniteQueueId                 -- ^ A finite 'Q.Queue'.               | InfiniteQueueId@@ -231,6 +243,12 @@ russianResultLocalisation TimingStatsLastTimeId = "конечное время сбора статистики" russianResultLocalisation TimingStatsSumId = "сумма" russianResultLocalisation TimingStatsSum2Id = "сумма квадратов"+russianResultLocalisation SamplingCounterId = "счетчик"+russianResultLocalisation SamplingCounterValueId = "текущее значение"+russianResultLocalisation SamplingCounterStatsId = "статистика"+russianResultLocalisation TimingCounterId = "временной счетчик"+russianResultLocalisation TimingCounterValueId = "текущее значение"+russianResultLocalisation TimingCounterStatsId = "статистика" russianResultLocalisation FiniteQueueId = "конечная очередь" russianResultLocalisation InfiniteQueueId = "бесконечная очередь" russianResultLocalisation EnqueueStrategyId = "стратегия добавления элементов"@@ -309,6 +327,12 @@ englishResultLocalisation TimingStatsLastTimeId = "the last time" englishResultLocalisation TimingStatsSumId = "sum" englishResultLocalisation TimingStatsSum2Id = "sum square"+englishResultLocalisation SamplingCounterId = "counter"+englishResultLocalisation SamplingCounterValueId = "current value"+englishResultLocalisation SamplingCounterStatsId = "statistics"+englishResultLocalisation TimingCounterId = "timing counter"+englishResultLocalisation TimingCounterValueId = "current value"+englishResultLocalisation TimingCounterStatsId = "statistics" englishResultLocalisation FiniteQueueId = "the finite queue" englishResultLocalisation InfiniteQueueId = "the infinite queue" englishResultLocalisation EnqueueStrategyId = "the enqueueing strategy"

@@ -11,8 +11,11 @@ module Simulation.Aivika.Server        (-- * Server         Server,+        ServerInterruption(..),         newServer,         newStateServer,+        newInterruptibleServer,+        newInterruptibleStateServer,         -- * Processing         serverProcessor,         -- * Server Properties and Activities@@ -52,6 +55,7 @@         serverOutputWaitFactorChanged_,         -- * Basic Signals         serverInputReceived,+        serverTaskInterrupted,         serverTaskProcessed,         serverOutputProvided,         -- * Overall Signal@@ -60,6 +64,7 @@ import Data.IORef import Data.Monoid +import Control.Monad import Control.Monad.Trans import Control.Arrow @@ -82,6 +87,8 @@            -- ^ The current state of the server.            serverProcess :: s -> a -> Process (s, b),            -- ^ Provide @b@ by specified @a@.+           serverProcessInterruptible :: Bool,+           -- ^ Whether the process is interruptible.            serverTotalInputWaitTimeRef :: IORef Double,            -- ^ The counted total time spent in awating the input.            serverTotalProcessingTimeRef :: IORef Double,@@ -96,6 +103,8 @@            -- ^ The statistics for the time spent for delivering the output.            serverInputReceivedSource :: SignalSource a,            -- ^ A signal raised when the server recieves a new input to process.+           serverTaskInterruptedSource :: SignalSource (ServerInterruption a),+           -- ^ A signal raised when the task was interrupted.            serverTaskProcessedSource :: SignalSource (a, b),            -- ^ A signal raised when the input is processed and            -- the output is prepared for deliverying.@@ -103,24 +112,62 @@            -- ^ A signal raised when the server has supplied the output.          } +-- | Contains data about the interrupted task.+data ServerInterruption a =+  ServerInterruption { serverInterruptedInput :: a,+                       -- ^ The input task that was interrupted.+                       serverStartProcessingTime :: Double,+                       -- ^ The start time of processing the task.+                       serverInterruptionTime :: Double+                       -- ^ The time of interrupting the task.+                     }+ -- | Create a new server that can provide output @b@ by input @a@.+--+-- By default, it is assumed that the server cannot be interrupted,+-- because the handling of possible task interruption is rather costly+-- operation. newServer :: (a -> Process b)              -- ^ provide an output by the specified input              -> Simulation (Server () a b)-newServer provide =-  flip newStateServer () $ \s a ->-  do b <- provide a-     return (s, b)+newServer = newInterruptibleServer False  -- | Create a new server that can provide output @b@ by input @a@ -- starting from state @s@.+--+-- By default, it is assumed that the server cannot be interrupted,+-- because the handling of possible task interruption is rather costly+-- operation. newStateServer :: (s -> a -> Process (s, b))                   -- ^ provide a new state and output by the specified                    -- old state and input                   -> s                   -- ^ the initial state                   -> Simulation (Server s a b)-newStateServer provide state =+newStateServer = newInterruptibleStateServer False++-- | Create a new interruptible server that can provide output @b@ by input @a@.+newInterruptibleServer :: Bool+                          -- ^ whether the server can be interrupted+                          -> (a -> Process b)+                          -- ^ provide an output by the specified input+                          -> Simulation (Server () a b)+newInterruptibleServer interruptible provide =+  flip (newInterruptibleStateServer interruptible) () $ \s a ->+  do b <- provide a+     return (s, b)++-- | Create a new interruptible server that can provide output @b@ by input @a@+-- starting from state @s@.+newInterruptibleStateServer :: Bool+                               -- ^ whether the server can be interrupted+                               -> (s -> a -> Process (s, b))+                               -- ^ provide a new state and output by the specified +                               -- old state and input+                               -> s+                               -- ^ the initial state+                               -> Simulation (Server s a b)+newInterruptibleStateServer interruptible provide state =   do r0 <- liftIO $ newIORef state      r1 <- liftIO $ newIORef 0      r2 <- liftIO $ newIORef 0@@ -131,9 +178,11 @@      s1 <- newSignalSource      s2 <- newSignalSource      s3 <- newSignalSource+     s4 <- newSignalSource      let server = Server { serverInitState = state,                            serverStateRef = r0,                            serverProcess = provide,+                           serverProcessInterruptible = interruptible,                            serverTotalInputWaitTimeRef = r1,                            serverTotalProcessingTimeRef = r2,                            serverTotalOutputWaitTimeRef = r3,@@ -141,8 +190,9 @@                            serverProcessingTimeRef = r5,                            serverOutputWaitTimeRef = r6,                            serverInputReceivedSource = s1,-                           serverTaskProcessedSource = s2,-                           serverOutputProvidedSource = s3 }+                           serverTaskInterruptedSource = s2,+                           serverTaskProcessedSource = s3,+                           serverOutputProvidedSource = s4 }      return server  -- | Return a processor for the specified server.@@ -192,7 +242,10 @@                      addSamplingStats (t1 - t0)               triggerSignal (serverInputReceivedSource server) a          -- provide the service-         (s', b) <- serverProcess server s a+         (s', b) <-+           if serverProcessInterruptible server+           then serverProcessInterrupting server s a+           else serverProcess server s a          t2 <- liftDynamics time          liftEvent $            do liftIO $@@ -203,6 +256,24 @@               triggerSignal (serverTaskProcessedSource server) (a, b)          return (b, loop s' (Just (t2, a, b)) xs') +-- | Process the input with ability to handle a possible interruption.+serverProcessInterrupting :: Server s a b -> s -> a -> Process (s, b)+serverProcessInterrupting server s a =+  do pid <- processId+     t1  <- liftDynamics time+     finallyProcess+       (serverProcess server s a)+       (liftEvent $+        do cancelled <- processCancelled pid+           when cancelled $+             do t2 <- liftDynamics time+                liftIO $+                  do modifyIORef' (serverTotalProcessingTimeRef server) (+ (t2 - t1))+                     modifyIORef' (serverProcessingTimeRef server) $+                       addSamplingStats (t2 - t1)+                let x = ServerInterruption a t1 t2+                triggerSignal (serverTaskInterruptedSource server) x)+ -- | Return the current state of the server. -- -- See also 'serverStateChanged' and 'serverStateChanged_'.@@ -445,6 +516,10 @@ serverInputReceived :: Server s a b -> Signal a serverInputReceived = publishSignal . serverInputReceivedSource +-- | Raised when the task processing by the server was interrupted.+serverTaskInterrupted :: Server s a b -> Signal (ServerInterruption a)+serverTaskInterrupted = publishSignal . serverTaskInterruptedSource+ -- | Raised when the server has just processed the task. serverTaskProcessed :: Server s a b -> Signal (a, b) serverTaskProcessed = publishSignal . serverTaskProcessedSource@@ -457,6 +532,7 @@ serverChanged_ :: Server s a b -> Signal () serverChanged_ server =   mapSignal (const ()) (serverInputReceived server) <>+  mapSignal (const ()) (serverTaskInterrupted server) <>   mapSignal (const ()) (serverTaskProcessed server) <>   mapSignal (const ()) (serverOutputProvided server) 

@@ -48,6 +48,8 @@         Signalable(..),         signalableChanged,         emptySignalable,-        appendSignalable) where+        appendSignalable,+        -- * Debugging+        traceSignal) where  import Simulation.Aivika.Internal.Signal

@@ -20,6 +20,9 @@         finallySimulation,         throwSimulation,         -- * Memoization-        memoSimulation) where+        memoSimulation,+        -- * Exceptions+        SimulationException(..),+        SimulationAbort(..)) where  import Simulation.Aivika.Internal.Simulation

@@ -27,7 +27,21 @@         timingStatsDeviation,         timingStatsSummary,         returnTimingStats,-        fromIntTimingStats) where +        fromIntTimingStats,+        -- * Simple Counter+        SamplingCounter(..),+        emptySamplingCounter,+        incSamplingCounter,+        decSamplingCounter,+        resetSamplingCounter,+        returnSamplingCounter,+        -- * Timing Counter+        TimingCounter(..),+        emptyTimingCounter,+        incTimingCounter,+        decTimingCounter,+        resetTimingCounter,+        returnTimingCounter) where  import Data.Monoid @@ -60,7 +74,7 @@   deriving (Eq, Ord)             -- | Specifies data type from which values we can gather the statistics.           -class SamplingData a where           +class Num a => SamplingData a where                 -- | An empty statistics that has no samples.              emptySamplingStats :: SamplingStats a@@ -230,6 +244,8 @@                 -- ^ Return the minimum value.                 timingStatsMax       :: !a,                 -- ^ Return the maximum value.+                timingStatsLast      :: !a,+                -- ^ Return the last value.                 timingStatsMinTime   :: !Double,                 -- ^ Return the time at which the minimum is attained.                 timingStatsMaxTime   :: !Double,@@ -245,7 +261,7 @@                 } deriving (Eq, Ord)                             -- | Defines the data type from which values we can gather the timing statistics.-class TimingData a where                           +class Num a => TimingData a where                                 -- | An empty statistics that has no samples.   emptyTimingStats :: TimingStats a@@ -265,6 +281,7 @@     TimingStats { timingStatsCount     = 0,                   timingStatsMin       = 1 / 0,                   timingStatsMax       = (-1) / 0,+                  timingStatsLast      = 0 / 0,                   timingStatsMinTime   = 1 / 0,                   timingStatsMaxTime   = (-1) / 0,                   timingStatsStartTime = 1 / 0,@@ -282,6 +299,7 @@     TimingStats { timingStatsCount     = 0,                   timingStatsMin       = maxBound,                   timingStatsMax       = minBound,+                  timingStatsLast      = 0,                   timingStatsMinTime   = 1 / 0,                   timingStatsMaxTime   = (-1) / 0,                   timingStatsStartTime = 1 / 0,@@ -300,6 +318,7 @@   | count == 1 = TimingStats { timingStatsCount     = 1,                                timingStatsMin       = a,                                timingStatsMax       = a,+                               timingStatsLast      = a,                                timingStatsMinTime   = t,                                timingStatsMaxTime   = t,                                timingStatsStartTime = t,@@ -309,6 +328,7 @@   | otherwise  = TimingStats { timingStatsCount     = count,                                timingStatsMin       = minX,                                timingStatsMax       = maxX,+                               timingStatsLast      = a,                                timingStatsMinTime   = minT,                                timingStatsMaxTime   = maxT,                                timingStatsStartTime = t0,@@ -326,11 +346,13 @@                | otherwise = timingStatsMaxTime stats           t0 = timingStatsStartTime stats           t' = timingStatsLastTime stats+          a' = timingStatsLast stats           x  = convertToDouble a+          x' = convertToDouble a'           sumX'  = timingStatsSum stats-          sumX   = sumX' + (t - t') * x+          sumX   = sumX' + (t - t') * x'           sumX2' = timingStatsSum2 stats-          sumX2  = sumX2' + (t - t') * x * x+          sumX2  = sumX2' + (t - t') * x' * x'        timingStatsMeanGeneric :: ConvertableToDouble a => TimingStats a -> Double timingStatsMeanGeneric stats@@ -370,8 +392,9 @@ -- | Convert the statistics from integer to double values. fromIntTimingStats :: TimingStats Int -> TimingStats Double fromIntTimingStats stats =-  stats { timingStatsMin = fromIntegral $ timingStatsMin stats,-          timingStatsMax = fromIntegral $ timingStatsMax stats }+  stats { timingStatsMin  = fromIntegral $ timingStatsMin stats,+          timingStatsMax  = fromIntegral $ timingStatsMax stats,+          timingStatsLast = fromIntegral $ timingStatsLast stats }  -- | Show the summary of the statistics.        showTimingStats :: (Show a, TimingData a) => TimingStats a -> ShowS@@ -415,3 +438,83 @@      showString "t in [" . shows (timingStatsStartTime stats) .      showString ", " . shows (timingStatsLastTime stats) .      showString "]"++-- | A counter for which the statistics is collected too.+data SamplingCounter a =+  SamplingCounter { samplingCounterValue :: a,+                    -- ^ The counter value.+                    samplingCounterStats :: SamplingStats a+                    -- ^ The counter statistics.+                  } deriving (Eq, Ord, Show)++-- | An empty counter.+emptySamplingCounter :: SamplingData a => SamplingCounter a+emptySamplingCounter =+  SamplingCounter { samplingCounterValue = 0,+                    samplingCounterStats = emptySamplingStats }++-- | Increase the counter.+incSamplingCounter :: SamplingData a => a -> SamplingCounter a -> SamplingCounter a+incSamplingCounter a counter =+  SamplingCounter { samplingCounterValue = a',+                    samplingCounterStats = addSamplingStats a' (samplingCounterStats counter) }+  where a' = samplingCounterValue counter + a++-- | Decrease the counter.+decSamplingCounter :: SamplingData a => a -> SamplingCounter a -> SamplingCounter a+decSamplingCounter a counter =+  SamplingCounter { samplingCounterValue = a',+                    samplingCounterStats = addSamplingStats a' (samplingCounterStats counter) }+  where a' = samplingCounterValue counter - a++-- | Reset the counter.+resetSamplingCounter :: SamplingData a => SamplingCounter a -> SamplingCounter a+resetSamplingCounter counter =+  SamplingCounter { samplingCounterValue = 0,+                    samplingCounterStats = addSamplingStats 0 (samplingCounterStats counter) }++-- | Create a counter with the specified initial value.+returnSamplingCounter :: SamplingData  a => a -> SamplingCounter a+returnSamplingCounter a =+  SamplingCounter { samplingCounterValue = a,+                    samplingCounterStats = returnSamplingStats a }++-- | A counter for which the timing statistics is collected too.+data TimingCounter a =+  TimingCounter { timingCounterValue :: a,+                  -- ^ The counter value.+                  timingCounterStats :: TimingStats a+                  -- ^ The counter statistics.+                } deriving (Eq, Ord, Show)++-- | An empty counter.+emptyTimingCounter :: TimingData a => TimingCounter a+emptyTimingCounter =+  TimingCounter { timingCounterValue = 0,+                  timingCounterStats = emptyTimingStats }++-- | Increase the counter at the specified time.+incTimingCounter :: TimingData a => Double -> a -> TimingCounter a -> TimingCounter a+incTimingCounter t a counter =+  TimingCounter { timingCounterValue = a',+                  timingCounterStats = addTimingStats t a' (timingCounterStats counter) }+  where a' = timingCounterValue counter + a++-- | Decrease the counter at the specified time.+decTimingCounter :: TimingData a => Double -> a -> TimingCounter a -> TimingCounter a+decTimingCounter t a counter =+  TimingCounter { timingCounterValue = a',+                  timingCounterStats = addTimingStats t a' (timingCounterStats counter) }+  where a' = timingCounterValue counter - a++-- | Reset the counter at the specified time.+resetTimingCounter :: TimingData a => Double -> TimingCounter a -> TimingCounter a+resetTimingCounter t counter =+  TimingCounter { timingCounterValue = 0,+                  timingCounterStats = addTimingStats t 0 (timingCounterStats counter) }++-- | Create a timing counter with the specified initial value at the given time.+returnTimingCounter :: TimingData a => Double -> a -> TimingCounter a+returnTimingCounter t a =+  TimingCounter { timingCounterValue = a,+                  timingCounterStats = returnTimingStats t a }

@@ -58,7 +58,9 @@         rightStream,         replaceLeftStream,         replaceRightStream,-        partitionEitherStream) where+        partitionEitherStream,+        -- * Debugging+        traceStream) where  import Data.IORef import Data.Maybe@@ -532,3 +534,24 @@ -- | Delay the stream by one step using the specified initial value. delayStream :: a -> Stream a -> Stream a delayStream a0 s = Cons $ return (a0, s)++-- | Show the debug messages with the current simulation time.+traceStream :: Maybe String+               -- ^ the request message+               -> Maybe String+               -- ^ the response message+               -> Stream a+               -- ^ a stream+               -> Stream a+traceStream request response s = Cons $ loop s where+  loop s = do (a, xs) <-+                case request of+                  Nothing -> runStream s+                  Just message ->+                    traceProcess message $+                    runStream s+              case response of+                Nothing -> return (a, Cons $ loop xs)+                Just message ->+                  traceProcess message $+                  return (a, Cons $ loop xs)

@@ -1,5 +1,5 @@ name:            aivika-version:         2.1+version:         3.0 synopsis:        A multi-paradigm simulation library description:     Aivika is a multi-paradigm simulation library with a strong emphasis@@ -90,6 +90,7 @@ tested-with:     GHC == 7.8.3  extra-source-files:  examples/BassDiffusion.hs+                     examples/BouncingBall.hs                      examples/ChemicalReaction.hs                      examples/ChemicalReactionCircuit.hs                      examples/FishBank.hs@@ -98,10 +99,12 @@                      examples/MachRep1TimeDriven.hs                      examples/MachRep2.hs                      examples/MachRep3.hs+                     examples/MachineBreakdowns.hs                      examples/Furnace.hs                      examples/InspectionAdjustmentStations.hs+                     examples/InventorySystem.hs                      examples/WorkStationsInSeries.hs-		     examples/QuarryOperations.hs+                     examples/QuarryOperations.hs                      examples/TimeOut.hs                      examples/TimeOutInt.hs                      examples/TimeOutWait.hs@@ -193,6 +196,7 @@                         FunctionalDependencies,                         ExistentialQuantification,                         TypeFamilies,+                        DeriveDataTypeable,                         CPP                           ghc-options:     -O2

@@ -0,0 +1,60 @@++{-# LANGUAGE RecursiveDo #-}++-- Example: Simulation of a Bouncing Ball.+--+-- It is described in MATLAB & Simulink example available by the following link:+--+-- http://www.mathworks.com/help/simulink/examples/simulation-of-a-bouncing-ball.html++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika+import Simulation.Aivika.SystemDynamics++-- | The simulation specs.+specs = Specs { spcStartTime = 0.0,+                spcStopTime = 25.0,+                spcDT = 0.01,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }++-- the acceleration due to gravity+g = 9.81++-- the initial velocity+v0 = 15++-- the initial position+x0 = 10++-- the coefficient of restitution of the ball+k = 0.8++model :: Simulation Results+model = mdo+  v <- integEither dv v0+  x <- integEither dx x0+  let dv = do+        x' <- x+        v' <- v+        if x' < 0+          then return $ Left (- k * v')+          else return $ Right (- g)+      dx = do+        x' <- x+        v' <- v+        if x' < 0+          then return $ Left 0+          else return $ Right v'+  return $+    results+    [resultSource "t" "time" time,+     resultSource "x" "position" x,+     resultSource "v" "velocity" v]++main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs

@@ -0,0 +1,168 @@++-- Example: Inventory System with Lost Sales and Backorders +--+-- It is described in different sources [1, 2]. So, this is chapter 11 of [2] and section 6.7 of [1].+--+-- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed.+--+-- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006++import Control.Monad+import Control.Monad.Trans+import Control.Category++import Data.Monoid++import Simulation.Aivika+import qualified Simulation.Aivika.Queue.Infinite as IQ++-- | The simulation specs.+specs = Specs { spcStartTime = 0.0,+                spcStopTime = 312.0,+                spcDT = 0.1,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }++-- | The time between demands for a radio.+avgRadioDemand = 0.2++-- | The percent of customers who will backorder the radio.+backorderPercent = 0.2++-- | The stock control level to be ordered up.+stockControlLevel = 72++-- | The inventory position for reordering radio.+inventoryPositionThreshold = 18++-- | The initial stock of radios.+radioStock0 = 72 :: Int++-- | The time from the placement of an order to its receipt+procurementLeadTime = 3++-- | How often to order the radios?+procurementPeriod = 4++-- | Clear the statistics at the end of the first year+clearingTime = 52+  +model :: Simulation Results+model = do+  -- the start time+  t0 <- liftParameter starttime+  -- the radios in stock+  radioStock <- newRef $ returnTimingCounter t0 radioStock0+  -- the number of orders+  orderCount <- newRef emptyTimingCounter+  -- the queue of backorders+  backorderQueue <- runEventInStartTime $ IQ.newFCFSQueue+  -- the total number of customers+  totalCustomerCount <- newRef (0 :: Int)+  -- the total order count+  totalOrderCount <- newRef (0 :: Int)+  -- the total number of backorders+  totalBackorderCount <- newRef (0 :: Int)+  -- the number of immediate sales+  immedSalesCount <- newRef (0 :: Int)+  -- the lost sales count+  lostSalesCount <- newRef (0 :: Int)+  -- whether the procurement initiated?+  procuring <- newRef False+  -- the inventotyPosition+  let inventoryPosition = do+        x1 <- readRef radioStock+        x2 <- readRef orderCount+        x3 <- IQ.queueCount backorderQueue+        return (timingCounterValue x1 ++                timingCounterValue x2 -+                x3)+  -- implement the ordering policy of the company+  runEventInStartTime $+    enqueueEventWithTimes [t0, t0 + procurementPeriod..] $+    do c <- readRef orderCount+       when (timingCounterValue c == 0) $+         do x <- inventoryPosition+            when (x < inventoryPositionThreshold) $+              do let order = stockControlLevel - x+                 t0 <- liftDynamics time+                 modifyRef orderCount $ incTimingCounter t0 order+                 modifyRef totalOrderCount (+ order)+                 enqueueEvent (t0 + procurementLeadTime) $+                   do t <- liftDynamics time+                      modifyRef radioStock $ incTimingCounter t order+                      modifyRef orderCount $ resetTimingCounter t+                      y1 <- readRef radioStock+                      y2 <- IQ.queueCount backorderQueue+                      let dy = min (timingCounterValue y1) y2+                      modifyRef radioStock $ decTimingCounter t dy+                      forM_ [1..dy] $ \i ->+                        do IQ.tryDequeue backorderQueue+                           return ()+  -- a stream of customers+  let customers = randomExponentialStream avgRadioDemand+  -- model their behavior+  runProcessInStartTime $+    flip consumeStream customers $ \a ->+    liftEvent $+    do modifyRef totalCustomerCount (+ 1)+       t <- liftDynamics time+       x <- readRef radioStock+       if timingCounterValue x > 0+         then do modifyRef radioStock $ decTimingCounter t 1+                 modifyRef immedSalesCount (+ 1)+         else do b <- liftParameter $+                      randomTrue backorderPercent+                 if b+                   then do modifyRef totalBackorderCount (+ 1)+                           IQ.enqueue backorderQueue a+                   else modifyRef lostSalesCount (+ 1)+  -- clear the statistics at the end of the first year (??)+  runEventInStartTime $+    enqueueEvent clearingTime $+    do modifyRef radioStock $ \x -> x { timingCounterStats = emptyTimingStats }+       modifyRef orderCount $ \x -> x { timingCounterStats = emptyTimingStats }+       -- N.B. there is not yet clearing of the backorderQueue statistics+  -- return the simulation results in start time+  return $+    results+    [resultSource+     "radioStock" "the radios in stock"+     radioStock,+     --+     resultSource+     "inventoryPosition" "inventory position"+     inventoryPosition,+     --+     resultSource+     "orderCount" "the number of orders"+     orderCount,+     --+     resultSource+     "backorderQueue" "the queue of backorders"+     backorderQueue,+     --+     resultSource+     "totalCustomerCount" "the total number of customers"+     totalCustomerCount,+     --+     resultSource+     "totalOrderCount" "the total order count"+     totalOrderCount,+     --+     resultSource+     "totalBackorderCount" "the total number of backorders"+     totalBackorderCount,+     --+     resultSource+     "lostSalesCount" "the lost sales count"+     lostSalesCount,+     --+     resultSource+     "immedSalesCount" "the number of immediate sales"+     immedSalesCount]++main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  (fmap resultSummary model) specs

@@ -0,0 +1,170 @@++-- Example: Machine Tool with Breakdowns +--+-- It is described in different sources [1, 2]. So, this is chapter 13 of [2] and section 6.12 of [1].+--+-- [1] A. Alan B. Pritsker, Simulation with Visual SLAM and AweSim, 2nd ed.+--+-- [2] Труб И.И., Объектно-ориентированное моделирование на C++: Учебный курс. - СПб.: Питер, 2006++import Control.Monad+import Control.Monad.Trans+import Control.Category++import Data.Monoid++import Simulation.Aivika+import qualified Simulation.Aivika.Queue.Infinite as IQ++-- | The simulation specs.+specs = Specs { spcStartTime = 0.0,+                spcStopTime = 500.0,+                spcDT = 0.1,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }++-- | How often do jobs arrive to a machine tool (exponential)?+jobArrivingMu = 1++-- | A mean of time to process a job (normal). +jobProcessingMu = 0.5++-- | The standard deviation of time to process a job (normal).+jobProcessingSigma = 0.1++-- | The minimum set-up time (uniform).+minSetUpTime = 0.2++-- | The maximum set-up time (uniform).+maxSetUpTime = 0.5++-- | A mean of time between breakdowns (normal).+breakdownMu = 20++-- | The standard deviation of time between breakdowns (normal).+breakdownSigma = 2++-- | A mean of each of the three repair phases (Erlang).+repairMu = 3/4++-- | It defines a job.+data Job = Job { jobProcessingTime :: Double,+                 -- ^ the job processing time defined when arriving.+                 jobRemainingTime :: Double+                 -- ^ the remaining processing time (may differ after return).+               }++model :: Simulation Results+model = do+  -- create an input queue+  inputQueue <- runEventInStartTime $ IQ.newFCFSQueue+  -- a counter of jobs completed+  jobsCompleted <- newArrivalTimer+  -- 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 ->+    do -- set up the machine+       setUpTime <-+         liftParameter $+         randomUniform minSetUpTime maxSetUpTime+       holdProcess setUpTime+       return a+  -- create the processing phase itself+  machineProcessing <-+    newInterruptibleServer True $ \a ->+    do -- process the job+       let job = arrivalValue a+       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+  -- start the machine tool+  runProcessInStartTime launch+  -- model a stream of jobs+  let jobs =+        traceStream Nothing (Just "a new job") $+        randomExponentialStream jobArrivingMu+  -- start the processing of jobs by enqueueing them+  runProcessInStartTime $+    flip consumeStream jobs $ \a ->+    liftEvent $ do+      -- define the processing time for the job+      jobProcessingTime <-+        liftParameter $+        randomNormal jobProcessingMu jobProcessingSigma+      -- enqueue the job+      IQ.enqueue inputQueue $+        a { arrivalValue =+               Job jobProcessingTime jobProcessingTime }+  -- return the simulation results in start time+  return $+    results+    [resultSource+     "inputQueue" "the queue of jobs"+     inputQueue,+     --+     resultSource+     "machineSettingUp" "the machine tool (the setting up phase)"+     machineSettingUp,+     --+     resultSource+     "machineProcessing" "the machine tool (the processing phase)"+     machineProcessing,+     --+     resultSource+     "jobsCompleted" "a counter of the completed jobs"+     jobsCompleted]++main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  (fmap resultSummary model) specs