-- |
-- 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) IORef (Maybe ProcessId) -> IORef (Maybe ProcessId) -> Bool
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 = Int -> Int -> Int
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 =
  (Run -> IO AssemblySet) -> Simulation AssemblySet
forall a. (Run -> IO a) -> Simulation a
Simulation ((Run -> IO AssemblySet) -> Simulation AssemblySet)
-> (Run -> IO AssemblySet) -> Simulation AssemblySet
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 <- Maybe ProcessId -> IO (IORef (Maybe ProcessId))
forall a. a -> IO (IORef a)
newIORef Maybe ProcessId
forall a. Maybe a
Nothing
     IORef Int
assemblingCounter  <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
     StrategyQueue (TransactQueueStrategy FCFS) ProcessId
gatheringTransacts <- Run
-> Simulation
     (StrategyQueue (TransactQueueStrategy FCFS) ProcessId)
-> IO (StrategyQueue (TransactQueueStrategy FCFS) ProcessId)
forall a. Run -> Simulation a -> IO a
invokeSimulation Run
r (Simulation (StrategyQueue (TransactQueueStrategy FCFS) ProcessId)
 -> IO (StrategyQueue (TransactQueueStrategy FCFS) ProcessId))
-> Simulation
     (StrategyQueue (TransactQueueStrategy FCFS) ProcessId)
-> IO (StrategyQueue (TransactQueueStrategy FCFS) ProcessId)
forall a b. (a -> b) -> a -> b
$ TransactQueueStrategy FCFS
-> Simulation
     (StrategyQueue (TransactQueueStrategy FCFS) ProcessId)
forall s i. QueueStrategy s => s -> Simulation (StrategyQueue s i)
newStrategyQueue (FCFS -> TransactQueueStrategy FCFS
forall s. s -> TransactQueueStrategy s
TransactQueueStrategy FCFS
FCFS)
     IORef Int
gatheringCounter   <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
     AssemblySet -> IO AssemblySet
forall (m :: * -> *) a. Monad m => a -> m a
return AssemblySet :: Int
-> IORef (Maybe ProcessId)
-> IORef Int
-> StrategyQueue (TransactQueueStrategy FCFS) ProcessId
-> IORef Int
-> AssemblySet
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 :: Transact a -> Int -> Process ()
assembleTransact Transact a
t Int
n =
  do (AssemblySet
s, Int
a) <-
       Event (AssemblySet, Int) -> Process (AssemblySet, Int)
forall (m :: * -> *) a. EventLift m => Event a -> m a
liftEvent (Event (AssemblySet, Int) -> Process (AssemblySet, Int))
-> Event (AssemblySet, Int) -> Process (AssemblySet, Int)
forall a b. (a -> b) -> a -> b
$
       do AssemblySet
s <- Transact a -> Event AssemblySet
forall a. Transact a -> Event AssemblySet
transactAssemblySet Transact a
t
          Int
a <- IO Int -> Event Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> Event Int) -> IO Int -> Event Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (AssemblySet -> IORef Int
assemblySetAssemblingCounter AssemblySet
s)
          (AssemblySet, Int) -> Event (AssemblySet, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (AssemblySet
s, Int
a)
     if Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
       then do let n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
               Bool -> Process () -> Process ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$
                 SimulationRetry -> Process ()
forall e a. Exception e => e -> Process a
throwProcess (SimulationRetry -> Process ()) -> SimulationRetry -> Process ()
forall a b. (a -> b) -> a -> b
$
                 String -> SimulationRetry
SimulationRetry
                 String
"The number of transacts must be positive: assembleTransact"
               if Int
n' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                 then () -> Process ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                 else do Event () -> Process ()
forall (m :: * -> *) a. EventLift m => Event a -> m a
liftEvent (Event () -> Process ()) -> Event () -> Process ()
forall a b. (a -> b) -> a -> b
$
                           do ProcessId
pid <- Transact a -> Event ProcessId
forall a. Transact a -> Event ProcessId
requireTransactProcessId Transact a
t
                              IO () -> Event ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Event ()) -> IO () -> Event ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe ProcessId) -> Maybe ProcessId -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (AssemblySet -> IORef (Maybe ProcessId)
assemblySetAssemblingTransact AssemblySet
s) (ProcessId -> Maybe ProcessId
forall a. a -> Maybe a
Just ProcessId
pid)
                              IO () -> Event ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Event ()) -> IO () -> Event ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (AssemblySet -> IORef Int
assemblySetAssemblingCounter AssemblySet
s) (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$! Int
n'
                         Process ()
passivateProcess
       else do let a' :: Int
a' = Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
               if Int
a' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                 then do Event () -> Process ()
forall (m :: * -> *) a. EventLift m => Event a -> m a
liftEvent (Event () -> Process ()) -> Event () -> Process ()
forall a b. (a -> b) -> a -> b
$
                           do Just ProcessId
pid <- IO (Maybe ProcessId) -> Event (Maybe ProcessId)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ProcessId) -> Event (Maybe ProcessId))
-> IO (Maybe ProcessId) -> Event (Maybe ProcessId)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe ProcessId) -> IO (Maybe ProcessId)
forall a. IORef a -> IO a
readIORef (AssemblySet -> IORef (Maybe ProcessId)
assemblySetAssemblingTransact AssemblySet
s)
                              IO () -> Event ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Event ()) -> IO () -> Event ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe ProcessId) -> Maybe ProcessId -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (AssemblySet -> IORef (Maybe ProcessId)
assemblySetAssemblingTransact AssemblySet
s) Maybe ProcessId
forall a. Maybe a
Nothing
                              IO () -> Event ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Event ()) -> IO () -> Event ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (AssemblySet -> IORef Int
assemblySetAssemblingCounter AssemblySet
s) (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$! Int
a'
                              ProcessId -> Event ()
reactivateProcessImmediately ProcessId
pid
                         Process ()
forall a. Process a
cancelProcess
                 else do IO () -> Process ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (AssemblySet -> IORef Int
assemblySetAssemblingCounter AssemblySet
s) (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$! Int
a'
                         Process ()
forall a. Process a
cancelProcess

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