-- |
-- Module     : Simulation.Aivika.GPSS.AssemblySet
-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 8.0.2
--
-- This module defines a GPSS assembly set.
--
module Simulation.Aivika.GPSS.AssemblySet
       (-- * Types
        AssemblySet,
        -- * Creating Assembly Set
        newAssemblySet,
        -- * Functions
        assembleTransact,
        gatherTransacts,
        -- * Properties
        transactAssembling,
        transactGathering) where

import Data.IORef
import Data.Monoid
import Data.Maybe
import Data.Hashable

import Control.Monad
import Control.Monad.Trans

import Simulation.Aivika
import Simulation.Aivika.Internal.Specs
import Simulation.Aivika.Internal.Parameter
import Simulation.Aivika.Internal.Simulation

import Simulation.Aivika.GPSS.Transact
import Simulation.Aivika.GPSS.TransactQueueStrategy

-- | Represents an assembly set.
data AssemblySet =
  AssemblySet { AssemblySet -> Int
assemblySetSequenceNo :: Int,
                AssemblySet -> IORef (Maybe ProcessId)
assemblySetAssemblingTransact :: IORef (Maybe ProcessId),
                AssemblySet -> IORef Int
assemblySetAssemblingCounter :: IORef Int,
                AssemblySet -> StrategyQueue (TransactQueueStrategy FCFS) ProcessId
assemblySetGatheringTransacts :: StrategyQueue (TransactQueueStrategy FCFS) ProcessId,
                AssemblySet -> IORef Int
assemblySetGatheringCounter :: IORef Int
              }

instance Eq AssemblySet where
  AssemblySet
x == :: AssemblySet -> AssemblySet -> Bool
== AssemblySet
y = (AssemblySet -> IORef (Maybe ProcessId)
assemblySetAssemblingTransact AssemblySet
x) forall a. Eq a => a -> a -> Bool
== (AssemblySet -> IORef (Maybe ProcessId)
assemblySetAssemblingTransact AssemblySet
y)

instance Hashable AssemblySet where
  hashWithSalt :: Int -> AssemblySet -> Int
hashWithSalt Int
salt AssemblySet
x = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (AssemblySet -> Int
assemblySetSequenceNo AssemblySet
x)

-- | Create a new assembly set.
newAssemblySet :: Simulation AssemblySet
newAssemblySet :: Simulation AssemblySet
newAssemblySet =
  forall a. (Run -> IO a) -> Simulation a
Simulation forall a b. (a -> b) -> a -> b
$ \Run
r ->
  do let g :: Generator
g = Run -> Generator
runGenerator Run
r
     Int
sequenceNo <- Generator -> IO Int
generateSequenceNo Generator
g
     IORef (Maybe ProcessId)
assemblingTransact <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
     IORef Int
assemblingCounter  <- forall a. a -> IO (IORef a)
newIORef Int
0
     StrategyQueue (TransactQueueStrategy FCFS) ProcessId
gatheringTransacts <- forall a. Run -> Simulation a -> IO a
invokeSimulation Run
r forall a b. (a -> b) -> a -> b
$ forall s i. QueueStrategy s => s -> Simulation (StrategyQueue s i)
newStrategyQueue (forall s. s -> TransactQueueStrategy s
TransactQueueStrategy FCFS
FCFS)
     IORef Int
gatheringCounter   <- forall a. a -> IO (IORef a)
newIORef Int
0
     forall (m :: * -> *) a. Monad m => a -> m a
return AssemblySet { assemblySetSequenceNo :: Int
assemblySetSequenceNo         = Int
sequenceNo,
                          assemblySetAssemblingTransact :: IORef (Maybe ProcessId)
assemblySetAssemblingTransact = IORef (Maybe ProcessId)
assemblingTransact,
                          assemblySetAssemblingCounter :: IORef Int
assemblySetAssemblingCounter  = IORef Int
assemblingCounter,
                          assemblySetGatheringTransacts :: StrategyQueue (TransactQueueStrategy FCFS) ProcessId
assemblySetGatheringTransacts = StrategyQueue (TransactQueueStrategy FCFS) ProcessId
gatheringTransacts,
                          assemblySetGatheringCounter :: IORef Int
assemblySetGatheringCounter   = IORef Int
gatheringCounter
                        }

-- | Assemble the transact by the specified number.
assembleTransact :: Transact a -> Int -> Process ()
assembleTransact :: forall a. Transact a -> Int -> Process ()
assembleTransact Transact a
t Int
n =
  do (AssemblySet
s, Int
a) <-
       forall (m :: * -> *) a. EventLift m => Event a -> m a
