module Simulation.Aivika.GPSS.AssemblySet
(
AssemblySet,
newAssemblySet,
assembleTransact,
gatherTransacts,
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
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)
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
}
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
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
transactAssembling :: Transact a -> Event Bool
transactAssembling t =
do s <- transactAssemblySet t
a <- liftIO $ readIORef (assemblySetAssemblingCounter s)
return (a > 0)
transactGathering :: Transact a -> Event Bool
transactGathering t =
do s <- transactAssemblySet t
a <- liftIO $ readIORef (assemblySetGatheringCounter s)
return (a > 0)