diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017 David Sorokin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/Simulation/Aivika/GPSS.hs b/Simulation/Aivika/GPSS.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS.hs @@ -0,0 +1,76 @@ + +-- | +-- Module : Simulation.Aivika.GPSS +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/GPSS/AssemblySet.hs b/Simulation/Aivika/GPSS/AssemblySet.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/AssemblySet.hs @@ -0,0 +1,165 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.AssemblySet +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) diff --git a/Simulation/Aivika/GPSS/AssemblySet.hs-boot b/Simulation/Aivika/GPSS/AssemblySet.hs-boot new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/AssemblySet.hs-boot @@ -0,0 +1,18 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.AssemblySet +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/GPSS/Block.hs b/Simulation/Aivika/GPSS/Block.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block.hs @@ -0,0 +1,53 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) } diff --git a/Simulation/Aivika/GPSS/Block/Advance.hs b/Simulation/Aivika/GPSS/Block/Advance.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Advance.hs @@ -0,0 +1,25 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Advance +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/GPSS/Block/Assemble.hs b/Simulation/Aivika/GPSS/Block/Assemble.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Assemble.hs @@ -0,0 +1,27 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Assemble +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/GPSS/Block/Assign.hs b/Simulation/Aivika/GPSS/Block/Assign.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Assign.hs @@ -0,0 +1,36 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Assign +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/GPSS/Block/Depart.hs b/Simulation/Aivika/GPSS/Block/Depart.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Depart.hs @@ -0,0 +1,29 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Depart +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/GPSS/Block/Enter.hs b/Simulation/Aivika/GPSS/Block/Enter.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Enter.hs @@ -0,0 +1,29 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Enter +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/GPSS/Block/Gather.hs b/Simulation/Aivika/GPSS/Block/Gather.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Gather.hs @@ -0,0 +1,27 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Gather +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/GPSS/Block/Generate.hs b/Simulation/Aivika/GPSS/Block/Generate.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Generate.hs @@ -0,0 +1,51 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Generate +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/GPSS/Block/Leave.hs b/Simulation/Aivika/GPSS/Block/Leave.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Leave.hs @@ -0,0 +1,29 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Leave +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/GPSS/Block/Link.hs b/Simulation/Aivika/GPSS/Block/Link.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Link.hs @@ -0,0 +1,38 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Link +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 + } diff --git a/Simulation/Aivika/GPSS/Block/Loop.hs b/Simulation/Aivika/GPSS/Block/Loop.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Loop.hs @@ -0,0 +1,53 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Loop +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) + } diff --git a/Simulation/Aivika/GPSS/Block/Match.hs b/Simulation/Aivika/GPSS/Block/Match.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Match.hs @@ -0,0 +1,27 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Match +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/GPSS/Block/Preempt.hs b/Simulation/Aivika/GPSS/Block/Preempt.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Preempt.hs @@ -0,0 +1,79 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Preempt +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/GPSS/Block/Priority.hs b/Simulation/Aivika/GPSS/Block/Priority.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Priority.hs @@ -0,0 +1,26 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Priority +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) } diff --git a/Simulation/Aivika/GPSS/Block/Queue.hs b/Simulation/Aivika/GPSS/Block/Queue.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Queue.hs @@ -0,0 +1,29 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Queue +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/GPSS/Block/Release.hs b/Simulation/Aivika/GPSS/Block/Release.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Release.hs @@ -0,0 +1,27 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Release +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/GPSS/Block/Return.hs b/Simulation/Aivika/GPSS/Block/Return.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Return.hs @@ -0,0 +1,27 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Return +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/GPSS/Block/Seize.hs b/Simulation/Aivika/GPSS/Block/Seize.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Seize.hs @@ -0,0 +1,27 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Seize +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/GPSS/Block/Split.hs b/Simulation/Aivika/GPSS/Block/Split.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Split.hs @@ -0,0 +1,52 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Split +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 + } diff --git a/Simulation/Aivika/GPSS/Block/Terminate.hs b/Simulation/Aivika/GPSS/Block/Terminate.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Terminate.hs @@ -0,0 +1,69 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Terminate +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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" diff --git a/Simulation/Aivika/GPSS/Block/Test.hs b/Simulation/Aivika/GPSS/Block/Test.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Test.hs @@ -0,0 +1,93 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Test +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) + } diff --git a/Simulation/Aivika/GPSS/Block/Transfer.hs b/Simulation/Aivika/GPSS/Block/Transfer.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Transfer.hs @@ -0,0 +1,25 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Transfer +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) } diff --git a/Simulation/Aivika/GPSS/Block/Unlink.hs b/Simulation/Aivika/GPSS/Block/Unlink.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Block/Unlink.hs @@ -0,0 +1,35 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Block.Unlink +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 + } diff --git a/Simulation/Aivika/GPSS/Facility.hs b/Simulation/Aivika/GPSS/Facility.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Facility.hs @@ -0,0 +1,702 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Facility +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) () diff --git a/Simulation/Aivika/GPSS/MatchChain.hs b/Simulation/Aivika/GPSS/MatchChain.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/MatchChain.hs @@ -0,0 +1,98 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.MatchChain +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) diff --git a/Simulation/Aivika/GPSS/Queue.hs b/Simulation/Aivika/GPSS/Queue.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Queue.hs @@ -0,0 +1,336 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Queue +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/GPSS/Queue.hs-boot b/Simulation/Aivika/GPSS/Queue.hs-boot new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Queue.hs-boot @@ -0,0 +1,27 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Queue +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/GPSS/Results.hs b/Simulation/Aivika/GPSS/Results.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Results.hs @@ -0,0 +1,175 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Results +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) diff --git a/Simulation/Aivika/GPSS/Results/Locale.hs b/Simulation/Aivika/GPSS/Results/Locale.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Results/Locale.hs @@ -0,0 +1,316 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Results.Locale +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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")] diff --git a/Simulation/Aivika/GPSS/Results/Transform.hs b/Simulation/Aivika/GPSS/Results/Transform.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Results/Transform.hs @@ -0,0 +1,214 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Results.Transform +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/GPSS/Storage.hs b/Simulation/Aivika/GPSS/Storage.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Storage.hs @@ -0,0 +1,514 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Storage +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) () diff --git a/Simulation/Aivika/GPSS/Transact.hs b/Simulation/Aivika/GPSS/Transact.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/Transact.hs @@ -0,0 +1,302 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Transact +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/GPSS/TransactQueueStrategy.hs b/Simulation/Aivika/GPSS/TransactQueueStrategy.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/GPSS/TransactQueueStrategy.hs @@ -0,0 +1,166 @@ + +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.GPSS.TransactQueueStrategy +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans/GPSS.hs b/Simulation/Aivika/Trans/GPSS.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS.hs @@ -0,0 +1,76 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans/GPSS/AssemblySet.hs b/Simulation/Aivika/Trans/GPSS/AssemblySet.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/AssemblySet.hs @@ -0,0 +1,171 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.AssemblySet +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) diff --git a/Simulation/Aivika/Trans/GPSS/AssemblySet.hs-boot b/Simulation/Aivika/Trans/GPSS/AssemblySet.hs-boot new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/AssemblySet.hs-boot @@ -0,0 +1,27 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.AssemblySet +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) diff --git a/Simulation/Aivika/Trans/GPSS/Block.hs b/Simulation/Aivika/Trans/GPSS/Block.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block.hs @@ -0,0 +1,58 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Advance.hs b/Simulation/Aivika/Trans/GPSS/Block/Advance.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Advance.hs @@ -0,0 +1,27 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Advance +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Assemble.hs b/Simulation/Aivika/Trans/GPSS/Block/Assemble.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Assemble.hs @@ -0,0 +1,29 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Assemble +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Assign.hs b/Simulation/Aivika/Trans/GPSS/Block/Assign.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Assign.hs @@ -0,0 +1,40 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Assign +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Depart.hs b/Simulation/Aivika/Trans/GPSS/Block/Depart.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Depart.hs @@ -0,0 +1,31 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Depart +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Enter.hs b/Simulation/Aivika/Trans/GPSS/Block/Enter.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Enter.hs @@ -0,0 +1,31 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Enter +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Gather.hs b/Simulation/Aivika/Trans/GPSS/Block/Gather.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Gather.hs @@ -0,0 +1,29 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Gather +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Generate.hs b/Simulation/Aivika/Trans/GPSS/Block/Generate.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Generate.hs @@ -0,0 +1,57 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Generate +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans/GPSS/Block/Leave.hs b/Simulation/Aivika/Trans/GPSS/Block/Leave.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Leave.hs @@ -0,0 +1,31 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Leave +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Link.hs b/Simulation/Aivika/Trans/GPSS/Block/Link.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Link.hs @@ -0,0 +1,40 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Link +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 + } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Loop.hs b/Simulation/Aivika/Trans/GPSS/Block/Loop.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Loop.hs @@ -0,0 +1,57 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Loop +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) + } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Match.hs b/Simulation/Aivika/Trans/GPSS/Block/Match.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Match.hs @@ -0,0 +1,29 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Match +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Preempt.hs b/Simulation/Aivika/Trans/GPSS/Block/Preempt.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Preempt.hs @@ -0,0 +1,84 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Preempt +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Priority.hs b/Simulation/Aivika/Trans/GPSS/Block/Priority.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Priority.hs @@ -0,0 +1,28 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Priority +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Queue.hs b/Simulation/Aivika/Trans/GPSS/Block/Queue.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Queue.hs @@ -0,0 +1,31 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Queue +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Release.hs b/Simulation/Aivika/Trans/GPSS/Block/Release.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Release.hs @@ -0,0 +1,29 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Release +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Return.hs b/Simulation/Aivika/Trans/GPSS/Block/Return.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Return.hs @@ -0,0 +1,29 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Return +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Seize.hs b/Simulation/Aivika/Trans/GPSS/Block/Seize.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Seize.hs @@ -0,0 +1,29 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Seize +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Split.hs b/Simulation/Aivika/Trans/GPSS/Block/Split.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Split.hs @@ -0,0 +1,54 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Split +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 + } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Terminate.hs b/Simulation/Aivika/Trans/GPSS/Block/Terminate.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Terminate.hs @@ -0,0 +1,74 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Terminate +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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" diff --git a/Simulation/Aivika/Trans/GPSS/Block/Test.hs b/Simulation/Aivika/Trans/GPSS/Block/Test.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Test.hs @@ -0,0 +1,101 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Test +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) + } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Transfer.hs b/Simulation/Aivika/Trans/GPSS/Block/Transfer.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Transfer.hs @@ -0,0 +1,27 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Transfer +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) } diff --git a/Simulation/Aivika/Trans/GPSS/Block/Unlink.hs b/Simulation/Aivika/Trans/GPSS/Block/Unlink.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Block/Unlink.hs @@ -0,0 +1,37 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Block.Unlink +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 + } diff --git a/Simulation/Aivika/Trans/GPSS/Facility.hs b/Simulation/Aivika/Trans/GPSS/Facility.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Facility.hs @@ -0,0 +1,760 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Facility +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) () diff --git a/Simulation/Aivika/Trans/GPSS/MatchChain.hs b/Simulation/Aivika/Trans/GPSS/MatchChain.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/MatchChain.hs @@ -0,0 +1,102 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.MatchChain +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) diff --git a/Simulation/Aivika/Trans/GPSS/Queue.hs b/Simulation/Aivika/Trans/GPSS/Queue.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Queue.hs @@ -0,0 +1,376 @@ + +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Queue +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans/GPSS/Queue.hs-boot b/Simulation/Aivika/Trans/GPSS/Queue.hs-boot new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Queue.hs-boot @@ -0,0 +1,43 @@ + +{-# LANGUAGE KindSignatures #-} + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Queue +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) diff --git a/Simulation/Aivika/Trans/GPSS/Results.hs b/Simulation/Aivika/Trans/GPSS/Results.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Results.hs @@ -0,0 +1,183 @@ + +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Results +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) diff --git a/Simulation/Aivika/Trans/GPSS/Results/Locale.hs b/Simulation/Aivika/Trans/GPSS/Results/Locale.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Results/Locale.hs @@ -0,0 +1,316 @@ + +-- | +-- Module : Simulation.Aivika.GPSS.Trans.Results.Locale +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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")] diff --git a/Simulation/Aivika/Trans/GPSS/Results/Transform.hs b/Simulation/Aivika/Trans/GPSS/Results/Transform.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Results/Transform.hs @@ -0,0 +1,216 @@ + +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Results.Transform +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans/GPSS/Storage.hs b/Simulation/Aivika/Trans/GPSS/Storage.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Storage.hs @@ -0,0 +1,570 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Storage +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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) () diff --git a/Simulation/Aivika/Trans/GPSS/Transact.hs b/Simulation/Aivika/Trans/GPSS/Transact.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/Transact.hs @@ -0,0 +1,317 @@ + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.Transact +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/Simulation/Aivika/Trans/GPSS/TransactQueueStrategy.hs b/Simulation/Aivika/Trans/GPSS/TransactQueueStrategy.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/GPSS/TransactQueueStrategy.hs @@ -0,0 +1,165 @@ + +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.GPSS.TransactQueueStrategy +-- Copyright : Copyright (c) 2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- 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 diff --git a/aivika-gpss.cabal b/aivika-gpss.cabal new file mode 100644 --- /dev/null +++ b/aivika-gpss.cabal @@ -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] + . + \[2] + . +category: Simulation +license: BSD3 +license-file: LICENSE +copyright: (c) 2017. David Sorokin +author: David Sorokin +maintainer: David Sorokin +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 + diff --git a/examples/Example2A.hs b/examples/Example2A.hs new file mode 100644 --- /dev/null +++ b/examples/Example2A.hs @@ -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 diff --git a/examples/Example2ATrans.hs b/examples/Example2ATrans.hs new file mode 100644 --- /dev/null +++ b/examples/Example2ATrans.hs @@ -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 diff --git a/examples/Example2B.hs b/examples/Example2B.hs new file mode 100644 --- /dev/null +++ b/examples/Example2B.hs @@ -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 diff --git a/examples/Example2BTrans.hs b/examples/Example2BTrans.hs new file mode 100644 --- /dev/null +++ b/examples/Example2BTrans.hs @@ -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 diff --git a/examples/Example2C.hs b/examples/Example2C.hs new file mode 100644 --- /dev/null +++ b/examples/Example2C.hs @@ -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 diff --git a/examples/Example2CTrans.hs b/examples/Example2CTrans.hs new file mode 100644 --- /dev/null +++ b/examples/Example2CTrans.hs @@ -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 diff --git a/examples/Example2D.hs b/examples/Example2D.hs new file mode 100644 --- /dev/null +++ b/examples/Example2D.hs @@ -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 diff --git a/examples/Example2DTrans.hs b/examples/Example2DTrans.hs new file mode 100644 --- /dev/null +++ b/examples/Example2DTrans.hs @@ -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 diff --git a/examples/Example2E.hs b/examples/Example2E.hs new file mode 100644 --- /dev/null +++ b/examples/Example2E.hs @@ -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 diff --git a/examples/Example2ETrans.hs b/examples/Example2ETrans.hs new file mode 100644 --- /dev/null +++ b/examples/Example2ETrans.hs @@ -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 diff --git a/examples/Example7-26.hs b/examples/Example7-26.hs new file mode 100644 --- /dev/null +++ b/examples/Example7-26.hs @@ -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 diff --git a/examples/Example7-26Distributed.hs b/examples/Example7-26Distributed.hs new file mode 100644 --- /dev/null +++ b/examples/Example7-26Distributed.hs @@ -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 diff --git a/examples/Example7-26Trans.hs b/examples/Example7-26Trans.hs new file mode 100644 --- /dev/null +++ b/examples/Example7-26Trans.hs @@ -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 diff --git a/examples/Example7-28.hs b/examples/Example7-28.hs new file mode 100644 --- /dev/null +++ b/examples/Example7-28.hs @@ -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 diff --git a/examples/Example7-28Trans.hs b/examples/Example7-28Trans.hs new file mode 100644 --- /dev/null +++ b/examples/Example7-28Trans.hs @@ -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 diff --git a/examples/Example7-31.hs b/examples/Example7-31.hs new file mode 100644 --- /dev/null +++ b/examples/Example7-31.hs @@ -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 diff --git a/examples/Example7-31Trans.hs b/examples/Example7-31Trans.hs new file mode 100644 --- /dev/null +++ b/examples/Example7-31Trans.hs @@ -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 diff --git a/examples/Example7-35.hs b/examples/Example7-35.hs new file mode 100644 --- /dev/null +++ b/examples/Example7-35.hs @@ -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 diff --git a/examples/Example7-35Trans.hs b/examples/Example7-35Trans.hs new file mode 100644 --- /dev/null +++ b/examples/Example7-35Trans.hs @@ -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