liftEvent forall a b. (a -> b) -> a -> b
$
       do AssemblySet
s <- forall a. Transact a -> Event AssemblySet
transactAssemblySet Transact a
t
          Int
a <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (AssemblySet -> IORef Int
assemblySetAssemblingCounter AssemblySet
s)
          forall (m :: * -> *) a. Monad m => a -> m a
return (AssemblySet
s, Int
a)
     if Int
a forall a. Eq a => a -> a -> Bool
== Int
0
       then do let n' :: Int
n' = Int
n forall a. Num a => a -> a -> a
- Int
1
               forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n' forall a. Ord a => a -> a -> Bool
< Int
0) forall a b. (a -> b) -> a -> b
$
                 forall e a. Exception e => e -> Process a
throwProcess forall a b. (a -> b) -> a -> b
$
                 String -> SimulationRetry
SimulationRetry
                 String
"The number of transacts must be positive: assembleTransact"
               if Int
n' forall a. Eq a => a -> a -> Bool
== Int
0
                 then forall (m :: * -> *) a. Monad m => a -> m a
return ()
                 else do forall (m :: * -> *) a. EventLift m => Event a -> m a
liftEvent forall a b. (a -> b) -> a -> b
$
                           do ProcessId
pid <- forall a. Transact a -> Event ProcessId
requireTransactProcessId Transact a
t
                              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef (AssemblySet -> IORef (Maybe ProcessId)
assemblySetAssemblingTransact AssemblySet
s) (forall a. a -> Maybe a
Just ProcessId
pid)
                              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef (AssemblySet -> IORef Int
assemblySetAssemblingCounter AssemblySet
s) forall a b. (a -> b) -> a -> b
$! Int
n'
                         Process ()
passivateProcess
       else do let a' :: Int
a' = Int
a forall a. Num a => a -> a -> a
- Int
1
               if Int
a' forall a. Eq a => a -> a -> Bool
== Int
0
                 then do forall (m :: * -> *) a. EventLift m => Event a -> m a
liftEvent forall a b. (a -> b) -> a -> b
$
                           do Just ProcessId
pid <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (AssemblySet -> IORef (Maybe ProcessId)
assemblySetAssemblingTransact AssemblySet
s)
                              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef (AssemblySet -> IORef (Maybe ProcessId)
assemblySetAssemblingTransact AssemblySet
s) forall a. Maybe a
Nothing
                              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef (AssemblySet -> IORef Int
assemblySetAssemblingCounter AssemblySet
s) forall a b. (a -> b) -> a -> b
$! Int
a'
                              ProcessId -> Event ()
reactivateProcessImmediately ProcessId
pid
                         forall a. Process a
cancelProcess
                 else do forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef (AssemblySet -> IORef Int
assemblySetAssemblingCounter AssemblySet
s) forall a b. (a -> b) -> a -> b
$! Int
a'
                         forall a. Process a
cancelProcess

-- | Gather the transacts by the specified number.
gatherTransacts :: Transact a -> Int -> Process ()
gatherTransacts :: forall a. Transact a -> Int -> Process ()
gatherTransacts Transact a
t Int
n =
  do (AssemblySet
s, Int
a) <-
       forall (m :: * -> *) a. EventLift m => Event a -> m a
liftEvent forall a b. (a -> b) -> a -> b
$
       do AssemblySet
s <- forall a. Transact a -> Event AssemblySet
transactAssemblySet Transact a
t
          Int
a <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (AssemblySet -> IORef Int
assemblySetGatheringCounter AssemblySet
s)
          forall (m :: * -> *) a. Monad m => a -> m a
return (AssemblySet
s, Int
a)
     if Int
a forall a. Eq a => a -> a -> Bool
== Int
0
       then do let n' :: Int
n' = Int
n forall a. Num a => a -> a -> a
- Int
1
               forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n' forall a. Ord a => a -> a -> Bool
< Int
0) forall a b. (a -> b) -> a -> b
$
                 forall e a. Exception e => e -> Process a
throwProcess forall a b. (a -> b) -> a -> b
$
                 String -> SimulationRetry
SimulationRetry
                 String
"The number of transacts must be positive: gatherTransacts"
               if Int
n' forall a. Eq a => a -> a -> Bool
== Int
0
                 then forall (m :: * -> *) a. Monad m => a -> m a
return ()
                 else do forall (m :: * -> *) a. EventLift m => Event a -> m a
liftEvent forall a b. (a -> b) -> a -> b
$
                           do ProcessId
