packages feed

aivika-gpss (empty) → 0.3

raw patch · 94 files changed

+10071/−0 lines, 94 filesdep +aivikadep +aivika-transformersdep +basesetup-changed

Dependencies added: aivika, aivika-transformers, base, containers, hashable, mtl, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017 David Sorokin <david.sorokin@gmail.com>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ Simulation/Aivika/GPSS.hs view
@@ -0,0 +1,76 @@++-- |+-- Module     : Simulation.Aivika.GPSS+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module re-exports the library functionality related to the GPSS-like domain specific language.+--+module Simulation.Aivika.GPSS+       (-- * Modules+        module Simulation.Aivika.GPSS.Block,+        module Simulation.Aivika.GPSS.Block.Advance,+        module Simulation.Aivika.GPSS.Block.Assemble,+        module Simulation.Aivika.GPSS.Block.Assign,+        module Simulation.Aivika.GPSS.Block.Depart,+        module Simulation.Aivika.GPSS.Block.Enter,+        module Simulation.Aivika.GPSS.Block.Gather,+        module Simulation.Aivika.GPSS.Block.Generate,+        module Simulation.Aivika.GPSS.Block.Leave,+        module Simulation.Aivika.GPSS.Block.Link,+        module Simulation.Aivika.GPSS.Block.Loop,+        module Simulation.Aivika.GPSS.Block.Match,+        module Simulation.Aivika.GPSS.Block.Preempt,+        module Simulation.Aivika.GPSS.Block.Priority,+        module Simulation.Aivika.GPSS.Block.Queue,+        module Simulation.Aivika.GPSS.Block.Release,+        module Simulation.Aivika.GPSS.Block.Return,+        module Simulation.Aivika.GPSS.Block.Seize,+        module Simulation.Aivika.GPSS.Block.Split,+        module Simulation.Aivika.GPSS.Block.Terminate,+        module Simulation.Aivika.GPSS.Block.Test,+        module Simulation.Aivika.GPSS.Block.Transfer,+        module Simulation.Aivika.GPSS.Block.Unlink,+        module Simulation.Aivika.GPSS.AssemblySet,+        module Simulation.Aivika.GPSS.Facility,+        module Simulation.Aivika.GPSS.MatchChain,+        module Simulation.Aivika.GPSS.Results,+        module Simulation.Aivika.GPSS.Results.Locale,+        module Simulation.Aivika.GPSS.Storage,+        module Simulation.Aivika.GPSS.Transact,+        module Simulation.Aivika.GPSS.TransactQueueStrategy) where++import Simulation.Aivika.GPSS.Block+import Simulation.Aivika.GPSS.Block.Advance+import Simulation.Aivika.GPSS.Block.Assemble+import Simulation.Aivika.GPSS.Block.Assign+import Simulation.Aivika.GPSS.Block.Depart+import Simulation.Aivika.GPSS.Block.Enter+import Simulation.Aivika.GPSS.Block.Gather+import Simulation.Aivika.GPSS.Block.Generate+import Simulation.Aivika.GPSS.Block.Leave+import Simulation.Aivika.GPSS.Block.Link+import Simulation.Aivika.GPSS.Block.Loop+import Simulation.Aivika.GPSS.Block.Match+import Simulation.Aivika.GPSS.Block.Preempt+import Simulation.Aivika.GPSS.Block.Priority+import Simulation.Aivika.GPSS.Block.Queue+import Simulation.Aivika.GPSS.Block.Release+import Simulation.Aivika.GPSS.Block.Return+import Simulation.Aivika.GPSS.Block.Seize+import Simulation.Aivika.GPSS.Block.Split+import Simulation.Aivika.GPSS.Block.Terminate+import Simulation.Aivika.GPSS.Block.Test+import Simulation.Aivika.GPSS.Block.Transfer+import Simulation.Aivika.GPSS.Block.Unlink+import Simulation.Aivika.GPSS.AssemblySet+import Simulation.Aivika.GPSS.Facility+import Simulation.Aivika.GPSS.MatchChain+import Simulation.Aivika.GPSS.Results+import Simulation.Aivika.GPSS.Results.Locale+import Simulation.Aivika.GPSS.Storage+import Simulation.Aivika.GPSS.Transact+import Simulation.Aivika.GPSS.TransactQueueStrategy
+ Simulation/Aivika/GPSS/AssemblySet.hs view
@@ -0,0 +1,165 @@++-- |+-- Module     : Simulation.Aivika.GPSS.AssemblySet+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines a GPSS assembly set.+--+module Simulation.Aivika.GPSS.AssemblySet+       (-- * Types+        AssemblySet,+        -- * Creating Assembly Set+        newAssemblySet,+        -- * Functions+        assembleTransact,+        gatherTransacts,+        -- * Properties+        transactAssembling,+        transactGathering) where++import Data.IORef+import Data.Monoid+import Data.Maybe+import Data.Hashable++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika+import Simulation.Aivika.Internal.Specs+import Simulation.Aivika.Internal.Parameter+import Simulation.Aivika.Internal.Simulation++import Simulation.Aivika.GPSS.Transact+import Simulation.Aivika.GPSS.TransactQueueStrategy++-- | Represents an assembly set.+data AssemblySet =+  AssemblySet { assemblySetSequenceNo :: Int,+                assemblySetAssemblingTransact :: IORef (Maybe ProcessId),+                assemblySetAssemblingCounter :: IORef Int,+                assemblySetGatheringTransacts :: StrategyQueue (TransactQueueStrategy FCFS) ProcessId,+                assemblySetGatheringCounter :: IORef Int+              }++instance Eq AssemblySet where+  x == y = (assemblySetAssemblingTransact x) == (assemblySetAssemblingTransact y)++instance Hashable AssemblySet where+  hashWithSalt salt x = hashWithSalt salt (assemblySetSequenceNo x)++-- | Create a new assembly set.+newAssemblySet :: Simulation AssemblySet+newAssemblySet =+  Simulation $ \r ->+  do let g = runGenerator r+     sequenceNo <- generateSequenceNo g+     assemblingTransact <- newIORef Nothing+     assemblingCounter  <- newIORef 0+     gatheringTransacts <- invokeSimulation r $ newStrategyQueue (TransactQueueStrategy FCFS)+     gatheringCounter   <- newIORef 0+     return AssemblySet { assemblySetSequenceNo         = sequenceNo,+                          assemblySetAssemblingTransact = assemblingTransact,+                          assemblySetAssemblingCounter  = assemblingCounter,+                          assemblySetGatheringTransacts = gatheringTransacts,+                          assemblySetGatheringCounter   = gatheringCounter+                        }++-- | Assemble the transact by the specified number.+assembleTransact :: Transact a -> Int -> Process ()+assembleTransact t n =+  do (s, a) <-+       liftEvent $+       do s <- transactAssemblySet t+          a <- liftIO $ readIORef (assemblySetAssemblingCounter s)+          return (s, a)+     if a == 0+       then do let n' = n - 1+               when (n' < 0) $+                 throwProcess $+                 SimulationRetry+                 "The number of transacts must be positive: assembleTransact"+               if n' == 0+                 then return ()+                 else do liftEvent $+                           do pid <- requireTransactProcessId t+                              liftIO $ writeIORef (assemblySetAssemblingTransact s) (Just pid)+                              liftIO $ writeIORef (assemblySetAssemblingCounter s) $! n'+                         passivateProcess+       else do let a' = a - 1+               if a' == 0+                 then do liftEvent $+                           do Just pid <- liftIO $ readIORef (assemblySetAssemblingTransact s)+                              liftIO $ writeIORef (assemblySetAssemblingTransact s) Nothing+                              liftIO $ writeIORef (assemblySetAssemblingCounter s) $! a'+                              reactivateProcessImmediately pid+                         cancelProcess+                 else do liftIO $ writeIORef (assemblySetAssemblingCounter s) $! a'+                         cancelProcess++-- | Gather the transacts by the specified number.+gatherTransacts :: Transact a -> Int -> Process ()+gatherTransacts t n =+  do (s, a) <-+       liftEvent $+       do s <- transactAssemblySet t+          a <- liftIO $ readIORef (assemblySetGatheringCounter s)+          return (s, a)+     if a == 0+       then do let n' = n - 1+               when (n' < 0) $+                 throwProcess $+                 SimulationRetry+                 "The number of transacts must be positive: gatherTransacts"+               if n' == 0+                 then return ()+                 else do liftEvent $+                           do pid <- requireTransactProcessId t+                              strategyEnqueueWithPriority+                                (assemblySetGatheringTransacts s)+                                (transactPriority t)+                                pid+                              liftIO $ writeIORef (assemblySetGatheringCounter s) $! n'+                         passivateProcess+       else do let a' = a - 1+               liftEvent $+                 do pid <- requireTransactProcessId t+                    strategyEnqueueWithPriority+                      (assemblySetGatheringTransacts s)+                      (transactPriority t)+                      pid+                    liftIO $ writeIORef (assemblySetGatheringCounter s) $! a'+               if a' == 0+                 then passivateProcessBefore $+                      liftEvent $+                      do let loop acc =+                               do f <- strategyQueueNull (assemblySetGatheringTransacts s)+                                  if f+                                    then return (reverse acc)+                                    else do x <- strategyDequeue (assemblySetGatheringTransacts s)+                                            loop (x: acc)+                             act [] = return ()+                             act (pid: pids') =+                               do reactivateProcessImmediately pid+                                  yieldEvent $ act pids'+                         pids <- loop []+                         act pids+                 else passivateProcess++-- | Test whether another transact is assembled for the corresponding assembly set.+transactAssembling :: Transact a -> Event Bool+transactAssembling t =+  do s <- transactAssemblySet t+     a <- liftIO $ readIORef (assemblySetAssemblingCounter s)+     return (a > 0)++-- | Test whether the transacts are gathered for the corresponding assembly set.+transactGathering :: Transact a -> Event Bool+transactGathering t =+  do s <- transactAssemblySet t+     a <- liftIO $ readIORef (assemblySetGatheringCounter s)+     return (a > 0)
+ Simulation/Aivika/GPSS/AssemblySet.hs-boot view
@@ -0,0 +1,18 @@++-- |+-- Module     : Simulation.Aivika.GPSS.AssemblySet+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This is an hs-boot file.+--+module Simulation.Aivika.GPSS.AssemblySet where++import Simulation.Aivika++data AssemblySet++newAssemblySet :: Simulation AssemblySet
+ Simulation/Aivika/GPSS/Block.hs view
@@ -0,0 +1,53 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines a GPSS block.+--+module Simulation.Aivika.GPSS.Block+       (Block(..),+        GeneratorBlock(..),+        withinBlock,+        traceBlock) where++import Control.Monad+import Control.Monad.Trans+import qualified Control.Category as C++import Simulation.Aivika++-- | Represents a GPSS block.+data Block a b =+  Block { blockProcess :: a -> Process b+          -- ^ Process the item.+        }++-- | Represents a GPSS generator block.+newtype GeneratorBlock a =+  GeneratorBlock { runGeneratorBlock :: Block a () -> Process ()+                   -- ^ Run the generator block.+                 }++instance C.Category Block where++  id = Block { blockProcess = return }++  x . y = Block { blockProcess = \a -> do { b <- blockProcess y a; blockProcess x b } }++-- | Perform some action within the block, for example,+-- opening or inverting the 'Gate' to emulate the LOGIC block.+withinBlock :: Process ()+               -- ^ the action to be executed for each transact+               -> Block a a+withinBlock m =+  Block { blockProcess = \a -> m >> return a }++-- | Trace the specified block.+traceBlock :: String -> Block a b -> Block a b+traceBlock message x =+  Block { blockProcess = \a -> traceProcess message (blockProcess x a) }
+ Simulation/Aivika/GPSS/Block/Advance.hs view
@@ -0,0 +1,25 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Advance+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block ADVANCE.+--+module Simulation.Aivika.GPSS.Block.Advance+       (advanceBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Block++-- | This is the GPSS construct+--+-- @ADVANCE A,B@+advanceBlock :: Process ()+                -- ^ the delay+                -> Block a a+advanceBlock p =+  Block { blockProcess = \a -> p >> return a }
+ Simulation/Aivika/GPSS/Block/Assemble.hs view
@@ -0,0 +1,27 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Assemble+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block ASSEMBLE.+--+module Simulation.Aivika.GPSS.Block.Assemble+       (assembleBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Block+import Simulation.Aivika.GPSS.AssemblySet+import Simulation.Aivika.GPSS.Transact++-- | This is the GPSS construct+--+-- @ASSEMBLE A@+assembleBlock :: Int+                 -- ^ the number of transacts to assemble+                 -> Block (Transact a) (Transact a)+assembleBlock n =+  Block { blockProcess = \a -> assembleTransact a n >> return a }
+ Simulation/Aivika/GPSS/Block/Assign.hs view
@@ -0,0 +1,36 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Assign+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block ASSIGN.+--+module Simulation.Aivika.GPSS.Block.Assign+       (assignBlock,+        assignBlockM) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Block+import Simulation.Aivika.GPSS.Transact++-- | This is the GPSS construct+--+-- @ASSIGN A,B,C@+assignBlock :: (a -> b)+               -- ^ the transform+               -> Block (Transact a) (Transact b)+assignBlock f =+  Block { blockProcess = \a -> return (assignTransactValue a f) }++-- | This is the GPSS construct+--+-- @ASSIGN A,B,C@+assignBlockM :: (a -> Process b)+                -- ^ the transform computation+                -> Block (Transact a) (Transact b)+assignBlockM f =+  Block { blockProcess = \a -> assignTransactValueM a f }
+ Simulation/Aivika/GPSS/Block/Depart.hs view
@@ -0,0 +1,29 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Depart+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block DEPART.+--+module Simulation.Aivika.GPSS.Block.Depart+       (departBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Transact+import Simulation.Aivika.GPSS.Block+import qualified Simulation.Aivika.GPSS.Queue as Q++-- | This is the GPSS construct+--+-- @DEPART A,B@+departBlock :: Q.Queue+               -- ^ the queue+               -> Int+               -- ^ the content decrement+               -> Block (Transact a) (Transact a)+departBlock q decrement =+  Block { blockProcess = \a -> (liftEvent $ Q.dequeue q a decrement) >> return a }
+ Simulation/Aivika/GPSS/Block/Enter.hs view
@@ -0,0 +1,29 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Enter+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block ENTER.+--+module Simulation.Aivika.GPSS.Block.Enter+       (enterBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Transact+import Simulation.Aivika.GPSS.Block+import Simulation.Aivika.GPSS.Storage++-- | This is the GPSS construct+--+-- @ENTER A,B@+enterBlock :: Storage+              -- ^ the storage+              -> Int+              -- ^ the content decrement+              -> Block (Transact a) (Transact a)+enterBlock r decrement =+  Block { blockProcess = \a -> enterStorage r a decrement >> return a }
+ Simulation/Aivika/GPSS/Block/Gather.hs view
@@ -0,0 +1,27 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Gather+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block GATHER.+--+module Simulation.Aivika.GPSS.Block.Gather+       (gatherBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Block+import Simulation.Aivika.GPSS.AssemblySet+import Simulation.Aivika.GPSS.Transact++-- | This is the GPSS construct+--+-- @GATHER A@+gatherBlock :: Int+               -- ^ the number of transacts to gather+               -> Block (Transact a) (Transact a)+gatherBlock n =+  Block { blockProcess = \a -> gatherTransacts a n >> return a }
+ Simulation/Aivika/GPSS/Block/Generate.hs view
@@ -0,0 +1,51 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Generate+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block GENERATE.+--+module Simulation.Aivika.GPSS.Block.Generate+       (streamGeneratorBlock0,+        streamGeneratorBlock,+        streamGeneratorBlockM) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Block+import Simulation.Aivika.GPSS.Transact++-- | Return a generator block by the specified stream and priority computation.+streamGeneratorBlockM :: Stream (Arrival a)+                         -- ^ the input stream of data+                         -> Event Int+                         -- ^ the transact priority+                         -> GeneratorBlock (Transact a)+streamGeneratorBlockM s priority =+  let loop s block =+        do (a, xs) <- runStream s+           liftEvent $+             do p <- priority+                t <- liftSimulation $ newTransact a p+                runProcess $+                  do takeTransact t+                     blockProcess block t+           loop xs block+  in GeneratorBlock (loop s)++-- | Return a generator block by the specified stream and priority.+streamGeneratorBlock :: Stream (Arrival a)+                        -- ^ the input stream of data+                        -> Int+                        -- ^ the transact priority+                        -> GeneratorBlock (Transact a)+streamGeneratorBlock s = streamGeneratorBlockM s . return++-- | Return a generator block by the specified stream using zero priority.+streamGeneratorBlock0 :: Stream (Arrival a)+                         -- ^ the input stream of data+                         -> GeneratorBlock (Transact a)+streamGeneratorBlock0 s = streamGeneratorBlock s 0
+ Simulation/Aivika/GPSS/Block/Leave.hs view
@@ -0,0 +1,29 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Leave+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block LEAVE.+--+module Simulation.Aivika.GPSS.Block.Leave+       (leaveBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Transact+import Simulation.Aivika.GPSS.Block+import Simulation.Aivika.GPSS.Storage++-- | This is the GPSS construct+--+-- @LEAVE A,B@+leaveBlock :: Storage+              -- ^ the storage+              -> Int+              -- ^ the content increment+              -> Block (Transact a) (Transact a)+leaveBlock r increment =+  Block { blockProcess = \a -> leaveStorage r increment >> return a }
+ Simulation/Aivika/GPSS/Block/Link.hs view
@@ -0,0 +1,38 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Link+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines an analog of the GPSS block LINK.+--+module Simulation.Aivika.GPSS.Block.Link+       (linkBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Block++-- | This is an analog of the GPSS construct+--+-- @LINK A,B,C@+linkBlock :: (a -> Process (Either (Block a ()) Bool))+             -- ^ try to link the transact and return either the next block to transfer+             -- or a flag indicating whether the transact process should be passivated+             -- in case of successful linking, i.e. storing in the queue+             -> Block a a+linkBlock f =+  Block { blockProcess = \a ->+           do x <- f a+              case x of+                Left transfer ->+                  transferProcess $+                  blockProcess transfer a+                Right False ->+                  return a+                Right True ->+                  do passivateProcess+                     return a+        }
+ Simulation/Aivika/GPSS/Block/Loop.hs view
@@ -0,0 +1,53 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Loop+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block LOOP.+--+module Simulation.Aivika.GPSS.Block.Loop+       (loopBlock,+        loopBlockM) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Block++-- | This is the GPSS construct+--+-- @LOOP A,B@+loopBlock :: (a -> (b, Bool))+             -- ^ by the specified transact return the next version+             -- of the same transact and a condition whether we should+             -- exit the loop+             -> Block b ()+             -- ^ the block to transfer in when the condition fails+             -> Block a b+loopBlock f block =+  Block { blockProcess = \a ->+           do let (b, c) = f a+              if c+                then return b+                else transferProcess (blockProcess block b)+        }++-- | This is the GPSS construct+--+-- @LOOP A,B@+loopBlockM :: (a -> Process (b, Bool))+              -- ^ by the specified transact return the next version+              -- of the same transact and a condition whether we should+              -- exit the loop+              -> Block b ()+              -- ^ the block to transfer in when the condition fails+              -> Block a b+loopBlockM f block =+  Block { blockProcess = \a ->+           do (b, c) <- f a+              if c+                then return b+                else transferProcess (blockProcess block b)+        }
+ Simulation/Aivika/GPSS/Block/Match.hs view
@@ -0,0 +1,27 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Match+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block MATCH.+--+module Simulation.Aivika.GPSS.Block.Match+       (matchBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Block+import Simulation.Aivika.GPSS.MatchChain+import Simulation.Aivika.GPSS.Transact++-- | This is an analog of the GPSS construct+--+-- @MATCH A@+matchBlock :: MatchChain+              -- ^ the corresponding match chain+              -> Block (Transact a) (Transact a)+matchBlock chain =+  Block { blockProcess = \a -> matchTransact chain a >> return a }
+ Simulation/Aivika/GPSS/Block/Preempt.hs view
@@ -0,0 +1,79 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Preempt+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block Preempt.+--+module Simulation.Aivika.GPSS.Block.Preempt+       (preemptBlock,+        PreemptBlockMode(..),+        defaultPreemptBlockMode,+        toFacilityPreemptMode,+        fromFacilityPreemptMode) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Transact+import Simulation.Aivika.GPSS.Block+import Simulation.Aivika.GPSS.Facility++-- | Specifies the Preempt block mode.+data PreemptBlockMode a =+  PreemptBlockMode { preemptBlockPriorityMode :: Bool,+                     -- ^ the Priority mode; otherwise, the Interrupt mode+                     preemptBlockTransfer :: Maybe (Maybe Double -> Block (Transact a) ()),+                     -- ^ where to transfer the preempted transact,+                     -- passing in the remaining time from the process holding +                     -- computation such as the ADVANCE block+                     preemptBlockRemoveMode :: Bool+                     -- ^ the Remove mode+                   }++-- | Convert 'PreemptBlockMode' to 'FacilityPreemptMode'.+toFacilityPreemptMode :: PreemptBlockMode a -> FacilityPreemptMode a+toFacilityPreemptMode m =+  FacilityPreemptMode { facilityPriorityMode = preemptBlockPriorityMode m,+                        facilityTransfer     = transfer,+                        facilityRemoveMode   = preemptBlockRemoveMode m+                      }+  where+    transfer =+      case preemptBlockTransfer m of+        Nothing -> Nothing+        Just f  -> Just (\a dt -> blockProcess (f dt) a)++-- | Convert 'PreemptBlockMode' from 'FacilityPreemptMode'.+fromFacilityPreemptMode :: FacilityPreemptMode a -> PreemptBlockMode a+fromFacilityPreemptMode m =+  PreemptBlockMode { preemptBlockPriorityMode = facilityPriorityMode m,+                     preemptBlockTransfer     = transfer,+                     preemptBlockRemoveMode   = facilityRemoveMode m+                   }+  where+    transfer =+      case facilityTransfer m of+        Nothing -> Nothing+        Just f  -> Just (\dt -> Block $ \a -> f a dt)++-- | The default Preempt block mode.+defaultPreemptBlockMode :: PreemptBlockMode a+defaultPreemptBlockMode =+  PreemptBlockMode { preemptBlockPriorityMode = False,+                     preemptBlockTransfer     = Nothing,+                     preemptBlockRemoveMode   = False+                   }++-- | This is the GPSS construct+--+-- @PREEMPT A,B,C,D,E@+preemptBlock :: Facility a+                -- ^ the facility+                -> PreemptBlockMode a+                -- ^ the Preempt block mode+                -> Block (Transact a) (Transact a)+preemptBlock r m =+  Block { blockProcess = \a -> preemptFacility r a (toFacilityPreemptMode m) >> return a }
+ Simulation/Aivika/GPSS/Block/Priority.hs view
@@ -0,0 +1,26 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Priority+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block PRIORITY.+--+module Simulation.Aivika.GPSS.Block.Priority+       (priorityBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Block+import Simulation.Aivika.GPSS.Transact++-- | This is the GPSS construct+--+-- @PRIORITY A@+priorityBlock :: Int+                 -- ^ the priority+                 -> Block (Transact a) (Transact a)+priorityBlock priority =+  Block { blockProcess = \a -> return (assignTransactPriority a priority) }
+ Simulation/Aivika/GPSS/Block/Queue.hs view
@@ -0,0 +1,29 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Queue+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block QUEUE.+--+module Simulation.Aivika.GPSS.Block.Queue+       (queueBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Transact+import Simulation.Aivika.GPSS.Block+import qualified Simulation.Aivika.GPSS.Queue as Q++-- | This is the GPSS construct+--+-- @QUEUE A,B@+queueBlock :: Q.Queue+              -- ^ the queue+              -> Int+              -- ^ the content increment+              -> Block (Transact a) (Transact a)+queueBlock q increment =+  Block { blockProcess = \a -> (liftEvent $ Q.enqueue q a increment) >> return a }
+ Simulation/Aivika/GPSS/Block/Release.hs view
@@ -0,0 +1,27 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Release+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block RELEASE.+--+module Simulation.Aivika.GPSS.Block.Release+       (releaseBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Transact+import Simulation.Aivika.GPSS.Block+import Simulation.Aivika.GPSS.Facility++-- | This is the GPSS construct+--+-- @RELEASE A@+releaseBlock :: Facility a+                -- ^ the facility+                -> Block (Transact a) (Transact a)+releaseBlock r =+  Block { blockProcess = \a -> releaseFacility r a >> return a }
+ Simulation/Aivika/GPSS/Block/Return.hs view
@@ -0,0 +1,27 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Return+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block RETURN.+--+module Simulation.Aivika.GPSS.Block.Return+       (returnBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Transact+import Simulation.Aivika.GPSS.Block+import Simulation.Aivika.GPSS.Facility++-- | This is the GPSS construct+--+-- @RETURN A@+returnBlock :: Facility a+               -- ^ the facility+               -> Block (Transact a) (Transact a)+returnBlock r =+  Block { blockProcess = \a -> returnFacility r a >> return a }
+ Simulation/Aivika/GPSS/Block/Seize.hs view
@@ -0,0 +1,27 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Seize+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block SEIZE.+--+module Simulation.Aivika.GPSS.Block.Seize+       (seizeBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Transact+import Simulation.Aivika.GPSS.Block+import Simulation.Aivika.GPSS.Facility++-- | This is the GPSS construct+--+-- @SEIZE A@+seizeBlock :: Facility a+              -- ^ the facility+              -> Block (Transact a) (Transact a)+seizeBlock r =+  Block { blockProcess = \a -> seizeFacility r a >> return a }
+ Simulation/Aivika/GPSS/Block/Split.hs view
@@ -0,0 +1,52 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Split+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines an analog of the GPSS block SPLIT.+--+module Simulation.Aivika.GPSS.Block.Split+       (splitBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Block+import Simulation.Aivika.GPSS.Transact++-- | This is an analog of the GPSS construct+--+-- @SPLIT A,B,C@+--+-- Parameter @A@ is a length of the list parameter passed in to the function.+-- Parameter @B@ is the list itself. If you need to define parameter @C@ then+-- you can create the blocks dynamically that could depend on the index and+-- where we could assign a new value for each new transcact after splitting.+--+-- An example is+--+-- @+-- let blocks :: [Block (Transact (a, Int)) ()]+--     blocks = ...+--     f :: (Int, Block (Transact (a, Int)) ()) -> Block (Transact a) ()+--     f (n, block) = assignBlock (\a -> (a, n)) >>> block+--     blocks' :: [Block (Transact a) ()]+--     blocks' = map f $ zip [0..] blocks+-- in splitBlock blocks'+-- @+splitBlock :: [Block (Transact a) ()]+              -- ^ split and transfer new transacts to the specified blocks+              -> Block (Transact a) (Transact a)+splitBlock blocks =+  Block { blockProcess = \a ->+           do let loop [] = return ()+                  loop (transfer: transfers) =+                    do a' <- liftSimulation $ splitTransact a+                       transferTransact a' $+                         blockProcess transfer a'+                       loop transfers+              liftEvent $ loop blocks+              return a+        }
+ Simulation/Aivika/GPSS/Block/Terminate.hs view
@@ -0,0 +1,69 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Terminate+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block TERMINATE.+--+module Simulation.Aivika.GPSS.Block.Terminate+       (terminateBlock,+        terminateBlockByCount,+        terminateBlockByCountM) where++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika+import Simulation.Aivika.GPSS.Block++-- | This is the GPSS construct+--+-- @TERMINATE@+terminateBlock :: Block a ()+terminateBlock =+  Block { blockProcess = \a -> return () }++-- | This is the GPSS construct+--+-- @TERMINATE Count@+terminateBlockByCountM :: Ref Int+                          -- ^ the counter+                          -> Event Int+                          -- ^ the computation of decrement+                          -> Block a ()+terminateBlockByCountM counter decrement =+  Block { blockProcess = \a -> action }+    where+      action = +        liftEvent $+        do i <- decrement+           n <- readRef counter+           let n' = n - i+           n' `seq` writeRef counter n'+           when (n' <= 0) $+             throwEvent $+             SimulationAbort "Terminated by exceeding the counter"++-- | This is the GPSS construct+--+-- @TERMINATE Count@+terminateBlockByCount :: Ref Int+                         -- ^ the counter+                         -> Int+                         -- ^ the decrement+                         -> Block a ()+terminateBlockByCount counter i =+  Block { blockProcess = \a -> action }+    where+      action = +        liftEvent $+        do n <- readRef counter+           let n' = n - i+           n' `seq` writeRef counter n'+           when (n' <= 0) $+             throwEvent $+             SimulationAbort "Terminated by exceeding the counter"
+ Simulation/Aivika/GPSS/Block/Test.hs view
@@ -0,0 +1,93 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Test+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block TEST.+--+module Simulation.Aivika.GPSS.Block.Test+       (awaitingTestBlock,+        awaitingTestBlockM,+        transferringTestBlock,+        transferringTestBlockM) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Block++-- | This is the GPSS construct+--+-- @TEST O A,B@+awaitingTestBlock :: (a -> Signalable Bool)+                     -- ^ by the specified transact return+                     -- a test condition and signal that notifies+                     -- about changing the condition+                     -> Block a a+awaitingTestBlock f =+  Block { blockProcess = \a ->+           do let s = f a+                  loop =+                    do f <- liftEvent $ readSignalable s+                       if f+                         then return ()+                         else do processAwait $ signalableChanged_ s+                                 loop+              loop+              return a+        }++-- | This is the GPSS construct+--+-- @TEST O A,B@+awaitingTestBlockM :: (a -> Process (Signalable Bool))+                      -- ^ by the specified transact return+                      -- a test condition and signal that notifies+                      -- about changing the condition+                      -> Block a a+awaitingTestBlockM f =+  Block { blockProcess = \a ->+           do s <- f a+              let loop =+                    do f <- liftEvent $ readSignalable s+                       if f+                         then return ()+                         else do processAwait $ signalableChanged_ s+                                 loop+              loop+              return a+        }++-- | This is the GPSS construct+--+-- @TEST O A,B,C@+transferringTestBlock :: (a -> Bool)+                         -- ^ the predicate+                         -> Block a ()+                         -- ^ the block to transfer in when the condition fails+                         -> Block a a+transferringTestBlock pred block =+  Block { blockProcess = \a ->+           do let f = pred a+              if f+                then return a+                else transferProcess (blockProcess block a)+        }++-- | This is the GPSS construct+--+-- @TEST O A,B,C@+transferringTestBlockM :: (a -> Process Bool)+                          -- ^ the predicate+                          -> Block a ()+                          -- ^ the block to transfer in when the condition fails+                          -> Block a a+transferringTestBlockM pred block =+  Block { blockProcess = \a ->+           do f <- pred a+              if f+                then return a+                else transferProcess (blockProcess block a)+        }
+ Simulation/Aivika/GPSS/Block/Transfer.hs view
@@ -0,0 +1,25 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Transfer+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block TRANSFER.+--+module Simulation.Aivika.GPSS.Block.Transfer+       (transferBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Block++-- | This is the GPSS construct+--+-- @TRANSFER ,New_Place@+transferBlock :: Block a ()+                 -- ^ a new place+                 -> Block a b+transferBlock x =+  Block { blockProcess = \a -> transferProcess (blockProcess x a) }
+ Simulation/Aivika/GPSS/Block/Unlink.hs view
@@ -0,0 +1,35 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Block.Unlink+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines an analog of the GPSS block UNLINK.+--+module Simulation.Aivika.GPSS.Block.Unlink+       (unlinkBlock) where++import Simulation.Aivika+import Simulation.Aivika.GPSS.Block+import Simulation.Aivika.GPSS.Transact++-- | This is an analog of the GPSS construct+--+-- @UNLINK O A,B,C,D,E,F@+unlinkBlock :: Process [(Transact a, Maybe (Block (Transact a) ()))]+               -- ^ a computation of the list of transacts to reactivate,+               -- transfering them to the specified blocks if required+               -> Block b b+unlinkBlock m =+  Block { blockProcess = \b ->+           do let f (a, Nothing)       = (a, Nothing)+                  f (a, Just transfer) = (a, Just $ blockProcess transfer a)+              xs <- m+              liftEvent $+                reactivateTransacts $+                map f xs+              return b+        }
+ Simulation/Aivika/GPSS/Facility.hs view
@@ -0,0 +1,702 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Facility+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.1+--+-- This module defines the GPSS Facility entity.+--+module Simulation.Aivika.GPSS.Facility+       (-- * Facility Type+        Facility,+        FacilityPreemptMode(..),+        FacilityPreemptTransfer,+        -- * Creating Facility+        newFacility,+        -- * Facility Properties+        facilityCount,+        facilityCountStats,+        facilityCaptureCount,+        facilityUtilisationCount,+        facilityUtilisationCountStats,+        facilityQueueCount,+        facilityQueueCountStats,+        facilityTotalWaitTime,+        facilityWaitTime,+        facilityTotalHoldingTime,+        facilityHoldingTime,+        facilityInterrupted,+        -- * Seizing-Releasing and Preempting-Returning Facility+        seizeFacility,+        releaseFacility,+        preemptFacility,+        returnFacility,+        -- * Statistics Reset+        resetFacility,+        -- * Signals+        facilityCountChanged,+        facilityCountChanged_,+        facilityCaptureCountChanged,+        facilityCaptureCountChanged_,+        facilityUtilisationCountChanged,+        facilityUtilisationCountChanged_,+        facilityQueueCountChanged,+        facilityQueueCountChanged_,+        facilityWaitTimeChanged,+        facilityWaitTimeChanged_,+        facilityHoldingTimeChanged,+        facilityHoldingTimeChanged_,+        facilityChanged_) where++import Data.IORef+import Data.Monoid+import Data.Maybe++import Control.Monad+import Control.Monad.Trans+import Control.Exception++import Simulation.Aivika.Internal.Specs+import Simulation.Aivika.Internal.Simulation+import Simulation.Aivika.Internal.Event+import Simulation.Aivika.Internal.Cont+import Simulation.Aivika.Internal.Process+import Simulation.Aivika.QueueStrategy+import Simulation.Aivika.Statistics+import Simulation.Aivika.Signal++import Simulation.Aivika.GPSS.Transact+import Simulation.Aivika.GPSS.TransactQueueStrategy++-- | Represents a GPSS Facility entity.+data Facility a = +  Facility { facilityCountRef :: IORef Int,+             facilityCountStatsRef :: IORef (TimingStats Int),+             facilityCountSource :: SignalSource Int,+             facilityCaptureCountRef :: IORef Int,+             facilityCaptureCountSource :: SignalSource Int,+             facilityUtilisationCountRef :: IORef Int,+             facilityUtilisationCountStatsRef :: IORef (TimingStats Int),+             facilityUtilisationCountSource :: SignalSource Int,+             facilityQueueCountRef :: IORef Int,+             facilityQueueCountStatsRef :: IORef (TimingStats Int),+             facilityQueueCountSource :: SignalSource Int,+             facilityTotalWaitTimeRef :: IORef Double,+             facilityWaitTimeRef :: IORef (SamplingStats Double),+             facilityWaitTimeSource :: SignalSource (),+             facilityTotalHoldingTimeRef :: IORef Double,+             facilityHoldingTimeRef :: IORef (SamplingStats Double),+             facilityHoldingTimeSource :: SignalSource (),+             facilityOwnerRef :: IORef (Maybe (FacilityOwnerItem a)),+             facilityDelayChain :: StrategyQueue (TransactQueueStrategy FCFS) (FacilityDelayedItem a),+             facilityInterruptChain :: StrategyQueue (TransactQueueStrategy LCFS) (FacilityInterruptedItem a),+             facilityPendingChain :: StrategyQueue (TransactQueueStrategy FCFS) (FacilityPendingItem a) }++-- | Identifies a transact item that owns the facility.+data FacilityOwnerItem a =+  FacilityOwnerItem { ownerItemTransact :: Transact a,+                      ownerItemTime :: Double,+                      ownerItemPreempting :: Bool,+                      ownerItemInterrupting :: Bool,+                      ownerItemAccHoldingTime :: Double }++-- | Idenitifies a transact item that was delayed.+data FacilityDelayedItem a =+  FacilityDelayedItem { delayedItemTransact :: Transact a,+                        delayedItemTime :: Double,+                        delayedItemPreempting :: Bool,+                        delayedItemInterrupting :: Bool,+                        delayedItemCont :: FrozenCont () }++-- | Idenitifies a transact item that was interrupted.+data FacilityInterruptedItem a =+  FacilityInterruptedItem { interruptedItemTransact :: Transact a,+                            interruptedItemTime :: Double,+                            interruptedItemPreempting :: Bool,+                            interruptedItemInterrupting :: Bool,+                            interruptedItemRemainingTime :: Maybe Double,+                            interruptedItemTransfer :: Maybe (FacilityPreemptTransfer a),+                            interruptedItemAccHoldingTime :: Double }++-- | Idenitifies a transact item which is pending.+data FacilityPendingItem a =+  FacilityPendingItem { pendingItemTransact :: Transact a,+                        pendingItemTime :: Double,+                        pendingItemPreempting :: Bool,+                        pendingItemInterrupting :: Bool,+                        pendingItemCont :: FrozenCont () }++instance Eq (Facility a) where+  x == y = facilityCountRef x == facilityCountRef y  -- unique references++-- | The facility preemption mode.+data FacilityPreemptMode a =+  FacilityPreemptMode { facilityPriorityMode :: Bool,+                        -- ^ the Priority mode; otherwise, the Interrupt mode+                        facilityTransfer :: Maybe (FacilityPreemptTransfer a),+                        -- ^ where to transfer the preempted transact,+                        -- passing in the remaining time from the process holding+                        -- computation such as the  ADVANCE block+                        facilityRemoveMode :: Bool+                        -- ^ the Remove mode+                      }++-- | Proceed with the computation by the specified preempted transact+-- and remaining time from the process holding computation such as the ADVANCE block.+type FacilityPreemptTransfer a = Transact a -> Maybe Double -> Process ()++-- | The default facility preemption mode.+defaultFacilityPreemptMode :: FacilityPreemptMode a+defaultFacilityPreemptMode =+  FacilityPreemptMode { facilityPriorityMode = False,+                        facilityTransfer = Nothing,+                        facilityRemoveMode = False+                      }++-- | Create a new facility.+newFacility :: Event (Facility a)+newFacility =+  Event $ \p ->+  do let r = pointRun p+         t = pointTime p+     countRef <- newIORef 1+     countStatsRef <- newIORef $ returnTimingStats t 1+     countSource <- invokeSimulation r newSignalSource+     captureCountRef <- newIORef 0+     captureCountSource <- invokeSimulation r newSignalSource+     utilCountRef <- newIORef 0+     utilCountStatsRef <- newIORef $ returnTimingStats t 0+     utilCountSource <- invokeSimulation r newSignalSource+     queueCountRef <- newIORef 0+     queueCountStatsRef <- newIORef $ returnTimingStats t 0+     queueCountSource <- invokeSimulation r newSignalSource+     totalWaitTimeRef <- newIORef 0+     waitTimeRef <- newIORef emptySamplingStats+     waitTimeSource <- invokeSimulation r newSignalSource+     totalHoldingTimeRef <- newIORef 0+     holdingTimeRef <- newIORef emptySamplingStats+     holdingTimeSource <- invokeSimulation r newSignalSource+     ownerRef <- newIORef Nothing+     delayChain <- invokeSimulation r $ newStrategyQueue (TransactQueueStrategy FCFS)+     interruptChain <- invokeSimulation r $ newStrategyQueue (TransactQueueStrategy LCFS)+     pendingChain <- invokeSimulation r $ newStrategyQueue (TransactQueueStrategy FCFS)+     return Facility { facilityCountRef = countRef,+                       facilityCountStatsRef = countStatsRef,+                       facilityCountSource = countSource,+                       facilityCaptureCountRef = captureCountRef,+                       facilityCaptureCountSource = captureCountSource,+                       facilityUtilisationCountRef = utilCountRef,+                       facilityUtilisationCountStatsRef = utilCountStatsRef,+                       facilityUtilisationCountSource = utilCountSource,+                       facilityQueueCountRef = queueCountRef,+                       facilityQueueCountStatsRef = queueCountStatsRef,+                       facilityQueueCountSource = queueCountSource,+                       facilityTotalWaitTimeRef = totalWaitTimeRef,+                       facilityWaitTimeRef = waitTimeRef,+                       facilityWaitTimeSource = waitTimeSource,+                       facilityTotalHoldingTimeRef = totalHoldingTimeRef,+                       facilityHoldingTimeRef = holdingTimeRef,+                       facilityHoldingTimeSource = holdingTimeSource,+                       facilityOwnerRef = ownerRef,+                       facilityDelayChain = delayChain,+                       facilityInterruptChain = interruptChain,+                       facilityPendingChain = pendingChain }++-- | Return the current available count of the facility.+facilityCount :: Facility a -> Event Int+facilityCount r =+  Event $ \p -> readIORef (facilityCountRef r)++-- | Return the statistics for the available count of the facility.+facilityCountStats :: Facility a -> Event (TimingStats Int)+facilityCountStats r =+  Event $ \p -> readIORef (facilityCountStatsRef r)++-- | Signal triggered when the 'facilityCount' property changes.+facilityCountChanged :: Facility a -> Signal Int+facilityCountChanged r =+  publishSignal $ facilityCountSource r++-- | Signal triggered when the 'facilityCount' property changes.+facilityCountChanged_ :: Facility a -> Signal ()+facilityCountChanged_ r =+  mapSignal (const ()) $ facilityCountChanged r++-- | Return the current capture count of the facility.+facilityCaptureCount :: Facility a -> Event Int+facilityCaptureCount r =+  Event $ \p -> readIORef (facilityCaptureCountRef r)++-- | Signal triggered when the 'facilityCaptureCount' property changes.+facilityCaptureCountChanged :: Facility a -> Signal Int+facilityCaptureCountChanged r =+  publishSignal $ facilityCaptureCountSource r++-- | Signal triggered when the 'facilityCaptureCount' property changes.+facilityCaptureCountChanged_ :: Facility a -> Signal ()+facilityCaptureCountChanged_ r =+  mapSignal (const ()) $ facilityCaptureCountChanged r++-- | Return the current utilisation count of the facility.+facilityUtilisationCount :: Facility a -> Event Int+facilityUtilisationCount r =+  Event $ \p -> readIORef (facilityUtilisationCountRef r)++-- | Return the statistics for the utilisation count of the facility.+facilityUtilisationCountStats :: Facility a -> Event (TimingStats Int)+facilityUtilisationCountStats r =+  Event $ \p -> readIORef (facilityUtilisationCountStatsRef r)++-- | Signal triggered when the 'facilityUtilisationCount' property changes.+facilityUtilisationCountChanged :: Facility a -> Signal Int+facilityUtilisationCountChanged r =+  publishSignal $ facilityUtilisationCountSource r++-- | Signal triggered when the 'facilityUtilisationCount' property changes.+facilityUtilisationCountChanged_ :: Facility a -> Signal ()+facilityUtilisationCountChanged_ r =+  mapSignal (const ()) $ facilityUtilisationCountChanged r++-- | Return the current queue length of the facility.+facilityQueueCount :: Facility a -> Event Int+facilityQueueCount r =+  Event $ \p -> readIORef (facilityQueueCountRef r)++-- | Return the statistics for the queue length of the facility.+facilityQueueCountStats :: Facility a -> Event (TimingStats Int)+facilityQueueCountStats r =+  Event $ \p -> readIORef (facilityQueueCountStatsRef r)++-- | Signal triggered when the 'facilityQueueCount' property changes.+facilityQueueCountChanged :: Facility a -> Signal Int+facilityQueueCountChanged r =+  publishSignal $ facilityQueueCountSource r++-- | Signal triggered when the 'facilityQueueCount' property changes.+facilityQueueCountChanged_ :: Facility a -> Signal ()+facilityQueueCountChanged_ r =+  mapSignal (const ()) $ facilityQueueCountChanged r++-- | Return the total wait time of the facility.+facilityTotalWaitTime :: Facility a -> Event Double+facilityTotalWaitTime r =+  Event $ \p -> readIORef (facilityTotalWaitTimeRef r)++-- | Return the statistics for the wait time of the facility.+facilityWaitTime :: Facility a -> Event (SamplingStats Double)+facilityWaitTime r =+  Event $ \p -> readIORef (facilityWaitTimeRef r)++-- | Signal triggered when the 'facilityTotalWaitTime' and 'facilityWaitTime' properties change.+facilityWaitTimeChanged :: Facility a -> Signal (SamplingStats Double)+facilityWaitTimeChanged r =+  mapSignalM (\() -> facilityWaitTime r) $ facilityWaitTimeChanged_ r++-- | Signal triggered when the 'facilityTotalWaitTime' and 'facilityWaitTime' properties change.+facilityWaitTimeChanged_ :: Facility a -> Signal ()+facilityWaitTimeChanged_ r =+  publishSignal $ facilityWaitTimeSource r++-- | Return the total holding time of the facility.+facilityTotalHoldingTime :: Facility a -> Event Double+facilityTotalHoldingTime r =+  Event $ \p -> readIORef (facilityTotalHoldingTimeRef r)++-- | Return the statistics for the holding time of the facility.+facilityHoldingTime :: Facility a -> Event (SamplingStats Double)+facilityHoldingTime r =+  Event $ \p -> readIORef (facilityHoldingTimeRef r)++-- | Signal triggered when the 'facilityTotalHoldingTime' and 'facilityHoldingTime' properties change.+facilityHoldingTimeChanged :: Facility a -> Signal (SamplingStats Double)+facilityHoldingTimeChanged r =+  mapSignalM (\() -> facilityHoldingTime r) $ facilityHoldingTimeChanged_ r++-- | Signal triggered when the 'facilityTotalHoldingTime' and 'facilityHoldingTime' properties change.+facilityHoldingTimeChanged_ :: Facility a -> Signal ()+facilityHoldingTimeChanged_ r =+  publishSignal $ facilityHoldingTimeSource r++-- | Whether the facility is currently interrupted.+facilityInterrupted :: Facility a -> Event Bool+facilityInterrupted r =+  Event $ \p ->+  do x <- readIORef (facilityOwnerRef r)+     case x of+       Nothing -> return False+       Just a  -> return (ownerItemPreempting a)++-- | Seize the facility.+seizeFacility :: Facility a+                 -- ^ the requested facility+                 -> Transact a+                 -- ^ the transact that tries to seize the facility+                 -> Process ()+seizeFacility r transact =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do let t = pointTime p+     f <- do f1 <- invokeEvent p $ strategyQueueNull (facilityDelayChain r)+             if f1+               then do f2 <- invokeEvent p $ strategyQueueNull (facilityInterruptChain r)+                       if f2+                         then invokeEvent p $ strategyQueueNull (facilityPendingChain r)+                         else return False+               else return False+     if f+       then invokeEvent p $+            invokeCont c $+            invokeProcess pid $+            seizeFacility' r transact+       else do c <- invokeEvent p $+                    freezeContReentering c () $+                    invokeCont c $+                    invokeProcess pid $+                    seizeFacility r transact+               invokeEvent p $+                 strategyEnqueueWithPriority+                 (facilityDelayChain r)+                 (transactPriority transact)+                 (FacilityDelayedItem transact t False False c)+               invokeEvent p $ updateFacilityQueueCount r 1++-- | Seize the facility.+seizeFacility' :: Facility a+                  -- ^ the requested facility+                  -> Transact a+                  -- ^ the transact that tries to seize the facility+                  -> Process ()+seizeFacility' r transact =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do let t = pointTime p+     a <- readIORef (facilityOwnerRef r)+     case a of+       Nothing ->+         do writeIORef (facilityOwnerRef r) $ Just (FacilityOwnerItem transact t False False 0)+            invokeEvent p $ updateFacilityWaitTime r 0+            invokeEvent p $ updateFacilityCount r (-1)+            invokeEvent p $ updateFacilityCaptureCount r 1+            invokeEvent p $ updateFacilityUtilisationCount r 1+            invokeEvent p $ resumeCont c ()+       Just owner ->+         do c <- invokeEvent p $+                 freezeContReentering c () $+                 invokeCont c $+                 invokeProcess pid $+                 seizeFacility r transact+            invokeEvent p $+              strategyEnqueueWithPriority+              (facilityDelayChain r)+              (transactPriority transact)+              (FacilityDelayedItem transact t False False c)+            invokeEvent p $ updateFacilityQueueCount r 1++-- | Preempt the facility.+preemptFacility :: Facility a+                   -- ^ the requested facility+                   -> Transact a+                   -- ^ the transact that tries to preempt the facility+                   -> FacilityPreemptMode a+                   -- ^ the Preempt mode+                   -> Process ()+preemptFacility r transact mode =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do let t = pointTime p+     a <- readIORef (facilityOwnerRef r)+     case a of+       Nothing ->+         do writeIORef (facilityOwnerRef r) $ Just (FacilityOwnerItem transact t True False 0)+            invokeEvent p $ updateFacilityWaitTime r 0+            invokeEvent p $ updateFacilityCount r (-1)+            invokeEvent p $ updateFacilityCaptureCount r 1+            invokeEvent p $ updateFacilityUtilisationCount r 1+            invokeEvent p $ resumeCont c ()+       Just owner@(FacilityOwnerItem transact0 t0 preempting0 interrupting0 acc0)+         | (not $ facilityPriorityMode mode) && interrupting0 ->+         do c <- invokeEvent p $+                 freezeContReentering c () $+                 invokeCont c $+                 invokeProcess pid $+                 preemptFacility r transact mode+            invokeEvent p $+              strategyEnqueueWithPriority+              (facilityPendingChain r)+              (transactPriority transact)+              (FacilityPendingItem transact t True True c)+            invokeEvent p $ updateFacilityQueueCount r 1+       Just owner@(FacilityOwnerItem transact0 t0 preempting0 interrupting0 acc0)+         | facilityPriorityMode mode && (transactPriority transact <= transactPriority transact0) ->+         do c <- invokeEvent p $+                 freezeContReentering c () $+                 invokeCont c $+                 invokeProcess pid $+                 preemptFacility r transact mode+            invokeEvent p $+              strategyEnqueueWithPriority+              (facilityDelayChain r)+              (transactPriority transact)+              (FacilityDelayedItem transact t True True c)+            invokeEvent p $ updateFacilityQueueCount r 1+       Just owner@(FacilityOwnerItem transact0 t0 preempting0 interrupting0 acc0)+         | (not $ facilityRemoveMode mode) ->+         do writeIORef (facilityOwnerRef r) $ Just (FacilityOwnerItem transact t True True 0)+            pid0 <- invokeEvent p $ requireTransactProcessId transact0+            t2   <- invokeEvent p $ processInterruptionTime pid0+            let dt0 = fmap (\x -> x - t) t2+            invokeEvent p $+              strategyEnqueueWithPriority+              (facilityInterruptChain r)+              (transactPriority transact0)+              (FacilityInterruptedItem transact0 t preempting0 interrupting0 dt0 (facilityTransfer mode) (acc0 + (t - t0)))+            invokeEvent p $ updateFacilityQueueCount r 1+            invokeEvent p $ updateFacilityWaitTime r 0+            invokeEvent p $ updateFacilityCaptureCount r 1+            invokeEvent p $ transactPreemptionBegin transact0+            invokeEvent p $ resumeCont c ()+       Just owner@(FacilityOwnerItem transact0 t0 preempting0 interrupting0 acc0)+         | facilityRemoveMode mode ->+         do writeIORef (facilityOwnerRef r) $ Just (FacilityOwnerItem transact t True True 0)+            pid0 <- invokeEvent p $ requireTransactProcessId transact0+            t2   <- invokeEvent p $ processInterruptionTime pid0+            let dt0 = fmap (\x -> x - t) t2+            invokeEvent p $ updateFacilityWaitTime r 0+            invokeEvent p $ updateFacilityCaptureCount r 1+            invokeEvent p $ updateFacilityHoldingTime r (acc0 + (t - t0))+            case facilityTransfer mode of+              Nothing ->+                throwIO $+                SimulationRetry+                "The transfer destination is not specified for the removed preempted transact: preemptFacility"+              Just transfer ->+                invokeEvent p $ transferTransact transact0 (transfer transact0 dt0)+            invokeEvent p $ resumeCont c ()++-- | Return the facility by the active transact.+returnFacility :: Facility a+                  -- ^ the facility to return+                  -> Transact a+                  -- ^ the active transact that tries to return the facility+                  -> Process ()+returnFacility r transact = releaseFacility' r transact True ++-- | Release the facility by the active transact.+releaseFacility :: Facility a+                   -- ^ the facility to release+                   -> Transact a+                   -- ^ the active transact that tries to release the facility+                   -> Process ()+releaseFacility r transact = releaseFacility' r transact False ++-- | Release the facility by the active transact.+releaseFacility' :: Facility a+                    -- ^ the facility to release+                    -> Transact a+                    -- ^ the active transact that tries to release the facility+                    -> Bool+                    -- ^ whether the transact is preempting+                    -> Process ()+releaseFacility' r transact preempting = +  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do let t = pointTime p+     a <- readIORef (facilityOwnerRef r)+     case a of+       Nothing ->+         throwIO $+         SimulationRetry+         "There is no owner of the facility: releaseFacility'"+       Just owner@(FacilityOwnerItem transact0 t0 preempting0 interrupting0 acc0) | transact0 == transact && preempting0 /= preempting ->+         throwIO $+         SimulationRetry+         "The mismatch use of releaseFacility and returnFacility: releaseFacility'"+       Just owner@(FacilityOwnerItem transact0 t0 preempting0 interrupting0 acc0) | transact0 == transact ->+         do writeIORef (facilityOwnerRef r) Nothing+            invokeEvent p $ updateFacilityUtilisationCount r (-1)+            invokeEvent p $ updateFacilityHoldingTime r (acc0 + (t - t0))+            invokeEvent p $ updateFacilityCount r 1+            invokeEvent p $ enqueueEvent t $ tryCaptureFacility r+            invokeEvent p $ resumeCont c ()+       Just owner ->+         throwIO $+         SimulationRetry+         "The facility has another owner: releaseFacility'"++-- | Try to capture the facility.+tryCaptureFacility :: Facility a -> Event ()+tryCaptureFacility r =+  Event $ \p ->+  do let t = pointTime p+     a <- readIORef (facilityOwnerRef r)+     case a of+       Nothing ->+         invokeEvent p $ captureFacility r+       Just owner -> return ()++-- | Find another owner of the facility.+captureFacility :: Facility a -> Event ()+captureFacility r =+  Event $ \p ->+  do let t = pointTime p+     f <- invokeEvent p $ strategyQueueNull (facilityPendingChain r)+     if not f+       then do FacilityPendingItem transact t0 preempting interrupting c0 <- invokeEvent p $ strategyDequeue (facilityPendingChain r)+               invokeEvent p $ updateFacilityQueueCount r (-1)+               c <- invokeEvent p $ unfreezeCont c0+               case c of+                 Nothing ->+                   invokeEvent p $ captureFacility r+                 Just c ->+                   do writeIORef (facilityOwnerRef r) $ Just (FacilityOwnerItem transact t preempting interrupting 0)+                      invokeEvent p $ updateFacilityWaitTime r (t - t0)+                      invokeEvent p $ updateFacilityUtilisationCount r 1+                      invokeEvent p $ updateFacilityCaptureCount r 1+                      invokeEvent p $ updateFacilityCount r (-1)+                      invokeEvent p $ enqueueEvent t $ reenterCont c ()+       else do f <- invokeEvent p $ strategyQueueNull (facilityInterruptChain r)+               if not f+                  then do FacilityInterruptedItem transact t0 preempting interrupting dt0 transfer0 acc0 <- invokeEvent p $ strategyDequeue (facilityInterruptChain r)+                          pid <- invokeEvent p $ requireTransactProcessId transact+                          invokeEvent p $ updateFacilityQueueCount r (-1)+                          f <- invokeEvent p $ processCancelled pid+                          case f of+                            True ->+                              invokeEvent p $ captureFacility r+                            False ->+                              do writeIORef (facilityOwnerRef r) $ Just (FacilityOwnerItem transact t preempting interrupting acc0)+                                 invokeEvent p $ updateFacilityWaitTime r (t - t0)+                                 invokeEvent p $ updateFacilityUtilisationCount r 1+                                 invokeEvent p $ updateFacilityCount r (-1)+                                 case transfer0 of+                                   Nothing -> return ()+                                   Just transfer ->+                                     invokeEvent p $ transferTransact transact (transfer transact dt0)+                                 invokeEvent p $ transactPreemptionEnd transact+                 else do f <- invokeEvent p $ strategyQueueNull (facilityDelayChain r)+                         if not f+                           then do FacilityDelayedItem transact t0 preempting interrupting c0 <- invokeEvent p $ strategyDequeue (facilityDelayChain r)+                                   invokeEvent p $ updateFacilityQueueCount r (-1)+                                   c <- invokeEvent p $ unfreezeCont c0+                                   case c of+                                     Nothing ->+                                       invokeEvent p $ captureFacility r+                                     Just c ->+                                       do writeIORef (facilityOwnerRef r) $ Just (FacilityOwnerItem transact t preempting interrupting 0)+                                          invokeEvent p $ updateFacilityWaitTime r (t - t0)+                                          invokeEvent p $ updateFacilityUtilisationCount r 1+                                          invokeEvent p $ updateFacilityCaptureCount r 1+                                          invokeEvent p $ updateFacilityCount r (-1)+                                          invokeEvent p $ enqueueEvent t $ reenterCont c ()+                           else return ()++-- | Signal triggered when one of the facility counters changes.+facilityChanged_ :: Facility a -> Signal ()+facilityChanged_ r =+  facilityCountChanged_ r <>+  facilityCaptureCountChanged_ r <>+  facilityUtilisationCountChanged_ r <>+  facilityQueueCountChanged_ r++-- | Update the facility count and its statistics.+updateFacilityCount :: Facility a -> Int -> Event ()+updateFacilityCount r delta =+  Event $ \p ->+  do a <- readIORef (facilityCountRef r)+     let a' = a + delta+     a' `seq` writeIORef (facilityCountRef r) a'+     modifyIORef' (facilityCountStatsRef r) $+       addTimingStats (pointTime p) a'+     invokeEvent p $+       triggerSignal (facilityCountSource r) a'++-- | Update the facility capture count.+updateFacilityCaptureCount :: Facility a -> Int -> Event ()+updateFacilityCaptureCount r delta =+  Event $ \p ->+  do a <- readIORef (facilityCaptureCountRef r)+     let a' = a + delta+     a' `seq` writeIORef (facilityCaptureCountRef r) a'+     invokeEvent p $+       triggerSignal (facilityCaptureCountSource r) a'++-- | Update the facility queue length and its statistics.+updateFacilityQueueCount :: Facility a -> Int -> Event ()+updateFacilityQueueCount r delta =+  Event $ \p ->+  do a <- readIORef (facilityQueueCountRef r)+     let a' = a + delta+     a' `seq` writeIORef (facilityQueueCountRef r) a'+     modifyIORef' (facilityQueueCountStatsRef r) $+       addTimingStats (pointTime p) a'+     invokeEvent p $+       triggerSignal (facilityQueueCountSource r) a'++-- | Update the facility utilisation count and its statistics.+updateFacilityUtilisationCount :: Facility a -> Int -> Event ()+updateFacilityUtilisationCount r delta =+  Event $ \p ->+  do a <- readIORef (facilityUtilisationCountRef r)+     let a' = a + delta+     a' `seq` writeIORef (facilityUtilisationCountRef r) a'+     modifyIORef' (facilityUtilisationCountStatsRef r) $+       addTimingStats (pointTime p) a'+     invokeEvent p $+       triggerSignal (facilityUtilisationCountSource r) a'++-- | Update the facility wait time and its statistics.+updateFacilityWaitTime :: Facility a -> Double -> Event ()+updateFacilityWaitTime r delta =+  Event $ \p ->+  do a <- readIORef (facilityTotalWaitTimeRef r)+     let a' = a + delta+     a' `seq` writeIORef (facilityTotalWaitTimeRef r) a'+     modifyIORef' (facilityWaitTimeRef r) $+       addSamplingStats delta+     invokeEvent p $+       triggerSignal (facilityWaitTimeSource r) ()++-- | Update the facility holding time and its statistics.+updateFacilityHoldingTime :: Facility a -> Double -> Event ()+updateFacilityHoldingTime r delta =+  Event $ \p ->+  do a <- readIORef (facilityTotalHoldingTimeRef r)+     let a' = a + delta+     a' `seq` writeIORef (facilityTotalHoldingTimeRef r) a'+     modifyIORef' (facilityHoldingTimeRef r) $+       addSamplingStats delta+     invokeEvent p $+       triggerSignal (facilityHoldingTimeSource r) ()++-- | Reset the statistics.+resetFacility :: Facility a -> Event ()+resetFacility r =+  Event $ \p ->+  do let t = pointTime p+     count <- readIORef (facilityCountRef r)+     writeIORef (facilityCountStatsRef r) $+       returnTimingStats t count+     writeIORef (facilityCaptureCountRef r) 0+     utilCount <- readIORef (facilityUtilisationCountRef r)+     writeIORef (facilityUtilisationCountStatsRef r) $+       returnTimingStats t utilCount+     queueCount <- readIORef (facilityQueueCountRef r)+     writeIORef (facilityQueueCountStatsRef r) $+       returnTimingStats t queueCount+     writeIORef (facilityTotalWaitTimeRef r) 0+     writeIORef (facilityWaitTimeRef r) emptySamplingStats+     writeIORef (facilityTotalHoldingTimeRef r) 0+     writeIORef (facilityHoldingTimeRef r) emptySamplingStats+     invokeEvent p $+       triggerSignal (facilityCaptureCountSource r) 0+     invokeEvent p $+       triggerSignal (facilityWaitTimeSource r) ()+     invokeEvent p $+       triggerSignal (facilityHoldingTimeSource r) ()
+ Simulation/Aivika/GPSS/MatchChain.hs view
@@ -0,0 +1,98 @@++-- |+-- Module     : Simulation.Aivika.GPSS.MatchChain+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines a GPSS Match Chain.+--+module Simulation.Aivika.GPSS.MatchChain+       (MatchChain,+        newMatchChain,+        matchTransact,+        transactMatching,+        transactMatchingChanged,+        transactMatchingChangedByTransact_,+        transactMatchingChangedByAssemblySet_) where++import Data.IORef++import Control.Monad+import Control.Monad.Trans++import qualified Data.HashMap.Lazy as HM++import Simulation.Aivika+import Simulation.Aivika.GPSS.Transact+import Simulation.Aivika.GPSS.AssemblySet++-- | Represents a Match Chain.+data MatchChain =+  MatchChain { matchChainMap :: IORef (HM.HashMap AssemblySet ProcessId),+               matchChainSource :: SignalSource AssemblySet+             }++-- | Create a new Match Chain.+newMatchChain :: Simulation MatchChain+newMatchChain =+  do map <- liftIO $ newIORef HM.empty+     src <- newSignalSource+     return MatchChain { matchChainMap = map,+                         matchChainSource = src+                       }++-- | Match the transact.+matchTransact :: MatchChain -> Transact a -> Process ()+matchTransact chain t =+  do (map, set) <-+       liftEvent $+       do map <- liftIO $ readIORef (matchChainMap chain)+          set <- transactAssemblySet t+          return (map, set)+     case HM.lookup set map of+       Just pid ->+         liftEvent $+           do liftIO $ modifyIORef (matchChainMap chain) $+                HM.delete set+              yieldEvent $+                triggerSignal (matchChainSource chain) set+              reactivateProcess pid+       Nothing ->+         do liftEvent $+              do pid <- requireTransactProcessId t+                 liftIO $ modifyIORef (matchChainMap chain) $+                   HM.insert set pid+                 yieldEvent $+                   triggerSignal (matchChainSource chain) set+            passivateProcess++-- | Test whether there is a matching transact.+transactMatching :: MatchChain -> AssemblySet -> Event Bool+transactMatching chain set =+  do map <- liftIO $ readIORef (matchChainMap chain)+     return (HM.member set map)++-- | Signal each time the 'transactMatching' flag changes.+transactMatchingChangedByAssemblySet_ :: MatchChain -> AssemblySet -> Signal ()+transactMatchingChangedByAssemblySet_ chain set =+  mapSignal (const ()) $+  filterSignal (== set) $+  transactMatchingChanged chain++-- | Signal each time the 'transactMatching' flag changes.+transactMatchingChangedByTransact_ :: MatchChain -> Transact a -> Signal ()+transactMatchingChangedByTransact_ chain t =+  mapSignal (const ()) $+  filterSignalM pred $+  transactMatchingChanged chain+    where pred set =+            do set' <- transactAssemblySet t+               return (set == set')++-- | Signal each time the 'transactMatching' flag changes.+transactMatchingChanged :: MatchChain -> Signal AssemblySet+transactMatchingChanged chain =+  publishSignal (matchChainSource chain)
+ Simulation/Aivika/GPSS/Queue.hs view
@@ -0,0 +1,336 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Queue+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines a GPSS queue entity.+--+module Simulation.Aivika.GPSS.Queue+       (-- * Queue Types+        Queue,+        QueueEntry(..),+        -- * Creating Queue+        newQueue,+        -- * Queue Properties and Activities+        queueNull,+        queueContent,+        queueContentStats,+        enqueueCount,+        enqueueZeroEntryCount,+        queueWaitTime,+        queueNonZeroEntryWaitTime,+        queueRate,+        -- * Dequeuing and Enqueuing+        enqueue,+        dequeue,+        -- * Statistics Reset+        resetQueue,+        -- * Derived Signals for Properties+        queueNullChanged,+        queueNullChanged_,+        queueContentChanged,+        queueContentChanged_,+        enqueueCountChanged,+        enqueueCountChanged_,+        enqueueZeroEntryCountChanged,+        enqueueZeroEntryCountChanged_,+        queueWaitTimeChanged,+        queueWaitTimeChanged_,+        queueNonZeroEntryWaitTimeChanged,+        queueNonZeroEntryWaitTimeChanged_,+        queueRateChanged,+        queueRateChanged_,+        -- * Basic Signals+        enqueued,+        dequeued,+        -- * Overall Signal+        queueChanged_) where++import Data.IORef+import Data.Monoid+import Data.Maybe+import Data.Hashable++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika+import Simulation.Aivika.Internal.Specs+import Simulation.Aivika.Internal.Simulation+import Simulation.Aivika.Internal.Dynamics+import Simulation.Aivika.Internal.Event+import Simulation.Aivika.Internal.Process+import Simulation.Aivika.Signal+import Simulation.Aivika.Statistics++import Simulation.Aivika.GPSS.Transact++-- | Represents the queue entity.+data Queue =+  Queue { queueSequenceNo :: Int,+          queueContentRef :: IORef Int,+          queueContentStatsRef :: IORef (TimingStats Int),+          enqueueCountRef :: IORef Int,+          enqueueZeroEntryCountRef :: IORef Int,+          queueWaitTimeRef :: IORef (SamplingStats Double),+          queueNonZeroEntryWaitTimeRef :: IORef (SamplingStats Double),+          enqueuedSource :: SignalSource (),+          dequeuedSource :: SignalSource ()+        }++-- | The information about queue entry.+data QueueEntry =+  QueueEntry { entryQueue :: Queue,+               -- ^ the entry queue+               entryEnqueueTime :: Double+               -- ^ the time of registering the queue entry+             } deriving Eq++instance Eq Queue where+  x == y = (queueContentRef x) == (queueContentRef y)++instance Hashable Queue where+  hashWithSalt salt x = hashWithSalt salt (queueSequenceNo x)++-- | Create a new queue.+newQueue :: Event Queue  +newQueue =+  do t  <- liftDynamics time+     g  <- liftParameter generatorParameter+     no <- liftIO $ generateSequenceNo g+     i  <- liftIO $ newIORef 0+     is <- liftIO $ newIORef $ returnTimingStats t 0+     e  <- liftIO $ newIORef 0+     z  <- liftIO $ newIORef 0 +     w  <- liftIO $ newIORef mempty+     w2 <- liftIO $ newIORef mempty+     s1 <- liftSimulation $ newSignalSource+     s2 <- liftSimulation $ newSignalSource+     return Queue { queueSequenceNo = no,+                    queueContentRef = i,+                    queueContentStatsRef = is,+                    enqueueCountRef = e,+                    enqueueZeroEntryCountRef = z,+                    queueWaitTimeRef = w,+                    queueNonZeroEntryWaitTimeRef = w2,+                    enqueuedSource = s1,+                    dequeuedSource = s2 }+  +-- | Test whether the queue is empty.+--+-- See also 'queueNullChanged' and 'queueNullChanged_'.+queueNull :: Queue -> Event Bool+queueNull q =+  Event $ \p ->+  do n <- readIORef (queueContentRef q)+     return (n == 0)+  +-- | Signal when the 'queueNull' property value has changed.+queueNullChanged :: Queue -> Signal Bool+queueNullChanged q =+  mapSignalM (const $ queueNull q) (queueNullChanged_ q)+  +-- | Signal when the 'queueNull' property value has changed.+queueNullChanged_ :: Queue -> Signal ()+queueNullChanged_ = queueContentChanged_++-- | Return the current queue content.+--+-- See also 'queueContentStats', 'queueContentChanged' and 'queueContentChanged_'.+queueContent :: Queue -> Event Int+queueContent q =+  Event $ \p -> readIORef (queueContentRef q)++-- | Return the queue content statistics.+queueContentStats :: Queue -> Event (TimingStats Int)+queueContentStats q =+  Event $ \p -> readIORef (queueContentStatsRef q)+  +-- | Signal when the 'queueContent' property value has changed.+queueContentChanged :: Queue -> Signal Int+queueContentChanged q =+  mapSignalM (const $ queueContent q) (queueContentChanged_ q)+  +-- | Signal when the 'queueContent' property value has changed.+queueContentChanged_ :: Queue -> Signal ()+queueContentChanged_ q =+  mapSignal (const ()) (enqueued q) <>+  mapSignal (const ()) (dequeued q)++-- | Return the total number of input items that were enqueued.+--+-- See also 'enqueueCountChanged' and 'enqueueCountChanged_'.+enqueueCount :: Queue -> Event Int+enqueueCount q =+  Event $ \p -> readIORef (enqueueCountRef q)+  +-- | Signal when the 'enqueueCount' property value has changed.+enqueueCountChanged :: Queue -> Signal Int+enqueueCountChanged q =+  mapSignalM (const $ enqueueCount q) (enqueueCountChanged_ q)+  +-- | Signal when the 'enqueueCount' property value has changed.+enqueueCountChanged_ :: Queue -> Signal ()+enqueueCountChanged_ q =+  mapSignal (const ()) (enqueued q)++-- | Return the total number of zero entry items.+--+-- See also 'enqueueZeroEntryCountChanged' and 'enqueueZeroEntryCountChanged_'.+enqueueZeroEntryCount :: Queue -> Event Int+enqueueZeroEntryCount q =+  Event $ \p -> readIORef (enqueueZeroEntryCountRef q)+  +-- | Signal when the 'enqueueZeroEntryCount' property value has changed.+enqueueZeroEntryCountChanged :: Queue -> Signal Int+enqueueZeroEntryCountChanged q =+  mapSignalM (const $ enqueueZeroEntryCount q) (enqueueZeroEntryCountChanged_ q)+  +-- | Signal when the 'enqueueZeroEntryCount' property value has changed.+enqueueZeroEntryCountChanged_ :: Queue -> Signal ()+enqueueZeroEntryCountChanged_ q =+  mapSignal (const ()) (dequeued q)++-- | Return the wait (or residence) time.+--+-- See also 'queueWaitTimeChanged' and 'queueWaitTimeChanged_'.+queueWaitTime :: Queue -> Event (SamplingStats Double)+queueWaitTime q =+  Event $ \p -> readIORef (queueWaitTimeRef q)+      +-- | Signal when the 'queueWaitTime' property value has changed.+queueWaitTimeChanged :: Queue -> Signal (SamplingStats Double)+queueWaitTimeChanged q =+  mapSignalM (const $ queueWaitTime q) (queueWaitTimeChanged_ q)+  +-- | Signal when the 'queueWaitTime' property value has changed.+queueWaitTimeChanged_ :: Queue -> Signal ()+queueWaitTimeChanged_ q =+  mapSignal (const ()) (dequeued q)+      +-- | Return the wait (or residence) time excluding zero entries.+--+-- See also 'queueNonZeroEntryWaitTimeChanged' and 'queueNonZeroEntryWaitTimeChanged_'.+queueNonZeroEntryWaitTime :: Queue -> Event (SamplingStats Double)+queueNonZeroEntryWaitTime q =+  Event $ \p -> readIORef (queueNonZeroEntryWaitTimeRef q)+      +-- | Signal when the 'queueNonZeroEntryWaitTime' property value has changed.+queueNonZeroEntryWaitTimeChanged :: Queue -> Signal (SamplingStats Double)+queueNonZeroEntryWaitTimeChanged q =+  mapSignalM (const $ queueNonZeroEntryWaitTime q) (queueNonZeroEntryWaitTimeChanged_ q)+  +-- | Signal when the 'queueNonZeroEntryWaitTime' property value has changed.+queueNonZeroEntryWaitTimeChanged_ :: Queue -> Signal ()+queueNonZeroEntryWaitTimeChanged_ q =+  mapSignal (const ()) (dequeued q)++-- | Return a long-term average queue rate calculated as+-- the average queue content divided by the average wait time.+--+-- See also 'queueRateChanged' and 'queueRateChanged_'.+queueRate :: Queue -> Event Double+queueRate q =+  Event $ \p ->+  do x <- readIORef (queueContentStatsRef q)+     y <- readIORef (queueWaitTimeRef q)+     return (timingStatsMean x / samplingStatsMean y) +      +-- | Signal when the 'queueRate' property value has changed.+queueRateChanged :: Queue -> Signal Double+queueRateChanged q =+  mapSignalM (const $ queueRate q) (queueRateChanged_ q)+      +-- | Signal when the 'queueRate' property value has changed.+queueRateChanged_ :: Queue -> Signal ()+queueRateChanged_ q =+  mapSignal (const ()) (enqueued q) <>+  mapSignal (const ()) (dequeued q)++-- | Return a signal that notifies when enqueuing an item.+enqueued:: Queue -> Signal ()+enqueued q = publishSignal (enqueuedSource q)++-- | Return a signal that notifies when the dequeuing the item.+dequeued :: Queue -> Signal ()+dequeued q = publishSignal (dequeuedSource q)++-- | Enqueue the item.+enqueue :: Queue+           -- ^ the queue+           -> Transact a+           -- ^ the item to be enqueued+           -> Int+           -- ^ the content increment+           -> Event ()+enqueue q transact increment =+  Event $ \p ->+  do let t = pointTime p+         e = QueueEntry { entryQueue = q,+                          entryEnqueueTime = t }+     n <- readIORef (enqueueCountRef q)+     let n' = n + 1+     n' `seq` writeIORef (enqueueCountRef q) n'+     c <- readIORef (queueContentRef q)+     let c' = c + increment+     c' `seq` writeIORef (queueContentRef q) c'+     modifyIORef' (queueContentStatsRef q) (addTimingStats t c')+     invokeEvent p $+       registerTransactQueueEntry transact e+     invokeEvent p $+       triggerSignal (enqueuedSource q) ()++-- | Dequeue the item.+dequeue :: Queue+           -- ^ the queue+           -> Transact a+           -- ^ the item to be dequeued+           -> Int+           -- ^ the content decrement+           -> Event ()+dequeue q transact decrement =+  Event $ \p ->+  do e <- invokeEvent p $+          unregisterTransactQueueEntry transact q+     let t  = pointTime p+         t0 = entryEnqueueTime e+         dt = t - t0+     c <- readIORef (queueContentRef q)+     let c' = c - decrement+     c' `seq` writeIORef (queueContentRef q) c'+     modifyIORef' (queueContentStatsRef q) (addTimingStats t c')+     modifyIORef' (queueWaitTimeRef q) $+       addSamplingStats dt+     if t == t0+       then modifyIORef' (enqueueZeroEntryCountRef q) (+ 1)+       else modifyIORef' (queueNonZeroEntryWaitTimeRef q) $+            addSamplingStats dt+     invokeEvent p $+       triggerSignal (dequeuedSource q) ()++-- | Signal whenever any property of the queue changes.+--+-- The property must have the corresponded signal. There are also characteristics+-- similar to the properties but that have no signals. As a rule, such characteristics+-- already depend on the simulation time and therefore they may change at any+-- time point.+queueChanged_ :: Queue -> Signal ()+queueChanged_ q =+  mapSignal (const ()) (enqueued q) <>+  mapSignal (const ()) (dequeued q)++-- | Reset the statistics.+resetQueue :: Queue -> Event () +resetQueue q =+  do t  <- liftDynamics time+     content <- liftIO $ readIORef (queueContentRef q)+     liftIO $ writeIORef (queueContentStatsRef q) $+       returnTimingStats t content+     liftIO $ writeIORef (enqueueCountRef q) 0+     liftIO $ writeIORef (enqueueZeroEntryCountRef q) 0+     liftIO $ writeIORef (queueWaitTimeRef q) mempty+     liftIO $ writeIORef (queueNonZeroEntryWaitTimeRef q) mempty
+ Simulation/Aivika/GPSS/Queue.hs-boot view
@@ -0,0 +1,27 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Queue+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This is an hs-boot file.+--+module Simulation.Aivika.GPSS.Queue+       (Queue,+        QueueEntry,+        entryQueue) where++import Data.Hashable++data Queue+data QueueEntry++instance Eq Queue+instance Hashable Queue++instance Eq QueueEntry++entryQueue :: QueueEntry -> Queue
+ Simulation/Aivika/GPSS/Results.hs view
@@ -0,0 +1,175 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Results+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- The module allows exporting the simulation results from the model.+--+module Simulation.Aivika.GPSS.Results () where++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika++import qualified Simulation.Aivika.GPSS.Queue as Q+import Simulation.Aivika.GPSS.Facility+import Simulation.Aivika.GPSS.Storage+import Simulation.Aivika.GPSS.Results.Locale+  +-- | Return a source by the specified queue.+queueResultSource :: ResultContainer Q.Queue+                     -- ^ the queue container+                     -> ResultSource+queueResultSource c =+  ResultObjectSource $+  ResultObject {+    resultObjectName = resultContainerName c,+    resultObjectId = resultContainerId c,+    resultObjectTypeId = queueId,+    resultObjectSignal = resultContainerSignal c,+    resultObjectSummary = queueResultSummary c,+    resultObjectProperties = [+      resultContainerProperty c "queueNull" queueNullId Q.queueNull Q.queueNullChanged_,+      resultContainerProperty c "queueContent" queueContentId Q.queueContent Q.queueContentChanged_,+      resultContainerProperty c "queueContentStats" queueContentStatsId Q.queueContentStats Q.queueContentChanged_,+      resultContainerProperty c "enqueueCount" enqueueCountId Q.enqueueCount Q.enqueueCountChanged_,+      resultContainerProperty c "enqueueZeroEntryCount" enqueueZeroEntryCountId Q.enqueueZeroEntryCount Q.enqueueZeroEntryCountChanged_,+      resultContainerProperty c "queueWaitTime" queueWaitTimeId Q.queueWaitTime Q.queueWaitTimeChanged_,+      resultContainerProperty c "queueNonZeroEntryWaitTime" queueNonZeroEntryWaitTimeId Q.queueNonZeroEntryWaitTime Q.queueNonZeroEntryWaitTimeChanged_,+      resultContainerProperty c "queueRate" queueRateId Q.queueRate Q.queueRateChanged_ ] }++-- | Return the summary by the specified queue.+queueResultSummary :: ResultContainer Q.Queue+                      -- ^ the queue container+                      -> ResultSource+queueResultSummary c =+  ResultObjectSource $+  ResultObject {+    resultObjectName = resultContainerName c,+    resultObjectId = resultContainerId c,+    resultObjectTypeId = queueId,+    resultObjectSignal = resultContainerSignal c,+    resultObjectSummary = queueResultSummary c,+    resultObjectProperties = [+      resultContainerProperty c "queueContentStats" queueContentStatsId Q.queueContentStats Q.queueContentChanged_,+      resultContainerProperty c "enqueueCount" enqueueCountId Q.enqueueCount Q.enqueueCountChanged_,+      resultContainerProperty c "enqueueZeroEntryCount" enqueueZeroEntryCountId Q.enqueueZeroEntryCount Q.enqueueZeroEntryCountChanged_,+      resultContainerProperty c "queueWaitTime" queueWaitTimeId Q.queueWaitTime Q.queueWaitTimeChanged_,+      resultContainerProperty c "queueNonZeroEntryWaitTime" queueNonZeroEntryWaitTimeId Q.queueNonZeroEntryWaitTime Q.queueNonZeroEntryWaitTimeChanged_,+      resultContainerProperty c "queueRate" queueRateId Q.queueRate Q.queueRateChanged_ ] }++-- | Return a source by the specified facility.+facilityResultSource :: ResultContainer (Facility a)+                        -- ^ the facility container+                        -> ResultSource+facilityResultSource c =+  ResultObjectSource $+  ResultObject {+    resultObjectName = resultContainerName c,+    resultObjectId = resultContainerId c,+    resultObjectTypeId = facilityId,+    resultObjectSignal = resultContainerSignal c,+    resultObjectSummary = facilityResultSummary c,+    resultObjectProperties = [+      resultContainerProperty c "queueCount" facilityQueueCountId facilityQueueCount facilityQueueCountChanged_,+      resultContainerProperty c "queueCountStats" facilityQueueCountStatsId facilityQueueCountStats facilityQueueCountChanged_,+      resultContainerProperty c "totalWaitTime" facilityTotalWaitTimeId facilityTotalWaitTime facilityWaitTimeChanged_,+      resultContainerProperty c "waitTime" facilityWaitTimeId facilityWaitTime facilityWaitTimeChanged_,+      resultContainerProperty c "totalHoldingTime" facilityTotalHoldingTimeId facilityTotalHoldingTime facilityHoldingTimeChanged_,+      resultContainerProperty c "holdingTime" facilityHoldingTimeId facilityHoldingTime facilityHoldingTimeChanged_,+      resultContainerIntegProperty c "interrupted" facilityInterruptedId facilityInterrupted,+      resultContainerProperty c "count" facilityCountId facilityCount facilityCountChanged_,+      resultContainerProperty c "countStats" facilityCountStatsId facilityCountStats facilityCountChanged_,+      resultContainerProperty c "captureCount" facilityCaptureCountId facilityCaptureCount facilityCaptureCountChanged_,+      resultContainerProperty c "utilisationCount" facilityUtilisationCountId facilityUtilisationCount facilityUtilisationCountChanged_,+      resultContainerProperty c "utilisationCountStats" facilityUtilisationCountStatsId facilityUtilisationCountStats facilityUtilisationCountChanged_ ] }++-- | Return a summary by the specified facility.+facilityResultSummary :: ResultContainer (Facility a)+                         -- ^ the facility container+                         -> ResultSource+facilityResultSummary c =+  ResultObjectSource $+  ResultObject {+    resultObjectName = resultContainerName c,+    resultObjectId = resultContainerId c,+    resultObjectTypeId = facilityId,+    resultObjectSignal = resultContainerSignal c,+    resultObjectSummary = facilityResultSummary c,+    resultObjectProperties = [+      resultContainerProperty c "queueCountStats" facilityQueueCountStatsId facilityQueueCountStats facilityQueueCountChanged_,+      resultContainerProperty c "waitTime" facilityWaitTimeId facilityWaitTime facilityWaitTimeChanged_,+      resultContainerProperty c "holdingTime" facilityHoldingTimeId facilityHoldingTime facilityHoldingTimeChanged_,+      resultContainerProperty c "countStats" facilityCountStatsId facilityCountStats facilityCountChanged_,+      resultContainerProperty c "captureCount" facilityCaptureCountId facilityCaptureCount facilityCaptureCountChanged_,+      resultContainerProperty c "utilisationCountStats" facilityUtilisationCountStatsId facilityUtilisationCountStats facilityUtilisationCountChanged_ ] }++-- | Return a source by the specified storage.+storageResultSource :: ResultContainer Storage+                       -- ^ the storage container+                       -> ResultSource+storageResultSource c =+  ResultObjectSource $+  ResultObject {+    resultObjectName = resultContainerName c,+    resultObjectId = resultContainerId c,+    resultObjectTypeId = storageId,+    resultObjectSignal = resultContainerSignal c,+    resultObjectSummary = storageResultSummary c,+    resultObjectProperties = [+      resultContainerConstProperty c "capacity" storageCapacityId storageCapacity,+      resultContainerIntegProperty c "empty" storageEmptyId storageEmpty,+      resultContainerIntegProperty c "full" storageFullId storageFull,+      resultContainerProperty c "queueCount" storageQueueCountId storageQueueCount storageQueueCountChanged_,+      resultContainerProperty c "queueCountStats" storageQueueCountStatsId storageQueueCountStats storageQueueCountChanged_,+      resultContainerProperty c "totalWaitTime" storageTotalWaitTimeId storageTotalWaitTime storageWaitTimeChanged_,+      resultContainerProperty c "waitTime" storageWaitTimeId storageWaitTime storageWaitTimeChanged_,+      resultContainerIntegProperty c "averageHoldingTime" storageAverageHoldingTimeId storageAverageHoldingTime,+      resultContainerProperty c "content" storageContentId storageContent storageContentChanged_,+      resultContainerProperty c "contentStats" storageContentStatsId storageContentStats storageContentChanged_,+      resultContainerProperty c "useCount" storageUseCountId storageUseCount storageUseCountChanged_,+      resultContainerProperty c "usedContent" storageUsedContentId storageUsedContent storageUsedContentChanged_,+      resultContainerProperty c "utilisationCount" storageUtilisationCountId storageUtilisationCount storageUtilisationCountChanged_,+      resultContainerProperty c "utilisationCountStats" storageUtilisationCountStatsId storageUtilisationCountStats storageUtilisationCountChanged_ ] }++-- | Return a summary by the specified storage.+storageResultSummary :: ResultContainer Storage+                        -- ^ the storage container+                        -> ResultSource+storageResultSummary c =+  ResultObjectSource $+  ResultObject {+    resultObjectName = resultContainerName c,+    resultObjectId = resultContainerId c,+    resultObjectTypeId = storageId,+    resultObjectSignal = resultContainerSignal c,+    resultObjectSummary = storageResultSummary c,+    resultObjectProperties = [+      resultContainerConstProperty c "capacity" storageCapacityId storageCapacity,+      resultContainerProperty c "queueCountStats" storageQueueCountStatsId storageQueueCountStats storageQueueCountChanged_,+      resultContainerProperty c "waitTime" storageWaitTimeId storageWaitTime storageWaitTimeChanged_,+      resultContainerIntegProperty c "averageHoldingTime" storageAverageHoldingTimeId storageAverageHoldingTime,+      resultContainerProperty c "contentStats" storageContentStatsId storageContentStats storageContentChanged_,+      resultContainerProperty c "useCount" storageUseCountId storageUseCount storageUseCountChanged_,+      resultContainerProperty c "usedContent" storageUsedContentId storageUsedContent storageUsedContentChanged_,+      resultContainerProperty c "utilisationCountStats" storageUtilisationCountStatsId storageUtilisationCountStats storageUtilisationCountChanged_ ] }++instance ResultProvider Q.Queue where++  resultSource' name i m =+    queueResultSource $ ResultContainer name i m (ResultSignal $ Q.queueChanged_ m)++instance ResultProvider (Facility a) where++  resultSource' name i m =+    facilityResultSource $ ResultContainer name i m (ResultSignal $ facilityChanged_ m)++instance ResultProvider Storage where++  resultSource' name i m =+    storageResultSource $ ResultContainer name i m (ResultSignal $ storageChanged_ m)
+ Simulation/Aivika/GPSS/Results/Locale.hs view
@@ -0,0 +1,316 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Results.Locale+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- The module defines locales for the simulation results.+--+module Simulation.Aivika.GPSS.Results.Locale where++import qualified Data.Map as M++import Simulation.Aivika++import qualified Simulation.Aivika.GPSS.Queue as Q+import Simulation.Aivika.GPSS.Facility+import Simulation.Aivika.GPSS.Storage++-- | The queue identifier.+queueId :: ResultId+queueId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "очередь"),+   (englishResultLocale, "the queue")]++-- | Property 'Q.queueNull'.+queueNullId :: ResultId+queueNullId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "очередь пуста?"),+   (englishResultLocale, "is the queue empty?")]++-- | Property 'Q.queueContent'.+queueContentId :: ResultId+queueContentId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "текущее содержимое очереди"),+   (englishResultLocale, "the current queue content")]++-- | Property 'Q.queueContentStats'.+queueContentStatsId :: ResultId+queueContentStatsId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "статистика по содержимому очереди"),+   (englishResultLocale, "the queue content statistics")]++-- | Property 'Q.enqueueCount'.+enqueueCountId :: ResultId+enqueueCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "количество добавленных транзактов"),+   (englishResultLocale, "the number of enqueued transacts")]++-- | Property 'Q.enqueueZeroEntryCount'.+enqueueZeroEntryCountId :: ResultId+enqueueZeroEntryCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "количество добавленных транзактов без фактического ожидания"),+   (englishResultLocale, "the number of zero entry enqueued transacts")]++-- | Property 'Q.queueWaitTime'.+queueWaitTimeId :: ResultId+queueWaitTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "время ожидания"),+   (englishResultLocale, "the wait time")]++-- | Property 'Q.queueNonZeroEntryWaitTime'.+queueNonZeroEntryWaitTimeId :: ResultId+queueNonZeroEntryWaitTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "время ожидания без учета фактически неожидавших транзактов"),+   (englishResultLocale, "the wait time without zero entries")]++-- | Property 'Q.queueRate'.+queueRateId :: ResultId+queueRateId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "усредненная скорость (как средняя длина очереди на среднее время ожидания)"),+   (englishResultLocale, "the average queue rate (= queue size / wait time)")]++-- | The facility identifier.+facilityId :: ResultId+facilityId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "прибор"),+   (englishResultLocale, "the facility")]++-- | Property 'facilityCount'.+facilityCountId :: ResultId+facilityCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "текущее доступное количество прибора"),+   (englishResultLocale, "the current available count")]++-- | Property 'facilityCountStats'.+facilityCountStatsId :: ResultId+facilityCountStatsId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "статистика доступного количества прибора"),+   (englishResultLocale, "the available count statistics")]++-- | Property 'facilityCaptureCount'.+facilityCaptureCountId :: ResultId+facilityCaptureCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "текущее количество захвата прибора"),+   (englishResultLocale, "the current capture count")]++-- | Property 'facilityUtilisationCount'.+facilityUtilisationCountId :: ResultId+facilityUtilisationCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "текущее используемое количество прибора"),+   (englishResultLocale, "the current utilisation count")]++-- | Property 'facilityUtilisationCountStats'.+facilityUtilisationCountStatsId :: ResultId+facilityUtilisationCountStatsId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "статистка по используемому количеству прибора"),+   (englishResultLocale, "the utilisation count statistics")]++-- | Property 'facilityQueueCount'.+facilityQueueCountId :: ResultId+facilityQueueCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "текущая длина очереди к прибору"),+   (englishResultLocale, "the current queue size")]++-- | Property 'facilityQueueCountStats'.+facilityQueueCountStatsId :: ResultId+facilityQueueCountStatsId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "статистика длины очереди к прибору"),+   (englishResultLocale, "the queue size statistics")]++-- | Property 'facilityTotalWaitTime'.+facilityTotalWaitTimeId :: ResultId+facilityTotalWaitTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "общее время ожидания прибора"),+   (englishResultLocale, "the total wait time")]++-- | Property 'facilityWaitTime'.+facilityWaitTimeId :: ResultId+facilityWaitTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "время ожидания прибора"),+   (englishResultLocale, "the wait time")]++-- | Property 'facilityTotalHoldingTime'.+facilityTotalHoldingTimeId :: ResultId+facilityTotalHoldingTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "общее время удержания прибора"),+   (englishResultLocale, "the total holding time")]++-- | Property 'facilityHoldingTime'.+facilityHoldingTimeId :: ResultId+facilityHoldingTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "время удержания прибора"),+   (englishResultLocale, "the holding time")]++-- | Property 'facilityInterrupted'.+facilityInterruptedId :: ResultId+facilityInterruptedId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "удержание прибора сейчас прервано?"),+   (englishResultLocale, "is the facility interrupted now?")]++-- | The storage identifier.+storageId :: ResultId+storageId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "многоканальное устройство"),+   (englishResultLocale, "the storage")]++-- | Property 'storageCapacity'.+storageCapacityId :: ResultId+storageCapacityId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "емкость многоканального устройства"),+   (englishResultLocale, "the storage capacity")]++-- | Property 'storageEmpty'.+storageEmptyId :: ResultId+storageEmptyId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "не используется ли совсем устройство сейчас?"),+   (englishResultLocale, "is the storage unused completely now?")]++-- | Property 'storageFull'.+storageFullId :: ResultId+storageFullId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "используется ли устройство полностью сейчас?"),+   (englishResultLocale, "is the storage used completely now?")]++-- | Property 'storageContent'.+storageContentId :: ResultId+storageContentId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "доступное содержимое устройства"),+   (englishResultLocale, "the current available content")]++-- | Property 'storageContentStats'.+storageContentStatsId :: ResultId+storageContentStatsId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "статистика доступного содержимого устройства"),+   (englishResultLocale, "the available content statistics")]++-- | Property 'storageUseCount'.+storageUseCountId :: ResultId+storageUseCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "общее количество использований устройства"),+   (englishResultLocale, "the total use count")]++-- | Property 'storageUsedContent'.+storageUsedContentId :: ResultId+storageUsedContentId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "общее использованное количество устройства"),+   (englishResultLocale, "the total used content")]++-- | Property 'storageUtilisationCount'.+storageUtilisationCountId :: ResultId+storageUtilisationCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "текущее используемое количество устройства"),+   (englishResultLocale, "the current utilisation count")]++-- | Property 'storageUtilisationCountStats'.+storageUtilisationCountStatsId :: ResultId+storageUtilisationCountStatsId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "статистка по используемому количеству устройства"),+   (englishResultLocale, "the utilisation count statistics")]++-- | Property 'storageQueueCount'.+storageQueueCountId :: ResultId+storageQueueCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "текущая длина очереди к устройству"),+   (englishResultLocale, "the current queue size")]++-- | Property 'storageQueueCountStats'.+storageQueueCountStatsId :: ResultId+storageQueueCountStatsId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "статистика длины очереди к устройству"),+   (englishResultLocale, "the queue size statistics")]++-- | Property 'storageTotalWaitTime'.+storageTotalWaitTimeId :: ResultId+storageTotalWaitTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "общее время ожидания устройства"),+   (englishResultLocale, "the total wait time")]++-- | Property 'storageWaitTime'.+storageWaitTimeId :: ResultId+storageWaitTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "время ожидания устройства"),+   (englishResultLocale, "the wait time")]++-- | Property 'storageAverageHoldingTime'.+storageAverageHoldingTimeId :: ResultId+storageAverageHoldingTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "среднее время удержания устройства на единицу устройства"),+   (englishResultLocale, "the average holding time per unit")]
+ Simulation/Aivika/GPSS/Results/Transform.hs view
@@ -0,0 +1,214 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Results.Transform+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- The module defines transformations for the simulation results.+--+module Simulation.Aivika.GPSS.Results.Transform where++import Control.Category++import Simulation.Aivika+import qualified Simulation.Aivika.Results.Transform as T++import qualified Simulation.Aivika.GPSS.Queue as Q+import qualified Simulation.Aivika.GPSS.Facility as F+import qualified Simulation.Aivika.GPSS.Storage as S+import Simulation.Aivika.GPSS.Results+import Simulation.Aivika.GPSS.Results.Locale++-- | Represents the 'Q.Queue'.+newtype Queue = Queue ResultTransform++-- | An instance of the result transformer.+instance T.ResultTransformer Queue where+  tr (Queue a) = a++-- | Property 'Q.queueNull'.+queueNull :: Queue -> ResultTransform+queueNull (Queue a) =+  a >>> resultById queueNullId++-- | Property 'Q.queueContent'.+queueContent :: Queue -> ResultTransform+queueContent (Queue a) =+  a >>> resultById queueContentId++-- | Property 'Q.queueContentStats'.+queueContentStats :: Queue -> T.TimingStats+queueContentStats (Queue a) =+  T.TimingStats (a >>> resultById queueContentStatsId)++-- | Property 'Q.enqueueCount'.+enqueueCount :: Queue -> ResultTransform+enqueueCount (Queue a) =+  a >>> resultById enqueueCountId++-- | Property 'Q.enqueueZeroEntryCount'.+enqueueZeroEntryCount :: Queue -> ResultTransform+enqueueZeroEntryCount (Queue a) =+  a >>> resultById enqueueZeroEntryCountId++-- | Property 'Q.queueWaitTime'.+queueWaitTime :: Queue -> T.SamplingStats+queueWaitTime (Queue a) =+  T.SamplingStats (a >>> resultById queueWaitTimeId)++-- | Property 'Q.queueNonZeroEntryWaitTime'.+queueNonZeroEntryWaitTime :: Queue -> T.SamplingStats+queueNonZeroEntryWaitTime (Queue a) =+  T.SamplingStats (a >>> resultById queueNonZeroEntryWaitTimeId)++-- | Property 'Q.queueRate'.+queueRate :: Queue -> ResultTransform+queueRate (Queue a) =+  a >>> resultById queueRateId++-- | Represents the 'F.Facility'.+newtype Facility = Facility ResultTransform++-- | An instance of the result transformer.+instance T.ResultTransformer Facility where+  tr (Facility a) = a++-- | Property 'F.facilityCount'.+facilityCount :: Facility -> ResultTransform+facilityCount (Facility a) =+  a >>> resultById facilityCountId++-- | Property 'F.facilityCountStats'.+facilityCountStats :: Facility -> T.TimingStats+facilityCountStats (Facility a) =+  T.TimingStats (a >>> resultById facilityCountStatsId)++-- | Property 'F.facilityCaptureCount'.+facilityCaptureCount :: Facility -> ResultTransform+facilityCaptureCount (Facility a) =+  a >>> resultById facilityCaptureCountId++-- | Property 'F.facilityUtilisationCount'.+facilityUtilisationCount :: Facility -> ResultTransform+facilityUtilisationCount (Facility a) =+  a >>> resultById facilityUtilisationCountId++-- | Property 'F.facilityUtilisationCountStats'.+facilityUtilisationCountStats :: Facility -> T.TimingStats+facilityUtilisationCountStats (Facility a) =+  T.TimingStats (a >>> resultById facilityUtilisationCountStatsId)++-- | Property 'F.facilityQueueCount'.+facilityQueueCount :: Facility -> ResultTransform+facilityQueueCount (Facility a) =+  a >>> resultById facilityQueueCountId++-- | Property 'F.facilityQueueCountStats'.+facilityQueueCountStats :: Facility -> T.TimingStats+facilityQueueCountStats (Facility a) =+  T.TimingStats (a >>> resultById facilityQueueCountStatsId)++-- | Property 'F.facilityTotalWaitTime'.+facilityTotalWaitTime :: Facility -> ResultTransform+facilityTotalWaitTime (Facility a) =+  a >>> resultById facilityTotalWaitTimeId++-- | Property 'F.facilityWaitTime'.+facilityWaitTime :: Facility -> T.SamplingStats+facilityWaitTime (Facility a) =+  T.SamplingStats (a >>> resultById facilityWaitTimeId)++-- | Property 'F.facilityTotalHoldingTime'.+facilityTotalHoldingTime :: Facility -> ResultTransform+facilityTotalHoldingTime (Facility a) =+  a >>> resultById facilityTotalHoldingTimeId++-- | Property 'F.facilityHoldingTime'.+facilityHoldingTime :: Facility -> T.SamplingStats+facilityHoldingTime (Facility a) =+  T.SamplingStats (a >>> resultById facilityHoldingTimeId)++-- | Property 'F.facilityInterrupted'.+facilityInterrupted :: Facility -> ResultTransform+facilityInterrupted (Facility a) =+  a >>> resultById facilityInterruptedId++-- | Represents the 'S.Storage'.+newtype Storage = Storage ResultTransform++-- | An instance of the result transformer.+instance T.ResultTransformer Storage where+  tr (Storage a) = a++-- | Property 'S.storageCapacity'.+storageCapacity :: Storage -> ResultTransform+storageCapacity (Storage a) =+  a >>> resultById storageCapacityId++-- | Property 'S.storageEmpty'.+storageEmpty :: Storage -> ResultTransform+storageEmpty (Storage a) =+  a >>> resultById storageEmptyId++-- | Property 'S.storageFull'.+storageFull :: Storage -> ResultTransform+storageFull (Storage a) =+  a >>> resultById storageFullId++-- | Property 'S.storageContent'.+storageContent :: Storage -> ResultTransform+storageContent (Storage a) =+  a >>> resultById storageContentId++-- | Property 'S.storageContentStats'.+storageContentStats :: Storage -> T.TimingStats+storageContentStats (Storage a) =+  T.TimingStats (a >>> resultById storageContentStatsId)++-- | Property 'S.storageUseCount'.+storageUseCount :: Storage -> ResultTransform+storageUseCount (Storage a) =+  a >>> resultById storageUseCountId++-- | Property 'S.storageUsedContent'.+storageUsedContent :: Storage -> ResultTransform+storageUsedContent (Storage a) =+  a >>> resultById storageUsedContentId++-- | Property 'S.storageUtilisationCount'.+storageUtilisationCount :: Storage -> ResultTransform+storageUtilisationCount (Storage a) =+  a >>> resultById storageUtilisationCountId++-- | Property 'S.storageUtilisationCountStats'.+storageUtilisationCountStats :: Storage -> T.TimingStats+storageUtilisationCountStats (Storage a) =+  T.TimingStats (a >>> resultById storageUtilisationCountStatsId)++-- | Property 'S.storageQueueCount'.+storageQueueCount :: Storage -> ResultTransform+storageQueueCount (Storage a) =+  a >>> resultById storageQueueCountId++-- | Property 'S.storageQueueCountStats'.+storageQueueCountStats :: Storage -> T.TimingStats+storageQueueCountStats (Storage a) =+  T.TimingStats (a >>> resultById storageQueueCountStatsId)++-- | Property 'S.storageTotalWaitTime'.+storageTotalWaitTime :: Storage -> ResultTransform+storageTotalWaitTime (Storage a) =+  a >>> resultById storageTotalWaitTimeId++-- | Property 'S.storageWaitTime'.+storageWaitTime :: Storage -> T.SamplingStats+storageWaitTime (Storage a) =+  T.SamplingStats (a >>> resultById storageWaitTimeId)++-- | Property 'S.storageAverageHoldingTime'.+storageAverageHoldingTime :: Storage -> ResultTransform+storageAverageHoldingTime (Storage a) =+  a >>> resultById storageAverageHoldingTimeId
+ Simulation/Aivika/GPSS/Storage.hs view
@@ -0,0 +1,514 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Storage+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.1+--+-- This module defines the GPSS Storage entity.+--+module Simulation.Aivika.GPSS.Storage+       (-- * Storage Type+        Storage,+        -- * Creating Storage+        newStorage,+        -- * Storage Properties+        storageCapacity,+        storageEmpty,+        storageFull,+        storageContent,+        storageContentStats,+        storageUseCount,+        storageUsedContent,+        storageUtilisationCount,+        storageUtilisationCountStats,+        storageQueueCount,+        storageQueueCountStats,+        storageTotalWaitTime,+        storageWaitTime,+        storageAverageHoldingTime,+        -- * Entering-Leaving Storage+        enterStorage,+        leaveStorage,+        leaveStorageWithinEvent,+        -- * Statistics Reset+        resetStorage,+        -- * Signals+        storageContentChanged,+        storageContentChanged_,+        storageUseCountChanged,+        storageUseCountChanged_,+        storageUsedContentChanged,+        storageUsedContentChanged_,+        storageUtilisationCountChanged,+        storageUtilisationCountChanged_,+        storageQueueCountChanged,+        storageQueueCountChanged_,+        storageWaitTimeChanged,+        storageWaitTimeChanged_,+        storageChanged_) where++import Data.IORef+import Data.Monoid+import Data.Maybe++import Control.Monad+import Control.Monad.Trans+import Control.Exception++import Simulation.Aivika.Internal.Specs+import Simulation.Aivika.Internal.Simulation+import Simulation.Aivika.Internal.Event+import Simulation.Aivika.Internal.Cont+import Simulation.Aivika.Internal.Process+import Simulation.Aivika.QueueStrategy+import Simulation.Aivika.Statistics+import Simulation.Aivika.Signal++import Simulation.Aivika.GPSS.Transact+import Simulation.Aivika.GPSS.TransactQueueStrategy++-- | Represents a GPSS Storage entity.+data Storage = +  Storage { storageCapacity :: Int,+            -- ^ Return the storage capacity.+            storageContentRef :: IORef Int,+            storageContentStatsRef :: IORef (TimingStats Int),+            storageContentSource :: SignalSource Int,+            storageUseCountRef :: IORef Int,+            storageUseCountSource :: SignalSource Int,+            storageUsedContentRef :: IORef Int,+            storageUsedContentSource :: SignalSource Int,+            storageUtilisationCountRef :: IORef Int,+            storageUtilisationCountStatsRef :: IORef (TimingStats Int),+            storageUtilisationCountSource :: SignalSource Int,+            storageQueueCountRef :: IORef Int,+            storageQueueCountStatsRef :: IORef (TimingStats Int),+            storageQueueCountSource :: SignalSource Int,+            storageTotalWaitTimeRef :: IORef Double,+            storageWaitTimeRef :: IORef (SamplingStats Double),+            storageWaitTimeSource :: SignalSource (),+            storageDelayChain :: StrategyQueue (TransactQueueStrategy FCFS) StorageDelayedItem }++-- | Identifies an item that was delayed.+data StorageDelayedItem =+  StorageDelayedItem { delayedItemTime :: Double,+                       delayedItemDecrement :: Int,+                       delayedItemCont :: FrozenCont () }++instance Eq Storage where+  x == y = storageContentRef x == storageContentRef y  -- unique references++-- | Create a new storage by the specified capacity.+newStorage :: Int -> Event Storage+newStorage capacity =+  Event $ \p ->+  do let r = pointRun p+         t = pointTime p+     contentRef <- newIORef capacity+     contentStatsRef <- newIORef $ returnTimingStats t capacity+     contentSource <- invokeSimulation r newSignalSource+     useCountRef <- newIORef 0+     useCountSource <- invokeSimulation r newSignalSource+     usedContentRef <- newIORef 0+     usedContentSource <- invokeSimulation r newSignalSource+     utilCountRef <- newIORef 0+     utilCountStatsRef <- newIORef $ returnTimingStats t 0+     utilCountSource <- invokeSimulation r newSignalSource+     queueCountRef <- newIORef 0+     queueCountStatsRef <- newIORef $ returnTimingStats t 0+     queueCountSource <- invokeSimulation r newSignalSource+     totalWaitTimeRef <- newIORef 0+     waitTimeRef <- newIORef emptySamplingStats+     waitTimeSource <- invokeSimulation r newSignalSource+     delayChain <- invokeSimulation r $ newStrategyQueue (TransactQueueStrategy FCFS)+     return Storage { storageCapacity = capacity,+                      storageContentRef = contentRef,+                      storageContentStatsRef = contentStatsRef,+                      storageContentSource = contentSource,+                      storageUseCountRef = useCountRef,+                      storageUseCountSource = useCountSource,+                      storageUsedContentRef = usedContentRef,+                      storageUsedContentSource = usedContentSource,+                      storageUtilisationCountRef = utilCountRef,+                      storageUtilisationCountStatsRef = utilCountStatsRef,+                      storageUtilisationCountSource = utilCountSource,+                      storageQueueCountRef = queueCountRef,+                      storageQueueCountStatsRef = queueCountStatsRef,+                      storageQueueCountSource = queueCountSource,+                      storageTotalWaitTimeRef = totalWaitTimeRef,+                      storageWaitTimeRef = waitTimeRef,+                      storageWaitTimeSource = waitTimeSource,+                      storageDelayChain = delayChain }++-- | Whether the storage is empty, i.e. completely unused.+storageEmpty :: Storage -> Event Bool+storageEmpty r =+  Event $ \p ->+  do n <- readIORef (storageContentRef r)+     return (n == storageCapacity r)++-- | Whether the storage is full, i.e. completely used.+storageFull :: Storage -> Event Bool+storageFull r =+  Event $ \p ->+  do n <- readIORef (storageContentRef r)+     return (n == 0)++-- | Return the current storage content available for use.+storageContent :: Storage -> Event Int+storageContent r =+  Event $ \p -> readIORef (storageContentRef r)++-- | Return the statistics of the storage content available for use.+storageContentStats :: Storage -> Event (TimingStats Int)+storageContentStats r =+  Event $ \p -> readIORef (storageContentStatsRef r)++-- | Signal triggered when the 'storageContent' property changes.+storageContentChanged :: Storage -> Signal Int+storageContentChanged r =+  publishSignal $ storageContentSource r++-- | Signal triggered when the 'storageContent' property changes.+storageContentChanged_ :: Storage -> Signal ()+storageContentChanged_ r =+  mapSignal (const ()) $ storageContentChanged r++-- | Return the total use count of the storage.+storageUseCount :: Storage -> Event Int+storageUseCount r =+  Event $ \p -> readIORef (storageUseCountRef r)++-- | Signal triggered when the 'storageUseCount' property changes.+storageUseCountChanged :: Storage -> Signal Int+storageUseCountChanged r =+  publishSignal $ storageUseCountSource r++-- | Signal triggered when the 'storageUseCount' property changes.+storageUseCountChanged_ :: Storage -> Signal ()+storageUseCountChanged_ r =+  mapSignal (const ()) $ storageUseCountChanged r++-- | Return the total used content of the storage.+storageUsedContent :: Storage -> Event Int+storageUsedContent r =+  Event $ \p -> readIORef (storageUsedContentRef r)++-- | Signal triggered when the 'storageUsedContent' property changes.+storageUsedContentChanged :: Storage -> Signal Int+storageUsedContentChanged r =+  publishSignal $ storageUsedContentSource r++-- | Signal triggered when the 'storageUsedContent' property changes.+storageUsedContentChanged_ :: Storage -> Signal ()+storageUsedContentChanged_ r =+  mapSignal (const ()) $ storageUsedContentChanged r++-- | Return the current utilisation count of the storage.+storageUtilisationCount :: Storage -> Event Int+storageUtilisationCount r =+  Event $ \p -> readIORef (storageUtilisationCountRef r)++-- | Return the statistics for the utilisation count of the storage.+storageUtilisationCountStats :: Storage -> Event (TimingStats Int)+storageUtilisationCountStats r =+  Event $ \p -> readIORef (storageUtilisationCountStatsRef r)++-- | Signal triggered when the 'storageUtilisationCount' property changes.+storageUtilisationCountChanged :: Storage -> Signal Int+storageUtilisationCountChanged r =+  publishSignal $ storageUtilisationCountSource r++-- | Signal triggered when the 'storageUtilisationCount' property changes.+storageUtilisationCountChanged_ :: Storage -> Signal ()+storageUtilisationCountChanged_ r =+  mapSignal (const ()) $ storageUtilisationCountChanged r++-- | Return the current queue length of the storage.+storageQueueCount :: Storage -> Event Int+storageQueueCount r =+  Event $ \p -> readIORef (storageQueueCountRef r)++-- | Return the statistics for the queue length of the storage.+storageQueueCountStats :: Storage -> Event (TimingStats Int)+storageQueueCountStats r =+  Event $ \p -> readIORef (storageQueueCountStatsRef r)++-- | Signal triggered when the 'storageQueueCount' property changes.+storageQueueCountChanged :: Storage -> Signal Int+storageQueueCountChanged r =+  publishSignal $ storageQueueCountSource r++-- | Signal triggered when the 'storageQueueCount' property changes.+storageQueueCountChanged_ :: Storage -> Signal ()+storageQueueCountChanged_ r =+  mapSignal (const ()) $ storageQueueCountChanged r++-- | Return the total wait time of the storage.+storageTotalWaitTime :: Storage -> Event Double+storageTotalWaitTime r =+  Event $ \p -> readIORef (storageTotalWaitTimeRef r)++-- | Return the statistics for the wait time of the storage.+storageWaitTime :: Storage -> Event (SamplingStats Double)+storageWaitTime r =+  Event $ \p -> readIORef (storageWaitTimeRef r)++-- | Signal triggered when the 'storageTotalWaitTime' and 'storageWaitTime' properties change.+storageWaitTimeChanged :: Storage -> Signal (SamplingStats Double)+storageWaitTimeChanged r =+  mapSignalM (\() -> storageWaitTime r) $ storageWaitTimeChanged_ r++-- | Signal triggered when the 'storageTotalWaitTime' and 'storageWaitTime' properties change.+storageWaitTimeChanged_ :: Storage -> Signal ()+storageWaitTimeChanged_ r =+  publishSignal $ storageWaitTimeSource r++-- | Return the average holding time per unit.+storageAverageHoldingTime :: Storage -> Event Double+storageAverageHoldingTime r =+  Event $ \p ->+  do s <- readIORef (storageUtilisationCountStatsRef r)+     n <- readIORef (storageUtilisationCountRef r)+     m <- readIORef (storageUsedContentRef r)+     let t  = pointTime p+         s' = addTimingStats t n s+         k  = timingStatsSum s' / (fromRational $ toRational m)+     return k++-- | Enter the storage.+enterStorage :: Storage+                -- ^ the requested storage+                -> Transact a+                -- ^ a transact that makes the request+                -> Int+                -- ^ the content decrement+                -> Process ()+enterStorage r transact decrement =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do let t = pointTime p+     f <- invokeEvent p $ strategyQueueNull (storageDelayChain r)+     if f+       then invokeEvent p $+            invokeCont c $+            invokeProcess pid $+            enterStorage' r transact decrement+       else do c <- invokeEvent p $+                    freezeContReentering c () $+                    invokeCont c $+                    invokeProcess pid $+                    enterStorage r transact decrement+               invokeEvent p $+                 strategyEnqueueWithPriority+                 (storageDelayChain r)+                 (transactPriority transact)+                 (StorageDelayedItem t decrement c)+               invokeEvent p $ updateStorageQueueCount r 1+               +-- | Enter the storage.+enterStorage' :: Storage+                 -- ^ the requested storage+                 -> Transact a+                 -- ^ a transact that makes the request+                 -> Int+                 -- ^ the content decrement+                 -> Process ()+enterStorage' r transact decrement =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do let t = pointTime p+     a <- readIORef (storageContentRef r)+     if a < decrement+       then do c <- invokeEvent p $+                    freezeContReentering c () $+                    invokeCont c $+                    invokeProcess pid $+                    enterStorage r transact decrement+               invokeEvent p $+                 strategyEnqueueWithPriority+                 (storageDelayChain r)+                 (transactPriority transact)+                 (StorageDelayedItem t decrement c)+               invokeEvent p $ updateStorageQueueCount r 1+       else do invokeEvent p $ updateStorageWaitTime r 0+               invokeEvent p $ updateStorageContent r (- decrement)+               invokeEvent p $ updateStorageUseCount r 1+               invokeEvent p $ updateStorageUsedContent r decrement+               invokeEvent p $ updateStorageUtilisationCount r decrement+               invokeEvent p $ resumeCont c ()++-- | Leave the storage.+leaveStorage :: Storage+                -- ^ the storage to leave+                -> Int+                -- ^ the content increment+                -> Process ()+leaveStorage r increment =+  Process $ \_ ->+  Cont $ \c ->+  Event $ \p ->+  do invokeEvent p $ leaveStorageWithinEvent r increment+     invokeEvent p $ resumeCont c ()++-- | Leave the storage.+leaveStorageWithinEvent :: Storage+                           -- ^ the storage to leave+                           -> Int+                           -- ^ the content increment+                           -> Event ()+leaveStorageWithinEvent r increment =+  Event $ \p ->+  do let t = pointTime p+     invokeEvent p $ updateStorageUtilisationCount r (- increment)+     invokeEvent p $ updateStorageContent r increment+     invokeEvent p $ enqueueEvent t $ tryEnterStorage r++-- | Try to enter the storage.+tryEnterStorage :: Storage -> Event ()+tryEnterStorage r =+  Event $ \p ->+  do let t = pointTime p+     a <- readIORef (storageContentRef r)+     if a > 0+       then invokeEvent p $ letEnterStorage r+       else return ()++-- | Let enter the storage.+letEnterStorage :: Storage -> Event ()+letEnterStorage r =+  Event $ \p ->+  do let t = pointTime p+     a <- readIORef (storageContentRef r)+     when (a > storageCapacity r) $+       throwIO $+       SimulationRetry $+       "The storage content cannot exceed the limited capacity: leaveStorage'"+     x <- invokeEvent p $+          strategyQueueDeleteBy+          (storageDelayChain r)+          (\i -> delayedItemDecrement i <= a)+     case x of+       Nothing -> return ()+       Just (StorageDelayedItem t0 decrement0 c0) ->+         do invokeEvent p $ updateStorageQueueCount r (-1)+            c <- invokeEvent p $ unfreezeCont c0+            case c of+              Nothing ->+                invokeEvent p $ letEnterStorage r+              Just c ->+                do invokeEvent p $ updateStorageContent r (- decrement0)+                   invokeEvent p $ updateStorageWaitTime r (t - t0)+                   invokeEvent p $ updateStorageUtilisationCount r decrement0+                   invokeEvent p $ updateStorageUseCount r 1+                   invokeEvent p $ updateStorageUsedContent r decrement0+                   invokeEvent p $ enqueueEvent t $ reenterCont c ()++-- | Signal triggered when one of the storage counters changes.+storageChanged_ :: Storage -> Signal ()+storageChanged_ r =+  storageContentChanged_ r <>+  storageUsedContentChanged_ r <>+  storageUtilisationCountChanged_ r <>+  storageQueueCountChanged_ r++-- | Update the storage content and its statistics.+updateStorageContent :: Storage -> Int -> Event ()+updateStorageContent r delta =+  Event $ \p ->+  do a <- readIORef (storageContentRef r)+     let a' = a + delta+     a' `seq` writeIORef (storageContentRef r) a'+     modifyIORef' (storageContentStatsRef r) $+       addTimingStats (pointTime p) a'+     invokeEvent p $+       triggerSignal (storageContentSource r) a'++-- | Update the storage use count.+updateStorageUseCount :: Storage -> Int -> Event ()+updateStorageUseCount r delta =+  Event $ \p ->+  do a <- readIORef (storageUseCountRef r)+     let a' = a + delta+     a' `seq` writeIORef (storageUseCountRef r) a'+     invokeEvent p $+       triggerSignal (storageUseCountSource r) a'++-- | Update the storage used content.+updateStorageUsedContent :: Storage -> Int -> Event ()+updateStorageUsedContent r delta =+  Event $ \p ->+  do a <- readIORef (storageUsedContentRef r)+     let a' = a + delta+     a' `seq` writeIORef (storageUsedContentRef r) a'+     invokeEvent p $+       triggerSignal (storageUsedContentSource r) a'++-- | Update the storage queue length and its statistics.+updateStorageQueueCount :: Storage -> Int -> Event ()+updateStorageQueueCount r delta =+  Event $ \p ->+  do a <- readIORef (storageQueueCountRef r)+     let a' = a + delta+     a' `seq` writeIORef (storageQueueCountRef r) a'+     modifyIORef' (storageQueueCountStatsRef r) $+       addTimingStats (pointTime p) a'+     invokeEvent p $+       triggerSignal (storageQueueCountSource r) a'++-- | Update the storage utilisation count and its statistics.+updateStorageUtilisationCount :: Storage -> Int -> Event ()+updateStorageUtilisationCount r delta =+  Event $ \p ->+  do a <- readIORef (storageUtilisationCountRef r)+     let a' = a + delta+     a' `seq` writeIORef (storageUtilisationCountRef r) a'+     modifyIORef' (storageUtilisationCountStatsRef r) $+       addTimingStats (pointTime p) a'+     invokeEvent p $+       triggerSignal (storageUtilisationCountSource r) a'++-- | Update the storage wait time and its statistics.+updateStorageWaitTime :: Storage -> Double -> Event ()+updateStorageWaitTime r delta =+  Event $ \p ->+  do a <- readIORef (storageTotalWaitTimeRef r)+     let a' = a + delta+     a' `seq` writeIORef (storageTotalWaitTimeRef r) a'+     modifyIORef' (storageWaitTimeRef r) $+       addSamplingStats delta+     invokeEvent p $+       triggerSignal (storageWaitTimeSource r) ()++-- | Reset the statistics.+resetStorage :: Storage -> Event ()+resetStorage r =+  Event $ \p ->+  do let t = pointTime p+     content <- readIORef (storageContentRef r)+     writeIORef (storageContentStatsRef r) $+       returnTimingStats t content+     writeIORef (storageUseCountRef r) 0+     let usedContent = storageCapacity r - content+     writeIORef (storageUsedContentRef r) usedContent+     utilCount <- readIORef (storageUtilisationCountRef r)+     writeIORef (storageUtilisationCountStatsRef r) $+       returnTimingStats t utilCount+     queueCount <- readIORef (storageQueueCountRef r)+     writeIORef (storageQueueCountStatsRef r) $+       returnTimingStats t queueCount+     writeIORef (storageTotalWaitTimeRef r) 0+     writeIORef (storageWaitTimeRef r) emptySamplingStats+     invokeEvent p $+       triggerSignal (storageUseCountSource r) 0+     invokeEvent p $+       triggerSignal (storageUsedContentSource r) usedContent+     invokeEvent p $+       triggerSignal (storageUtilisationCountSource r) utilCount+     invokeEvent p $+       triggerSignal (storageWaitTimeSource r) ()
+ Simulation/Aivika/GPSS/Transact.hs view
@@ -0,0 +1,302 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Transact+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines a GPSS transact.+--+module Simulation.Aivika.GPSS.Transact+       (Transact,+        transactValue,+        transactArrivalDelay,+        transactArrivalTime,+        transactPriority,+        transactAssemblySet,+        newTransact,+        splitTransact,+        assignTransactValue,+        assignTransactValueM,+        assignTransactPriority,+        takeTransact,+        releaseTransact,+        transactPreemptionBegin,+        transactPreemptionEnd,+        requireTransactProcessId,+        transferTransact,+        reactivateTransacts,+        registerTransactQueueEntry,+        unregisterTransactQueueEntry) where++import Control.Monad+import Control.Monad.Trans+import Control.Exception++import Data.IORef+import qualified Data.HashMap.Lazy as HM++import Simulation.Aivika+import Simulation.Aivika.Internal.Specs+import Simulation.Aivika.Internal.Simulation+import Simulation.Aivika.Internal.Event+import Simulation.Aivika.Internal.Cont+import Simulation.Aivika.Internal.Process++import {-# SOURCE #-} Simulation.Aivika.GPSS.Queue+import {-# SOURCE #-} Simulation.Aivika.GPSS.AssemblySet++-- | Represents a GPSS transact.+data Transact a =+  Transact { transactValue :: a,+             -- ^ The data of the transact.+             transactArrivalDelay :: Maybe Double,+             -- ^ The delay between the transacts generated.+             transactArrivalTime :: Double,+             -- ^ The time at which the transact was generated.+             transactPriority :: Int,+             -- ^ The transact priority.+             transactAssemblySetRef :: IORef (Maybe AssemblySet),+             -- ^ The assembly set.+             transactPreemptionCountRef :: IORef Int,+             -- ^ How many times the transact is preempted.+             transactProcessIdRef :: IORef (Maybe ProcessId),+             -- ^ An identifier of the process that handles the transact at present+             transactProcessContRef :: IORef (Maybe (FrozenCont ())),+             -- ^ A continuation of the process that tried to handle the transact.+             transactQueueEntryRef :: IORef (HM.HashMap Queue QueueEntry)+             -- ^ The queue entries registered by the the transact.+           }++instance Eq (Transact a) where+  x == y = (transactProcessIdRef x) == (transactProcessIdRef y)++-- | Create a new transact.+newTransact :: Arrival a+               -- ^ the arrival data+               -> Int+               -- ^ the transact priority+               -> Simulation (Transact a)+newTransact a priority =+  Simulation $ \r ->+  do r0 <- newIORef 0+     r1 <- newIORef Nothing+     r2 <- newIORef Nothing+     r3 <- newIORef HM.empty+     r4 <- newIORef Nothing+     return Transact { transactValue = arrivalValue a,+                       transactArrivalDelay = arrivalDelay a,+                       transactArrivalTime = arrivalTime a,+                       transactPriority = priority,+                       transactAssemblySetRef = r4,+                       transactPreemptionCountRef = r0,+                       transactProcessIdRef = r1,+                       transactProcessContRef = r2,+                       transactQueueEntryRef = r3+                     }++-- | Split the transact.+splitTransact :: Transact a -> Simulation (Transact a)+splitTransact t =+  Simulation $ \r ->+  do r0 <- newIORef 0+     r1 <- newIORef Nothing+     r2 <- newIORef Nothing+     r3 <- newIORef HM.empty+     return Transact { transactValue = transactValue t,+                       transactArrivalDelay = transactArrivalDelay t,+                       transactArrivalTime = transactArrivalTime t,+                       transactPriority = transactPriority t,+                       transactAssemblySetRef = transactAssemblySetRef t,+                       transactPreemptionCountRef = r0,+                       transactProcessIdRef = r1,+                       transactProcessContRef = r2,+                       transactQueueEntryRef = r3+                     }++-- | Return the transact assembly set.+transactAssemblySet :: Transact a -> Event AssemblySet+transactAssemblySet t =+  Event $ \p ->+  do let r = pointRun p+     x <- readIORef (transactAssemblySetRef t)+     case x of+       Just a  -> return a+       Nothing ->+         do a <- invokeSimulation r newAssemblySet+            writeIORef (transactAssemblySetRef t) (Just a)+            return a++-- | Take the transact.+takeTransact :: Transact a -> Process ()+takeTransact t =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do pid0 <- readIORef (transactProcessIdRef t)+     case pid0 of+       Just pid0 ->+         throwIO $+         SimulationRetry+         "The transact is acquired by another process: takeTransact"+       Nothing   ->+         do writeIORef (transactProcessIdRef t) (Just pid)+            n <- readIORef (transactPreemptionCountRef t)+            if n == 0+              then invokeEvent p $ resumeCont c ()+              else do c <- invokeEvent p $+                           freezeContReentering c () $+                           invokeCont c $+                           invokeProcess pid $+                           takeTransact t+                      writeIORef (transactProcessContRef t) (Just c)+                      forM_ [1 .. n] $ \_ ->+                        invokeEvent p $+                        processPreemptionBegin pid++-- | Release the transact.+releaseTransact :: Transact a -> Process ()+releaseTransact t =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do pid0 <- readIORef (transactProcessIdRef t)+     case pid0 of+       Nothing ->+         throwIO $+         SimulationRetry+         "The transact is not acquired by any process: releaseTransact"+       Just pid0 | pid0 /= pid ->+         throwIO $+         SimulationRetry+         "The transact is acquired by another process: releaseTransact"+       Just pid0 ->+         do writeIORef (transactProcessIdRef t) Nothing+            writeIORef (transactProcessContRef t) Nothing+            invokeEvent p $ resumeCont c ()++-- | Preempt the computation that handles the transact.+transactPreemptionBegin :: Transact a -> Event ()+transactPreemptionBegin t =+  Event $ \p ->+  do n <- readIORef (transactPreemptionCountRef t)+     let n' = n + 1+     n' `seq` writeIORef (transactPreemptionCountRef t) n'+     pid <- readIORef (transactProcessIdRef t)+     case pid of+       Nothing  -> return ()+       Just pid -> invokeEvent p $ processPreemptionBegin pid++-- | Proceed with the computation after the transact was preempted earlier.+transactPreemptionEnd :: Transact a -> Event ()+transactPreemptionEnd t =+  Event $ \p ->+  do n <- readIORef (transactPreemptionCountRef t)+     let n' = n - 1+     unless (n' >= 0) $+       throwIO $+       SimulationRetry+       "The transact preemption count cannot be negative: transactPreemptionEnd"+     n' `seq` writeIORef (transactPreemptionCountRef t) n'+     pid <- readIORef (transactProcessIdRef t)+     case pid of+       Nothing  -> return ()+       Just pid ->+         do invokeEvent p $ processPreemptionEnd pid+            c <- readIORef (transactProcessContRef t)+            case c of+              Nothing -> return ()+              Just c  ->+                do writeIORef (transactProcessContRef t) Nothing+                   c <- invokeEvent p $ unfreezeCont c+                   case c of+                     Nothing -> return ()+                     Just c  -> invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c ()++-- | Require to return an identifier of the process associated with the transact.+requireTransactProcessId :: Transact a -> Event ProcessId+requireTransactProcessId t =+  Event $ \p ->+  do a <- readIORef (transactProcessIdRef t)+     case a of+       Nothing ->+         throwIO $+         SimulationRetry+         "The transact must be associated with any process: requireTransactProcessId"+       Just pid ->+         return pid++-- | Like the GoTo statement, it associates the transact with another process.+transferTransact :: Transact a -> Process () -> Event ()+transferTransact t transfer =+  Event $ \p ->+  do a <- readIORef (transactProcessIdRef t)+     case a of+       Nothing  -> return ()+       Just pid ->+         invokeEvent p $ cancelProcessWithId pid+     writeIORef (transactProcessIdRef t) Nothing+     writeIORef (transactProcessContRef t) Nothing+     invokeEvent p $+       runProcess $+       do takeTransact t+          transferProcess transfer++-- | Register the queue entry in the transact.+registerTransactQueueEntry :: Transact a -> QueueEntry -> Event ()+registerTransactQueueEntry t e =+  Event $ \p ->+  do let q = entryQueue e+     m <- readIORef (transactQueueEntryRef t)+     case HM.lookup q m of+       Just e0 ->+         throwIO $+         SimulationRetry+         "There is already another queue entry for the specified queue: registerTransactQueueEntry"+       Nothing ->+         writeIORef (transactQueueEntryRef t) (HM.insert q e m)++-- | Unregister the queue entry from the transact.+unregisterTransactQueueEntry :: Transact a -> Queue -> Event QueueEntry+unregisterTransactQueueEntry t q =+  Event $ \p ->+  do m <- readIORef (transactQueueEntryRef t)+     case HM.lookup q m of+       Nothing ->+         throwIO $+         SimulationRetry+         "There is no queue entry for the specified queue: unregisterTransactQueueEntry"+       Just e  ->+         do writeIORef (transactQueueEntryRef t) (HM.delete q m)+            return e++-- | Assign the transact value and return a new version of the same transact.+assignTransactValue :: Transact a -> (a -> b) -> Transact b+assignTransactValue t f =+  let b = f (transactValue t)+  in t { transactValue = b }++-- | Assign the transact value and return a new version of the same transact.+assignTransactValueM :: Monad c => Transact a -> (a -> c b) -> c (Transact b)+{-# INLINABLE assignTransactValue #-}+assignTransactValueM t f =+  do b <- f (transactValue t)+     return t { transactValue = b }++-- | Assign the priority and return a new version of the same transact.+assignTransactPriority :: Transact a -> Int -> Transact a+assignTransactPriority t priority =+  t { transactPriority = priority }++-- | Reactivate the transacts or transfer them to the specified computations.+reactivateTransacts :: [(Transact a, Maybe (Process ()))] -> Event ()+reactivateTransacts [] = return ()+reactivateTransacts ((t, Nothing): xs) =+  do pid <- requireTransactProcessId t+     reactivateProcess pid+     reactivateTransacts xs+reactivateTransacts ((t, Just transfer): xs) =+  do transferTransact t transfer+     reactivateTransacts xs
+ Simulation/Aivika/GPSS/TransactQueueStrategy.hs view
@@ -0,0 +1,166 @@++{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}++-- |+-- Module     : Simulation.Aivika.GPSS.TransactQueueStrategy+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines a GPSS transact queue strategy.+--+module Simulation.Aivika.GPSS.TransactQueueStrategy+       (TransactQueueStrategy(..),+        transactStrategyQueueDeleteBy,+        transactStrategyQueueContainsBy) where++import Control.Monad+import Control.Monad.Trans++import Data.IORef+import qualified Data.IntMap as M++import Simulation.Aivika+import qualified Simulation.Aivika.DoubleLinkedList as DLL++-- | The transact queue strategy.+data TransactQueueStrategy s = TransactQueueStrategy s++-- | An implementation of the 'QueueStrategy' class.+instance QueueStrategy (TransactQueueStrategy s) where++  -- | A queue used by the 'TransactQueueStrategy' strategy.+  data StrategyQueue (TransactQueueStrategy s) a =+    TransactStrategyQueue { transactStrategy :: TransactQueueStrategy s,+                            -- ^ the strategy itself+                            transactStrategyQueue :: IORef (M.IntMap (DLL.DoubleLinkedList a))+                            -- ^ the transact queue+                          }++  newStrategyQueue s =+    liftIO $+    do r <- newIORef M.empty+       return $ TransactStrategyQueue s r++  strategyQueueNull q =+    liftIO $+    do m <- readIORef (transactStrategyQueue q)+       return $ M.null m++instance DequeueStrategy (TransactQueueStrategy FCFS) where++  strategyDequeue q =+    liftIO $ +    do m <- readIORef (transactStrategyQueue q)+       let (k, xs) = M.findMin m+       i <- DLL.listFirst xs+       DLL.listRemoveFirst xs+       empty <- DLL.listNull xs+       when empty $+         modifyIORef (transactStrategyQueue q) $+         M.delete k+       return i++instance DequeueStrategy (TransactQueueStrategy LCFS) where++  strategyDequeue q =+    liftIO $ +    do m <- readIORef (transactStrategyQueue q)+       let (k, xs) = M.findMin m+       i <- DLL.listLast xs+       DLL.listRemoveLast xs+       empty <- DLL.listNull xs+       when empty $+         modifyIORef (transactStrategyQueue q) $+         M.delete k+       return i++instance DequeueStrategy (TransactQueueStrategy s) => PriorityQueueStrategy (TransactQueueStrategy s) Int where++  {-# SPECIALISE instance PriorityQueueStrategy (TransactQueueStrategy FCFS) Int #-}+  {-# SPECIALISE instance PriorityQueueStrategy (TransactQueueStrategy LCFS) Int #-}+  +  strategyEnqueueWithPriority q priority i =+    liftIO $+    do m <- readIORef (transactStrategyQueue q)+       let k  = - priority+           xs = M.lookup k m+       case xs of+         Nothing ->+           do xs <- DLL.newList+              DLL.listAddLast xs i+              modifyIORef (transactStrategyQueue q) $+                M.insert k xs+         Just xs ->+           DLL.listAddLast xs i++instance DeletingQueueStrategy (TransactQueueStrategy FCFS) where++  strategyQueueDeleteBy q pred =+    liftIO $+    do m <- readIORef (transactStrategyQueue q)+       let loop [] = return Nothing+           loop ((k, xs): tail) =+             do a <- DLL.listRemoveBy xs pred+                case a of+                  Nothing -> loop tail+                  Just _  ->+                    do empty <- DLL.listNull xs+                       when empty $+                         modifyIORef (transactStrategyQueue q) $+                         M.delete k+                       return a+       loop (M.assocs m)++  strategyQueueContainsBy q pred =+    liftIO $+    do m <- readIORef (transactStrategyQueue q)+       let loop [] = return Nothing+           loop ((k, xs): tail) =+             do a <- DLL.listContainsBy xs pred+                case a of+                  Nothing -> loop tail+                  Just _  -> return a+       loop (M.assocs m)++-- | Try to delete the transact by the specified priority and satisfying to the provided predicate.+transactStrategyQueueDeleteBy :: StrategyQueue (TransactQueueStrategy s) a+                                 -- ^ the queue+                                 -> Int+                                 -- ^ the transact priority+                                 -> (a -> Bool)+                                 -- ^ the predicate+                                 -> Event (Maybe a)+transactStrategyQueueDeleteBy q priority pred =+  liftIO $+  do m <- readIORef (transactStrategyQueue q)+     let k  = - priority+         xs = M.lookup k m+     case xs of+       Nothing -> return Nothing+       Just xs ->+         do a <- DLL.listRemoveBy xs pred+            empty <- DLL.listNull xs+            when empty $+              modifyIORef (transactStrategyQueue q) $+              M.delete k+            return a++-- | Test whether the queue contains a transact with the specified priority satisfying the provided predicate.+transactStrategyQueueContainsBy :: StrategyQueue (TransactQueueStrategy s) a+                                   -- ^ the queue+                                   -> Int+                                   -- ^ the transact priority+                                   -> (a -> Bool)+                                   -- ^ the predicate+                                   -> Event (Maybe a)+transactStrategyQueueContainsBy q priority pred =+  liftIO $+  do m <- readIORef (transactStrategyQueue q)+     let k  = - priority+         xs = M.lookup k m+     case xs of+       Nothing -> return Nothing+       Just xs -> DLL.listContainsBy xs pred
+ Simulation/Aivika/Trans/GPSS.hs view
@@ -0,0 +1,76 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module re-exports the library functionality related to the GPSS-like domain specific language.+--+module Simulation.Aivika.Trans.GPSS+       (-- * Modules+        module Simulation.Aivika.Trans.GPSS.Block,+        module Simulation.Aivika.Trans.GPSS.Block.Advance,+        module Simulation.Aivika.Trans.GPSS.Block.Assemble,+        module Simulation.Aivika.Trans.GPSS.Block.Assign,+        module Simulation.Aivika.Trans.GPSS.Block.Depart,+        module Simulation.Aivika.Trans.GPSS.Block.Enter,+        module Simulation.Aivika.Trans.GPSS.Block.Gather,+        module Simulation.Aivika.Trans.GPSS.Block.Generate,+        module Simulation.Aivika.Trans.GPSS.Block.Leave,+        module Simulation.Aivika.Trans.GPSS.Block.Link,+        module Simulation.Aivika.Trans.GPSS.Block.Loop,+        module Simulation.Aivika.Trans.GPSS.Block.Match,+        module Simulation.Aivika.Trans.GPSS.Block.Preempt,+        module Simulation.Aivika.Trans.GPSS.Block.Priority,+        module Simulation.Aivika.Trans.GPSS.Block.Queue,+        module Simulation.Aivika.Trans.GPSS.Block.Release,+        module Simulation.Aivika.Trans.GPSS.Block.Return,+        module Simulation.Aivika.Trans.GPSS.Block.Seize,+        module Simulation.Aivika.Trans.GPSS.Block.Split,+        module Simulation.Aivika.Trans.GPSS.Block.Terminate,+        module Simulation.Aivika.Trans.GPSS.Block.Test,+        module Simulation.Aivika.Trans.GPSS.Block.Transfer,+        module Simulation.Aivika.Trans.GPSS.Block.Unlink,+        module Simulation.Aivika.Trans.GPSS.AssemblySet,+        module Simulation.Aivika.Trans.GPSS.Facility,+        module Simulation.Aivika.Trans.GPSS.MatchChain,+        module Simulation.Aivika.Trans.GPSS.Results,+        module Simulation.Aivika.Trans.GPSS.Results.Locale,+        module Simulation.Aivika.Trans.GPSS.Storage,+        module Simulation.Aivika.Trans.GPSS.Transact,+        module Simulation.Aivika.Trans.GPSS.TransactQueueStrategy) where++import Simulation.Aivika.Trans.GPSS.Block+import Simulation.Aivika.Trans.GPSS.Block.Advance+import Simulation.Aivika.Trans.GPSS.Block.Assemble+import Simulation.Aivika.Trans.GPSS.Block.Assign+import Simulation.Aivika.Trans.GPSS.Block.Depart+import Simulation.Aivika.Trans.GPSS.Block.Enter+import Simulation.Aivika.Trans.GPSS.Block.Gather+import Simulation.Aivika.Trans.GPSS.Block.Generate+import Simulation.Aivika.Trans.GPSS.Block.Leave+import Simulation.Aivika.Trans.GPSS.Block.Link+import Simulation.Aivika.Trans.GPSS.Block.Loop+import Simulation.Aivika.Trans.GPSS.Block.Match+import Simulation.Aivika.Trans.GPSS.Block.Preempt+import Simulation.Aivika.Trans.GPSS.Block.Priority+import Simulation.Aivika.Trans.GPSS.Block.Queue+import Simulation.Aivika.Trans.GPSS.Block.Release+import Simulation.Aivika.Trans.GPSS.Block.Return+import Simulation.Aivika.Trans.GPSS.Block.Seize+import Simulation.Aivika.Trans.GPSS.Block.Split+import Simulation.Aivika.Trans.GPSS.Block.Terminate+import Simulation.Aivika.Trans.GPSS.Block.Test+import Simulation.Aivika.Trans.GPSS.Block.Transfer+import Simulation.Aivika.Trans.GPSS.Block.Unlink+import Simulation.Aivika.Trans.GPSS.AssemblySet+import Simulation.Aivika.Trans.GPSS.Facility+import Simulation.Aivika.Trans.GPSS.MatchChain+import Simulation.Aivika.Trans.GPSS.Results+import Simulation.Aivika.Trans.GPSS.Results.Locale+import Simulation.Aivika.Trans.GPSS.Storage+import Simulation.Aivika.Trans.GPSS.Transact+import Simulation.Aivika.Trans.GPSS.TransactQueueStrategy
+ Simulation/Aivika/Trans/GPSS/AssemblySet.hs view
@@ -0,0 +1,171 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.AssemblySet+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines a GPSS assembly set.+--+module Simulation.Aivika.Trans.GPSS.AssemblySet+       (-- * Types+        AssemblySet,+        -- * Creating Assembly Set+        newAssemblySet,+        -- * Functions+        assembleTransact,+        gatherTransacts,+        -- * Properties+        transactAssembling,+        transactGathering) where++import Data.Monoid+import Data.Maybe+import Data.Hashable++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Internal.Parameter+import Simulation.Aivika.Trans.Internal.Simulation++import Simulation.Aivika.Trans.GPSS.Transact+import Simulation.Aivika.Trans.GPSS.TransactQueueStrategy++-- | Represents an assembly set.+data AssemblySet m =+  AssemblySet { assemblySetSequenceNo :: Int,+                assemblySetAssemblingTransact :: Ref m (Maybe (ProcessId m)),+                assemblySetAssemblingCounter :: Ref m Int,+                assemblySetGatheringTransacts :: StrategyQueue m (TransactQueueStrategy FCFS) (ProcessId m),+                assemblySetGatheringCounter :: Ref m Int+              }++instance MonadDES m => Eq (AssemblySet m) where++  {-# INLINABLE (==) #-}+  x == y = (assemblySetAssemblingTransact x) == (assemblySetAssemblingTransact y)++instance Hashable (AssemblySet m) where+  hashWithSalt salt x = hashWithSalt salt (assemblySetSequenceNo x)++-- | Create a new assembly set.+newAssemblySet :: MonadDES m => Simulation m (AssemblySet m)+{-# INLINABLE newAssemblySet #-}+newAssemblySet =+  Simulation $ \r ->+  do let g = runGenerator r+     sequenceNo <- generateSequenceNo g+     assemblingTransact <- invokeSimulation r $ newRef Nothing+     assemblingCounter  <- invokeSimulation r $ newRef 0+     gatheringTransacts <- invokeSimulation r $ newStrategyQueue (TransactQueueStrategy FCFS)+     gatheringCounter   <- invokeSimulation r $ newRef 0+     return AssemblySet { assemblySetSequenceNo         = sequenceNo,+                          assemblySetAssemblingTransact = assemblingTransact,+                          assemblySetAssemblingCounter  = assemblingCounter,+                          assemblySetGatheringTransacts = gatheringTransacts,+                          assemblySetGatheringCounter   = gatheringCounter+                        }++-- | Assemble the transact by the specified number.+assembleTransact :: MonadDES m => Transact m a -> Int -> Process m ()+{-# INLINABLE assembleTransact #-}+assembleTransact t n =+  do (s, a) <-+       liftEvent $+       do s <- transactAssemblySet t+          a <- readRef (assemblySetAssemblingCounter s)+          return (s, a)+     if a == 0+       then do let n' = n - 1+               when (n' < 0) $+                 throwProcess $+                 SimulationRetry+                 "The number of transacts must be positive: assembleTransact"+               if n' == 0+                 then return ()+                 else do liftEvent $+                           do pid <- requireTransactProcessId t+                              writeRef (assemblySetAssemblingTransact s) (Just pid)+                              writeRef (assemblySetAssemblingCounter s) $! n'+                         passivateProcess+       else do let a' = a - 1+               if a' == 0+                 then do liftEvent $+                           do Just pid <- readRef (assemblySetAssemblingTransact s)+                              writeRef (assemblySetAssemblingTransact s) Nothing+                              writeRef (assemblySetAssemblingCounter s) $! a'+                              reactivateProcessImmediately pid+                         cancelProcess+                 else do liftEvent $ writeRef (assemblySetAssemblingCounter s) $! a'+                         cancelProcess++-- | Gather the transacts by the specified number.+gatherTransacts :: MonadDES m => Transact m a -> Int -> Process m ()+{-# INLINABLE gatherTransacts #-}+gatherTransacts t n =+  do (s, a) <-+       liftEvent $+       do s <- transactAssemblySet t+          a <- readRef (assemblySetGatheringCounter s)+          return (s, a)+     if a == 0+       then do let n' = n - 1+               when (n' < 0) $+                 throwProcess $+                 SimulationRetry+                 "The number of transacts must be positive: gatherTransacts"+               if n' == 0+                 then return ()+                 else do liftEvent $+                           do pid <- requireTransactProcessId t+                              strategyEnqueueWithPriority+                                (assemblySetGatheringTransacts s)+                                (transactPriority t)+                                pid+                              writeRef (assemblySetGatheringCounter s) $! n'+                         passivateProcess+       else do let a' = a - 1+               liftEvent $+                 do pid <- requireTransactProcessId t+                    strategyEnqueueWithPriority+                      (assemblySetGatheringTransacts s)+                      (transactPriority t)+                      pid+                    writeRef (assemblySetGatheringCounter s) $! a'+               if a' == 0+                 then passivateProcessBefore $+                      liftEvent $+                      do let loop acc =+                               do f <- strategyQueueNull (assemblySetGatheringTransacts s)+                                  if f+                                    then return (reverse acc)+                                    else do x <- strategyDequeue (assemblySetGatheringTransacts s)+                                            loop (x: acc)+                             act [] = return ()+                             act (pid: pids') =+                               do reactivateProcessImmediately pid+                                  yieldEvent $ act pids'+                         pids <- loop []+                         act pids+                 else passivateProcess++-- | Test whether another transact is assembled for the corresponding assembly set.+transactAssembling :: MonadDES m => Transact m a -> Event m Bool+{-# INLINABLE transactAssembling #-}+transactAssembling t =+  do s <- transactAssemblySet t+     a <- readRef (assemblySetAssemblingCounter s)+     return (a > 0)++-- | Test whether the transacts are gathered for the corresponding assembly set.+transactGathering :: MonadDES m => Transact m a -> Event m Bool+{-# INLINABLE transactGathering #-}+transactGathering t =+  do s <- transactAssemblySet t+     a <- readRef (assemblySetGatheringCounter s)+     return (a > 0)
+ Simulation/Aivika/Trans/GPSS/AssemblySet.hs-boot view
@@ -0,0 +1,27 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.AssemblySet+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This is an hs-boot file.+--+module Simulation.Aivika.Trans.GPSS.AssemblySet+       (AssemblySet,+        newAssemblySet) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.TransactQueueStrategy++data AssemblySet m =+  AssemblySet { assemblySetSequenceNo :: Int,+                assemblySetAssemblingTransact :: Ref m (Maybe (ProcessId m)),+                assemblySetAssemblingCounter :: Ref m Int,+                assemblySetGatheringTransacts :: StrategyQueue m (TransactQueueStrategy FCFS) (ProcessId m),+                assemblySetGatheringCounter :: Ref m Int+              }++newAssemblySet :: MonadDES m => Simulation m (AssemblySet m)
+ Simulation/Aivika/Trans/GPSS/Block.hs view
@@ -0,0 +1,58 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines a GPSS block.+--+module Simulation.Aivika.Trans.GPSS.Block+       (Block(..),+        GeneratorBlock(..),+        withinBlock,+        traceBlock) where++import Control.Monad+import Control.Monad.Trans+import qualified Control.Category as C++import Simulation.Aivika.Trans++-- | Represents a GPSS block.+data Block m a b =+  Block { blockProcess :: a -> Process m b+          -- ^ Process the item.+        }++-- | Represents a GPSS generator block.+newtype GeneratorBlock m a =+  GeneratorBlock { runGeneratorBlock :: Block m a () -> Process m ()+                   -- ^ Run the generator block.+                 }++instance MonadDES m => C.Category (Block m) where++  {-# INLINABLE id #-}+  id = Block { blockProcess = return }++  {-# INLINABLE (.) #-}+  x . y = Block { blockProcess = \a -> do { b <- blockProcess y a; blockProcess x b } }++-- | Perform some action within the block, for example,+-- opening or inverting the 'Gate' to emulate the LOGIC block.+withinBlock :: MonadDES m+               => Process m ()+               -- ^ the action to be executed for each transact+               -> Block m a a+{-# INLINABLE withinBlock #-}+withinBlock m =+  Block { blockProcess = \a -> m >> return a }++-- | Trace the specified block.+traceBlock :: MonadDES m => String -> Block m a b -> Block m a b+{-# INLINABLE traceBlock #-}+traceBlock message x =+  Block { blockProcess = \a -> traceProcess message (blockProcess x a) }
+ Simulation/Aivika/Trans/GPSS/Block/Advance.hs view
@@ -0,0 +1,27 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Advance+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block ADVANCE.+--+module Simulation.Aivika.Trans.GPSS.Block.Advance+       (advanceBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Block++-- | This is the GPSS construct+--+-- @ADVANCE A,B@+advanceBlock :: MonadDES m+                => Process m ()+                -- ^ the delay+                -> Block m a a+{-# INLINABLE advanceBlock #-}+advanceBlock p =+  Block { blockProcess = \a -> p >> return a }
+ Simulation/Aivika/Trans/GPSS/Block/Assemble.hs view
@@ -0,0 +1,29 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Assemble+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block ASSEMBLE.+--+module Simulation.Aivika.Trans.GPSS.Block.Assemble+       (assembleBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Block+import Simulation.Aivika.Trans.GPSS.AssemblySet+import Simulation.Aivika.Trans.GPSS.Transact++-- | This is the GPSS construct+--+-- @ASSEMBLE A@+assembleBlock :: MonadDES m+                 => Int+                 -- ^ the number of transacts to assemble+                 -> Block m (Transact m a) (Transact m a)+{-# INLINABLE assembleBlock #-}+assembleBlock n =+  Block { blockProcess = \a -> assembleTransact a n >> return a }
+ Simulation/Aivika/Trans/GPSS/Block/Assign.hs view
@@ -0,0 +1,40 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Assign+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block ASSIGN.+--+module Simulation.Aivika.Trans.GPSS.Block.Assign+       (assignBlock,+        assignBlockM) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Block+import Simulation.Aivika.Trans.GPSS.Transact++-- | This is the GPSS construct+--+-- @ASSIGN A,B,C@+assignBlock :: MonadDES m+               => (a -> b)+               -- ^ the transform+               -> Block m (Transact m a) (Transact m b)+{-# INLINABLE assignBlock #-}+assignBlock f =+  Block { blockProcess = \a -> return (assignTransactValue a f) }++-- | This is the GPSS construct+--+-- @ASSIGN A,B,C@+assignBlockM :: MonadDES m =>+                (a -> Process m b)+                -- ^ the transform computation+                -> Block m (Transact m a) (Transact m b)+{-# INLINABLE assignBlockM #-}+assignBlockM f =+  Block { blockProcess = \a -> assignTransactValueM a f }
+ Simulation/Aivika/Trans/GPSS/Block/Depart.hs view
@@ -0,0 +1,31 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Depart+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block DEPART.+--+module Simulation.Aivika.Trans.GPSS.Block.Depart+       (departBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Transact+import Simulation.Aivika.Trans.GPSS.Block+import qualified Simulation.Aivika.Trans.GPSS.Queue as Q++-- | This is the GPSS construct+--+-- @DEPART A,B@+departBlock :: MonadDES m+               => Q.Queue m+               -- ^ the queue+               -> Int+               -- ^ the content decrement+               -> Block m (Transact m a) (Transact m a)+{-# INLINABLE departBlock #-}+departBlock q decrement =+  Block { blockProcess = \a -> (liftEvent $ Q.dequeue q a decrement) >> return a }
+ Simulation/Aivika/Trans/GPSS/Block/Enter.hs view
@@ -0,0 +1,31 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Enter+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block ENTER.+--+module Simulation.Aivika.Trans.GPSS.Block.Enter+       (enterBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Transact+import Simulation.Aivika.Trans.GPSS.Block+import Simulation.Aivika.Trans.GPSS.Storage++-- | This is the GPSS construct+--+-- @ENTER A,B@+enterBlock :: MonadDES m+              => Storage m+              -- ^ the storage+              -> Int+              -- ^ the content decrement+              -> Block m (Transact m a) (Transact m a)+{-# INLINABLE enterBlock #-}+enterBlock r decrement =+  Block { blockProcess = \a -> enterStorage r a decrement >> return a }
+ Simulation/Aivika/Trans/GPSS/Block/Gather.hs view
@@ -0,0 +1,29 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Gather+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block GATHER.+--+module Simulation.Aivika.Trans.GPSS.Block.Gather+       (gatherBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Block+import Simulation.Aivika.Trans.GPSS.AssemblySet+import Simulation.Aivika.Trans.GPSS.Transact++-- | This is the GPSS construct+--+-- @GATHER A@+gatherBlock :: MonadDES m+               => Int+               -- ^ the number of transacts to gather+               -> Block m (Transact m a) (Transact m a)+{-# INLINABLE gatherBlock #-}+gatherBlock n =+  Block { blockProcess = \a -> gatherTransacts a n >> return a }
+ Simulation/Aivika/Trans/GPSS/Block/Generate.hs view
@@ -0,0 +1,57 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Generate+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block GENERATE.+--+module Simulation.Aivika.Trans.GPSS.Block.Generate+       (streamGeneratorBlock0,+        streamGeneratorBlock,+        streamGeneratorBlockM) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Block+import Simulation.Aivika.Trans.GPSS.Transact++-- | Return a generator block by the specified stream and priority computation.+streamGeneratorBlockM :: MonadDES m+                         => Stream m (Arrival a)+                         -- ^ the input stream of data+                         -> Event m Int+                         -- ^ the transact priority+                         -> GeneratorBlock m (Transact m a)+{-# INLINABLE streamGeneratorBlockM #-}+streamGeneratorBlockM s priority =+  let loop s block =+        do (a, xs) <- runStream s+           liftEvent $+             do p <- priority+                t <- liftSimulation $ newTransact a p+                runProcess $+                  do takeTransact t+                     blockProcess block t+           loop xs block+  in GeneratorBlock (loop s)++-- | Return a generator block by the specified stream and priority.+streamGeneratorBlock :: MonadDES m+                        => Stream m (Arrival a)+                        -- ^ the input stream of data+                        -> Int+                        -- ^ the transact priority+                        -> GeneratorBlock m (Transact m a)+{-# INLINABLE streamGeneratorBlock #-}+streamGeneratorBlock s = streamGeneratorBlockM s . return++-- | Return a generator block by the specified stream using zero priority.+streamGeneratorBlock0 :: MonadDES m+                         => Stream m (Arrival a)+                         -- ^ the input stream of data+                         -> GeneratorBlock m (Transact m a)+{-# INLINABLE streamGeneratorBlock0 #-}+streamGeneratorBlock0 s = streamGeneratorBlock s 0
+ Simulation/Aivika/Trans/GPSS/Block/Leave.hs view
@@ -0,0 +1,31 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Leave+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block LEAVE.+--+module Simulation.Aivika.Trans.GPSS.Block.Leave+       (leaveBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Transact+import Simulation.Aivika.Trans.GPSS.Block+import Simulation.Aivika.Trans.GPSS.Storage++-- | This is the GPSS construct+--+-- @LEAVE A,B@+leaveBlock :: MonadDES m+              => Storage m+              -- ^ the storage+              -> Int+              -- ^ the content increment+              -> Block m (Transact m a) (Transact m a)+{-# INLINABLE leaveBlock #-}+leaveBlock r increment =+  Block { blockProcess = \a -> leaveStorage r increment >> return a }
+ Simulation/Aivika/Trans/GPSS/Block/Link.hs view
@@ -0,0 +1,40 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Link+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines an analog of the GPSS block LINK.+--+module Simulation.Aivika.Trans.GPSS.Block.Link+       (linkBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Block++-- | This is an analog of the GPSS construct+--+-- @LINK A,B,C@+linkBlock :: MonadDES m+             => (a -> Process m (Either (Block m a ()) Bool))+             -- ^ try to link the transact and return either the next block to transfer+             -- or a flag indicating whether the transact process should be passivated+             -- in case of successful linking, i.e. storing in the queue+             -> Block m a a+{-# INLINABLE linkBlock #-}+linkBlock f =+  Block { blockProcess = \a ->+           do x <- f a+              case x of+                Left transfer ->+                  transferProcess $+                  blockProcess transfer a+                Right False ->+                  return a+                Right True ->+                  do passivateProcess+                     return a+        }
+ Simulation/Aivika/Trans/GPSS/Block/Loop.hs view
@@ -0,0 +1,57 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Loop+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block LOOP.+--+module Simulation.Aivika.Trans.GPSS.Block.Loop+       (loopBlock,+        loopBlockM) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Block++-- | This is the GPSS construct+--+-- @LOOP A,B@+loopBlock :: MonadDES m+             => (a -> (b, Bool))+             -- ^ by the specified transact return the next version+             -- of the same transact and a condition whether we should+             -- exit the loop+             -> Block m b ()+             -- ^ the block to transfer in when the condition fails+             -> Block m a b+{-# INLINABLE loopBlock #-}+loopBlock f block =+  Block { blockProcess = \a ->+           do let (b, c) = f a+              if c+                then return b+                else transferProcess (blockProcess block b)+        }++-- | This is the GPSS construct+--+-- @LOOP A,B@+loopBlockM :: MonadDES m+              => (a -> Process m (b, Bool))+              -- ^ by the specified transact return the next version+              -- of the same transact and a condition whether we should+              -- exit the loop+              -> Block m b ()+              -- ^ the block to transfer in when the condition fails+              -> Block m a b+{-# INLINABLE loopBlockM #-}+loopBlockM f block =+  Block { blockProcess = \a ->+           do (b, c) <- f a+              if c+                then return b+                else transferProcess (blockProcess block b)+        }
+ Simulation/Aivika/Trans/GPSS/Block/Match.hs view
@@ -0,0 +1,29 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Match+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block MATCH.+--+module Simulation.Aivika.Trans.GPSS.Block.Match+       (matchBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Block+import Simulation.Aivika.Trans.GPSS.MatchChain+import Simulation.Aivika.Trans.GPSS.Transact++-- | This is an analog of the GPSS construct+--+-- @MATCH A@+matchBlock :: MonadDES m+              => MatchChain m+              -- ^ the corresponding match chain+              -> Block m (Transact m a) (Transact m a)+{-# INLINABLE matchBlock #-}+matchBlock chain =+  Block { blockProcess = \a -> matchTransact chain a >> return a }
+ Simulation/Aivika/Trans/GPSS/Block/Preempt.hs view
@@ -0,0 +1,84 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Preempt+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block Preempt.+--+module Simulation.Aivika.Trans.GPSS.Block.Preempt+       (preemptBlock,+        PreemptBlockMode(..),+        defaultPreemptBlockMode,+        toFacilityPreemptMode,+        fromFacilityPreemptMode) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Transact+import Simulation.Aivika.Trans.GPSS.Block+import Simulation.Aivika.Trans.GPSS.Facility++-- | Specifies the Preempt block mode.+data PreemptBlockMode m a =+  PreemptBlockMode { preemptBlockPriorityMode :: Bool,+                     -- ^ the Priority mode; otherwise, the Interrupt mode+                     preemptBlockTransfer :: Maybe (Maybe Double -> Block m (Transact m a) ()),+                     -- ^ where to transfer the preempted transact,+                     -- passing in the remaining time from the process holding +                     -- computation such as the ADVANCE block+                     preemptBlockRemoveMode :: Bool+                     -- ^ the Remove mode+                   }++-- | Convert 'PreemptBlockMode' to 'FacilityPreemptMode'.+toFacilityPreemptMode :: MonadDES m => PreemptBlockMode m a -> FacilityPreemptMode m a+{-# INLINABLE toFacilityPreemptMode #-}+toFacilityPreemptMode m =+  FacilityPreemptMode { facilityPriorityMode = preemptBlockPriorityMode m,+                        facilityTransfer     = transfer,+                        facilityRemoveMode   = preemptBlockRemoveMode m+                      }+  where+    transfer =+      case preemptBlockTransfer m of+        Nothing -> Nothing+        Just f  -> Just (\a dt -> blockProcess (f dt) a)++-- | Convert 'PreemptBlockMode' from 'FacilityPreemptMode'.+fromFacilityPreemptMode :: MonadDES m => FacilityPreemptMode m a -> PreemptBlockMode m a+{-# INLINABLE fromFacilityPreemptMode #-}+fromFacilityPreemptMode m =+  PreemptBlockMode { preemptBlockPriorityMode = facilityPriorityMode m,+                     preemptBlockTransfer     = transfer,+                     preemptBlockRemoveMode   = facilityRemoveMode m+                   }+  where+    transfer =+      case facilityTransfer m of+        Nothing -> Nothing+        Just f  -> Just (\dt -> Block $ \a -> f a dt)++-- | The default Preempt block mode.+defaultPreemptBlockMode :: MonadDES m => PreemptBlockMode m a+{-# INLINABLE defaultPreemptBlockMode #-}+defaultPreemptBlockMode =+  PreemptBlockMode { preemptBlockPriorityMode = False,+                     preemptBlockTransfer     = Nothing,+                     preemptBlockRemoveMode   = False+                   }++-- | This is the GPSS construct+--+-- @PREEMPT A,B,C,D,E@+preemptBlock :: MonadDES m+                => Facility m a+                -- ^ the facility+                -> PreemptBlockMode m a+                -- ^ the Preempt block mode+                -> Block m (Transact m a) (Transact m a)+{-# INLINABLE preemptBlock #-}+preemptBlock r m =+  Block { blockProcess = \a -> preemptFacility r a (toFacilityPreemptMode m) >> return a }
+ Simulation/Aivika/Trans/GPSS/Block/Priority.hs view
@@ -0,0 +1,28 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Priority+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block PRIORITY.+--+module Simulation.Aivika.Trans.GPSS.Block.Priority+       (priorityBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Block+import Simulation.Aivika.Trans.GPSS.Transact++-- | This is the GPSS construct+--+-- @PRIORITY A@+priorityBlock :: MonadDES m +                 => Int+                 -- ^ the priority+                 -> Block m (Transact m a) (Transact m a)+{-# INLINABLE priorityBlock #-}+priorityBlock priority =+  Block { blockProcess = \a -> return (assignTransactPriority a priority) }
+ Simulation/Aivika/Trans/GPSS/Block/Queue.hs view
@@ -0,0 +1,31 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Queue+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block QUEUE.+--+module Simulation.Aivika.Trans.GPSS.Block.Queue+       (queueBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Transact+import Simulation.Aivika.Trans.GPSS.Block+import qualified Simulation.Aivika.Trans.GPSS.Queue as Q++-- | This is the GPSS construct+--+-- @QUEUE A,B@+queueBlock :: MonadDES m+              => Q.Queue m+              -- ^ the queue+              -> Int+              -- ^ the content increment+              -> Block m (Transact m a) (Transact m a)+{-# INLINABLE queueBlock #-}+queueBlock q increment =+  Block { blockProcess = \a -> (liftEvent $ Q.enqueue q a increment) >> return a }
+ Simulation/Aivika/Trans/GPSS/Block/Release.hs view
@@ -0,0 +1,29 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Release+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block RELEASE.+--+module Simulation.Aivika.Trans.GPSS.Block.Release+       (releaseBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Transact+import Simulation.Aivika.Trans.GPSS.Block+import Simulation.Aivika.Trans.GPSS.Facility++-- | This is the GPSS construct+--+-- @RELEASE A@+releaseBlock :: MonadDES m+                => Facility m a+                -- ^ the facility+                -> Block m (Transact m a) (Transact m a)+{-# INLINABLE releaseBlock #-}+releaseBlock r =+  Block { blockProcess = \a -> releaseFacility r a >> return a }
+ Simulation/Aivika/Trans/GPSS/Block/Return.hs view
@@ -0,0 +1,29 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Return+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block RETURN.+--+module Simulation.Aivika.Trans.GPSS.Block.Return+       (returnBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Transact+import Simulation.Aivika.Trans.GPSS.Block+import Simulation.Aivika.Trans.GPSS.Facility++-- | This is the GPSS construct+--+-- @RETURN A@+returnBlock :: MonadDES m+               => Facility m a+               -- ^ the facility+               -> Block m (Transact m a) (Transact m a)+{-# INLINABLE returnBlock #-}+returnBlock r =+  Block { blockProcess = \a -> returnFacility r a >> return a }
+ Simulation/Aivika/Trans/GPSS/Block/Seize.hs view
@@ -0,0 +1,29 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Seize+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block SEIZE.+--+module Simulation.Aivika.Trans.GPSS.Block.Seize+       (seizeBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Transact+import Simulation.Aivika.Trans.GPSS.Block+import Simulation.Aivika.Trans.GPSS.Facility++-- | This is the GPSS construct+--+-- @SEIZE A@+seizeBlock :: MonadDES m+              => Facility m a+              -- ^ the facility+              -> Block m (Transact m a) (Transact m a)+{-# INLINABLE seizeBlock #-}+seizeBlock r =+  Block { blockProcess = \a -> seizeFacility r a >> return a }
+ Simulation/Aivika/Trans/GPSS/Block/Split.hs view
@@ -0,0 +1,54 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Split+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines an analog of the GPSS block SPLIT.+--+module Simulation.Aivika.Trans.GPSS.Block.Split+       (splitBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Block+import Simulation.Aivika.Trans.GPSS.Transact++-- | This is an analog of the GPSS construct+--+-- @SPLIT A,B,C@+--+-- Parameter @A@ is a length of the list parameter passed in to the function.+-- Parameter @B@ is the list itself. If you need to define parameter @C@ then+-- you can create the blocks dynamically that could depend on the index and+-- where we could assign a new value for each new transcact after splitting.+--+-- An example is+--+-- @+-- let blocks :: [Block DIO (Transact DIO (a, Int)) ()]+--     blocks = ...+--     f :: (Int, Block DIO (Transact DIO (a, Int)) ()) -> Block DIO (Transact DIO a) ()+--     f (n, block) = assignBlock (\a -> (a, n)) >>> block+--     blocks' :: [Block DIO (Transact DIO a) ()]+--     blocks' = map f $ zip [0..] blocks+-- in splitBlock blocks'+-- @+splitBlock :: MonadDES m+              => [Block m (Transact m a) ()]+              -- ^ split and transfer new transacts to the specified blocks+              -> Block m (Transact m a) (Transact m a)+{-# INLINABLE splitBlock #-}+splitBlock blocks =+  Block { blockProcess = \a ->+           do let loop [] = return ()+                  loop (transfer: transfers) =+                    do a' <- liftSimulation $ splitTransact a+                       transferTransact a' $+                         blockProcess transfer a'+                       loop transfers+              liftEvent $ loop blocks+              return a+        }
+ Simulation/Aivika/Trans/GPSS/Block/Terminate.hs view
@@ -0,0 +1,74 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Terminate+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block TERMINATE.+--+module Simulation.Aivika.Trans.GPSS.Block.Terminate+       (terminateBlock,+        terminateBlockByCount,+        terminateBlockByCountM) where++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Block++-- | This is the GPSS construct+--+-- @TERMINATE@+terminateBlock :: MonadDES m => Block m a ()+{-# INLINABLE terminateBlock #-}+terminateBlock =+  Block { blockProcess = \a -> return () }++-- | This is the GPSS construct+--+-- @TERMINATE Count@+terminateBlockByCountM :: MonadDES m+                          => Ref m Int+                          -- ^ the counter+                          -> Event m Int+                          -- ^ the computation of decrement+                          -> Block m a ()+{-# INLINABLE terminateBlockByCountM #-}+terminateBlockByCountM counter decrement =+  Block { blockProcess = \a -> action }+    where+      action = +        liftEvent $+        do i <- decrement+           n <- readRef counter+           let n' = n - i+           n' `seq` writeRef counter n'+           when (n' <= 0) $+             throwEvent $+             SimulationAbort "Terminated by exceeding the counter"++-- | This is the GPSS construct+--+-- @TERMINATE Count@+terminateBlockByCount :: MonadDES m+                         => Ref m Int+                         -- ^ the counter+                         -> Int+                         -- ^ the decrement+                         -> Block m a ()+{-# INLINABLE terminateBlockByCount #-}+terminateBlockByCount counter i =+  Block { blockProcess = \a -> action }+    where+      action = +        liftEvent $+        do n <- readRef counter+           let n' = n - i+           n' `seq` writeRef counter n'+           when (n' <= 0) $+             throwEvent $+             SimulationAbort "Terminated by exceeding the counter"
+ Simulation/Aivika/Trans/GPSS/Block/Test.hs view
@@ -0,0 +1,101 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Test+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block TEST.+--+module Simulation.Aivika.Trans.GPSS.Block.Test+       (awaitingTestBlock,+        awaitingTestBlockM,+        transferringTestBlock,+        transferringTestBlockM) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Block++-- | This is the GPSS construct+--+-- @TEST O A,B@+awaitingTestBlock :: MonadDES m+                     => (a -> Signalable m Bool)+                     -- ^ by the specified transact return+                     -- a test condition and signal that notifies+                     -- about changing the condition+                     -> Block m a a+{-# INLINABLE awaitingTestBlock #-}+awaitingTestBlock f =+  Block { blockProcess = \a ->+           do let s = f a+                  loop =+                    do f <- liftEvent $ readSignalable s+                       if f+                         then return ()+                         else do processAwait $ signalableChanged_ s+                                 loop+              loop+              return a+        }++-- | This is the GPSS construct+--+-- @TEST O A,B@+awaitingTestBlockM :: MonadDES m+                      => (a -> Process m (Signalable m Bool))+                      -- ^ by the specified transact return+                      -- a test condition and signal that notifies+                      -- about changing the condition+                      -> Block m a a+{-# INLINABLE awaitingTestBlockM #-}+awaitingTestBlockM f =+  Block { blockProcess = \a ->+           do s <- f a+              let loop =+                    do f <- liftEvent $ readSignalable s+                       if f+                         then return ()+                         else do processAwait $ signalableChanged_ s+                                 loop+              loop+              return a+        }++-- | This is the GPSS construct+--+-- @TEST O A,B,C@+transferringTestBlock :: MonadDES m+                         => (a -> Bool)+                         -- ^ the predicate+                         -> Block m a ()+                         -- ^ the block to transfer in when the condition fails+                         -> Block m a a+{-# INLINABLE transferringTestBlock #-}+transferringTestBlock pred block =+  Block { blockProcess = \a ->+           do let f = pred a+              if f+                then return a+                else transferProcess (blockProcess block a)+        }++-- | This is the GPSS construct+--+-- @TEST O A,B,C@+transferringTestBlockM :: MonadDES m+                          => (a -> Process m Bool)+                          -- ^ the predicate+                          -> Block m a ()+                          -- ^ the block to transfer in when the condition fails+                          -> Block m a a+{-# INLINABLE transferringTestBlockM #-}+transferringTestBlockM pred block =+  Block { blockProcess = \a ->+           do f <- pred a+              if f+                then return a+                else transferProcess (blockProcess block a)+        }
+ Simulation/Aivika/Trans/GPSS/Block/Transfer.hs view
@@ -0,0 +1,27 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Transfer+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines the GPSS block TRANSFER.+--+module Simulation.Aivika.Trans.GPSS.Block.Transfer+       (transferBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Block++-- | This is the GPSS construct+--+-- @TRANSFER ,New_Place@+transferBlock :: MonadDES m+                 => Block m a ()+                 -- ^ a new place+                 -> Block m a b+{-# INLINABLE transferBlock #-}+transferBlock x =+  Block { blockProcess = \a -> transferProcess (blockProcess x a) }
+ Simulation/Aivika/Trans/GPSS/Block/Unlink.hs view
@@ -0,0 +1,37 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Block.Unlink+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines an analog of the GPSS block UNLINK.+--+module Simulation.Aivika.Trans.GPSS.Block.Unlink+       (unlinkBlock) where++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Block+import Simulation.Aivika.Trans.GPSS.Transact++-- | This is an analog of the GPSS construct+--+-- @UNLINK O A,B,C,D,E,F@+unlinkBlock :: MonadDES m+               => Process m [(Transact m a, Maybe (Block m (Transact m a) ()))]+               -- ^ a computation of the list of transacts to reactivate,+               -- transfering them to the specified blocks if required+               -> Block m b b+{-# INLINABLE unlinkBlock #-}+unlinkBlock m =+  Block { blockProcess = \b ->+           do let f (a, Nothing)       = (a, Nothing)+                  f (a, Just transfer) = (a, Just $ blockProcess transfer a)+              xs <- m+              liftEvent $+                reactivateTransacts $+                map f xs+              return b+        }
+ Simulation/Aivika/Trans/GPSS/Facility.hs view
@@ -0,0 +1,760 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Facility+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.1+--+-- This module defines the GPSS Facility entity.+--+module Simulation.Aivika.Trans.GPSS.Facility+       (-- * Facility Type+        Facility,+        FacilityPreemptMode(..),+        FacilityPreemptTransfer,+        -- * Creating Facility+        newFacility,+        -- * Facility Properties+        facilityCount,+        facilityCountStats,+        facilityCaptureCount,+        facilityUtilisationCount,+        facilityUtilisationCountStats,+        facilityQueueCount,+        facilityQueueCountStats,+        facilityTotalWaitTime,+        facilityWaitTime,+        facilityTotalHoldingTime,+        facilityHoldingTime,+        facilityInterrupted,+        -- * Seizing-Releasing and Preempting-Returning Facility+        seizeFacility,+        releaseFacility,+        preemptFacility,+        returnFacility,+        -- * Statistics Reset+        resetFacility,+        -- * Signals+        facilityCountChanged,+        facilityCountChanged_,+        facilityCaptureCountChanged,+        facilityCaptureCountChanged_,+        facilityUtilisationCountChanged,+        facilityUtilisationCountChanged_,+        facilityQueueCountChanged,+        facilityQueueCountChanged_,+        facilityWaitTimeChanged,+        facilityWaitTimeChanged_,+        facilityHoldingTimeChanged,+        facilityHoldingTimeChanged_,+        facilityChanged_) where++import Data.Monoid+import Data.Maybe++import Control.Monad+import Control.Monad.Trans+import Control.Exception++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Internal.Simulation+import Simulation.Aivika.Trans.Internal.Event+import Simulation.Aivika.Trans.Internal.Cont+import Simulation.Aivika.Trans.Internal.Process+import Simulation.Aivika.Trans.QueueStrategy+import Simulation.Aivika.Trans.Statistics+import Simulation.Aivika.Trans.Signal++import Simulation.Aivika.Trans.GPSS.Transact+import Simulation.Aivika.Trans.GPSS.TransactQueueStrategy++-- | Represents a GPSS Facility entity.+data Facility m a = +  Facility { facilityCountRef :: Ref m Int,+             facilityCountStatsRef :: Ref m (TimingStats Int),+             facilityCountSource :: SignalSource m Int,+             facilityCaptureCountRef :: Ref m Int,+             facilityCaptureCountSource :: SignalSource m Int,+             facilityUtilisationCountRef :: Ref m Int,+             facilityUtilisationCountStatsRef :: Ref m (TimingStats Int),+             facilityUtilisationCountSource :: SignalSource m Int,+             facilityQueueCountRef :: Ref m Int,+             facilityQueueCountStatsRef :: Ref m (TimingStats Int),+             facilityQueueCountSource :: SignalSource m Int,+             facilityTotalWaitTimeRef :: Ref m Double,+             facilityWaitTimeRef :: Ref m (SamplingStats Double),+             facilityWaitTimeSource :: SignalSource m (),+             facilityTotalHoldingTimeRef :: Ref m Double,+             facilityHoldingTimeRef :: Ref m (SamplingStats Double),+             facilityHoldingTimeSource :: SignalSource m (),+             facilityOwnerRef :: Ref m (Maybe (FacilityOwnerItem m a)),+             facilityDelayChain :: StrategyQueue m (TransactQueueStrategy FCFS) (FacilityDelayedItem m a),+             facilityInterruptChain :: StrategyQueue m (TransactQueueStrategy LCFS) (FacilityInterruptedItem m a),+             facilityPendingChain :: StrategyQueue m (TransactQueueStrategy FCFS) (FacilityPendingItem m a) }++-- | Identifies a transact item that owns the facility.+data FacilityOwnerItem m a =+  FacilityOwnerItem { ownerItemTransact :: Transact m a,+                      ownerItemTime :: Double,+                      ownerItemPreempting :: Bool,+                      ownerItemInterrupting :: Bool,+                      ownerItemAccHoldingTime :: Double }++-- | Idenitifies a transact item that was delayed.+data FacilityDelayedItem m a =+  FacilityDelayedItem { delayedItemTransact :: Transact m a,+                        delayedItemTime :: Double,+                        delayedItemPreempting :: Bool,+                        delayedItemInterrupting :: Bool,+                        delayedItemCont :: FrozenCont m () }++-- | Idenitifies a transact item that was interrupted.+data FacilityInterruptedItem m a =+  FacilityInterruptedItem { interruptedItemTransact :: Transact m a,+                            interruptedItemTime :: Double,+                            interruptedItemPreempting :: Bool,+                            interruptedItemInterrupting :: Bool,+                            interruptedItemRemainingTime :: Maybe Double,+                            interruptedItemTransfer :: Maybe (FacilityPreemptTransfer m a),+                            interruptedItemAccHoldingTime :: Double }++-- | Idenitifies a transact item which is pending.+data FacilityPendingItem m a =+  FacilityPendingItem { pendingItemTransact :: Transact m a,+                        pendingItemTime :: Double,+                        pendingItemPreempting :: Bool,+                        pendingItemInterrupting :: Bool,+                        pendingItemCont :: FrozenCont m () }++instance MonadDES m => Eq (Facility m a) where+  x == y = facilityCountRef x == facilityCountRef y  -- unique references++-- | The facility preemption mode.+data FacilityPreemptMode m a =+  FacilityPreemptMode { facilityPriorityMode :: Bool,+                        -- ^ the Priority mode; otherwise, the Interrupt mode+                        facilityTransfer :: Maybe (FacilityPreemptTransfer m a),+                        -- ^ where to transfer the preempted transact,+                        -- passing in the remaining time from the process holding+                        -- computation such as the ADVANCE block+                        facilityRemoveMode :: Bool+                        -- ^ the Remove mode+                      }++-- | Proceed with the computation by the specified preempted transact+-- and remaining time from the process holding computation such as the ADVANCE block.+type FacilityPreemptTransfer m a = Transact m a -> Maybe Double -> Process m ()++-- | The default facility preemption mode.+defaultFacilityPreemptMode :: FacilityPreemptMode m a+defaultFacilityPreemptMode =+  FacilityPreemptMode { facilityPriorityMode = False,+                        facilityTransfer = Nothing,+                        facilityRemoveMode = False+                      }++-- | Create a new facility.+newFacility :: MonadDES m => Event m (Facility m a)+{-# INLINABLE newFacility #-}+newFacility =+  Event $ \p ->+  do let r = pointRun p+         t = pointTime p+     countRef <- invokeSimulation r $ newRef 1+     countStatsRef <- invokeSimulation r $ newRef $ returnTimingStats t 1+     countSource <- invokeSimulation r newSignalSource+     captureCountRef <- invokeSimulation r $ newRef 0+     captureCountSource <- invokeSimulation r newSignalSource+     utilCountRef <- invokeSimulation r $ newRef 0+     utilCountStatsRef <- invokeSimulation r $ newRef $ returnTimingStats t 0+     utilCountSource <- invokeSimulation r newSignalSource+     queueCountRef <- invokeSimulation r $ newRef 0+     queueCountStatsRef <- invokeSimulation r $ newRef $ returnTimingStats t 0+     queueCountSource <- invokeSimulation r newSignalSource+     totalWaitTimeRef <- invokeSimulation r $ newRef 0+     waitTimeRef <- invokeSimulation r $ newRef emptySamplingStats+     waitTimeSource <- invokeSimulation r newSignalSource+     totalHoldingTimeRef <- invokeSimulation r $ newRef 0+     holdingTimeRef <- invokeSimulation r $ newRef emptySamplingStats+     holdingTimeSource <- invokeSimulation r newSignalSource+     ownerRef <- invokeSimulation r $ newRef Nothing+     delayChain <- invokeSimulation r $ newStrategyQueue (TransactQueueStrategy FCFS)+     interruptChain <- invokeSimulation r $ newStrategyQueue (TransactQueueStrategy LCFS)+     pendingChain <- invokeSimulation r $ newStrategyQueue (TransactQueueStrategy FCFS)+     return Facility { facilityCountRef = countRef,+                       facilityCountStatsRef = countStatsRef,+                       facilityCountSource = countSource,+                       facilityCaptureCountRef = captureCountRef,+                       facilityCaptureCountSource = captureCountSource,+                       facilityUtilisationCountRef = utilCountRef,+                       facilityUtilisationCountStatsRef = utilCountStatsRef,+                       facilityUtilisationCountSource = utilCountSource,+                       facilityQueueCountRef = queueCountRef,+                       facilityQueueCountStatsRef = queueCountStatsRef,+                       facilityQueueCountSource = queueCountSource,+                       facilityTotalWaitTimeRef = totalWaitTimeRef,+                       facilityWaitTimeRef = waitTimeRef,+                       facilityWaitTimeSource = waitTimeSource,+                       facilityTotalHoldingTimeRef = totalHoldingTimeRef,+                       facilityHoldingTimeRef = holdingTimeRef,+                       facilityHoldingTimeSource = holdingTimeSource,+                       facilityOwnerRef = ownerRef,+                       facilityDelayChain = delayChain,+                       facilityInterruptChain = interruptChain,+                       facilityPendingChain = pendingChain }++-- | Return the current available count of the facility.+facilityCount :: MonadDES m => Facility m a -> Event m Int+{-# INLINABLE facilityCount #-}+facilityCount r =+  Event $ \p -> invokeEvent p $ readRef (facilityCountRef r)++-- | Return the statistics for the available count of the facility.+facilityCountStats :: MonadDES m => Facility m a -> Event m (TimingStats Int)+{-# INLINABLE facilityCountStats #-}+facilityCountStats r =+  Event $ \p -> invokeEvent p $ readRef (facilityCountStatsRef r)++-- | Signal triggered when the 'facilityCount' property changes.+facilityCountChanged :: MonadDES m => Facility m a -> Signal m Int+{-# INLINABLE facilityCountChanged #-}+facilityCountChanged r =+  publishSignal $ facilityCountSource r++-- | Signal triggered when the 'facilityCount' property changes.+facilityCountChanged_ :: MonadDES m => Facility m a -> Signal m ()+{-# INLINABLE facilityCountChanged_ #-}+facilityCountChanged_ r =+  mapSignal (const ()) $ facilityCountChanged r++-- | Return the current capture count of the facility.+facilityCaptureCount :: MonadDES m => Facility m a -> Event m Int+{-# INLINABLE facilityCaptureCount #-}+facilityCaptureCount r =+  Event $ \p -> invokeEvent p $ readRef (facilityCaptureCountRef r)++-- | Signal triggered when the 'facilityCaptureCount' property changes.+facilityCaptureCountChanged :: MonadDES m => Facility m a -> Signal m Int+{-# INLINABLE facilityCaptureCountChanged #-}+facilityCaptureCountChanged r =+  publishSignal $ facilityCaptureCountSource r++-- | Signal triggered when the 'facilityCaptureCount' property changes.+facilityCaptureCountChanged_ :: MonadDES m => Facility m a -> Signal m ()+{-# INLINABLE facilityCaptureCountChanged_ #-}+facilityCaptureCountChanged_ r =+  mapSignal (const ()) $ facilityCaptureCountChanged r++-- | Return the current utilisation count of the facility.+facilityUtilisationCount :: MonadDES m => Facility m a -> Event m Int+{-# INLINABLE facilityUtilisationCount #-}+facilityUtilisationCount r =+  Event $ \p -> invokeEvent p $ readRef (facilityUtilisationCountRef r)++-- | Return the statistics for the utilisation count of the facility.+facilityUtilisationCountStats :: MonadDES m => Facility m a -> Event m (TimingStats Int)+{-# INLINABLE facilityUtilisationCountStats #-}+facilityUtilisationCountStats r =+  Event $ \p -> invokeEvent p $ readRef (facilityUtilisationCountStatsRef r)++-- | Signal triggered when the 'facilityUtilisationCount' property changes.+facilityUtilisationCountChanged :: MonadDES m => Facility m a -> Signal m Int+{-# INLINABLE facilityUtilisationCountChanged #-}+facilityUtilisationCountChanged r =+  publishSignal $ facilityUtilisationCountSource r++-- | Signal triggered when the 'facilityUtilisationCount' property changes.+facilityUtilisationCountChanged_ :: MonadDES m => Facility m a -> Signal m ()+{-# INLINABLE facilityUtilisationCountChanged_ #-}+facilityUtilisationCountChanged_ r =+  mapSignal (const ()) $ facilityUtilisationCountChanged r++-- | Return the current queue length of the facility.+facilityQueueCount :: MonadDES m => Facility m a -> Event m Int+{-# INLINABLE facilityQueueCount #-}+facilityQueueCount r =+  Event $ \p -> invokeEvent p $ readRef (facilityQueueCountRef r)++-- | Return the statistics for the queue length of the facility.+facilityQueueCountStats :: MonadDES m => Facility m a -> Event m (TimingStats Int)+{-# INLINABLE facilityQueueCountStats #-}+facilityQueueCountStats r =+  Event $ \p -> invokeEvent p $ readRef (facilityQueueCountStatsRef r)++-- | Signal triggered when the 'facilityQueueCount' property changes.+facilityQueueCountChanged :: MonadDES m => Facility m a -> Signal m Int+{-# INLINABLE facilityQueueCountChanged #-}+facilityQueueCountChanged r =+  publishSignal $ facilityQueueCountSource r++-- | Signal triggered when the 'facilityQueueCount' property changes.+facilityQueueCountChanged_ :: MonadDES m => Facility m a -> Signal m ()+{-# INLINABLE facilityQueueCountChanged_ #-}+facilityQueueCountChanged_ r =+  mapSignal (const ()) $ facilityQueueCountChanged r++-- | Return the total wait time of the facility.+facilityTotalWaitTime :: MonadDES m => Facility m a -> Event m Double+{-# INLINABLE facilityTotalWaitTime #-}+facilityTotalWaitTime r =+  Event $ \p -> invokeEvent p $ readRef (facilityTotalWaitTimeRef r)++-- | Return the statistics for the wait time of the facility.+facilityWaitTime :: MonadDES m => Facility m a -> Event m (SamplingStats Double)+{-# INLINABLE facilityWaitTime #-}+facilityWaitTime r =+  Event $ \p -> invokeEvent p $ readRef (facilityWaitTimeRef r)++-- | Signal triggered when the 'facilityTotalWaitTime' and 'facilityWaitTime' properties change.+facilityWaitTimeChanged :: MonadDES m => Facility m a -> Signal m (SamplingStats Double)+{-# INLINABLE facilityWaitTimeChanged #-}+facilityWaitTimeChanged r =+  mapSignalM (\() -> facilityWaitTime r) $ facilityWaitTimeChanged_ r++-- | Signal triggered when the 'facilityTotalWaitTime' and 'facilityWaitTime' properties change.+facilityWaitTimeChanged_ :: MonadDES m => Facility m a -> Signal m ()+{-# INLINABLE facilityWaitTimeChanged_ #-}+facilityWaitTimeChanged_ r =+  publishSignal $ facilityWaitTimeSource r++-- | Return the total holding time of the facility.+facilityTotalHoldingTime :: MonadDES m => Facility m a -> Event m Double+{-# INLINABLE facilityTotalHoldingTime #-}+facilityTotalHoldingTime r =+  Event $ \p -> invokeEvent p $ readRef (facilityTotalHoldingTimeRef r)++-- | Return the statistics for the holding time of the facility.+facilityHoldingTime :: MonadDES m => Facility m a -> Event m (SamplingStats Double)+{-# INLINABLE facilityHoldingTime #-}+facilityHoldingTime r =+  Event $ \p -> invokeEvent p $ readRef (facilityHoldingTimeRef r)++-- | Signal triggered when the 'facilityTotalHoldingTime' and 'facilityHoldingTime' properties change.+facilityHoldingTimeChanged :: MonadDES m => Facility m a -> Signal m (SamplingStats Double)+{-# INLINABLE facilityHoldingTimeChanged #-}+facilityHoldingTimeChanged r =+  mapSignalM (\() -> facilityHoldingTime r) $ facilityHoldingTimeChanged_ r++-- | Signal triggered when the 'facilityTotalHoldingTime' and 'facilityHoldingTime' properties change.+facilityHoldingTimeChanged_ :: MonadDES m => Facility m a -> Signal m ()+{-# INLINABLE facilityHoldingTimeChanged_ #-}+facilityHoldingTimeChanged_ r =+  publishSignal $ facilityHoldingTimeSource r++-- | Whether the facility is currently interrupted.+facilityInterrupted :: MonadDES m => Facility m a -> Event m Bool+{-# INLINABLE facilityInterrupted #-}+facilityInterrupted r =+  Event $ \p ->+  do x <- invokeEvent p $ readRef (facilityOwnerRef r)+     case x of+       Nothing -> return False+       Just a  -> return (ownerItemPreempting a)++-- | Seize the facility.+seizeFacility :: MonadDES m+                 => Facility m a+                 -- ^ the requested facility+                 -> Transact m a+                 -- ^ the transact that tries to seize the facility+                 -> Process m ()+{-# INLINABLE seizeFacility #-}+seizeFacility r transact =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do let t = pointTime p+     f <- do f1 <- invokeEvent p $ strategyQueueNull (facilityDelayChain r)+             if f1+               then do f2 <- invokeEvent p $ strategyQueueNull (facilityInterruptChain r)+                       if f2+                         then invokeEvent p $ strategyQueueNull (facilityPendingChain r)+                         else return False+               else return False+     if f+       then invokeEvent p $+            invokeCont c $+            invokeProcess pid $+            seizeFacility' r transact+       else do c <- invokeEvent p $+                    freezeContReentering c () $+                    invokeCont c $+                    invokeProcess pid $+                    seizeFacility r transact+               invokeEvent p $+                 strategyEnqueueWithPriority+                 (facilityDelayChain r)+                 (transactPriority transact)+                 (FacilityDelayedItem transact t False False c)+               invokeEvent p $ updateFacilityQueueCount r 1++-- | Seize the facility.+seizeFacility' :: MonadDES m+                  => Facility m a+                  -- ^ the requested facility+                  -> Transact m a+                  -- ^ the transact that tries to seize the facility+                  -> Process m ()+{-# INLINABLE seizeFacility' #-}+seizeFacility' r transact =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do let t = pointTime p+     a <- invokeEvent p $ readRef (facilityOwnerRef r)+     case a of+       Nothing ->+         do invokeEvent p $ writeRef (facilityOwnerRef r) $ Just (FacilityOwnerItem transact t False False 0)+            invokeEvent p $ updateFacilityWaitTime r 0+            invokeEvent p $ updateFacilityCount r (-1)+            invokeEvent p $ updateFacilityCaptureCount r 1+            invokeEvent p $ updateFacilityUtilisationCount r 1+            invokeEvent p $ resumeCont c ()+       Just owner ->+         do c <- invokeEvent p $+                 freezeContReentering c () $+                 invokeCont c $+                 invokeProcess pid $+                 seizeFacility r transact+            invokeEvent p $+              strategyEnqueueWithPriority+              (facilityDelayChain r)+              (transactPriority transact)+              (FacilityDelayedItem transact t False False c)+            invokeEvent p $ updateFacilityQueueCount r 1++-- | Preempt the facility.+preemptFacility :: MonadDES m+                   => Facility m a+                   -- ^ the requested facility+                   -> Transact m a+                   -- ^ the transact that tries to preempt the facility+                   -> FacilityPreemptMode m a+                   -- ^ the Preempt mode+                   -> Process m ()+{-# INLINABLE preemptFacility #-}+preemptFacility r transact mode =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do let t = pointTime p+     a <- invokeEvent p $ readRef (facilityOwnerRef r)+     case a of+       Nothing ->+         do invokeEvent p $ writeRef (facilityOwnerRef r) $ Just (FacilityOwnerItem transact t True False 0)+            invokeEvent p $ updateFacilityWaitTime r 0+            invokeEvent p $ updateFacilityCount r (-1)+            invokeEvent p $ updateFacilityCaptureCount r 1+            invokeEvent p $ updateFacilityUtilisationCount r 1+            invokeEvent p $ resumeCont c ()+       Just owner@(FacilityOwnerItem transact0 t0 preempting0 interrupting0 acc0)+         | (not $ facilityPriorityMode mode) && interrupting0 ->+         do c <- invokeEvent p $+                 freezeContReentering c () $+                 invokeCont c $+                 invokeProcess pid $+                 preemptFacility r transact mode+            invokeEvent p $+              strategyEnqueueWithPriority+              (facilityPendingChain r)+              (transactPriority transact)+              (FacilityPendingItem transact t True True c)+            invokeEvent p $ updateFacilityQueueCount r 1+       Just owner@(FacilityOwnerItem transact0 t0 preempting0 interrupting0 acc0)+         | facilityPriorityMode mode && (transactPriority transact <= transactPriority transact0) ->+         do c <- invokeEvent p $+                 freezeContReentering c () $+                 invokeCont c $+                 invokeProcess pid $+                 preemptFacility r transact mode+            invokeEvent p $+              strategyEnqueueWithPriority+              (facilityDelayChain r)+              (transactPriority transact)+              (FacilityDelayedItem transact t True True c)+            invokeEvent p $ updateFacilityQueueCount r 1+       Just owner@(FacilityOwnerItem transact0 t0 preempting0 interrupting0 acc0)+         | (not $ facilityRemoveMode mode) ->+         do invokeEvent p $ writeRef (facilityOwnerRef r) $ Just (FacilityOwnerItem transact t True True 0)+            pid0 <- invokeEvent p $ requireTransactProcessId transact0+            t2   <- invokeEvent p $ processInterruptionTime pid0+            let dt0 = fmap (\x -> x - t) t2+            invokeEvent p $+              strategyEnqueueWithPriority+              (facilityInterruptChain r)+              (transactPriority transact0)+              (FacilityInterruptedItem transact0 t preempting0 interrupting0 dt0 (facilityTransfer mode) (acc0 + (t - t0)))+            invokeEvent p $ updateFacilityQueueCount r 1+            invokeEvent p $ updateFacilityWaitTime r 0+            invokeEvent p $ updateFacilityCaptureCount r 1+            invokeEvent p $ transactPreemptionBegin transact0+            invokeEvent p $ resumeCont c ()+       Just owner@(FacilityOwnerItem transact0 t0 preempting0 interruptin0 acc0)+         | facilityRemoveMode mode ->+         do invokeEvent p $ writeRef (facilityOwnerRef r) $ Just (FacilityOwnerItem transact t True True 0)+            pid0 <- invokeEvent p $ requireTransactProcessId transact0+            t2   <- invokeEvent p $ processInterruptionTime pid0+            let dt0 = fmap (\x -> x - t) t2+            invokeEvent p $ updateFacilityWaitTime r 0+            invokeEvent p $ updateFacilityCaptureCount r 1+            invokeEvent p $ updateFacilityHoldingTime r (acc0 + (t - t0))+            case facilityTransfer mode of+              Nothing ->+                throwComp $+                SimulationRetry+                "The transfer destination is not specified for the removed preempted transact: preemptFacility"+              Just transfer ->+                invokeEvent p $ transferTransact transact0 (transfer transact0 dt0)+            invokeEvent p $ resumeCont c ()++-- | Return the facility by the active transact.+returnFacility :: MonadDES m+                  => Facility m a+                  -- ^ the facility to return+                  -> Transact m a+                  -- ^ the active transact that tries to return the facility+                  -> Process m ()+{-# INLINABLE returnFacility #-}+returnFacility r transact = releaseFacility' r transact True ++-- | Release the facility by the active transact.+releaseFacility :: MonadDES m+                   => Facility m a+                   -- ^ the facility to release+                   -> Transact m a+                   -- ^ the active transact that tries to release the facility+                   -> Process m ()+{-# INLINABLE releaseFacility #-}+releaseFacility r transact = releaseFacility' r transact False ++-- | Release the facility by the active transact.+releaseFacility' :: MonadDES m+                    => Facility m a+                    -- ^ the facility to release+                    -> Transact m a+                    -- ^ the active transact that tries to release the facility+                    -> Bool+                    -- ^ whether the transact is preempting+                    -> Process m ()+{-# INLINABLE releaseFacility' #-}+releaseFacility' r transact preempting = +  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do let t = pointTime p+     a <- invokeEvent p $ readRef (facilityOwnerRef r)+     case a of+       Nothing ->+         throwComp $+         SimulationRetry+         "There is no owner of the facility: releaseFacility'"+       Just owner@(FacilityOwnerItem transact0 t0 preempting0 interrupting0 acc0) | transact0 == transact && preempting0 /= preempting ->+         throwComp $+         SimulationRetry+         "The mismatch use of releaseFacility and returnFacility: releaseFacility'"+       Just owner@(FacilityOwnerItem transact0 t0 preempting0 interrupting0 acc0) | transact0 == transact ->+         do invokeEvent p $ writeRef (facilityOwnerRef r) Nothing+            invokeEvent p $ updateFacilityUtilisationCount r (-1)+            invokeEvent p $ updateFacilityHoldingTime r (acc0 + (t - t0))+            invokeEvent p $ updateFacilityCount r 1+            invokeEvent p $ enqueueEvent t $ tryCaptureFacility r+            invokeEvent p $ resumeCont c ()+       Just owner ->+         throwComp $+         SimulationRetry+         "The facility has another owner: releaseFacility'"++-- | Try to capture the facility.+tryCaptureFacility :: MonadDES m => Facility m a -> Event m ()+{-# INLINABLE tryCaptureFacility #-}+tryCaptureFacility r =+  Event $ \p ->+  do let t = pointTime p+     a <- invokeEvent p $ readRef (facilityOwnerRef r)+     case a of+       Nothing ->+         invokeEvent p $ captureFacility r+       Just owner -> return ()++-- | Find another owner of the facility.+captureFacility :: MonadDES m => Facility m a -> Event m ()+{-# INLINABLE captureFacility #-}+captureFacility r =+  Event $ \p ->+  do let t = pointTime p+     f <- invokeEvent p $ strategyQueueNull (facilityPendingChain r)+     if not f+       then do FacilityPendingItem transact t0 preempting interrupting c0 <- invokeEvent p $ strategyDequeue (facilityPendingChain r)+               invokeEvent p $ updateFacilityQueueCount r (-1)+               c <- invokeEvent p $ unfreezeCont c0+               case c of+                 Nothing ->+                   invokeEvent p $ captureFacility r+                 Just c ->+                   do invokeEvent p $ writeRef (facilityOwnerRef r) $ Just (FacilityOwnerItem transact t preempting interrupting 0)+                      invokeEvent p $ updateFacilityWaitTime r (t - t0)+                      invokeEvent p $ updateFacilityUtilisationCount r 1+                      invokeEvent p $ updateFacilityCaptureCount r 1+                      invokeEvent p $ updateFacilityCount r (-1)+                      invokeEvent p $ enqueueEvent t $ reenterCont c ()+       else do f <- invokeEvent p $ strategyQueueNull (facilityInterruptChain r)+               if not f+                  then do FacilityInterruptedItem transact t0 preempting interrupting dt0 transfer0 acc0 <- invokeEvent p $ strategyDequeue (facilityInterruptChain r)+                          pid <- invokeEvent p $ requireTransactProcessId transact+                          invokeEvent p $ updateFacilityQueueCount r (-1)+                          f <- invokeEvent p $ processCancelled pid+                          case f of+                            True ->+                              invokeEvent p $ captureFacility r+                            False ->+                              do invokeEvent p $ writeRef (facilityOwnerRef r) $ Just (FacilityOwnerItem transact t preempting interrupting acc0)+                                 invokeEvent p $ updateFacilityWaitTime r (t - t0)+                                 invokeEvent p $ updateFacilityUtilisationCount r 1+                                 invokeEvent p $ updateFacilityCount r (-1)+                                 case transfer0 of+                                   Nothing -> return ()+                                   Just transfer ->+                                     invokeEvent p $ transferTransact transact (transfer transact dt0)+                                 invokeEvent p $ transactPreemptionEnd transact+                 else do f <- invokeEvent p $ strategyQueueNull (facilityDelayChain r)+                         if not f+                           then do FacilityDelayedItem transact t0 preempting interrupting c0 <- invokeEvent p $ strategyDequeue (facilityDelayChain r)+                                   invokeEvent p $ updateFacilityQueueCount r (-1)+                                   c <- invokeEvent p $ unfreezeCont c0+                                   case c of+                                     Nothing ->+                                       invokeEvent p $ captureFacility r+                                     Just c ->+                                       do invokeEvent p $ writeRef (facilityOwnerRef r) $ Just (FacilityOwnerItem transact t preempting interrupting 0)+                                          invokeEvent p $ updateFacilityWaitTime r (t - t0)+                                          invokeEvent p $ updateFacilityUtilisationCount r 1+                                          invokeEvent p $ updateFacilityCaptureCount r 1+                                          invokeEvent p $ updateFacilityCount r (-1)+                                          invokeEvent p $ enqueueEvent t $ reenterCont c ()+                           else return ()++-- | Signal triggered when one of the facility counters changes.+facilityChanged_ :: MonadDES m => Facility m a -> Signal m ()+{-# INLINABLE facilityChanged_ #-}+facilityChanged_ r =+  facilityCountChanged_ r <>+  facilityCaptureCountChanged_ r <>+  facilityUtilisationCountChanged_ r <>+  facilityQueueCountChanged_ r++-- | Update the facility count and its statistics.+updateFacilityCount :: MonadDES m => Facility m a -> Int -> Event m ()+{-# INLINABLE updateFacilityCount #-}+updateFacilityCount r delta =+  Event $ \p ->+  do a <- invokeEvent p $ readRef (facilityCountRef r)+     let a' = a + delta+     invokeEvent p $+       writeRef (facilityCountRef r) a'+     invokeEvent p $+       modifyRef (facilityCountStatsRef r) $+       addTimingStats (pointTime p) a'+     invokeEvent p $+       triggerSignal (facilityCountSource r) a'++-- | Update the facility capture count.+updateFacilityCaptureCount :: MonadDES m => Facility m a -> Int -> Event m ()+{-# INLINABLE updateFacilityCaptureCount #-}+updateFacilityCaptureCount r delta =+  Event $ \p ->+  do a <- invokeEvent p $ readRef (facilityCaptureCountRef r)+     let a' = a + delta+     invokeEvent p $+       writeRef (facilityCaptureCountRef r) a'+     invokeEvent p $+       triggerSignal (facilityCaptureCountSource r) a'++-- | Update the facility queue length and its statistics.+updateFacilityQueueCount :: MonadDES m => Facility m a -> Int -> Event m ()+{-# INLINABLE updateFacilityQueueCount #-}+updateFacilityQueueCount r delta =+  Event $ \p ->+  do a <- invokeEvent p $ readRef (facilityQueueCountRef r)+     let a' = a + delta+     invokeEvent p $+       writeRef (facilityQueueCountRef r) a'+     invokeEvent p $+       modifyRef (facilityQueueCountStatsRef r) $+       addTimingStats (pointTime p) a'+     invokeEvent p $+       triggerSignal (facilityQueueCountSource r) a'++-- | Update the facility utilisation count and its statistics.+updateFacilityUtilisationCount :: MonadDES m => Facility m a -> Int -> Event m ()+{-# INLINABLE updateFacilityUtilisationCount #-}+updateFacilityUtilisationCount r delta =+  Event $ \p ->+  do a <- invokeEvent p $ readRef (facilityUtilisationCountRef r)+     let a' = a + delta+     invokeEvent p $+       writeRef (facilityUtilisationCountRef r) a'+     invokeEvent p $+       modifyRef (facilityUtilisationCountStatsRef r) $+       addTimingStats (pointTime p) a'+     invokeEvent p $+       triggerSignal (facilityUtilisationCountSource r) a'++-- | Update the facility wait time and its statistics.+updateFacilityWaitTime :: MonadDES m => Facility m a -> Double -> Event m ()+{-# INLINABLE updateFacilityWaitTime #-}+updateFacilityWaitTime r delta =+  Event $ \p ->+  do a <- invokeEvent p $ readRef (facilityTotalWaitTimeRef r)+     let a' = a + delta+     invokeEvent p $+       writeRef (facilityTotalWaitTimeRef r) a'+     invokeEvent p $+       modifyRef (facilityWaitTimeRef r) $+       addSamplingStats delta+     invokeEvent p $+       triggerSignal (facilityWaitTimeSource r) ()++-- | Update the facility holding time and its statistics.+updateFacilityHoldingTime :: MonadDES m => Facility m a -> Double -> Event m ()+{-# INLINABLE updateFacilityHoldingTime #-}+updateFacilityHoldingTime r delta =+  Event $ \p ->+  do a <- invokeEvent p $ readRef (facilityTotalHoldingTimeRef r)+     let a' = a + delta+     invokeEvent p $+       writeRef (facilityTotalHoldingTimeRef r) a'+     invokeEvent p $+       modifyRef (facilityHoldingTimeRef r) $+       addSamplingStats delta+     invokeEvent p $+       triggerSignal (facilityHoldingTimeSource r) ()++-- | Reset the statistics.+resetFacility :: MonadDES m => Facility m a -> Event m ()+{-# INLINABLE resetFacility #-}+resetFacility r =+  Event $ \p ->+  do let t = pointTime p+     count <- invokeEvent p $ readRef (facilityCountRef r)+     invokeEvent p $ writeRef (facilityCountStatsRef r) $+       returnTimingStats t count+     invokeEvent p $ writeRef (facilityCaptureCountRef r) 0+     utilCount <- invokeEvent p $ readRef (facilityUtilisationCountRef r)+     invokeEvent p $ writeRef (facilityUtilisationCountStatsRef r) $+       returnTimingStats t utilCount+     queueCount <- invokeEvent p $ readRef (facilityQueueCountRef r)+     invokeEvent p $ writeRef (facilityQueueCountStatsRef r) $+       returnTimingStats t queueCount+     invokeEvent p $ writeRef (facilityTotalWaitTimeRef r) 0+     invokeEvent p $ writeRef (facilityWaitTimeRef r) emptySamplingStats+     invokeEvent p $ writeRef (facilityTotalHoldingTimeRef r) 0+     invokeEvent p $ writeRef (facilityHoldingTimeRef r) emptySamplingStats+     invokeEvent p $+       triggerSignal (facilityCaptureCountSource r) 0+     invokeEvent p $+       triggerSignal (facilityWaitTimeSource r) ()+     invokeEvent p $+       triggerSignal (facilityHoldingTimeSource r) ()
+ Simulation/Aivika/Trans/GPSS/MatchChain.hs view
@@ -0,0 +1,102 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.MatchChain+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines a GPSS Match Chain.+--+module Simulation.Aivika.Trans.GPSS.MatchChain+       (MatchChain,+        newMatchChain,+        matchTransact,+        transactMatching,+        transactMatchingChanged,+        transactMatchingChangedByTransact_,+        transactMatchingChangedByAssemblySet_) where++import Control.Monad+import Control.Monad.Trans++import qualified Data.HashMap.Lazy as HM++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS.Transact+import Simulation.Aivika.Trans.GPSS.AssemblySet++-- | Represents a Match Chain.+data MatchChain m =+  MatchChain { matchChainMap :: Ref m (HM.HashMap (AssemblySet m) (ProcessId m)),+               matchChainSource :: SignalSource m (AssemblySet m)+             }++-- | Create a new Match Chain.+newMatchChain :: MonadDES m => Simulation m (MatchChain m)+{-# INLINABLE newMatchChain #-}+newMatchChain =+  do map <- newRef HM.empty+     src <- newSignalSource+     return MatchChain { matchChainMap = map,+                         matchChainSource = src+                       }++-- | Match the transact.+matchTransact :: MonadDES m => MatchChain m -> Transact m a -> Process m ()+{-# INLINABLE matchTransact #-}+matchTransact chain t =+  do (map, set) <-+       liftEvent $+       do map <- readRef (matchChainMap chain)+          set <- transactAssemblySet t+          return (map, set)+     case HM.lookup set map of+       Just pid ->+         liftEvent $+           do modifyRef (matchChainMap chain) $+                HM.delete set+              yieldEvent $+                triggerSignal (matchChainSource chain) set+              reactivateProcess pid+       Nothing ->+         do liftEvent $+              do pid <- requireTransactProcessId t+                 modifyRef (matchChainMap chain) $+                   HM.insert set pid+                 yieldEvent $+                   triggerSignal (matchChainSource chain) set+            passivateProcess++-- | Test whether there is a matching transact.+transactMatching :: MonadDES m => MatchChain m -> AssemblySet m -> Event m Bool+{-# INLINABLE transactMatching #-}+transactMatching chain set =+  do map <- readRef (matchChainMap chain)+     return (HM.member set map)++-- | Signal each time the 'transactMatching' flag changes.+transactMatchingChangedByAssemblySet_ :: MonadDES m => MatchChain m -> AssemblySet m -> Signal m ()+{-# INLINABLE transactMatchingChangedByAssemblySet_ #-}+transactMatchingChangedByAssemblySet_ chain set =+  mapSignal (const ()) $+  filterSignal (== set) $+  transactMatchingChanged chain++-- | Signal each time the 'transactMatching' flag changes.+transactMatchingChangedByTransact_ :: MonadDES m => MatchChain m -> Transact m a -> Signal m ()+{-# INLINABLE transactMatchingChangedByTransact_ #-}+transactMatchingChangedByTransact_ chain t =+  mapSignal (const ()) $+  filterSignalM pred $+  transactMatchingChanged chain+    where pred set =+            do set' <- transactAssemblySet t+               return (set == set')++-- | Signal each time the 'transactMatching' flag changes.+transactMatchingChanged :: MonadDES m => MatchChain m -> Signal m (AssemblySet m)+{-# INLINABLE transactMatchingChanged #-}+transactMatchingChanged chain =+  publishSignal (matchChainSource chain)
+ Simulation/Aivika/Trans/GPSS/Queue.hs view
@@ -0,0 +1,376 @@++{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Queue+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines a GPSS queue entity.+--+module Simulation.Aivika.Trans.GPSS.Queue+       (-- * Queue Types+        Queue,+        QueueEntry(..),+        -- * Creating Queue+        newQueue,+        -- * Queue Properties and Activities+        queueNull,+        queueContent,+        queueContentStats,+        enqueueCount,+        enqueueZeroEntryCount,+        queueWaitTime,+        queueNonZeroEntryWaitTime,+        queueRate,+        -- * Dequeuing and Enqueuing+        enqueue,+        dequeue,+        -- * Statistics Reset+        resetQueue,+        -- * Derived Signals for Properties+        queueNullChanged,+        queueNullChanged_,+        queueContentChanged,+        queueContentChanged_,+        enqueueCountChanged,+        enqueueCountChanged_,+        enqueueZeroEntryCountChanged,+        enqueueZeroEntryCountChanged_,+        queueWaitTimeChanged,+        queueWaitTimeChanged_,+        queueNonZeroEntryWaitTimeChanged,+        queueNonZeroEntryWaitTimeChanged_,+        queueRateChanged,+        queueRateChanged_,+        -- * Basic Signals+        enqueued,+        dequeued,+        -- * Overall Signal+        queueChanged_) where++import Data.Monoid+import Data.Maybe+import Data.Hashable++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Internal.Simulation+import Simulation.Aivika.Trans.Internal.Dynamics+import Simulation.Aivika.Trans.Internal.Event+import Simulation.Aivika.Trans.Internal.Process+import Simulation.Aivika.Trans.Signal+import Simulation.Aivika.Trans.Statistics++import Simulation.Aivika.Trans.GPSS.Transact++-- | Represents the queue entity.+data Queue m =+  Queue { queueSequenceNo :: Int,+          queueContentRef :: Ref m Int,+          queueContentStatsRef :: Ref m (TimingStats Int),+          enqueueCountRef :: Ref m Int,+          enqueueZeroEntryCountRef :: Ref m Int,+          queueWaitTimeRef :: Ref m (SamplingStats Double),+          queueNonZeroEntryWaitTimeRef :: Ref m (SamplingStats Double),+          enqueuedSource :: SignalSource m (),+          dequeuedSource :: SignalSource m ()+        }++-- | The information about queue entry.+data QueueEntry m =+  QueueEntry { entryQueue :: Queue m,+               -- ^ the entry queue+               entryEnqueueTime :: Double+               -- ^ the time of registering the queue entry+             } deriving Eq++instance MonadDES m => Eq (Queue m) where+  x == y = (queueContentRef x) == (queueContentRef y)++instance Hashable (Queue m) where+  hashWithSalt salt x = hashWithSalt salt (queueSequenceNo x)++-- | Create a new queue.+newQueue :: MonadDES m => Event m (Queue m)+{-# INLINABLE newQueue #-}+newQueue =+  do t  <- liftDynamics time+     g  <- liftParameter generatorParameter+     no <- liftComp $ generateSequenceNo g+     i  <- liftSimulation $ newRef 0+     is <- liftSimulation $ newRef $ returnTimingStats t 0+     e  <- liftSimulation $ newRef 0+     z  <- liftSimulation $ newRef 0 +     w  <- liftSimulation $ newRef mempty+     w2 <- liftSimulation $ newRef mempty+     s1 <- liftSimulation $ newSignalSource+     s2 <- liftSimulation $ newSignalSource+     return Queue { queueSequenceNo = no,+                    queueContentRef = i,+                    queueContentStatsRef = is,+                    enqueueCountRef = e,+                    enqueueZeroEntryCountRef = z,+                    queueWaitTimeRef = w,+                    queueNonZeroEntryWaitTimeRef = w2,+                    enqueuedSource = s1,+                    dequeuedSource = s2 }+  +-- | Test whether the queue is empty.+--+-- See also 'queueNullChanged' and 'queueNullChanged_'.+queueNull :: MonadDES m => Queue m -> Event m Bool+{-# INLINABLE queueNull #-}+queueNull q =+  Event $ \p ->+  do n <- invokeEvent p $ readRef (queueContentRef q)+     return (n == 0)+  +-- | Signal when the 'queueNull' property value has changed.+queueNullChanged :: MonadDES m => Queue m -> Signal m Bool+{-# INLINABLE queueNullChanged #-}+queueNullChanged q =+  mapSignalM (const $ queueNull q) (queueNullChanged_ q)+  +-- | Signal when the 'queueNull' property value has changed.+queueNullChanged_ :: MonadDES m => Queue m -> Signal m ()+{-# INLINABLE queueNullChanged_ #-}+queueNullChanged_ = queueContentChanged_++-- | Return the current queue content.+--+-- See also 'queueContentStats', 'queueContentChanged' and 'queueContentChanged_'.+queueContent :: MonadDES m => Queue m -> Event m Int+{-# INLINABLE queueContent #-}+queueContent q =+  Event $ \p -> invokeEvent p $ readRef (queueContentRef q)++-- | Return the queue content statistics.+queueContentStats :: MonadDES m => Queue m -> Event m (TimingStats Int)+{-# INLINABLE queueContentStats #-}+queueContentStats q =+  Event $ \p -> invokeEvent p $ readRef (queueContentStatsRef q)+  +-- | Signal when the 'queueContent' property value has changed.+queueContentChanged :: MonadDES m => Queue m -> Signal m Int+{-# INLINABLE queueContentChanged #-}+queueContentChanged q =+  mapSignalM (const $ queueContent q) (queueContentChanged_ q)+  +-- | Signal when the 'queueContent' property value has changed.+queueContentChanged_ :: MonadDES m => Queue m -> Signal m ()+{-# INLINABLE queueContentChanged_ #-}+queueContentChanged_ q =+  mapSignal (const ()) (enqueued q) <>+  mapSignal (const ()) (dequeued q)++-- | Return the total number of input items that were enqueued.+--+-- See also 'enqueueCountChanged' and 'enqueueCountChanged_'.+enqueueCount :: MonadDES m => Queue m -> Event m Int+{-# INLINABLE enqueueCount #-}+enqueueCount q =+  Event $ \p -> invokeEvent p $ readRef (enqueueCountRef q)+  +-- | Signal when the 'enqueueCount' property value has changed.+enqueueCountChanged :: MonadDES m => Queue m -> Signal m Int+{-# INLINABLE enqueueCountChanged #-}+enqueueCountChanged q =+  mapSignalM (const $ enqueueCount q) (enqueueCountChanged_ q)+  +-- | Signal when the 'enqueueCount' property value has changed.+enqueueCountChanged_ :: MonadDES m => Queue m -> Signal m ()+{-# INLINABLE enqueueCountChanged_ #-}+enqueueCountChanged_ q =+  mapSignal (const ()) (enqueued q)++-- | Return the total number of zero entry items.+--+-- See also 'enqueueZeroEntryCountChanged' and 'enqueueZeroEntryCountChanged_'.+enqueueZeroEntryCount :: MonadDES m => Queue m -> Event m Int+{-# INLINABLE enqueueZeroEntryCount #-}+enqueueZeroEntryCount q =+  Event $ \p -> invokeEvent p $ readRef (enqueueZeroEntryCountRef q)+  +-- | Signal when the 'enqueueZeroEntryCount' property value has changed.+enqueueZeroEntryCountChanged :: MonadDES m => Queue m -> Signal m Int+{-# INLINABLE enqueueZeroEntryCountChanged #-}+enqueueZeroEntryCountChanged q =+  mapSignalM (const $ enqueueZeroEntryCount q) (enqueueZeroEntryCountChanged_ q)+  +-- | Signal when the 'enqueueZeroEntryCount' property value has changed.+enqueueZeroEntryCountChanged_ :: MonadDES m => Queue m -> Signal m ()+{-# INLINABLE enqueueZeroEntryCountChanged_ #-}+enqueueZeroEntryCountChanged_ q =+  mapSignal (const ()) (dequeued q)++-- | Return the wait (or residence) time.+--+-- See also 'queueWaitTimeChanged' and 'queueWaitTimeChanged_'.+queueWaitTime :: MonadDES m => Queue m -> Event m (SamplingStats Double)+{-# INLINABLE queueWaitTime #-}+queueWaitTime q =+  Event $ \p -> invokeEvent p $ readRef (queueWaitTimeRef q)+      +-- | Signal when the 'queueWaitTime' property value has changed.+queueWaitTimeChanged :: MonadDES m => Queue m -> Signal m (SamplingStats Double)+{-# INLINABLE queueWaitTimeChanged #-}+queueWaitTimeChanged q =+  mapSignalM (const $ queueWaitTime q) (queueWaitTimeChanged_ q)+  +-- | Signal when the 'queueWaitTime' property value has changed.+queueWaitTimeChanged_ :: MonadDES m => Queue m -> Signal m ()+{-# INLINABLE queueWaitTimeChanged_ #-}+queueWaitTimeChanged_ q =+  mapSignal (const ()) (dequeued q)+      +-- | Return the wait (or residence) time excluding zero entries.+--+-- See also 'queueNonZeroEntryWaitTimeChanged' and 'queueNonZeroEntryWaitTimeChanged_'.+queueNonZeroEntryWaitTime :: MonadDES m => Queue m -> Event m (SamplingStats Double)+{-# INLINABLE queueNonZeroEntryWaitTime #-}+queueNonZeroEntryWaitTime q =+  Event $ \p -> invokeEvent p $ readRef (queueNonZeroEntryWaitTimeRef q)+      +-- | Signal when the 'queueNonZeroEntryWaitTime' property value has changed.+queueNonZeroEntryWaitTimeChanged :: MonadDES m => Queue m -> Signal m (SamplingStats Double)+{-# INLINABLE queueNonZeroEntryWaitTimeChanged #-}+queueNonZeroEntryWaitTimeChanged q =+  mapSignalM (const $ queueNonZeroEntryWaitTime q) (queueNonZeroEntryWaitTimeChanged_ q)+  +-- | Signal when the 'queueNonZeroEntryWaitTime' property value has changed.+queueNonZeroEntryWaitTimeChanged_ :: MonadDES m => Queue m -> Signal m ()+{-# INLINABLE queueNonZeroEntryWaitTimeChanged_ #-}+queueNonZeroEntryWaitTimeChanged_ q =+  mapSignal (const ()) (dequeued q)++-- | Return a long-term average queue rate calculated as+-- the average queue size divided by the average wait time.+--+-- See also 'queueRateChanged' and 'queueRateChanged_'.+queueRate :: MonadDES m => Queue m -> Event m Double+{-# INLINABLE queueRate #-}+queueRate q =+  Event $ \p ->+  do x <- invokeEvent p $ readRef (queueContentStatsRef q)+     y <- invokeEvent p $ readRef (queueWaitTimeRef q)+     return (timingStatsMean x / samplingStatsMean y) +      +-- | Signal when the 'queueRate' property value has changed.+queueRateChanged :: MonadDES m => Queue m -> Signal m Double+{-# INLINABLE queueRateChanged #-}+queueRateChanged q =+  mapSignalM (const $ queueRate q) (queueRateChanged_ q)+      +-- | Signal when the 'queueRate' property value has changed.+queueRateChanged_ :: MonadDES m => Queue m -> Signal m ()+{-# INLINABLE queueRateChanged_ #-}+queueRateChanged_ q =+  mapSignal (const ()) (enqueued q) <>+  mapSignal (const ()) (dequeued q)++-- | Return a signal that notifies when enqueuing an item.+enqueued:: MonadDES m => Queue m -> Signal m ()+{-# INLINABLE enqueued #-}+enqueued q = publishSignal (enqueuedSource q)++-- | Return a signal that notifies when the dequeuing the item.+dequeued :: MonadDES m => Queue m -> Signal m ()+{-# INLINABLE dequeued #-}+dequeued q = publishSignal (dequeuedSource q)++-- | Enqueue the item.+enqueue :: MonadDES m+           => Queue m+           -- ^ the queue+           -> Transact m a+           -- ^ the item to be enqueued+           -> Int+           -- ^ the content increment+           -> Event m ()+{-# INLINABLE enqueue #-}+enqueue q transact increment =+  Event $ \p ->+  do let t = pointTime p+         e = QueueEntry { entryQueue = q,+                          entryEnqueueTime = t }+     n <- invokeEvent p $ readRef (enqueueCountRef q)+     let n' = n + 1+     invokeEvent p $+       writeRef (enqueueCountRef q) n'+     c <- invokeEvent p $ readRef (queueContentRef q)+     let c' = c + increment+     invokeEvent p $+       writeRef (queueContentRef q) c'+     invokeEvent p $+       modifyRef (queueContentStatsRef q) (addTimingStats t c')+     invokeEvent p $+       registerTransactQueueEntry transact e+     invokeEvent p $+       triggerSignal (enqueuedSource q) ()++-- | Dequeue the item.+dequeue :: MonadDES m+           => Queue m+           -- ^ the queue+           -> Transact m a+           -- ^ the item to be dequeued+           -> Int+           -- ^ the content decrement+           -> Event m ()+{-# INLINABLE dequeue #-}+dequeue q transact decrement =+  Event $ \p ->+  do e <- invokeEvent p $+          unregisterTransactQueueEntry transact q+     let t  = pointTime p+         t0 = entryEnqueueTime e+         dt = t - t0+     c <- invokeEvent p $ readRef (queueContentRef q)+     let c' = c - decrement+     invokeEvent p $+       writeRef (queueContentRef q) c'+     invokeEvent p $+       modifyRef (queueContentStatsRef q) (addTimingStats t c')+     invokeEvent p $+       modifyRef (queueWaitTimeRef q) $+       addSamplingStats dt+     if t == t0+       then invokeEvent p $+            modifyRef (enqueueZeroEntryCountRef q) (+ 1)+       else invokeEvent p $+            modifyRef (queueNonZeroEntryWaitTimeRef q) $+            addSamplingStats dt+     invokeEvent p $+       triggerSignal (dequeuedSource q) ()++-- | Signal whenever any property of the queue changes.+--+-- The property must have the corresponded signal. There are also characteristics+-- similar to the properties but that have no signals. As a rule, such characteristics+-- already depend on the simulation time and therefore they may change at any+-- time point.+queueChanged_ :: MonadDES m => Queue m -> Signal m ()+{-# INLINABLE queueChanged_ #-}+queueChanged_ q =+  mapSignal (const ()) (enqueued q) <>+  mapSignal (const ()) (dequeued q)++-- | Reset the statistics.+resetQueue :: MonadDES m => Queue m -> Event m ()+{-# INLINABLE resetQueue #-}+resetQueue q =+  do t  <- liftDynamics time+     content <- readRef (queueContentRef q)+     writeRef (queueContentStatsRef q) $+       returnTimingStats t content+     writeRef (enqueueCountRef q) 0+     writeRef (enqueueZeroEntryCountRef q) 0+     writeRef (queueWaitTimeRef q) mempty+     writeRef (queueNonZeroEntryWaitTimeRef q) mempty
+ Simulation/Aivika/Trans/GPSS/Queue.hs-boot view
@@ -0,0 +1,43 @@++{-# LANGUAGE KindSignatures #-}++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Queue+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This is an hs-boot file.+--+module Simulation.Aivika.Trans.GPSS.Queue+       (Queue,+        QueueEntry,+        entryQueue) where++import Data.Hashable++import Simulation.Aivika.Trans++data Queue m =+  Queue { queueSequenceNo :: Int,+          queueContentRef :: Ref m Int,+          queueContentStatsRef :: Ref m (TimingStats Int),+          enqueueCountRef :: Ref m Int,+          enqueueZeroEntryCountRef :: Ref m Int,+          queueWaitTimeRef :: Ref m (SamplingStats Double),+          queueNonZeroEntryWaitTimeRef :: Ref m (SamplingStats Double),+          enqueuedSource :: SignalSource m (),+          dequeuedSource :: SignalSource m ()+        }++data QueueEntry m =+  QueueEntry { entryQueue :: Queue m,+               entryEnqueueTime :: Double+             }++instance MonadDES m => Eq (Queue m)+instance Hashable (Queue m)++instance MonadDES m => Eq (QueueEntry m)
+ Simulation/Aivika/Trans/GPSS/Results.hs view
@@ -0,0 +1,183 @@++{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Results+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- The module allows exporting the simulation results from the model.+--+module Simulation.Aivika.Trans.GPSS.Results () where++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Trans++import qualified Simulation.Aivika.Trans.GPSS.Queue as Q+import Simulation.Aivika.Trans.GPSS.Facility+import Simulation.Aivika.Trans.GPSS.Storage+import Simulation.Aivika.Trans.GPSS.Results.Locale+  +-- | Return a source by the specified queue.+queueResultSource :: MonadDES m+                     => ResultContainer (Q.Queue m) m+                     -- ^ the queue container+                     -> ResultSource m+queueResultSource c =+  ResultObjectSource $+  ResultObject {+    resultObjectName = resultContainerName c,+    resultObjectId = resultContainerId c,+    resultObjectTypeId = queueId,+    resultObjectSignal = resultContainerSignal c,+    resultObjectSummary = queueResultSummary c,+    resultObjectProperties = [+      resultContainerProperty c "queueNull" queueNullId Q.queueNull Q.queueNullChanged_,+      resultContainerProperty c "queueContent" queueContentId Q.queueContent Q.queueContentChanged_,+      resultContainerProperty c "queueContentStats" queueContentStatsId Q.queueContentStats Q.queueContentChanged_,+      resultContainerProperty c "enqueueCount" enqueueCountId Q.enqueueCount Q.enqueueCountChanged_,+      resultContainerProperty c "enqueueZeroEntryCount" enqueueZeroEntryCountId Q.enqueueZeroEntryCount Q.enqueueZeroEntryCountChanged_,+      resultContainerProperty c "queueWaitTime" queueWaitTimeId Q.queueWaitTime Q.queueWaitTimeChanged_,+      resultContainerProperty c "queueNonZeroEntryWaitTime" queueNonZeroEntryWaitTimeId Q.queueNonZeroEntryWaitTime Q.queueNonZeroEntryWaitTimeChanged_,+      resultContainerProperty c "queueRate" queueRateId Q.queueRate Q.queueRateChanged_ ] }++-- | Return the summary by the specified queue.+queueResultSummary :: MonadDES m =>+                      ResultContainer (Q.Queue m) m+                      -- ^ the queue container+                      -> ResultSource m+queueResultSummary c =+  ResultObjectSource $+  ResultObject {+    resultObjectName = resultContainerName c,+    resultObjectId = resultContainerId c,+    resultObjectTypeId = queueId,+    resultObjectSignal = resultContainerSignal c,+    resultObjectSummary = queueResultSummary c,+    resultObjectProperties = [+      resultContainerProperty c "queueContentStats" queueContentStatsId Q.queueContentStats Q.queueContentChanged_,+      resultContainerProperty c "enqueueCount" enqueueCountId Q.enqueueCount Q.enqueueCountChanged_,+      resultContainerProperty c "enqueueZeroEntryCount" enqueueZeroEntryCountId Q.enqueueZeroEntryCount Q.enqueueZeroEntryCountChanged_,+      resultContainerProperty c "queueWaitTime" queueWaitTimeId Q.queueWaitTime Q.queueWaitTimeChanged_,+      resultContainerProperty c "queueNonZeroEntryWaitTime" queueNonZeroEntryWaitTimeId Q.queueNonZeroEntryWaitTime Q.queueNonZeroEntryWaitTimeChanged_,+      resultContainerProperty c "queueRate" queueRateId Q.queueRate Q.queueRateChanged_ ] }++-- | Return a source by the specified facility.+facilityResultSource :: MonadDES m =>+                        ResultContainer (Facility m a) m+                        -- ^ the facility container+                        -> ResultSource m+facilityResultSource c =+  ResultObjectSource $+  ResultObject {+    resultObjectName = resultContainerName c,+    resultObjectId = resultContainerId c,+    resultObjectTypeId = facilityId,+    resultObjectSignal = resultContainerSignal c,+    resultObjectSummary = facilityResultSummary c,+    resultObjectProperties = [+      resultContainerProperty c "queueCount" facilityQueueCountId facilityQueueCount facilityQueueCountChanged_,+      resultContainerProperty c "queueCountStats" facilityQueueCountStatsId facilityQueueCountStats facilityQueueCountChanged_,+      resultContainerProperty c "totalWaitTime" facilityTotalWaitTimeId facilityTotalWaitTime facilityWaitTimeChanged_,+      resultContainerProperty c "waitTime" facilityWaitTimeId facilityWaitTime facilityWaitTimeChanged_,+      resultContainerProperty c "totalHoldingTime" facilityTotalHoldingTimeId facilityTotalHoldingTime facilityHoldingTimeChanged_,+      resultContainerProperty c "holdingTime" facilityHoldingTimeId facilityHoldingTime facilityHoldingTimeChanged_,+      resultContainerIntegProperty c "interrupted" facilityInterruptedId facilityInterrupted,+      resultContainerProperty c "count" facilityCountId facilityCount facilityCountChanged_,+      resultContainerProperty c "countStats" facilityCountStatsId facilityCountStats facilityCountChanged_,+      resultContainerProperty c "captureCount" facilityCaptureCountId facilityCaptureCount facilityCaptureCountChanged_,+      resultContainerProperty c "utilisationCount" facilityUtilisationCountId facilityUtilisationCount facilityUtilisationCountChanged_,+      resultContainerProperty c "utilisationCountStats" facilityUtilisationCountStatsId facilityUtilisationCountStats facilityUtilisationCountChanged_ ] }++-- | Return a summary by the specified facility.+facilityResultSummary :: MonadDES m =>+                         ResultContainer (Facility m a) m+                         -- ^ the facility container+                         -> ResultSource m+facilityResultSummary c =+  ResultObjectSource $+  ResultObject {+    resultObjectName = resultContainerName c,+    resultObjectId = resultContainerId c,+    resultObjectTypeId = facilityId,+    resultObjectSignal = resultContainerSignal c,+    resultObjectSummary = facilityResultSummary c,+    resultObjectProperties = [+      resultContainerProperty c "queueCountStats" facilityQueueCountStatsId facilityQueueCountStats facilityQueueCountChanged_,+      resultContainerProperty c "waitTime" facilityWaitTimeId facilityWaitTime facilityWaitTimeChanged_,+      resultContainerProperty c "holdingTime" facilityHoldingTimeId facilityHoldingTime facilityHoldingTimeChanged_,+      resultContainerProperty c "countStats" facilityCountStatsId facilityCountStats facilityCountChanged_,+      resultContainerProperty c "captureCount" facilityCaptureCountId facilityCaptureCount facilityCaptureCountChanged_,+      resultContainerProperty c "utilisationCountStats" facilityUtilisationCountStatsId facilityUtilisationCountStats facilityUtilisationCountChanged_ ] }++-- | Return a source by the specified storage.+storageResultSource :: MonadDES m+                       => ResultContainer (Storage m) m+                       -- ^ the storage container+                       -> ResultSource m+storageResultSource c =+  ResultObjectSource $+  ResultObject {+    resultObjectName = resultContainerName c,+    resultObjectId = resultContainerId c,+    resultObjectTypeId = storageId,+    resultObjectSignal = resultContainerSignal c,+    resultObjectSummary = storageResultSummary c,+    resultObjectProperties = [+      resultContainerConstProperty c "capacity" storageCapacityId storageCapacity,+      resultContainerIntegProperty c "empty" storageEmptyId storageEmpty,+      resultContainerIntegProperty c "full" storageFullId storageFull,+      resultContainerProperty c "queueCount" storageQueueCountId storageQueueCount storageQueueCountChanged_,+      resultContainerProperty c "queueCountStats" storageQueueCountStatsId storageQueueCountStats storageQueueCountChanged_,+      resultContainerProperty c "totalWaitTime" storageTotalWaitTimeId storageTotalWaitTime storageWaitTimeChanged_,+      resultContainerProperty c "waitTime" storageWaitTimeId storageWaitTime storageWaitTimeChanged_,+      resultContainerIntegProperty c "averageHoldingTime" storageAverageHoldingTimeId storageAverageHoldingTime,+      resultContainerProperty c "content" storageContentId storageContent storageContentChanged_,+      resultContainerProperty c "contentStats" storageContentStatsId storageContentStats storageContentChanged_,+      resultContainerProperty c "useCount" storageUseCountId storageUseCount storageUseCountChanged_,+      resultContainerProperty c "usedContent" storageUsedContentId storageUsedContent storageUsedContentChanged_,+      resultContainerProperty c "utilisationCount" storageUtilisationCountId storageUtilisationCount storageUtilisationCountChanged_,+      resultContainerProperty c "utilisationCountStats" storageUtilisationCountStatsId storageUtilisationCountStats storageUtilisationCountChanged_ ] }++-- | Return a summary by the specified storage.+storageResultSummary :: MonadDES m+                        => ResultContainer (Storage m) m+                        -- ^ the storage container+                        -> ResultSource m+storageResultSummary c =+  ResultObjectSource $+  ResultObject {+    resultObjectName = resultContainerName c,+    resultObjectId = resultContainerId c,+    resultObjectTypeId = storageId,+    resultObjectSignal = resultContainerSignal c,+    resultObjectSummary = storageResultSummary c,+    resultObjectProperties = [+      resultContainerConstProperty c "capacity" storageCapacityId storageCapacity,+      resultContainerProperty c "queueCountStats" storageQueueCountStatsId storageQueueCountStats storageQueueCountChanged_,+      resultContainerProperty c "waitTime" storageWaitTimeId storageWaitTime storageWaitTimeChanged_,+      resultContainerIntegProperty c "averageHoldingTime" storageAverageHoldingTimeId storageAverageHoldingTime,+      resultContainerProperty c "contentStats" storageContentStatsId storageContentStats storageContentChanged_,+      resultContainerProperty c "useCount" storageUseCountId storageUseCount storageUseCountChanged_,+      resultContainerProperty c "usedContent" storageUsedContentId storageUsedContent storageUsedContentChanged_,+      resultContainerProperty c "utilisationCountStats" storageUtilisationCountStatsId storageUtilisationCountStats storageUtilisationCountChanged_ ] }++instance MonadDES m => ResultProvider (Q.Queue m) m where++  resultSource' name i m =+    queueResultSource $ ResultContainer name i m (ResultSignal $ Q.queueChanged_ m)++instance MonadDES m => ResultProvider (Facility m a) m where++  resultSource' name i m =+    facilityResultSource $ ResultContainer name i m (ResultSignal $ facilityChanged_ m)++instance MonadDES m => ResultProvider (Storage m) m where++  resultSource' name i m =+    storageResultSource $ ResultContainer name i m (ResultSignal $ storageChanged_ m)
+ Simulation/Aivika/Trans/GPSS/Results/Locale.hs view
@@ -0,0 +1,316 @@++-- |+-- Module     : Simulation.Aivika.GPSS.Trans.Results.Locale+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- The module defines locales for the simulation results.+--+module Simulation.Aivika.Trans.GPSS.Results.Locale where++import qualified Data.Map as M++import Simulation.Aivika.Trans++import qualified Simulation.Aivika.Trans.GPSS.Queue as Q+import Simulation.Aivika.Trans.GPSS.Facility+import Simulation.Aivika.Trans.GPSS.Storage++-- | The queue identifier.+queueId :: ResultId+queueId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "очередь"),+   (englishResultLocale, "the queue")]++-- | Property 'Q.queueNull'.+queueNullId :: ResultId+queueNullId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "очередь пуста?"),+   (englishResultLocale, "is the queue empty?")]++-- | Property 'Q.queueContent'.+queueContentId :: ResultId+queueContentId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "текущее содержимое очереди"),+   (englishResultLocale, "the current queue content")]++-- | Property 'Q.queueContentStats'.+queueContentStatsId :: ResultId+queueContentStatsId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "статистика по содержимому очереди"),+   (englishResultLocale, "the queue content statistics")]++-- | Property 'Q.enqueueCount'.+enqueueCountId :: ResultId+enqueueCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "количество добавленных транзактов"),+   (englishResultLocale, "the number of enqueued transacts")]++-- | Property 'Q.enqueueZeroEntryCount'.+enqueueZeroEntryCountId :: ResultId+enqueueZeroEntryCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "количество добавленных транзактов без фактического ожидания"),+   (englishResultLocale, "the number of zero entry enqueued transacts")]++-- | Property 'Q.queueWaitTime'.+queueWaitTimeId :: ResultId+queueWaitTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "время ожидания"),+   (englishResultLocale, "the wait time")]++-- | Property 'Q.queueNonZeroEntryWaitTime'.+queueNonZeroEntryWaitTimeId :: ResultId+queueNonZeroEntryWaitTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "время ожидания без учета фактически неожидавших транзактов"),+   (englishResultLocale, "the wait time without zero entries")]++-- | Property 'Q.queueRate'.+queueRateId :: ResultId+queueRateId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "усредненная скорость (как средняя длина очереди на среднее время ожидания)"),+   (englishResultLocale, "the average queue rate (= queue size / wait time)")]++-- | The facility identifier.+facilityId :: ResultId+facilityId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "прибор"),+   (englishResultLocale, "the facility")]++-- | Property 'facilityCount'.+facilityCountId :: ResultId+facilityCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "текущее доступное количество прибора"),+   (englishResultLocale, "the current available count")]++-- | Property 'facilityCountStats'.+facilityCountStatsId :: ResultId+facilityCountStatsId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "статистика доступного количества прибора"),+   (englishResultLocale, "the available count statistics")]++-- | Property 'facilityCaptureCount'.+facilityCaptureCountId :: ResultId+facilityCaptureCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "текущее количество захвата прибора"),+   (englishResultLocale, "the current capture count")]++-- | Property 'facilityUtilisationCount'.+facilityUtilisationCountId :: ResultId+facilityUtilisationCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "текущее используемое количество прибора"),+   (englishResultLocale, "the current utilisation count")]++-- | Property 'facilityUtilisationCountStats'.+facilityUtilisationCountStatsId :: ResultId+facilityUtilisationCountStatsId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "статистка по используемому количеству прибора"),+   (englishResultLocale, "the utilisation count statistics")]++-- | Property 'facilityQueueCount'.+facilityQueueCountId :: ResultId+facilityQueueCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "текущая длина очереди к прибору"),+   (englishResultLocale, "the current queue size")]++-- | Property 'facilityQueueCountStats'.+facilityQueueCountStatsId :: ResultId+facilityQueueCountStatsId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "статистика длины очереди к прибору"),+   (englishResultLocale, "the queue size statistics")]++-- | Property 'facilityTotalWaitTime'.+facilityTotalWaitTimeId :: ResultId+facilityTotalWaitTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "общее время ожидания прибора"),+   (englishResultLocale, "the total wait time")]++-- | Property 'facilityWaitTime'.+facilityWaitTimeId :: ResultId+facilityWaitTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "время ожидания прибора"),+   (englishResultLocale, "the wait time")]++-- | Property 'facilityTotalHoldingTime'.+facilityTotalHoldingTimeId :: ResultId+facilityTotalHoldingTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "общее время удержания прибора"),+   (englishResultLocale, "the total holding time")]++-- | Property 'facilityHoldingTime'.+facilityHoldingTimeId :: ResultId+facilityHoldingTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "время удержания прибора"),+   (englishResultLocale, "the holding time")]++-- | Property 'facilityInterrupted'.+facilityInterruptedId :: ResultId+facilityInterruptedId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "удержание прибора сейчас прервано?"),+   (englishResultLocale, "is the facility interrupted now?")]++-- | The storage identifier.+storageId :: ResultId+storageId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "многоканальное устройство"),+   (englishResultLocale, "the storage")]++-- | Property 'storageCapacity'.+storageCapacityId :: ResultId+storageCapacityId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "емкость многоканального устройства"),+   (englishResultLocale, "the storage capacity")]++-- | Property 'storageEmpty'.+storageEmptyId :: ResultId+storageEmptyId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "не используется ли совсем устройство сейчас?"),+   (englishResultLocale, "is the storage unused completely now?")]++-- | Property 'storageFull'.+storageFullId :: ResultId+storageFullId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "используется ли устройство полностью сейчас?"),+   (englishResultLocale, "is the storage used completely now?")]++-- | Property 'storageContent'.+storageContentId :: ResultId+storageContentId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "доступное содержимое устройства"),+   (englishResultLocale, "the current available content")]++-- | Property 'storageContentStats'.+storageContentStatsId :: ResultId+storageContentStatsId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "статистика доступного содержимого устройства"),+   (englishResultLocale, "the available content statistics")]++-- | Property 'storageUseCount'.+storageUseCountId :: ResultId+storageUseCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "общее количество использований устройства"),+   (englishResultLocale, "the total use count")]++-- | Property 'storageUsedContent'.+storageUsedContentId :: ResultId+storageUsedContentId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "общее использованное количество устройства"),+   (englishResultLocale, "the total used content")]++-- | Property 'storageUtilisationCount'.+storageUtilisationCountId :: ResultId+storageUtilisationCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "текущее используемое количество устройства"),+   (englishResultLocale, "the current utilisation count")]++-- | Property 'storageUtilisationCountStats'.+storageUtilisationCountStatsId :: ResultId+storageUtilisationCountStatsId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "статистка по используемому количеству устройства"),+   (englishResultLocale, "the utilisation count statistics")]++-- | Property 'storageQueueCount'.+storageQueueCountId :: ResultId+storageQueueCountId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "текущая длина очереди к устройству"),+   (englishResultLocale, "the current queue size")]++-- | Property 'storageQueueCountStats'.+storageQueueCountStatsId :: ResultId+storageQueueCountStatsId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "статистика длины очереди к устройству"),+   (englishResultLocale, "the queue size statistics")]++-- | Property 'storageTotalWaitTime'.+storageTotalWaitTimeId :: ResultId+storageTotalWaitTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "общее время ожидания устройства"),+   (englishResultLocale, "the total wait time")]++-- | Property 'storageWaitTime'.+storageWaitTimeId :: ResultId+storageWaitTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "время ожидания устройства"),+   (englishResultLocale, "the wait time")]++-- | Property 'storageAverageHoldingTime'.+storageAverageHoldingTimeId :: ResultId+storageAverageHoldingTimeId =+  LocalisedResultId $+  M.fromList+  [(russianResultLocale, "среднее время удержания устройства на единицу устройства"),+   (englishResultLocale, "the average holding time per unit")]
+ Simulation/Aivika/Trans/GPSS/Results/Transform.hs view
@@ -0,0 +1,216 @@++{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Results.Transform+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- The module defines transformations for the simulation results.+--+module Simulation.Aivika.Trans.GPSS.Results.Transform where++import Control.Category++import Simulation.Aivika.Trans+import qualified Simulation.Aivika.Trans.Results.Transform as T++import qualified Simulation.Aivika.Trans.GPSS.Queue as Q+import qualified Simulation.Aivika.Trans.GPSS.Facility as F+import qualified Simulation.Aivika.Trans.GPSS.Storage as S+import Simulation.Aivika.Trans.GPSS.Results+import Simulation.Aivika.Trans.GPSS.Results.Locale++-- | Represents the 'Q.Queue'.+newtype Queue m = Queue (ResultTransform m)++-- | An instance of the result transformer.+instance T.ResultTransformer Queue m where+  tr (Queue a) = a++-- | Property 'Q.queueNull'.+queueNull :: Queue m -> ResultTransform m+queueNull (Queue a) =+  a >>> resultById queueNullId++-- | Property 'Q.queueContent'.+queueContent :: Queue m -> ResultTransform m+queueContent (Queue a) =+  a >>> resultById queueContentId++-- | Property 'Q.queueContentStats'.+queueContentStats :: Queue m -> T.TimingStats m+queueContentStats (Queue a) =+  T.TimingStats (a >>> resultById queueContentStatsId)++-- | Property 'Q.enqueueCount'.+enqueueCount :: Queue m -> ResultTransform m+enqueueCount (Queue a) =+  a >>> resultById enqueueCountId++-- | Property 'Q.enqueueZeroEntryCount'.+enqueueZeroEntryCount :: Queue m -> ResultTransform m+enqueueZeroEntryCount (Queue a) =+  a >>> resultById enqueueZeroEntryCountId++-- | Property 'Q.queueWaitTime'.+queueWaitTime :: Queue m -> T.SamplingStats m+queueWaitTime (Queue a) =+  T.SamplingStats (a >>> resultById queueWaitTimeId)++-- | Property 'Q.queueNonZeroEntryWaitTime'.+queueNonZeroEntryWaitTime :: Queue m -> T.SamplingStats m+queueNonZeroEntryWaitTime (Queue a) =+  T.SamplingStats (a >>> resultById queueNonZeroEntryWaitTimeId)++-- | Property 'Q.queueRate'.+queueRate :: Queue m -> ResultTransform m+queueRate (Queue a) =+  a >>> resultById queueRateId++-- | Represents the 'F.Facility'.+newtype Facility m = Facility (ResultTransform m)++-- | An instance of the result transformer.+instance T.ResultTransformer Facility m where+  tr (Facility a) = a++-- | Property 'F.facilityCount'.+facilityCount :: Facility m -> ResultTransform m+facilityCount (Facility a) =+  a >>> resultById facilityCountId++-- | Property 'F.facilityCountStats'.+facilityCountStats :: Facility m -> T.TimingStats m+facilityCountStats (Facility a) =+  T.TimingStats (a >>> resultById facilityCountStatsId)++-- | Property 'F.facilityCaptureCount'.+facilityCaptureCount :: Facility m -> ResultTransform m+facilityCaptureCount (Facility a) =+  a >>> resultById facilityCaptureCountId++-- | Property 'F.facilityUtilisationCount'.+facilityUtilisationCount :: Facility m -> ResultTransform m+facilityUtilisationCount (Facility a) =+  a >>> resultById facilityUtilisationCountId++-- | Property 'F.facilityUtilisationCountStats'.+facilityUtilisationCountStats :: Facility m -> T.TimingStats m+facilityUtilisationCountStats (Facility a) =+  T.TimingStats (a >>> resultById facilityUtilisationCountStatsId)++-- | Property 'F.facilityQueueCount'.+facilityQueueCount :: Facility m -> ResultTransform m+facilityQueueCount (Facility a) =+  a >>> resultById facilityQueueCountId++-- | Property 'F.facilityQueueCountStats'.+facilityQueueCountStats :: Facility m -> T.TimingStats m+facilityQueueCountStats (Facility a) =+  T.TimingStats (a >>> resultById facilityQueueCountStatsId)++-- | Property 'F.facilityTotalWaitTime'.+facilityTotalWaitTime :: Facility m -> ResultTransform m+facilityTotalWaitTime (Facility a) =+  a >>> resultById facilityTotalWaitTimeId++-- | Property 'F.facilityWaitTime'.+facilityWaitTime :: Facility m -> T.SamplingStats m+facilityWaitTime (Facility a) =+  T.SamplingStats (a >>> resultById facilityWaitTimeId)++-- | Property 'F.facilityTotalHoldingTime'.+facilityTotalHoldingTime :: Facility m -> ResultTransform m+facilityTotalHoldingTime (Facility a) =+  a >>> resultById facilityTotalHoldingTimeId++-- | Property 'F.facilityHoldingTime'.+facilityHoldingTime :: Facility m -> T.SamplingStats m+facilityHoldingTime (Facility a) =+  T.SamplingStats (a >>> resultById facilityHoldingTimeId)++-- | Property 'F.facilityInterrupted'.+facilityInterrupted :: Facility m -> ResultTransform m+facilityInterrupted (Facility a) =+  a >>> resultById facilityInterruptedId++-- | Represents the 'S.Storage'.+newtype Storage m = Storage (ResultTransform m)++-- | An instance of the result transformer.+instance T.ResultTransformer Storage m where+  tr (Storage a) = a++-- | Property 'S.storageCapacity'.+storageCapacity :: Storage m -> ResultTransform m+storageCapacity (Storage a) =+  a >>> resultById storageCapacityId++-- | Property 'S.storageEmpty'.+storageEmpty :: Storage m -> ResultTransform m+storageEmpty (Storage a) =+  a >>> resultById storageEmptyId++-- | Property 'S.storageFull'.+storageFull :: Storage m -> ResultTransform m+storageFull (Storage a) =+  a >>> resultById storageFullId++-- | Property 'S.storageContent'.+storageContent :: Storage m -> ResultTransform m+storageContent (Storage a) =+  a >>> resultById storageContentId++-- | Property 'S.storageContentStats'.+storageContentStats :: Storage m -> T.TimingStats m+storageContentStats (Storage a) =+  T.TimingStats (a >>> resultById storageContentStatsId)++-- | Property 'S.storageUseCount'.+storageUseCount :: Storage m -> ResultTransform m+storageUseCount (Storage a) =+  a >>> resultById storageUseCountId++-- | Property 'S.storageUsedContent'.+storageUsedContent :: Storage m -> ResultTransform m+storageUsedContent (Storage a) =+  a >>> resultById storageUsedContentId++-- | Property 'S.storageUtilisationCount'.+storageUtilisationCount :: Storage m -> ResultTransform m+storageUtilisationCount (Storage a) =+  a >>> resultById storageUtilisationCountId++-- | Property 'S.storageUtilisationCountStats'.+storageUtilisationCountStats :: Storage m -> T.TimingStats m+storageUtilisationCountStats (Storage a) =+  T.TimingStats (a >>> resultById storageUtilisationCountStatsId)++-- | Property 'S.storageQueueCount'.+storageQueueCount :: Storage m -> ResultTransform m+storageQueueCount (Storage a) =+  a >>> resultById storageQueueCountId++-- | Property 'S.storageQueueCountStats'.+storageQueueCountStats :: Storage m -> T.TimingStats m+storageQueueCountStats (Storage a) =+  T.TimingStats (a >>> resultById storageQueueCountStatsId)++-- | Property 'S.storageTotalWaitTime'.+storageTotalWaitTime :: Storage m -> ResultTransform m+storageTotalWaitTime (Storage a) =+  a >>> resultById storageTotalWaitTimeId++-- | Property 'S.storageWaitTime'.+storageWaitTime :: Storage m -> T.SamplingStats m+storageWaitTime (Storage a) =+  T.SamplingStats (a >>> resultById storageWaitTimeId)++-- | Property 'S.storageAverageHoldingTime'.+storageAverageHoldingTime :: Storage m -> ResultTransform m+storageAverageHoldingTime (Storage a) =+  a >>> resultById storageAverageHoldingTimeId
+ Simulation/Aivika/Trans/GPSS/Storage.hs view
@@ -0,0 +1,570 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Storage+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.1+--+-- This module defines the GPSS Storage entity.+--+module Simulation.Aivika.Trans.GPSS.Storage+       (-- * Storage Type+        Storage,+        -- * Creating Storage+        newStorage,+        -- * Storage Properties+        storageCapacity,+        storageEmpty,+        storageFull,+        storageContent,+        storageContentStats,+        storageUseCount,+        storageUsedContent,+        storageUtilisationCount,+        storageUtilisationCountStats,+        storageQueueCount,+        storageQueueCountStats,+        storageTotalWaitTime,+        storageWaitTime,+        storageAverageHoldingTime,+        -- * Entering-Leaving Storage+        enterStorage,+        leaveStorage,+        leaveStorageWithinEvent,+        -- * Statistics Reset+        resetStorage,+        -- * Signals+        storageContentChanged,+        storageContentChanged_,+        storageUseCountChanged,+        storageUseCountChanged_,+        storageUsedContentChanged,+        storageUsedContentChanged_,+        storageUtilisationCountChanged,+        storageUtilisationCountChanged_,+        storageQueueCountChanged,+        storageQueueCountChanged_,+        storageWaitTimeChanged,+        storageWaitTimeChanged_,+        storageChanged_) where++import Data.Monoid+import Data.Maybe++import Control.Monad+import Control.Monad.Trans+import Control.Exception++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Internal.Simulation+import Simulation.Aivika.Trans.Internal.Event+import Simulation.Aivika.Trans.Internal.Cont+import Simulation.Aivika.Trans.Internal.Process+import Simulation.Aivika.Trans.QueueStrategy+import Simulation.Aivika.Trans.Statistics+import Simulation.Aivika.Trans.Signal++import Simulation.Aivika.Trans.GPSS.Transact+import Simulation.Aivika.Trans.GPSS.TransactQueueStrategy++-- | Represents a GPSS Storage entity.+data Storage m = +  Storage { storageCapacity :: Int,+            -- ^ Return the storage capacity.+            storageContentRef :: Ref m Int,+            storageContentStatsRef :: Ref m (TimingStats Int),+            storageContentSource :: SignalSource m Int,+            storageUseCountRef :: Ref m Int,+            storageUseCountSource :: SignalSource m Int,+            storageUsedContentRef :: Ref m Int,+            storageUsedContentSource :: SignalSource m Int,+            storageUtilisationCountRef :: Ref m Int,+            storageUtilisationCountStatsRef :: Ref m (TimingStats Int),+            storageUtilisationCountSource :: SignalSource m Int,+            storageQueueCountRef :: Ref m Int,+            storageQueueCountStatsRef :: Ref m (TimingStats Int),+            storageQueueCountSource :: SignalSource m Int,+            storageTotalWaitTimeRef :: Ref m Double,+            storageWaitTimeRef :: Ref m (SamplingStats Double),+            storageWaitTimeSource :: SignalSource m (),+            storageDelayChain :: StrategyQueue m (TransactQueueStrategy FCFS) (StorageDelayedItem m) }++-- | Identifies an item that was delayed.+data StorageDelayedItem m =+  StorageDelayedItem { delayedItemTime :: Double,+                       delayedItemDecrement :: Int,+                       delayedItemCont :: FrozenCont m () }++instance MonadDES m => Eq (Storage m) where++  {-# INLINABLE (==) #-}+  x == y = storageContentRef x == storageContentRef y  -- unique references++-- | Create a new storage by the specified capacity.+newStorage :: MonadDES m => Int -> Event m (Storage m)+{-# INLINABLE newStorage #-}+newStorage capacity =+  Event $ \p ->+  do let r = pointRun p+         t = pointTime p+     contentRef <- invokeSimulation r $ newRef capacity+     contentStatsRef <- invokeSimulation r $ newRef $ returnTimingStats t capacity+     contentSource <- invokeSimulation r newSignalSource+     useCountRef <- invokeSimulation r $ newRef 0+     useCountSource <- invokeSimulation r newSignalSource+     usedContentRef <- invokeSimulation r $ newRef 0+     usedContentSource <- invokeSimulation r newSignalSource+     utilCountRef <- invokeSimulation r $ newRef 0+     utilCountStatsRef <- invokeSimulation r $ newRef $ returnTimingStats t 0+     utilCountSource <- invokeSimulation r newSignalSource+     queueCountRef <- invokeSimulation r $ newRef 0+     queueCountStatsRef <- invokeSimulation r $ newRef $ returnTimingStats t 0+     queueCountSource <- invokeSimulation r newSignalSource+     totalWaitTimeRef <- invokeSimulation r $ newRef 0+     waitTimeRef <- invokeSimulation r $ newRef emptySamplingStats+     waitTimeSource <- invokeSimulation r newSignalSource+     delayChain <- invokeSimulation r $ newStrategyQueue (TransactQueueStrategy FCFS)+     return Storage { storageCapacity = capacity,+                      storageContentRef = contentRef,+                      storageContentStatsRef = contentStatsRef,+                      storageContentSource = contentSource,+                      storageUseCountRef = useCountRef,+                      storageUseCountSource = useCountSource,+                      storageUsedContentRef = usedContentRef,+                      storageUsedContentSource = usedContentSource,+                      storageUtilisationCountRef = utilCountRef,+                      storageUtilisationCountStatsRef = utilCountStatsRef,+                      storageUtilisationCountSource = utilCountSource,+                      storageQueueCountRef = queueCountRef,+                      storageQueueCountStatsRef = queueCountStatsRef,+                      storageQueueCountSource = queueCountSource,+                      storageTotalWaitTimeRef = totalWaitTimeRef,+                      storageWaitTimeRef = waitTimeRef,+                      storageWaitTimeSource = waitTimeSource,+                      storageDelayChain = delayChain }++-- | Whether the storage is empty, i.e. completely unused.+storageEmpty :: MonadDES m => Storage m -> Event m Bool+{-# INLINABLE storageEmpty #-}+storageEmpty r =+  Event $ \p ->+  do n <- invokeEvent p $ readRef (storageContentRef r)+     return (n == storageCapacity r)++-- | Whether the storage is full, i.e. completely used.+storageFull :: MonadDES m => Storage m -> Event m Bool+{-# INLINABLE storageFull #-}+storageFull r =+  Event $ \p ->+  do n <- invokeEvent p $ readRef (storageContentRef r)+     return (n == 0)++-- | Return the current storage content available for use.+storageContent :: MonadDES m => Storage m -> Event m Int+{-# INLINABLE storageContent #-}+storageContent r =+  Event $ \p -> invokeEvent p $ readRef (storageContentRef r)++-- | Return the statistics of the storage content available for use.+storageContentStats :: MonadDES m => Storage m -> Event m (TimingStats Int)+{-# INLINABLE storageContentStats #-}+storageContentStats r =+  Event $ \p -> invokeEvent p $ readRef (storageContentStatsRef r)++-- | Signal triggered when the 'storageContent' property changes.+storageContentChanged :: MonadDES m => Storage m -> Signal m Int+{-# INLINABLE storageContentChanged #-}+storageContentChanged r =+  publishSignal $ storageContentSource r++-- | Signal triggered when the 'storageContent' property changes.+storageContentChanged_ :: MonadDES m => Storage m -> Signal m ()+{-# INLINABLE storageContentChanged_ #-}+storageContentChanged_ r =+  mapSignal (const ()) $ storageContentChanged r++-- | Return the total use count of the storage.+storageUseCount :: MonadDES m => Storage m -> Event m Int+{-# INLINABLE storageUseCount #-}+storageUseCount r =+  Event $ \p -> invokeEvent p $ readRef (storageUseCountRef r)++-- | Signal triggered when the 'storageUseCount' property changes.+storageUseCountChanged :: MonadDES m => Storage m -> Signal m Int+{-# INLINABLE storageUseCountChanged #-}+storageUseCountChanged r =+  publishSignal $ storageUseCountSource r++-- | Signal triggered when the 'storageUseCount' property changes.+storageUseCountChanged_ :: MonadDES m => Storage m -> Signal m ()+{-# INLINABLE storageUseCountChanged_ #-}+storageUseCountChanged_ r =+  mapSignal (const ()) $ storageUseCountChanged r++-- | Return the total used content of the storage.+storageUsedContent :: MonadDES m => Storage m -> Event m Int+{-# INLINABLE storageUsedContent #-}+storageUsedContent r =+  Event $ \p -> invokeEvent p $ readRef (storageUsedContentRef r)++-- | Signal triggered when the 'storageUsedContent' property changes.+storageUsedContentChanged :: MonadDES m => Storage m -> Signal m Int+{-# INLINABLE storageUsedContentChanged #-}+storageUsedContentChanged r =+  publishSignal $ storageUsedContentSource r++-- | Signal triggered when the 'storageUsedContent' property changes.+storageUsedContentChanged_ :: MonadDES m => Storage m -> Signal m ()+{-# INLINABLE storageUsedContentChanged_ #-}+storageUsedContentChanged_ r =+  mapSignal (const ()) $ storageUsedContentChanged r++-- | Return the current utilisation count of the storage.+storageUtilisationCount :: MonadDES m => Storage m -> Event m Int+{-# INLINABLE storageUtilisationCount #-}+storageUtilisationCount r =+  Event $ \p -> invokeEvent p $ readRef (storageUtilisationCountRef r)++-- | Return the statistics for the utilisation count of the storage.+storageUtilisationCountStats :: MonadDES m => Storage m -> Event m (TimingStats Int)+{-# INLINABLE storageUtilisationCountStats #-}+storageUtilisationCountStats r =+  Event $ \p -> invokeEvent p $ readRef (storageUtilisationCountStatsRef r)++-- | Signal triggered when the 'storageUtilisationCount' property changes.+storageUtilisationCountChanged :: MonadDES m => Storage m -> Signal m Int+{-# INLINABLE storageUtilisationCountChanged #-}+storageUtilisationCountChanged r =+  publishSignal $ storageUtilisationCountSource r++-- | Signal triggered when the 'storageUtilisationCount' property changes.+storageUtilisationCountChanged_ :: MonadDES m => Storage m -> Signal m ()+{-# INLINABLE storageUtilisationCountChanged_ #-}+storageUtilisationCountChanged_ r =+  mapSignal (const ()) $ storageUtilisationCountChanged r++-- | Return the current queue length of the storage.+storageQueueCount :: MonadDES m => Storage m -> Event m Int+{-# INLINABLE storageQueueCount #-}+storageQueueCount r =+  Event $ \p -> invokeEvent p $ readRef (storageQueueCountRef r)++-- | Return the statistics for the queue length of the storage.+storageQueueCountStats :: MonadDES m => Storage m -> Event m (TimingStats Int)+{-# INLINABLE storageQueueCountStats #-}+storageQueueCountStats r =+  Event $ \p -> invokeEvent p $ readRef (storageQueueCountStatsRef r)++-- | Signal triggered when the 'storageQueueCount' property changes.+storageQueueCountChanged :: MonadDES m => Storage m -> Signal m Int+{-# INLINABLE storageQueueCountChanged #-}+storageQueueCountChanged r =+  publishSignal $ storageQueueCountSource r++-- | Signal triggered when the 'storageQueueCount' property changes.+storageQueueCountChanged_ :: MonadDES m => Storage m -> Signal m ()+{-# INLINABLE storageQueueCountChanged_ #-}+storageQueueCountChanged_ r =+  mapSignal (const ()) $ storageQueueCountChanged r++-- | Return the total wait time of the storage.+storageTotalWaitTime :: MonadDES m => Storage m -> Event m Double+{-# INLINABLE storageTotalWaitTime #-}+storageTotalWaitTime r =+  Event $ \p -> invokeEvent p $ readRef (storageTotalWaitTimeRef r)++-- | Return the statistics for the wait time of the storage.+storageWaitTime :: MonadDES m => Storage m -> Event m (SamplingStats Double)+{-# INLINABLE storageWaitTime #-}+storageWaitTime r =+  Event $ \p -> invokeEvent p $ readRef (storageWaitTimeRef r)++-- | Signal triggered when the 'storageTotalWaitTime' and 'storageWaitTime' properties change.+storageWaitTimeChanged :: MonadDES m => Storage m -> Signal m (SamplingStats Double)+{-# INLINABLE storageWaitTimeChanged #-}+storageWaitTimeChanged r =+  mapSignalM (\() -> storageWaitTime r) $ storageWaitTimeChanged_ r++-- | Signal triggered when the 'storageTotalWaitTime' and 'storageWaitTime' properties change.+storageWaitTimeChanged_ :: MonadDES m => Storage m -> Signal m ()+{-# INLINABLE storageWaitTimeChanged_ #-}+storageWaitTimeChanged_ r =+  publishSignal $ storageWaitTimeSource r++-- | Return the average holding time per unit.+storageAverageHoldingTime :: MonadDES m => Storage m -> Event m Double+{-# INLINABLE storageAverageHoldingTime #-}+storageAverageHoldingTime r =+  Event $ \p ->+  do s <- invokeEvent p $ readRef (storageUtilisationCountStatsRef r)+     n <- invokeEvent p $ readRef (storageUtilisationCountRef r)+     m <- invokeEvent p $ readRef (storageUsedContentRef r)+     let t  = pointTime p+         s' = addTimingStats t n s+         k  = timingStatsSum s' / (fromRational $ toRational m)+     return k++-- | Enter the storage.+enterStorage :: MonadDES m+                => Storage m+                -- ^ the requested storage+                -> Transact m a+                -- ^ a transact that makes the request+                -> Int+                -- ^ the content decrement+                -> Process m ()+{-# INLINABLE enterStorage #-}+enterStorage r transact decrement =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do let t = pointTime p+     f <- invokeEvent p $ strategyQueueNull (storageDelayChain r)+     if f+       then invokeEvent p $+            invokeCont c $+            invokeProcess pid $+            enterStorage' r transact decrement+       else do c <- invokeEvent p $+                    freezeContReentering c () $+                    invokeCont c $+                    invokeProcess pid $+                    enterStorage r transact decrement+               invokeEvent p $+                 strategyEnqueueWithPriority+                 (storageDelayChain r)+                 (transactPriority transact)+                 (StorageDelayedItem t decrement c)+               invokeEvent p $ updateStorageQueueCount r 1++-- | Enter the storage.+enterStorage' :: MonadDES m+                 => Storage m+                 -- ^ the requested storage+                 -> Transact m a+                 -- ^ a transact that makes the request+                 -> Int+                 -- ^ the content decrement+                 -> Process m ()+{-# INLINABLE enterStorage' #-}+enterStorage' r transact decrement =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do let t = pointTime p+     a <- invokeEvent p $ readRef (storageContentRef r)+     if a < decrement+       then do c <- invokeEvent p $+                    freezeContReentering c () $+                    invokeCont c $+                    invokeProcess pid $+                    enterStorage r transact decrement+               invokeEvent p $+                 strategyEnqueueWithPriority+                 (storageDelayChain r)+                 (transactPriority transact)+                 (StorageDelayedItem t decrement c)+               invokeEvent p $ updateStorageQueueCount r 1+       else do invokeEvent p $ updateStorageWaitTime r 0+               invokeEvent p $ updateStorageContent r (- decrement)+               invokeEvent p $ updateStorageUseCount r 1+               invokeEvent p $ updateStorageUsedContent r decrement+               invokeEvent p $ updateStorageUtilisationCount r decrement+               invokeEvent p $ resumeCont c ()++-- | Leave the storage.+leaveStorage :: MonadDES m+                => Storage m+                -- ^ the storage to leave+                -> Int+                -- ^ the content increment+                -> Process m ()+{-# INLINABLE leaveStorage #-}+leaveStorage r increment =+  Process $ \_ ->+  Cont $ \c ->+  Event $ \p ->+  do invokeEvent p $ leaveStorageWithinEvent r increment+     invokeEvent p $ resumeCont c ()++-- | Leave the storage.+leaveStorageWithinEvent :: MonadDES m+                           => Storage m+                           -- ^ the storage to leave+                           -> Int+                           -- ^ the content increment+                           -> Event m ()+{-# INLINABLE leaveStorageWithinEvent #-}+leaveStorageWithinEvent r increment =+  Event $ \p ->+  do let t = pointTime p+     invokeEvent p $ updateStorageUtilisationCount r (- increment)+     invokeEvent p $ updateStorageContent r increment+     invokeEvent p $ enqueueEvent t $ tryEnterStorage r++-- | Try to enter the storage.+tryEnterStorage :: MonadDES m => Storage m -> Event m ()+{-# INLINABLE tryEnterStorage #-}+tryEnterStorage r =+  Event $ \p ->+  do let t = pointTime p+     a <- invokeEvent p $ readRef (storageContentRef r)+     if a > 0+       then invokeEvent p $ letEnterStorage r+       else return ()++-- | Let enter the storage.+letEnterStorage :: MonadDES m => Storage m -> Event m ()+{-# INLINABLE letEnterStorage #-}+letEnterStorage r =+  Event $ \p ->+  do let t = pointTime p+     a <- invokeEvent p $ readRef (storageContentRef r)+     when (a > storageCapacity r) $+       throwComp $+       SimulationRetry $+       "The storage content cannot exceed the limited capacity: leaveStorage'"+     x <- invokeEvent p $+          strategyQueueDeleteBy+          (storageDelayChain r)+          (\i -> delayedItemDecrement i <= a)+     case x of+       Nothing -> return ()+       Just (StorageDelayedItem t0 decrement0 c0) ->+         do invokeEvent p $ updateStorageQueueCount r (-1)+            c <- invokeEvent p $ unfreezeCont c0+            case c of+              Nothing ->+                invokeEvent p $ letEnterStorage r+              Just c ->+                do invokeEvent p $ updateStorageContent r (- decrement0)+                   invokeEvent p $ updateStorageWaitTime r (t - t0)+                   invokeEvent p $ updateStorageUtilisationCount r decrement0+                   invokeEvent p $ updateStorageUseCount r 1+                   invokeEvent p $ updateStorageUsedContent r decrement0+                   invokeEvent p $ enqueueEvent t $ reenterCont c ()++-- | Signal triggered when one of the storage counters changes.+storageChanged_ :: MonadDES m => Storage m -> Signal m ()+{-# INLINABLE storageChanged_ #-}+storageChanged_ r =+  storageContentChanged_ r <>+  storageUsedContentChanged_ r <>+  storageUtilisationCountChanged_ r <>+  storageQueueCountChanged_ r++-- | Update the storage content and its statistics.+updateStorageContent :: MonadDES m => Storage m -> Int -> Event m ()+{-# INLINABLE updateStorageContent #-}+updateStorageContent r delta =+  Event $ \p ->+  do a <- invokeEvent p $ readRef (storageContentRef r)+     let a' = a + delta+     invokeEvent p $+       writeRef (storageContentRef r) a'+     invokeEvent p $+       modifyRef (storageContentStatsRef r) $+       addTimingStats (pointTime p) a'+     invokeEvent p $+       triggerSignal (storageContentSource r) a'++-- | Update the storage use count.+updateStorageUseCount :: MonadDES m => Storage m -> Int -> Event m ()+{-# INLINABLE updateStorageUseCount #-}+updateStorageUseCount r delta =+  Event $ \p ->+  do a <- invokeEvent p $ readRef (storageUseCountRef r)+     let a' = a + delta+     invokeEvent p $+       writeRef (storageUseCountRef r) a'+     invokeEvent p $+       triggerSignal (storageUseCountSource r) a'++-- | Update the storage used content.+updateStorageUsedContent :: MonadDES m => Storage m -> Int -> Event m ()+{-# INLINABLE updateStorageUsedContent #-}+updateStorageUsedContent r delta =+  Event $ \p ->+  do a <- invokeEvent p $ readRef (storageUsedContentRef r)+     let a' = a + delta+     invokeEvent p $+       writeRef (storageUsedContentRef r) a'+     invokeEvent p $+       triggerSignal (storageUsedContentSource r) a'++-- | Update the storage queue length and its statistics.+updateStorageQueueCount :: MonadDES m => Storage m -> Int -> Event m ()+{-# INLINABLE updateStorageQueueCount #-}+updateStorageQueueCount r delta =+  Event $ \p ->+  do a <- invokeEvent p $ readRef (storageQueueCountRef r)+     let a' = a + delta+     invokeEvent p $+       writeRef (storageQueueCountRef r) a'+     invokeEvent p $+       modifyRef (storageQueueCountStatsRef r) $+       addTimingStats (pointTime p) a'+     invokeEvent p $+       triggerSignal (storageQueueCountSource r) a'++-- | Update the storage utilisation count and its statistics.+updateStorageUtilisationCount :: MonadDES m => Storage m -> Int -> Event m ()+{-# INLINABLE updateStorageUtilisationCount #-}+updateStorageUtilisationCount r delta =+  Event $ \p ->+  do a <- invokeEvent p $ readRef (storageUtilisationCountRef r)+     let a' = a + delta+     invokeEvent p $+       writeRef (storageUtilisationCountRef r) a'+     invokeEvent p $+       modifyRef (storageUtilisationCountStatsRef r) $+       addTimingStats (pointTime p) a'+     invokeEvent p $+       triggerSignal (storageUtilisationCountSource r) a'++-- | Update the storage wait time and its statistics.+updateStorageWaitTime :: MonadDES m => Storage m -> Double -> Event m ()+{-# INLINABLE updateStorageWaitTime #-}+updateStorageWaitTime r delta =+  Event $ \p ->+  do a <- invokeEvent p $ readRef (storageTotalWaitTimeRef r)+     let a' = a + delta+     invokeEvent p $+       writeRef (storageTotalWaitTimeRef r) a'+     invokeEvent p $+       modifyRef (storageWaitTimeRef r) $+       addSamplingStats delta+     invokeEvent p $+       triggerSignal (storageWaitTimeSource r) ()++-- | Reset the statistics.+resetStorage :: MonadDES m => Storage m -> Event m ()+{-# INLINABLE resetStorage #-}+resetStorage r =+  Event $ \p ->+  do let t = pointTime p+     content <- invokeEvent p $ readRef (storageContentRef r)+     invokeEvent p $ writeRef (storageContentStatsRef r) $+       returnTimingStats t content+     invokeEvent p $ writeRef (storageUseCountRef r) 0+     let usedContent = storageCapacity r - content+     invokeEvent p $ writeRef (storageUsedContentRef r) usedContent+     utilCount <- invokeEvent p $ readRef (storageUtilisationCountRef r)+     invokeEvent p $ writeRef (storageUtilisationCountStatsRef r) $+       returnTimingStats t utilCount+     queueCount <- invokeEvent p $ readRef (storageQueueCountRef r)+     invokeEvent p $ writeRef (storageQueueCountStatsRef r) $+       returnTimingStats t queueCount+     invokeEvent p $ writeRef (storageTotalWaitTimeRef r) 0+     invokeEvent p $ writeRef (storageWaitTimeRef r) emptySamplingStats+     invokeEvent p $+       triggerSignal (storageUseCountSource r) 0+     invokeEvent p $+       triggerSignal (storageUsedContentSource r) usedContent+     invokeEvent p $+       triggerSignal (storageUtilisationCountSource r) utilCount+     invokeEvent p $+       triggerSignal (storageWaitTimeSource r) ()
+ Simulation/Aivika/Trans/GPSS/Transact.hs view
@@ -0,0 +1,317 @@++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.Transact+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines a GPSS transact.+--+module Simulation.Aivika.Trans.GPSS.Transact+       (Transact,+        transactValue,+        transactArrivalDelay,+        transactArrivalTime,+        transactPriority,+        transactAssemblySet,+        newTransact,+        splitTransact,+        assignTransactValue,+        assignTransactValueM,+        assignTransactPriority,+        takeTransact,+        releaseTransact,+        transactPreemptionBegin,+        transactPreemptionEnd,+        requireTransactProcessId,+        transferTransact,+        reactivateTransacts,+        registerTransactQueueEntry,+        unregisterTransactQueueEntry) where++import Control.Monad+import Control.Monad.Trans+import Control.Exception++import qualified Data.HashMap.Lazy as HM++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.Internal.Specs+import Simulation.Aivika.Trans.Internal.Simulation+import Simulation.Aivika.Trans.Internal.Event+import Simulation.Aivika.Trans.Internal.Cont+import Simulation.Aivika.Trans.Internal.Process++import {-# SOURCE #-} Simulation.Aivika.Trans.GPSS.Queue+import {-# SOURCE #-} Simulation.Aivika.Trans.GPSS.AssemblySet++-- | Represents a GPSS transact.+data Transact m a =+  Transact { transactValue :: a,+             -- ^ The data of the transact.+             transactArrivalDelay :: Maybe Double,+             -- ^ The delay between the transacts generated.+             transactArrivalTime :: Double,+             -- ^ The time at which the transact was generated.+             transactPriority :: Int,+             -- ^ The transact priority.+             transactAssemblySetRef :: Ref m (Maybe (AssemblySet m)),+             -- ^ The assembly set.+             transactPreemptionCountRef :: Ref m Int,+             -- ^ How many times the transact is preempted.+             transactProcessIdRef :: Ref m (Maybe (ProcessId m)),+             -- ^ An identifier of the process that handles the transact at present+             transactProcessContRef :: Ref m (Maybe (FrozenCont m ())),+             -- ^ A continuation of the process that tried to handle the transact.+             transactQueueEntryRef :: Ref m (HM.HashMap (Queue m) (QueueEntry m))+             -- ^ The queue entries registered by the the transact.+           }++instance MonadDES m => Eq (Transact m a) where++  {-# INLINABLE (==) #-}+  x == y = (transactProcessIdRef x) == (transactProcessIdRef y)++-- | Create a new transact.+newTransact :: MonadDES m+               => Arrival a+               -- ^ the arrival data+               -> Int+               -- ^ the transact priority+               -> Simulation m (Transact m a)+{-# INLINABLE newTransact #-}+newTransact a priority =+  Simulation $ \r ->+  do r0 <- invokeSimulation r $ newRef 0+     r1 <- invokeSimulation r $ newRef Nothing+     r2 <- invokeSimulation r $ newRef Nothing+     r3 <- invokeSimulation r $ newRef HM.empty+     r4 <- invokeSimulation r $ newRef Nothing+     return Transact { transactValue = arrivalValue a,+                       transactArrivalDelay = arrivalDelay a,+                       transactArrivalTime = arrivalTime a,+                       transactPriority = priority,+                       transactAssemblySetRef = r4,+                       transactPreemptionCountRef = r0,+                       transactProcessIdRef = r1,+                       transactProcessContRef = r2,+                       transactQueueEntryRef = r3+                     }++-- | Split the transact.+splitTransact :: MonadDES m => Transact m a -> Simulation m (Transact m a)+{-# INLINABLE splitTransact #-}+splitTransact t =+  Simulation $ \r ->+  do r0 <- invokeSimulation r $ newRef 0+     r1 <- invokeSimulation r $ newRef Nothing+     r2 <- invokeSimulation r $ newRef Nothing+     r3 <- invokeSimulation r $ newRef HM.empty+     return Transact { transactValue = transactValue t,+                       transactArrivalDelay = transactArrivalDelay t,+                       transactArrivalTime = transactArrivalTime t,+                       transactPriority = transactPriority t,+                       transactAssemblySetRef = transactAssemblySetRef t,+                       transactPreemptionCountRef = r0,+                       transactProcessIdRef = r1,+                       transactProcessContRef = r2,+                       transactQueueEntryRef = r3+                     }++-- | Return the transact assembly set.+transactAssemblySet :: MonadDES m => Transact m a -> Event m (AssemblySet m)+{-# INLINABLE transactAssemblySet #-}+transactAssemblySet t =+  Event $ \p ->+  do let r = pointRun p+     x <- invokeEvent p $ readRef (transactAssemblySetRef t)+     case x of+       Just a  -> return a+       Nothing ->+         do a <- invokeSimulation r newAssemblySet+            invokeEvent p $ writeRef (transactAssemblySetRef t) (Just a)+            return a++-- | Take the transact.+takeTransact :: MonadDES m => Transact m a -> Process m ()+{-# INLINABLE takeTransact #-}+takeTransact t =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do pid0 <- invokeEvent p $ readRef (transactProcessIdRef t)+     case pid0 of+       Just pid0 ->+         throwComp $+         SimulationRetry+         "The transact is acquired by another process: takeTransact"+       Nothing   ->+         do invokeEvent p $ writeRef (transactProcessIdRef t) (Just pid)+            n <- invokeEvent p $ readRef (transactPreemptionCountRef t)+            if n == 0+              then invokeEvent p $ resumeCont c ()+              else do c <- invokeEvent p $+                           freezeContReentering c () $+                           invokeCont c $+                           invokeProcess pid $+                           takeTransact t+                      invokeEvent p $+                        writeRef (transactProcessContRef t) (Just c)+                      forM_ [1 .. n] $ \_ ->+                        invokeEvent p $+                        processPreemptionBegin pid++-- | Release the transact.+releaseTransact :: MonadDES m => Transact m a -> Process m ()+{-# INLINABLE releaseTransact #-}+releaseTransact t =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  do pid0 <- invokeEvent p $ readRef (transactProcessIdRef t)+     case pid0 of+       Nothing ->+         throwComp $+         SimulationRetry+         "The transact is not acquired by any process: releaseTransact"+       Just pid0 | pid0 /= pid ->+         throwComp $+         SimulationRetry+         "The transact is acquired by another process: releaseTransact"+       Just pid0 ->+         do invokeEvent p $ writeRef (transactProcessIdRef t) Nothing+            invokeEvent p $ writeRef (transactProcessContRef t) Nothing+            invokeEvent p $ resumeCont c ()++-- | Preempt the computation that handles the transact.+transactPreemptionBegin :: MonadDES m => Transact m a -> Event m ()+{-# INLINABLE transactPreemptionBegin #-}+transactPreemptionBegin t =+  Event $ \p ->+  do n <- invokeEvent p $ readRef (transactPreemptionCountRef t)+     let n' = n + 1+     n' `seq` invokeEvent p $ writeRef (transactPreemptionCountRef t) n'+     pid <- invokeEvent p $ readRef (transactProcessIdRef t)+     case pid of+       Nothing  -> return ()+       Just pid -> invokeEvent p $ processPreemptionBegin pid++-- | Proceed with the computation after the transact was preempted earlier.+transactPreemptionEnd :: MonadDES m => Transact m a -> Event m ()+{-# INLINABLE transactPreemptionEnd #-}+transactPreemptionEnd t =+  Event $ \p ->+  do n <- invokeEvent p $ readRef (transactPreemptionCountRef t)+     let n' = n - 1+     unless (n' >= 0) $+       throwComp $+       SimulationRetry+       "The transact preemption count cannot be negative: transactPreemptionEnd"+     n' `seq` invokeEvent p $ writeRef (transactPreemptionCountRef t) n'+     pid <- invokeEvent p $ readRef (transactProcessIdRef t)+     case pid of+       Nothing  -> return ()+       Just pid ->+         do invokeEvent p $ processPreemptionEnd pid+            c <- invokeEvent p $ readRef (transactProcessContRef t)+            case c of+              Nothing -> return ()+              Just c  ->+                do invokeEvent p $ writeRef (transactProcessContRef t) Nothing+                   c <- invokeEvent p $ unfreezeCont c+                   case c of+                     Nothing -> return ()+                     Just c  -> invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c ()++-- | Require to return an identifier of the process associated with the transact.+requireTransactProcessId :: MonadDES m => Transact m a -> Event m (ProcessId m)+{-# INLINABLE requireTransactProcessId #-}+requireTransactProcessId t =+  Event $ \p ->+  do a <- invokeEvent p $ readRef (transactProcessIdRef t)+     case a of+       Nothing ->+         throwComp $+         SimulationRetry+         "The transact must be associated with any process: requireTransactProcessId"+       Just pid ->+         return pid++-- | Like the GoTo statement, it associates the transact with another process.+transferTransact :: MonadDES m => Transact m a -> Process m () -> Event m ()+{-# INLINABLE transferTransact #-}+transferTransact t transfer =+  Event $ \p ->+  do a <- invokeEvent p $ readRef (transactProcessIdRef t)+     case a of+       Nothing  -> return ()+       Just pid ->+         invokeEvent p $ cancelProcessWithId pid+     invokeEvent p $ writeRef (transactProcessIdRef t) Nothing+     invokeEvent p $ writeRef (transactProcessContRef t) Nothing+     invokeEvent p $+       runProcess $+       do takeTransact t+          transferProcess transfer++-- | Register the queue entry in the transact.+registerTransactQueueEntry :: MonadDES m => Transact m a -> QueueEntry m -> Event m ()+{-# INLINABLE registerTransactQueueEntry #-}+registerTransactQueueEntry t e =+  Event $ \p ->+  do let q = entryQueue e+     m <- invokeEvent p $ readRef (transactQueueEntryRef t)+     case HM.lookup q m of+       Just e0 ->+         throwComp $+         SimulationRetry+         "There is already another queue entry for the specified queue: registerTransactQueueEntry"+       Nothing ->+         invokeEvent p $ writeRef (transactQueueEntryRef t) (HM.insert q e m)++-- | Unregister the queue entry from the transact.+unregisterTransactQueueEntry :: MonadDES m => Transact m a -> Queue m -> Event m (QueueEntry m)+{-# INLINABLE unregisterTransactQueueEntry #-}+unregisterTransactQueueEntry t q =+  Event $ \p ->+  do m <- invokeEvent p $ readRef (transactQueueEntryRef t)+     case HM.lookup q m of+       Nothing ->+         throwComp $+         SimulationRetry+         "There is no queue entry for the specified queue: unregisterTransactQueueEntry"+       Just e  ->+         do invokeEvent p $ writeRef (transactQueueEntryRef t) (HM.delete q m)+            return e++-- | Assign the transact value and return a new version of the same transact.+assignTransactValue :: Transact m a -> (a -> b) -> Transact m b+assignTransactValue t f =+  let b = f (transactValue t)+  in t { transactValue = b }++-- | Assign the transact value and return a new version of the same transact.+assignTransactValueM :: Monad c => Transact m a -> (a -> c b) -> c (Transact m b)+{-# INLINABLE assignTransactValue #-}+assignTransactValueM t f =+  do b <- f (transactValue t)+     return t { transactValue = b }++-- | Assign the priority and return a new version of the same transact.+assignTransactPriority :: Transact m a -> Int -> Transact m a+assignTransactPriority t priority =+  t { transactPriority = priority }++-- | Reactivate the transacts or transfer them to the specified computations.+reactivateTransacts :: MonadDES m => [(Transact m a, Maybe (Process m ()))] -> Event m ()+{-# INLINABLE reactivateTransacts #-}+reactivateTransacts [] = return ()+reactivateTransacts ((t, Nothing): xs) =+  do pid <- requireTransactProcessId t+     reactivateProcess pid+     reactivateTransacts xs+reactivateTransacts ((t, Just transfer): xs) =+  do transferTransact t transfer+     reactivateTransacts xs
+ Simulation/Aivika/Trans/GPSS/TransactQueueStrategy.hs view
@@ -0,0 +1,165 @@++{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}++-- |+-- Module     : Simulation.Aivika.Trans.GPSS.TransactQueueStrategy+-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 8.0.2+--+-- This module defines a GPSS transact queue strategy.+--+module Simulation.Aivika.Trans.GPSS.TransactQueueStrategy+       (TransactQueueStrategy(..),+        transactStrategyQueueDeleteBy,+        transactStrategyQueueContainsBy) where++import Control.Monad+import Control.Monad.Trans++import Data.IORef+import qualified Data.IntMap as M++import Simulation.Aivika.Trans+import qualified Simulation.Aivika.Trans.DoubleLinkedList as DLL++-- | The transact queue strategy.+data TransactQueueStrategy s = TransactQueueStrategy s++-- | An implementation of the 'QueueStrategy' class.+instance MonadDES m => QueueStrategy m (TransactQueueStrategy s) where++  -- | A queue used by the 'TransactQueueStrategy' strategy.+  data StrategyQueue m (TransactQueueStrategy s) a =+    TransactStrategyQueue { transactStrategy :: TransactQueueStrategy s,+                            -- ^ the strategy itself+                            transactStrategyQueue :: Ref m (M.IntMap (DLL.DoubleLinkedList m a))+                            -- ^ the transact queue+                          }++  {-# INLINABLE newStrategyQueue #-}+  newStrategyQueue s =+    do r <- newRef M.empty+       return $ TransactStrategyQueue s r++  {-# INLINABLE strategyQueueNull #-}+  strategyQueueNull q =+    do m <- readRef (transactStrategyQueue q)+       return $ M.null m++instance MonadDES m => DequeueStrategy m (TransactQueueStrategy FCFS) where++  {-# INLINABLE strategyDequeue #-}+  strategyDequeue q =+    do m <- readRef (transactStrategyQueue q)+       let (k, xs) = M.findMin m+       i <- DLL.listFirst xs+       DLL.listRemoveFirst xs+       empty <- DLL.listNull xs+       when empty $+         modifyRef (transactStrategyQueue q) $+         M.delete k+       return i++instance MonadDES m => DequeueStrategy m (TransactQueueStrategy LCFS) where++  {-# INLINABLE strategyDequeue #-}+  strategyDequeue q =+    do m <- readRef (transactStrategyQueue q)+       let (k, xs) = M.findMin m+       i <- DLL.listLast xs+       DLL.listRemoveLast xs+       empty <- DLL.listNull xs+       when empty $+         modifyRef (transactStrategyQueue q) $+         M.delete k+       return i++instance (MonadDES m, DequeueStrategy m (TransactQueueStrategy s)) => PriorityQueueStrategy m (TransactQueueStrategy s) Int where++  {-# INLINABLE strategyEnqueueWithPriority #-}+  strategyEnqueueWithPriority q priority i =+    do m <- readRef (transactStrategyQueue q)+       let k  = - priority+           xs = M.lookup k m+       case xs of+         Nothing ->+           do xs <- liftSimulation DLL.newList+              DLL.listAddLast xs i+              modifyRef (transactStrategyQueue q) $+                M.insert k xs+         Just xs ->+           DLL.listAddLast xs i++instance MonadDES m => DeletingQueueStrategy m (TransactQueueStrategy FCFS) where++  {-# INLINABLE strategyQueueDeleteBy #-}+  strategyQueueDeleteBy q pred =+    do m <- readRef (transactStrategyQueue q)+       let loop [] = return Nothing+           loop ((k, xs): tail) =+             do a <- DLL.listRemoveBy xs pred+                case a of+                  Nothing -> loop tail+                  Just _  ->+                    do empty <- DLL.listNull xs+                       when empty $+                         modifyRef (transactStrategyQueue q) $+                         M.delete k+                       return a+       loop (M.assocs m)++  {-# INLINABLE strategyQueueContainsBy #-}+  strategyQueueContainsBy q pred =+    do m <- readRef (transactStrategyQueue q)+       let loop [] = return Nothing+           loop ((k, xs): tail) =+             do a <- DLL.listContainsBy xs pred+                case a of+                  Nothing -> loop tail+                  Just _  -> return a+       loop (M.assocs m)++-- | Try to delete the transact by the specified priority and satisfying to the provided predicate.+transactStrategyQueueDeleteBy :: MonadDES m+                                 => StrategyQueue m (TransactQueueStrategy s) a+                                 -- ^ the queue+                                 -> Int+                                 -- ^ the transact priority+                                 -> (a -> Bool)+                                 -- ^ the predicate+                                 -> Event m (Maybe a)+{-# INLINABLE transactStrategyQueueDeleteBy #-}+transactStrategyQueueDeleteBy q priority pred =+  do m <- readRef (transactStrategyQueue q)+     let k  = - priority+         xs = M.lookup k m+     case xs of+       Nothing -> return Nothing+       Just xs ->+         do a <- DLL.listRemoveBy xs pred+            empty <- DLL.listNull xs+            when empty $+              modifyRef (transactStrategyQueue q) $+              M.delete k+            return a++-- | Test whether the queue contains a transact with the specified priority satisfying the provided predicate.+transactStrategyQueueContainsBy :: MonadDES m+                                   => StrategyQueue m (TransactQueueStrategy s) a+                                   -- ^ the queue+                                   -> Int+                                   -- ^ the transact priority+                                   -> (a -> Bool)+                                   -- ^ the predicate+                                   -> Event m (Maybe a)+{-# INLINABLE transactStrategyQueueContainsBy #-}+transactStrategyQueueContainsBy q priority pred =+  do m <- readRef (transactStrategyQueue q)+     let k  = - priority+         xs = M.lookup k m+     case xs of+       Nothing -> return Nothing+       Just xs -> DLL.listContainsBy xs pred
+ aivika-gpss.cabal view
@@ -0,0 +1,158 @@+name:            aivika-gpss+version:         0.3+synopsis:        GPSS-like DSL for Aivika+description:+    This package allows defining simulation models in terms of a GPSS-like+    domain specific language, which can be useful if you are going to +    translate your models from GPSS into Aivika [1, 2].+    .+    Note that the GPSS-like domain specific language is not equivalent to +    the original GPSS language, but it may return very similar results in +    some cases, while it can also return quite different results in other cases.+    .+    The package implements the most of GPSS simulation blocks, but the main difference+    is as follows.+    .+    Like GPSS, the package tries to treat the transact priorities properly within each block.+    Here it works in a very similar way even for such non-trivial blocks as PREEMPT, GATHER+    and ASSEMBLE. But unlike GPSS, the blocks behave independently from each other, where +    the transact priorities are not used when deciding which of the blocks will be activated next.+    The order of activating blocks is unpredictable.+    .+    There is a layer of emulation. The package creates a new discontinuous process for each new transact. +    Then that process becomes fully responsible for processing the transact by the blocks. Therefore, +    the speed of simulation is slower that it could be when implementing the same model but based on +    using the standard Aivika facilities. +    .+    The rough estimation is that this particular package is slower in 2-3 times than the existent GPSS +    simulators in case of sequential simulation. But the point is that you can combine GPSS with +    discontinuous processes, events and even agents within the same model. Moreover, you can use GPSS+    in parallel and distributed simulation models. +    .+    \[1] <http://hackage.haskell.org/package/aivika>+    .+    \[2] <http://hackage.haskell.org/package/aivika-transformers>+    .+category:        Simulation+license:         BSD3+license-file:    LICENSE+copyright:       (c) 2017. David Sorokin <david.sorokin@gmail.com>+author:          David Sorokin+maintainer:      David Sorokin <david.sorokin@gmail.com>+homepage:        http://www.aivikasoft.com+cabal-version:   >= 1.6+build-type:      Simple+tested-with:     GHC == 8.0.1++extra-source-files:  examples/Example2A.hs+                     examples/Example2ATrans.hs+                     examples/Example2B.hs+                     examples/Example2BTrans.hs+                     examples/Example2C.hs+                     examples/Example2CTrans.hs+                     examples/Example2D.hs+                     examples/Example2DTrans.hs+                     examples/Example2E.hs+                     examples/Example2ETrans.hs+                     examples/Example7-26.hs+                     examples/Example7-26Distributed.hs+                     examples/Example7-26Trans.hs+                     examples/Example7-28.hs+                     examples/Example7-28Trans.hs+                     examples/Example7-31.hs+                     examples/Example7-31Trans.hs+                     examples/Example7-35.hs+                     examples/Example7-35Trans.hs++library++    exposed-modules: Simulation.Aivika.GPSS+                     Simulation.Aivika.GPSS.Block+                     Simulation.Aivika.GPSS.Block.Advance+                     Simulation.Aivika.GPSS.Block.Assemble+                     Simulation.Aivika.GPSS.Block.Assign+                     Simulation.Aivika.GPSS.Block.Depart+                     Simulation.Aivika.GPSS.Block.Enter+                     Simulation.Aivika.GPSS.Block.Gather+                     Simulation.Aivika.GPSS.Block.Generate+                     Simulation.Aivika.GPSS.Block.Leave+                     Simulation.Aivika.GPSS.Block.Link+                     Simulation.Aivika.GPSS.Block.Loop+                     Simulation.Aivika.GPSS.Block.Match+                     Simulation.Aivika.GPSS.Block.Preempt+                     Simulation.Aivika.GPSS.Block.Priority+                     Simulation.Aivika.GPSS.Block.Queue+                     Simulation.Aivika.GPSS.Block.Release+                     Simulation.Aivika.GPSS.Block.Return+                     Simulation.Aivika.GPSS.Block.Seize+                     Simulation.Aivika.GPSS.Block.Split+                     Simulation.Aivika.GPSS.Block.Terminate+                     Simulation.Aivika.GPSS.Block.Test+                     Simulation.Aivika.GPSS.Block.Transfer+                     Simulation.Aivika.GPSS.Block.Unlink+                     Simulation.Aivika.GPSS.AssemblySet+                     Simulation.Aivika.GPSS.Facility+                     Simulation.Aivika.GPSS.MatchChain+                     Simulation.Aivika.GPSS.Queue+                     Simulation.Aivika.GPSS.Results+                     Simulation.Aivika.GPSS.Results.Locale+                     Simulation.Aivika.GPSS.Results.Transform+                     Simulation.Aivika.GPSS.Storage+                     Simulation.Aivika.GPSS.Transact+                     Simulation.Aivika.GPSS.TransactQueueStrategy+                     Simulation.Aivika.Trans.GPSS+                     Simulation.Aivika.Trans.GPSS.Block+                     Simulation.Aivika.Trans.GPSS.Block.Advance+                     Simulation.Aivika.Trans.GPSS.Block.Assemble+                     Simulation.Aivika.Trans.GPSS.Block.Assign+                     Simulation.Aivika.Trans.GPSS.Block.Depart+                     Simulation.Aivika.Trans.GPSS.Block.Enter+                     Simulation.Aivika.Trans.GPSS.Block.Gather+                     Simulation.Aivika.Trans.GPSS.Block.Generate+                     Simulation.Aivika.Trans.GPSS.Block.Leave+                     Simulation.Aivika.Trans.GPSS.Block.Link+                     Simulation.Aivika.Trans.GPSS.Block.Loop+                     Simulation.Aivika.Trans.GPSS.Block.Match+                     Simulation.Aivika.Trans.GPSS.Block.Preempt+                     Simulation.Aivika.Trans.GPSS.Block.Priority+                     Simulation.Aivika.Trans.GPSS.Block.Queue+                     Simulation.Aivika.Trans.GPSS.Block.Release+                     Simulation.Aivika.Trans.GPSS.Block.Return+                     Simulation.Aivika.Trans.GPSS.Block.Seize+                     Simulation.Aivika.Trans.GPSS.Block.Split+                     Simulation.Aivika.Trans.GPSS.Block.Terminate+                     Simulation.Aivika.Trans.GPSS.Block.Test+                     Simulation.Aivika.Trans.GPSS.Block.Transfer+                     Simulation.Aivika.Trans.GPSS.Block.Unlink+                     Simulation.Aivika.Trans.GPSS.AssemblySet+                     Simulation.Aivika.Trans.GPSS.Facility+                     Simulation.Aivika.Trans.GPSS.MatchChain+                     Simulation.Aivika.Trans.GPSS.Queue+                     Simulation.Aivika.Trans.GPSS.Results+                     Simulation.Aivika.Trans.GPSS.Results.Locale+                     Simulation.Aivika.Trans.GPSS.Results.Transform+                     Simulation.Aivika.Trans.GPSS.Storage+                     Simulation.Aivika.Trans.GPSS.Transact+                     Simulation.Aivika.Trans.GPSS.TransactQueueStrategy+                     +    build-depends:   base >= 4.2 && < 6,+                     mtl >= 1.1.0.2,+                     containers >= 0.4.0.0,+                     hashable >= 1.2.0.0,+                     unordered-containers >= 0.1.0.0,+                     aivika >= 5.2,+                     aivika-transformers >= 5.2++    extensions:      MultiParamTypeClasses,+                     TypeFamilies,+                     FlexibleInstances,+                     FlexibleContexts,+                     KindSignatures+                     +    ghc-options:     -O2+    +source-repository head++    type:     git+    location: https://github.com/dsorokin/aivika-gpss+
+ examples/Example2A.hs view
@@ -0,0 +1,57 @@++{-+  GENERATE 18,6+  QUEUE JOEQ+  SEIZE JOE+  DEPART JOEQ+  ADVANCE 16,4+  RELEASE JOE+  TERMINATE++  GENERATE 480+  TERMINATE 1++  START 1+ -}++import Control.Category+import Control.Monad.Trans++import Simulation.Aivika+import Simulation.Aivika.GPSS+import qualified Simulation.Aivika.GPSS.Queue as Q++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 480.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation Results+model =+  do joeq <- runEventInStartTime Q.newQueue+     joe  <- runEventInStartTime newFacility++     let clientStream = randomUniformStream (18 - 6) (18 + 6)++     let clients = streamGeneratorBlock0 clientStream+         chain   =+           queueBlock joeq 1 >>>+           seizeBlock joe >>>+           departBlock joeq 1 >>>+           advanceBlock (randomUniformProcess_ (16 - 4) (16 + 4)) >>>+           releaseBlock joe >>>+           terminateBlock++     runProcessInStartTime $+       runGeneratorBlock clients chain +  +     return $+       results+       [resultSource "joeq" "The Joe queue" joeq,+        resultSource "joe" "Joe" joe]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example2ATrans.hs view
@@ -0,0 +1,61 @@++{-+  GENERATE 18,6+  QUEUE JOEQ+  SEIZE JOE+  DEPART JOEQ+  ADVANCE 16,4+  RELEASE JOE+  TERMINATE++  GENERATE 480+  TERMINATE 1++  START 1+ -}++import Control.Category+import Control.Monad.Trans++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS+import qualified Simulation.Aivika.Trans.GPSS.Queue as Q++import Simulation.Aivika.IO++type DES = IO++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 480.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation DES (Results DES)+model =+  do joeq <- runEventInStartTime Q.newQueue+     joe  <- runEventInStartTime newFacility++     let clientStream = randomUniformStream (18 - 6) (18 + 6)++     let clients = streamGeneratorBlock0 clientStream+         chain   =+           queueBlock joeq 1 >>>+           seizeBlock joe >>>+           departBlock joeq 1 >>>+           advanceBlock (randomUniformProcess_ (16 - 4) (16 + 4)) >>>+           releaseBlock joe >>>+           terminateBlock++     runProcessInStartTime $+       runGeneratorBlock clients chain +  +     return $+       results+       [resultSource "joeq" "The Joe queue" joeq,+        resultSource "joe" "Joe" joe]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example2B.hs view
@@ -0,0 +1,80 @@++{-+  GENERATE 35,10+  QUEUE JOEQ+  SEIZE JOE+  DEPART JOEQ+  ADVANCE 18,6+  RELEASE JOE+  TERMINATE++  GENERATE 60,20+  QUEUE JOEQ+  SEIZE JOE+  DEPART JOEQ+  ADVANCE 10,2+  ADVANCE 18,6+  RELEASE JOE+  TERMINATE++  GENERATE 480+  TERMINATE 1++  START 1+ -}++import Control.Category+import Control.Monad.Trans++import Simulation.Aivika+import Simulation.Aivika.GPSS+import qualified Simulation.Aivika.GPSS.Queue as Q++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 480.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation Results+model =+  do joeq <- runEventInStartTime Q.newQueue+     joe  <- runEventInStartTime newFacility++     let clientStream1 = randomUniformStream (35 - 10) (35 + 10)+         clientStream2 = randomUniformStream (60 - 20) (60 + 20)++     let clients1 = streamGeneratorBlock0 clientStream1+         chain1   =+           queueBlock joeq 1 >>>+           seizeBlock joe >>>+           departBlock joeq 1 >>>+           advanceBlock (randomUniformProcess_ (18 - 6) (18 + 6)) >>>+           releaseBlock joe >>>+           terminateBlock++     let clients2 = streamGeneratorBlock0 clientStream2+         chain2   =+           queueBlock joeq 1 >>>+           seizeBlock joe >>>+           departBlock joeq 1 >>>+           advanceBlock (randomUniformProcess_ (10 - 2) (10 + 2)) >>>+           advanceBlock (randomUniformProcess_ (18 - 6) (18 + 6)) >>>+           releaseBlock joe >>>+           terminateBlock++     runProcessInStartTime $+       runGeneratorBlock clients1 chain1 ++     runProcessInStartTime $+       runGeneratorBlock clients2 chain2 +  +     return $+       results+       [resultSource "joeq" "The Joe queue" joeq,+        resultSource "joe" "Joe" joe]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example2BTrans.hs view
@@ -0,0 +1,84 @@++{-+  GENERATE 35,10+  QUEUE JOEQ+  SEIZE JOE+  DEPART JOEQ+  ADVANCE 18,6+  RELEASE JOE+  TERMINATE++  GENERATE 60,20+  QUEUE JOEQ+  SEIZE JOE+  DEPART JOEQ+  ADVANCE 10,2+  ADVANCE 18,6+  RELEASE JOE+  TERMINATE++  GENERATE 480+  TERMINATE 1++  START 1+ -}++import Control.Category+import Control.Monad.Trans++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS+import qualified Simulation.Aivika.Trans.GPSS.Queue as Q++import Simulation.Aivika.IO++type DES = IO++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 480.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation DES (Results DES)+model =+  do joeq <- runEventInStartTime Q.newQueue+     joe  <- runEventInStartTime newFacility++     let clientStream1 = randomUniformStream (35 - 10) (35 + 10)+         clientStream2 = randomUniformStream (60 - 20) (60 + 20)++     let clients1 = streamGeneratorBlock0 clientStream1+         chain1   =+           queueBlock joeq 1 >>>+           seizeBlock joe >>>+           departBlock joeq 1 >>>+           advanceBlock (randomUniformProcess_ (18 - 6) (18 + 6)) >>>+           releaseBlock joe >>>+           terminateBlock++     let clients2 = streamGeneratorBlock0 clientStream2+         chain2   =+           queueBlock joeq 1 >>>+           seizeBlock joe >>>+           departBlock joeq 1 >>>+           advanceBlock (randomUniformProcess_ (10 - 2) (10 + 2)) >>>+           advanceBlock (randomUniformProcess_ (18 - 6) (18 + 6)) >>>+           releaseBlock joe >>>+           terminateBlock++     runProcessInStartTime $+       runGeneratorBlock clients1 chain1 ++     runProcessInStartTime $+       runGeneratorBlock clients2 chain2 +  +     return $+       results+       [resultSource "joeq" "The Joe queue" joeq,+        resultSource "joe" "Joe" joe]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example2C.hs view
@@ -0,0 +1,78 @@++{-+  GENERATE 420,360,,,1+  QUEUE LINE+  SEIZE CLERK+  DEPART LINE+  ADVANCE 300,90+  RELEASE CLERK+  TERMINATE++  GENERATE 360,240,,,2+  QUEUE LINE+  SEIZE CLERK+  DEPART LINE+  ADVANCE 100,30+  RELEASE CLERK+  TERMINATE++  GENERATE 28800+  TERMINATE 1++  START 1+ -}++import Control.Category+import Control.Monad.Trans++import Simulation.Aivika+import Simulation.Aivika.GPSS+import qualified Simulation.Aivika.GPSS.Queue as Q++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 28800.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation Results+model =+  do line  <- runEventInStartTime Q.newQueue+     clerk <- runEventInStartTime newFacility++     let workerStream1 = randomUniformStream (420 - 360) (420 + 360)+         workerStream2 = randomUniformStream (360 - 240) (360 + 240)++     let workers1 = streamGeneratorBlock workerStream1 1+         chain1   =+           queueBlock line 1 >>>+           seizeBlock clerk >>>+           departBlock line 1 >>>+           advanceBlock (randomUniformProcess_ (300 - 90) (300 + 90)) >>>+           releaseBlock clerk >>>+           terminateBlock++     let workers2 = streamGeneratorBlock workerStream2 2+         chain2   =+           queueBlock line 1 >>>+           seizeBlock clerk >>>+           departBlock line 1 >>>+           advanceBlock (randomUniformProcess_ (100 - 30) (100 + 30)) >>>+           releaseBlock clerk >>>+           terminateBlock++     runProcessInStartTime $+       runGeneratorBlock workers1 chain1 ++     runProcessInStartTime $+       runGeneratorBlock workers2 chain2 +  +     return $+       results+       [resultSource "line" "Line" line,+        resultSource "clerk" "Clerk" clerk]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example2CTrans.hs view
@@ -0,0 +1,82 @@++{-+  GENERATE 420,360,,,1+  QUEUE LINE+  SEIZE CLERK+  DEPART LINE+  ADVANCE 300,90+  RELEASE CLERK+  TERMINATE++  GENERATE 360,240,,,2+  QUEUE LINE+  SEIZE CLERK+  DEPART LINE+  ADVANCE 100,30+  RELEASE CLERK+  TERMINATE++  GENERATE 28800+  TERMINATE 1++  START 1+ -}++import Control.Category+import Control.Monad.Trans++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS+import qualified Simulation.Aivika.Trans.GPSS.Queue as Q++import Simulation.Aivika.IO++type DES = IO++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 28800.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation DES (Results DES)+model =+  do line  <- runEventInStartTime Q.newQueue+     clerk <- runEventInStartTime newFacility++     let workerStream1 = randomUniformStream (420 - 360) (420 + 360)+         workerStream2 = randomUniformStream (360 - 240) (360 + 240)++     let workers1 = streamGeneratorBlock workerStream1 1+         chain1   =+           queueBlock line 1 >>>+           seizeBlock clerk >>>+           departBlock line 1 >>>+           advanceBlock (randomUniformProcess_ (300 - 90) (300 + 90)) >>>+           releaseBlock clerk >>>+           terminateBlock++     let workers2 = streamGeneratorBlock workerStream2 2+         chain2   =+           queueBlock line 1 >>>+           seizeBlock clerk >>>+           departBlock line 1 >>>+           advanceBlock (randomUniformProcess_ (100 - 30) (100 + 30)) >>>+           releaseBlock clerk >>>+           terminateBlock++     runProcessInStartTime $+       runGeneratorBlock workers1 chain1 ++     runProcessInStartTime $+       runGeneratorBlock workers2 chain2 +  +     return $+       results+       [resultSource "line" "Line" line,+        resultSource "clerk" "Clerk" clerk]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example2D.hs view
@@ -0,0 +1,55 @@++{-+        GENERATE ,,,4+Back1   ADVANCE 30,5+        SEIZE OVEN+        ADVANCE 8,2+        RELEASE OVEN+        TRANSFER ,Back1++        GENERATE 2400+        TERMINATE 1++        START 1+ -}++import Control.Category+import Control.Monad.Trans++import Simulation.Aivika+import Simulation.Aivika.GPSS+import qualified Simulation.Aivika.GPSS.Queue as Q++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 2400.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation Results+model =+  do oven <- runEventInStartTime newFacility++     let assemblerStream = takeStream 4 $+                           randomUniformIntStream 0 0++     let assemblers = streamGeneratorBlock0 assemblerStream+         chain      = back+         back       =+           advanceBlock (randomUniformProcess_ (30 - 5) (30 + 5)) >>>+           seizeBlock oven >>>+           advanceBlock (randomUniformProcess_ (8 - 2) (8 + 2)) >>>+           releaseBlock oven >>>+           transferBlock back++     runProcessInStartTime $+       runGeneratorBlock assemblers chain +  +     return $+       results+       [resultSource "oven" "Oven" oven]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example2DTrans.hs view
@@ -0,0 +1,59 @@++{-+        GENERATE ,,,4+Back1   ADVANCE 30,5+        SEIZE OVEN+        ADVANCE 8,2+        RELEASE OVEN+        TRANSFER ,Back1++        GENERATE 2400+        TERMINATE 1++        START 1+ -}++import Control.Category+import Control.Monad.Trans++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS+import qualified Simulation.Aivika.Trans.GPSS.Queue as Q++import Simulation.Aivika.IO++type DES = IO++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 2400.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation DES (Results DES)+model =+  do oven <- runEventInStartTime newFacility++     let assemblerStream = takeStream 4 $+                           randomUniformIntStream 0 0++     let assemblers = streamGeneratorBlock0 assemblerStream+         chain      = back+         back       =+           advanceBlock (randomUniformProcess_ (30 - 5) (30 + 5)) >>>+           seizeBlock oven >>>+           advanceBlock (randomUniformProcess_ (8 - 2) (8 + 2)) >>>+           releaseBlock oven >>>+           transferBlock back++     runProcessInStartTime $+       runGeneratorBlock assemblers chain +  +     return $+       results+       [resultSource "oven" "Oven" oven]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example2E.hs view
@@ -0,0 +1,65 @@++{-++MEN     STORAGE 3+NOWON   STORAGE 50++        GENERATE ,,,53+Back1   ENTER NOWON+        ADVANCE 157,25+        LEAVE NOWON+        ENTER MEN+        ADVANCE 7,3+        LEAVE MEN+        TRANSFER ,Back1++        GENERATE 6240+        TERMINATE 1++        START 1+ -}++import Control.Category+import Control.Monad.Trans++import Simulation.Aivika+import Simulation.Aivika.GPSS+import qualified Simulation.Aivika.GPSS.Queue as Q++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 6240.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation Results+model =+  do men   <- runEventInStartTime $ newStorage 3+     nowon <- runEventInStartTime $ newStorage 50++     let machineStream = takeStream 53 $+                         randomUniformIntStream 0 0++     let machines = streamGeneratorBlock0 machineStream+         chain    = back+         back     =+           enterBlock nowon 1 >>>+           advanceBlock (randomUniformProcess_ (157 - 25) (157 + 25)) >>>+           leaveBlock nowon 1 >>>+           enterBlock men 1 >>>+           advanceBlock (randomUniformProcess_ (7 - 3) (7 + 3)) >>>+           leaveBlock men 1 >>>+           transferBlock back++     runProcessInStartTime $+       runGeneratorBlock machines chain +  +     return $+       results+       [resultSource "men" "Men" men,+        resultSource "nowon" "NowOn" nowon]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example2ETrans.hs view
@@ -0,0 +1,69 @@++{-++MEN     STORAGE 3+NOWON   STORAGE 50++        GENERATE ,,,53+Back1   ENTER NOWON+        ADVANCE 157,25+        LEAVE NOWON+        ENTER MEN+        ADVANCE 7,3+        LEAVE MEN+        TRANSFER ,Back1++        GENERATE 6240+        TERMINATE 1++        START 1+ -}++import Control.Category+import Control.Monad.Trans++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS+import qualified Simulation.Aivika.Trans.GPSS.Queue as Q++import Simulation.Aivika.IO++type DES = IO++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 6240.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation IO (Results IO)+model =+  do men   <- runEventInStartTime $ newStorage 3+     nowon <- runEventInStartTime $ newStorage 50++     let machineStream = takeStream 53 $+                         randomUniformIntStream 0 0++     let machines = streamGeneratorBlock0 machineStream+         chain    = back+         back     =+           enterBlock nowon 1 >>>+           advanceBlock (randomUniformProcess_ (157 - 25) (157 + 25)) >>>+           leaveBlock nowon 1 >>>+           enterBlock men 1 >>>+           advanceBlock (randomUniformProcess_ (7 - 3) (7 + 3)) >>>+           leaveBlock men 1 >>>+           transferBlock back++     runProcessInStartTime $+       runGeneratorBlock machines chain +  +     return $+       results+       [resultSource "men" "Men" men,+        resultSource "nowon" "NowOn" nowon]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example7-26.hs view
@@ -0,0 +1,99 @@++{-+        GENERATE 2000,500,,,1+        GATE NI PROF,Busy+        PREEMPT PROF,PR,Add,5+        ADVANCE (Exponential(1,0,200))+        RETURN PROF+Busy    TERMINATE++        GENERATE 2000,500+        QUEUE LINE+        SEIZE PROF+        DEPART LINE+        ADVANCE (Exponential(1,0,1000))+LetGo   RELEASE PROF+        TERMINATE++Add     ASSIGN 5+,300+        ADVANCE P5+        TRANSFER ,LetGo++        GENERATE 10000000+        TERMINATE 1++        START 1+ -}++import Prelude hiding (id)++import Control.Category+import Control.Monad.Trans++import Data.Maybe++import Simulation.Aivika+import Simulation.Aivika.GPSS+import qualified Simulation.Aivika.GPSS.Queue as Q++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 10000000.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation Results+model =+  do line <- runEventInStartTime Q.newQueue+     prof <- runEventInStartTime newFacility++     let phoneCallStream = randomUniformStream (2000 - 500) (2000 + 500)+         studentStream   = randomUniformStream (2000 - 500) (2000 + 500)++     let phoneCalls     = streamGeneratorBlock phoneCallStream 1+         phoneCallChain =+           Block (\a ->+                   do f <- liftEvent (facilityInterrupted prof)+                      if f+                        then blockProcess (transferBlock busy) a+                        else return a) >>>+           preemptBlock prof+           (PreemptBlockMode { preemptBlockPriorityMode = True,+                               preemptBlockTransfer     = Just add,+                               -- preemptBlockTransfer     = Nothing,+                               preemptBlockRemoveMode   = False }) >>>+           advanceBlock (randomExponentialProcess_ 200) >>>+           returnBlock prof >>>+           busy+         busy           = terminateBlock+         +         students       = streamGeneratorBlock studentStream 0+         studentChain   =+           queueBlock line 1 >>>+           seizeBlock prof >>>+           departBlock line 1 >>>+           advanceBlock (randomExponentialProcess_ 1000) >>>+           letGo+         letGo          =+           releaseBlock prof >>>+           terminateBlock+         add dt0        =+           let dt = maybe 0 id dt0+           in advanceBlock (holdProcess (dt + 300)) >>>+              transferBlock letGo++     runProcessInStartTime $+       runGeneratorBlock phoneCalls phoneCallChain ++     runProcessInStartTime $+       runGeneratorBlock students studentChain +  +     return $+       results+       [resultSource "line" "Line" line,+        resultSource "prof" "Prof" prof]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example7-26Distributed.hs view
@@ -0,0 +1,130 @@++{-+        GENERATE 2000,500,,,1+        GATE NI PROF,Busy+        PREEMPT PROF,PR,Add,5+        ADVANCE (Exponential(1,0,200))+        RETURN PROF+Busy    TERMINATE++        GENERATE 2000,500+        QUEUE LINE+        SEIZE PROF+        DEPART LINE+        ADVANCE (Exponential(1,0,1000))+LetGo   RELEASE PROF+        TERMINATE++Add     ASSIGN 5+,300+        ADVANCE P5+        TRANSFER ,LetGo++        GENERATE 10000000+        TERMINATE 1++        START 1+ -}++import Prelude hiding (id, (.))++import Control.Category+import Control.Monad.Trans+import qualified Control.Distributed.Process as DP+import Control.Distributed.Process.Node (initRemoteTable)+import Control.Distributed.Process.Backend.SimpleLocalnet++import Data.Maybe++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS+import qualified Simulation.Aivika.Trans.GPSS.Queue as Q++import Simulation.Aivika.Distributed++type DES = DIO++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 10000000.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation DES ()+model =+  do line <- runEventInStartTime Q.newQueue+     prof <- runEventInStartTime newFacility++     let phoneCallStream = randomUniformStream (2000 - 500) (2000 + 500)+         studentStream   = randomUniformStream (2000 - 500) (2000 + 500)++     let phoneCalls     = streamGeneratorBlock phoneCallStream 1+         phoneCallChain =+           Block (\a ->+                   do f <- liftEvent (facilityInterrupted prof)+                      if f+                        then blockProcess (transferBlock busy) a+                        else return a) >>>+           preemptBlock prof+           (PreemptBlockMode { preemptBlockPriorityMode = True,+                               preemptBlockTransfer     = Just add,+                               -- preemptBlockTransfer     = Nothing,+                               preemptBlockRemoveMode   = False }) >>>+           advanceBlock (randomExponentialProcess_ 200) >>>+           returnBlock prof >>>+           busy+         busy           = terminateBlock+         +         students       = streamGeneratorBlock studentStream 0+         studentChain   =+           queueBlock line 1 >>>+           seizeBlock prof >>>+           departBlock line 1 >>>+           advanceBlock (randomExponentialProcess_ 1000) >>>+           letGo+         letGo          =+           releaseBlock prof >>>+           terminateBlock+         add dt0        =+           let dt = maybe 0 id dt0+           in advanceBlock (holdProcess (dt + 300)) >>>+              transferBlock letGo++     runProcessInStartTime $+       runGeneratorBlock phoneCalls phoneCallChain ++     runProcessInStartTime $+       runGeneratorBlock students studentChain +  +     let rs =+           results+           [resultSource "line" "Line" line,+            resultSource "prof" "Prof" prof]++     printResultsInStopTime printResultSourceInEnglish rs+  +runModel :: DP.ProcessId -> DP.Process ()+runModel timeServerId =+  do DP.say "Started simulating..."+     let ps = defaultDIOParams { dioLoggingPriority = NOTICE }+         m =+           do registerDIO+              a <- runSimulation model specs+              terminateDIO+              return a+     (modelId, modelProcess) <- runDIO m ps timeServerId+     modelProcess++master = \backend nodes ->+  do liftIO . putStrLn $ "Slaves: " ++ show nodes+     let timeServerParams = defaultTimeServerParams { tsLoggingPriority = NOTICE }+     timeServerId  <- DP.spawnLocal $ timeServer 1 timeServerParams+     runModel timeServerId++main :: IO ()+main = do+  backend <- initializeBackend "localhost" "8080" rtable+  startMaster backend (master backend)+    where+      rtable :: DP.RemoteTable+      -- rtable = __remoteTable initRemoteTable+      rtable = initRemoteTable
+ examples/Example7-26Trans.hs view
@@ -0,0 +1,103 @@++{-+        GENERATE 2000,500,,,1+        GATE NI PROF,Busy+        PREEMPT PROF,PR,Add,5+        ADVANCE (Exponential(1,0,200))+        RETURN PROF+Busy    TERMINATE++        GENERATE 2000,500+        QUEUE LINE+        SEIZE PROF+        DEPART LINE+        ADVANCE (Exponential(1,0,1000))+LetGo   RELEASE PROF+        TERMINATE++Add     ASSIGN 5+,300+        ADVANCE P5+        TRANSFER ,LetGo++        GENERATE 10000000+        TERMINATE 1++        START 1+ -}++import Prelude hiding (id)++import Control.Category+import Control.Monad.Trans++import Data.Maybe++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS+import qualified Simulation.Aivika.Trans.GPSS.Queue as Q++import Simulation.Aivika.IO++type DES = IO++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 10000000.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation DES (Results DES)+model =+  do line <- runEventInStartTime Q.newQueue+     prof <- runEventInStartTime newFacility++     let phoneCallStream = randomUniformStream (2000 - 500) (2000 + 500)+         studentStream   = randomUniformStream (2000 - 500) (2000 + 500)++     let phoneCalls     = streamGeneratorBlock phoneCallStream 1+         phoneCallChain =+           Block (\a ->+                   do f <- liftEvent (facilityInterrupted prof)+                      if f+                        then blockProcess (transferBlock busy) a+                        else return a) >>>+           preemptBlock prof+           (PreemptBlockMode { preemptBlockPriorityMode = True,+                               preemptBlockTransfer     = Just add,+                               -- preemptBlockTransfer     = Nothing,+                               preemptBlockRemoveMode   = False }) >>>+           advanceBlock (randomExponentialProcess_ 200) >>>+           returnBlock prof >>>+           busy+         busy           = terminateBlock+         +         students       = streamGeneratorBlock studentStream 0+         studentChain   =+           queueBlock line 1 >>>+           seizeBlock prof >>>+           departBlock line 1 >>>+           advanceBlock (randomExponentialProcess_ 1000) >>>+           letGo+         letGo          =+           releaseBlock prof >>>+           terminateBlock+         add dt0        =+           let dt = maybe 0 id dt0+           in advanceBlock (holdProcess (dt + 300)) >>>+              transferBlock letGo++     runProcessInStartTime $+       runGeneratorBlock phoneCalls phoneCallChain ++     runProcessInStartTime $+       runGeneratorBlock students studentChain +  +     return $+       results+       [resultSource "line" "Line" line,+        resultSource "prof" "Prof" prof]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example7-28.hs view
@@ -0,0 +1,75 @@++{-+TATYM   TABLE M1,200,10,10++        GENERATE ,,,1+Back1   MARK+        SEIZE WORKR+        SPLIT 1 Back1+        ADVANCE 16,3+        RELEASE WORKR+        ASSEMBLE 12+        TABULATE TATYM+        TERMINATE++        GENERATE 10000+        TERMINATE 1++        START 1+ -}++import Prelude hiding (id)++import Control.Category+import Control.Monad.Trans++import Data.Maybe++import Simulation.Aivika+import Simulation.Aivika.GPSS++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 10000.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation Results+model =+  do workr <- runEventInStartTime newFacility+     stats <- newRef emptySamplingStats++     let bottleStream = takeStream 1 $+                        randomUniformStream 0 0++     let bottles     = streamGeneratorBlock bottleStream 0+         bottleChain =+           Block (\a ->+                   do t <- liftDynamics time+                      return $ assignTransactValue a (const t)) >>>+           seizeBlock workr >>>+           splitBlock [bottleChain] >>>+           advanceBlock (randomUniformProcess_ (16 - 3) (16 + 3)) >>>+           releaseBlock workr >>>+           assembleBlock 12 >>>+           Block (\a ->+                   do t <- liftDynamics time+                      let t0 = transactValue a+                      liftEvent $+                        modifyRef stats $+                        addSamplingStats (t - t0)+                      return a) >>>+           terminateBlock++     runProcessInStartTime $+       runGeneratorBlock bottles bottleChain +  +     return $+       results+       [resultSource "workr" "WORKR" workr,+        resultSource "stats" "TATYM" stats]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example7-28Trans.hs view
@@ -0,0 +1,79 @@++{-+TATYM   TABLE M1,200,10,10++        GENERATE ,,,1+Back1   MARK+        SEIZE WORKR+        SPLIT 1 Back1+        ADVANCE 16,3+        RELEASE WORKR+        ASSEMBLE 12+        TABULATE TATYM+        TERMINATE++        GENERATE 10000+        TERMINATE 1++        START 1+ -}++import Prelude hiding (id)++import Control.Category+import Control.Monad.Trans++import Data.Maybe++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS++import Simulation.Aivika.IO++type DES = IO++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 10000.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation DES (Results DES)+model =+  do workr <- runEventInStartTime newFacility+     stats <- newRef emptySamplingStats++     let bottleStream = takeStream 1 $+                        randomUniformStream 0 0++     let bottles     = streamGeneratorBlock bottleStream 0+         bottleChain =+           Block (\a ->+                   do t <- liftDynamics time+                      return $ assignTransactValue a (const t)) >>>+           seizeBlock workr >>>+           splitBlock [bottleChain] >>>+           advanceBlock (randomUniformProcess_ (16 - 3) (16 + 3)) >>>+           releaseBlock workr >>>+           assembleBlock 12 >>>+           Block (\a ->+                   do t <- liftDynamics time+                      let t0 = transactValue a+                      liftEvent $+                        modifyRef stats $+                        addSamplingStats (t - t0)+                      return a) >>>+           terminateBlock++     runProcessInStartTime $+       runGeneratorBlock bottles bottleChain +  +     return $+       results+       [resultSource "workr" "WORKR" workr,+        resultSource "stats" "TATYM" stats]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example7-31.hs view
@@ -0,0 +1,87 @@++{-+TATYM   TABLE M1,450,20,20++        GENERATE ,,,1+Back1   MARK+        SEIZE WORKR+        ADVANCE 8,3+        SPLIT 1,Back1+        RELEASE WORKR+        PRIORITY 1+        GATHER 24++        SEIZE WORKR+        ADVANCE 16,3+        RELEASE WORKR+        ASSEMBLE 12+        TABULATE TATYM+        TERMINATE++        GENERATE 100000+        TERMINATE 1++        START 1+ -}++import Prelude hiding (id)++import Control.Category+import Control.Monad.Trans++import Data.Maybe++import Simulation.Aivika+import Simulation.Aivika.GPSS++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 100000.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation Results+model =+  do workr <- runEventInStartTime newFacility+     stats <- newRef emptySamplingStats++     let bottleStream = takeStream 1 $+                        randomUniformStream 0 0++     let bottles     = streamGeneratorBlock bottleStream 0+         bottleChain =+           Block (\a ->+                   do t <- liftDynamics time+                      return $ assignTransactValue a (const t)) >>>+           seizeBlock workr >>>+           advanceBlock (randomUniformProcess_ (8 - 3) (8 + 3)) >>>+           splitBlock [bottleChain] >>>+           releaseBlock workr >>>+           priorityBlock 1 >>>+           gatherBlock 24 >>>+           +           seizeBlock workr >>>+           advanceBlock (randomUniformProcess_ (16 - 3) (16 + 3)) >>>+           releaseBlock workr >>>+           assembleBlock 12 >>>+           Block (\a ->+                   do t <- liftDynamics time+                      let t0 = transactValue a+                      liftEvent $+                        modifyRef stats $+                        addSamplingStats (t - t0)+                      return a) >>>+           terminateBlock++     runProcessInStartTime $+       runGeneratorBlock bottles bottleChain +  +     return $+       results+       [resultSource "workr" "WORKR" workr,+        resultSource "stats" "TATYM" stats]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example7-31Trans.hs view
@@ -0,0 +1,91 @@++{-+TATYM   TABLE M1,450,20,20++        GENERATE ,,,1+Back1   MARK+        SEIZE WORKR+        ADVANCE 8,3+        SPLIT 1,Back1+        RELEASE WORKR+        PRIORITY 1+        GATHER 24++        SEIZE WORKR+        ADVANCE 16,3+        RELEASE WORKR+        ASSEMBLE 12+        TABULATE TATYM+        TERMINATE++        GENERATE 100000+        TERMINATE 1++        START 1+ -}++import Prelude hiding (id)++import Control.Category+import Control.Monad.Trans++import Data.Maybe++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS++import Simulation.Aivika.IO++type DES = IO++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 100000.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation DES (Results DES)+model =+  do workr <- runEventInStartTime newFacility+     stats <- newRef emptySamplingStats++     let bottleStream = takeStream 1 $+                        randomUniformStream 0 0++     let bottles     = streamGeneratorBlock bottleStream 0+         bottleChain =+           Block (\a ->+                   do t <- liftDynamics time+                      return $ assignTransactValue a (const t)) >>>+           seizeBlock workr >>>+           advanceBlock (randomUniformProcess_ (8 - 3) (8 + 3)) >>>+           splitBlock [bottleChain] >>>+           releaseBlock workr >>>+           priorityBlock 1 >>>+           gatherBlock 24 >>>+           +           seizeBlock workr >>>+           advanceBlock (randomUniformProcess_ (16 - 3) (16 + 3)) >>>+           releaseBlock workr >>>+           assembleBlock 12 >>>+           Block (\a ->+                   do t <- liftDynamics time+                      let t0 = transactValue a+                      liftEvent $+                        modifyRef stats $+                        addSamplingStats (t - t0)+                      return a) >>>+           terminateBlock++     runProcessInStartTime $+       runGeneratorBlock bottles bottleChain +  +     return $+       results+       [resultSource "workr" "WORKR" workr,+        resultSource "stats" "TATYM" stats]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example7-35.hs view
@@ -0,0 +1,98 @@++{-+TATYM   TABLE M1,150,20,20++        GENERATE 300,200+        MARK+        SPLIT 1,Route2+        SEIZE MAN1+        ADVANCE 100,20+Block1  MATCH Block2+        ADVANCE 50,5+Merge   ASSEMBLE 2+        RELEASE MAN1+        TABULATE TATYM+        TERMINATE++Route2  SEIZE MAN2+        ADVANCE 110,25+Block2  MATCH Block1+        ADVANCE 70,10+        RELEASE MAN2+        TRANSFER ,Merge ++        GENERATE 100000+        TERMINATE 1++        START 1+ -}++import Prelude hiding (id)++import Control.Category+import Control.Monad.Trans++import Data.Maybe++import Simulation.Aivika+import Simulation.Aivika.GPSS++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 100000.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation Results+model =+  do man1  <- runEventInStartTime newFacility+     man2  <- runEventInStartTime newFacility+     match <- newMatchChain+     stats <- newRef emptySamplingStats++     let orderStream = randomUniformStream (300 - 200) (300 + 200)++     let orders      = streamGeneratorBlock0 orderStream+         orderChain =+           Block (\a ->+                   do t <- liftDynamics time+                      return $ assignTransactValue a (const t)) >>>+           splitBlock [route2] >>>+           seizeBlock man1 >>>+           advanceBlock (randomUniformProcess_ (100 - 20) (100 + 20)) >>>+           matchBlock match >>>+           advanceBlock (randomUniformProcess_ (50 - 5) (50 + 5)) >>>+           merge+         merge =+           assembleBlock 2 >>>+           releaseBlock man1 >>>+           Block (\a ->+                   do t <- liftDynamics time+                      let t0 = transactValue a+                      liftEvent $+                        modifyRef stats $+                        addSamplingStats (t - t0)+                      return a) >>>+           terminateBlock++         route2 =+           seizeBlock man2 >>>+           advanceBlock (randomUniformProcess_ (110 - 25) (110 + 25)) >>>+           matchBlock match >>>+           advanceBlock (randomUniformProcess_ (70 - 10) (70 + 10)) >>>+           releaseBlock man2 >>>+           transferBlock merge+           +     runProcessInStartTime $+       runGeneratorBlock orders orderChain +  +     return $+       results+       [resultSource "man1" "MAN1" man1,+        resultSource "man2" "MAN2" man2,+        resultSource "stats" "TATYM" stats]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs
+ examples/Example7-35Trans.hs view
@@ -0,0 +1,102 @@++{-+TATYM   TABLE M1,150,20,20++        GENERATE 300,200+        MARK+        SPLIT 1,Route2+        SEIZE MAN1+        ADVANCE 100,20+Block1  MATCH Block2+        ADVANCE 50,5+Merge   ASSEMBLE 2+        RELEASE MAN1+        TABULATE TATYM+        TERMINATE++Route2  SEIZE MAN2+        ADVANCE 110,25+Block2  MATCH Block1+        ADVANCE 70,10+        RELEASE MAN2+        TRANSFER ,Merge ++        GENERATE 100000+        TERMINATE 1++        START 1+ -}++import Prelude hiding (id)++import Control.Category+import Control.Monad.Trans++import Data.Maybe++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.GPSS++import Simulation.Aivika.IO++type DES = IO++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 100000.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4,+                spcGeneratorType = SimpleGenerator }+        +model :: Simulation IO (Results IO)+model =+  do man1  <- runEventInStartTime newFacility+     man2  <- runEventInStartTime newFacility+     match <- newMatchChain+     stats <- newRef emptySamplingStats++     let orderStream = randomUniformStream (300 - 200) (300 + 200)++     let orders      = streamGeneratorBlock0 orderStream+         orderChain =+           Block (\a ->+                   do t <- liftDynamics time+                      return $ assignTransactValue a (const t)) >>>+           splitBlock [route2] >>>+           seizeBlock man1 >>>+           advanceBlock (randomUniformProcess_ (100 - 20) (100 + 20)) >>>+           matchBlock match >>>+           advanceBlock (randomUniformProcess_ (50 - 5) (50 + 5)) >>>+           merge+         merge =+           assembleBlock 2 >>>+           releaseBlock man1 >>>+           Block (\a ->+                   do t <- liftDynamics time+                      let t0 = transactValue a+                      liftEvent $+                        modifyRef stats $+                        addSamplingStats (t - t0)+                      return a) >>>+           terminateBlock++         route2 =+           seizeBlock man2 >>>+           advanceBlock (randomUniformProcess_ (110 - 25) (110 + 25)) >>>+           matchBlock match >>>+           advanceBlock (randomUniformProcess_ (70 - 10) (70 + 10)) >>>+           releaseBlock man2 >>>+           transferBlock merge+           +     runProcessInStartTime $+       runGeneratorBlock orders orderChain +  +     return $+       results+       [resultSource "man1" "MAN1" man1,+        resultSource "man2" "MAN2" man2,+        resultSource "stats" "TATYM" stats]+  +main =+  printSimulationResultsInStopTime+  printResultSourceInEnglish+  model specs