pid <- forall a. Transact a -> Event ProcessId
requireTransactProcessId Transact a
t
                              forall s p i.
PriorityQueueStrategy s p =>
StrategyQueue s i -> p -> i -> Event ()
strategyEnqueueWithPriority
                                (AssemblySet -> StrategyQueue (TransactQueueStrategy FCFS) ProcessId
assemblySetGatheringTransacts AssemblySet
s)
                                (forall a. Transact a -> Int
transactPriority Transact a
t)
                                ProcessId
pid
                              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef (AssemblySet -> IORef Int
assemblySetGatheringCounter AssemblySet
s) forall a b. (a -> b) -> a -> b
$! Int
n'
                         Process ()
passivateProcess
       else do let a' :: Int
a' = Int
a forall a. Num a => a -> a -> a
- Int
1
               forall (m :: * -> *) a. EventLift m => Event a -> m a
liftEvent forall a b. (a -> b) -> a -> b
$
                 do ProcessId
pid <- forall a. Transact a -> Event ProcessId
requireTransactProcessId Transact a
t
                    forall s p i.
PriorityQueueStrategy s p =>
StrategyQueue s i -> p -> i -> Event ()
strategyEnqueueWithPriority
                      (AssemblySet -> StrategyQueue (TransactQueueStrategy FCFS) ProcessId
assemblySetGatheringTransacts AssemblySet
s)
                      (forall a. Transact a -> Int
transactPriority Transact a
t)
                      ProcessId
pid
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef (AssemblySet -> IORef Int
assemblySetGatheringCounter AssemblySet
s) forall a b. (a -> b) -> a -> b
$! Int
a'
               if Int
a' forall a. Eq a => a -> a -> Bool
== Int
0
                 then Event () -> Process ()
passivateProcessBefore forall a b. (a -> b) -> a -> b
$
                      forall (m :: * -> *) a. EventLift m => Event a -> m a
liftEvent forall a b. (a -> b) -> a -> b
$
                      do let loop :: [ProcessId] -> Event [ProcessId]
loop [ProcessId]
acc =
                               do Bool
f <- forall s i. QueueStrategy s => StrategyQueue s i -> Event Bool
strategyQueueNull (AssemblySet -> StrategyQueue (TransactQueueStrategy FCFS) ProcessId
assemblySetGatheringTransacts AssemblySet
s)
                                  if Bool
f
                                    then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [ProcessId]
acc)
                                    else do ProcessId
x <- forall s i. DequeueStrategy s => StrategyQueue s i -> Event i
strategyDequeue (AssemblySet -> StrategyQueue (TransactQueueStrategy FCFS) ProcessId
assemblySetGatheringTransacts AssemblySet
s)
                                            [ProcessId] -> Event [ProcessId]
loop (ProcessId
xforall a. a -> [a] -> [a]
: [ProcessId]
acc)
                             act :: [ProcessId] -> Event ()
act [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
                             act (ProcessId
pid: [ProcessId]
pids') =
                               do ProcessId -> Event ()
reactivateProcessImmediately ProcessId
pid
                                  Event () -> Event ()
yieldEvent forall a b. (a -> b) -> a -> b
$ [ProcessId] -> Event ()
act [ProcessId]
pids'
                         [ProcessId]
pids <- [ProcessId] -> Event [ProcessId]
loop []
                         [ProcessId] -> Event ()
act [ProcessId]
pids
                 else Process ()
passivateProcess

-- | Test whether another transact is assembled for the corresponding assembly set.
transactAssembling :: Transact a -> Event Bool
transactAssembling :: forall a. Transact a -> Event Bool
transactAssembling Transact a
t =
  do AssemblySet
s <- forall a. Transact a -> Event AssemblySet
transactAssemblySet Transact a
t
     Int
a <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (AssemblySet -> IORef Int
assemblySetAssemblingCounter AssemblySet
s)
     forall (m :: * -> *) a. Monad m => a -> m a
return (Int
a forall a. Ord a => a -> a -> Bool
> Int
0)

-- | Test whether the transacts are gathered for the corresponding assembly set.
transactGathering :: Transact a -> Event Bool
transactGathering :: forall a. Transact a -> Event Bool
transactGathering Transact a
t =
  do AssemblySet
s <- forall a. Transact a -> Event AssemblySet
transactAssemblySet Transact a
t
     Int
a <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (AssemblySet -> IORef Int
assemblySetGatheringCounter AssemblySet
s)
     forall (m :: * -> *) a. Monad m => a -> m a
return (Int
a forall a. Ord a => a -> a -> Bool
> Int
0)