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

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

import Control.Monad
import Control.Monad.Trans

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

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

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

instance MonadDES m => Eq (AssemblySet m) where

  {-# INLINABLE (==) #-}
  AssemblySet m
x == :: AssemblySet m -> AssemblySet m -> Bool
== AssemblySet m
y = (forall (m :: * -> *). AssemblySet m -> Ref m (Maybe (ProcessId m))
assemblySetAssemblingTransact AssemblySet m
x) forall a. Eq a => a -> a -> Bool
== (forall (m :: * -> *). AssemblySet m -> Ref m (Maybe (ProcessId m))
assemblySetAssemblingTransact AssemblySet m
y)

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

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

-- | Assemble the transact by the specified number.
assembleTransact :: MonadDES m => Transact m a -> Int -> Process m ()
{-# INLINABLE assembleTransact #-}
assembleTransact :: forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Int -> Process m ()
assembleTransact Transact m a
t Int
n =
  do (AssemblySet m
s, Int
a) <-
       forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$
       do AssemblySet m
s <- forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Event m (AssemblySet m)
transactAssemblySet Transact m a
t
          Int
a <- forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *). AssemblySet m -> Ref m Int
assemblySetAssemblingCounter AssemblySet m
s)
          forall (m :: * -> *) a. Monad m => a -> m a
return (AssemblySet m
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 (m :: * -> *) e a.
(MonadDES m, Exception e) =>
e -> Process m 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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$
                           do ProcessId m
pid <- forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Event m (ProcessId m)
requireTransactProcessId Transact m a
t
                              forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *). AssemblySet m -> Ref m (Maybe (ProcessId m))
assemblySetAssemblingTransact AssemblySet m
s) (forall a. a -> Maybe a
Just ProcessId m
pid)
                              forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *). AssemblySet m -> Ref m Int
assemblySetAssemblingCounter AssemblySet m
s) forall a b. (a -> b) -> a -> b
$! Int
n'
                         forall (m :: * -> *). MonadDES m => Process m ()
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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$
                           do Just ProcessId m
pid <- forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *). AssemblySet m -> Ref m (Maybe (ProcessId m))
assemblySetAssemblingTransact AssemblySet m
s)
                              forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *). AssemblySet m -> Ref m (Maybe (ProcessId m))
assemblySetAssemblingTransact AssemblySet m
s) forall a. Maybe a
Nothing
                              forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *). AssemblySet m -> Ref m Int
assemblySetAssemblingCounter AssemblySet m
s) forall a b. (a -> b) -> a -> b
$! Int
a'
                              forall (m :: * -> *). MonadDES m => ProcessId m -> Event m ()
reactivateProcessImmediately ProcessId m
pid
                         forall (m :: * -> *) a. MonadDES m => Process m a
cancelProcess
                 else do forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *). AssemblySet m -> Ref m Int
assemblySetAssemblingCounter AssemblySet m
s) forall a b. (a -> b) -> a -> b
$! Int
a'
                         forall (m :: * -> *) a. MonadDES m => Process m a
cancelProcess

-- | Gather the transacts by the specified number.
gatherTransacts :: MonadDES m => Transact m a -> Int -> Process m ()
{-# INLINABLE gatherTransacts #-}
gatherTransacts :: forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Int -> Process m ()
gatherTransacts Transact m a
t Int
n =
  do (AssemblySet m
s, Int
a) <-
       forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$
       do AssemblySet m
s <- forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Event m (AssemblySet m)
transactAssemblySet Transact m a
t
          Int
a <- forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *). AssemblySet m -> Ref m Int
assemblySetGatheringCounter AssemblySet m
s)
          forall (m :: * -> *) a. Monad m => a -> m a
return (AssemblySet m
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 (m :: * -> *) e a.
(MonadDES m, Exception e) =>
e -> Process m 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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$
                           do ProcessId m
pid <- forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Event m (ProcessId m)
requireTransactProcessId Transact m a
t
                              forall (m :: * -> *) s p a.
PriorityQueueStrategy m s p =>
StrategyQueue m s a -> p -> a -> Event m ()
strategyEnqueueWithPriority
                                (forall (m :: * -> *).
AssemblySet m
-> StrategyQueue m (TransactQueueStrategy FCFS) (ProcessId m)
assemblySetGatheringTransacts AssemblySet m
s)
                                (forall (m :: * -> *) a. Transact m a -> Int
transactPriority Transact m a
t)
                                ProcessId m
pid
                              forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *). AssemblySet m -> Ref m Int
assemblySetGatheringCounter AssemblySet m
s) forall a b. (a -> b) -> a -> b
$! Int
n'
                         forall (m :: * -> *). MonadDES m => Process m ()
passivateProcess
       else do let a' :: Int
a' = Int
a forall a. Num a => a -> a -> a
- Int
1
               forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$
                 do ProcessId m
pid <- forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Event m (ProcessId m)
requireTransactProcessId Transact m a
t
                    forall (m :: * -> *) s p a.
PriorityQueueStrategy m s p =>
StrategyQueue m s a -> p -> a -> Event m ()
strategyEnqueueWithPriority
                      (forall (m :: * -> *).
AssemblySet m
-> StrategyQueue m (TransactQueueStrategy FCFS) (ProcessId m)
assemblySetGatheringTransacts AssemblySet m
s)
                      (forall (m :: * -> *) a. Transact m a -> Int
transactPriority Transact m a
t)
                      ProcessId m
pid
                    forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *). AssemblySet m -> Ref m Int
assemblySetGatheringCounter AssemblySet m
s) forall a b. (a -> b) -> a -> b
$! Int
a'
               if Int
a' forall a. Eq a => a -> a -> Bool
== Int
0
                 then forall (m :: * -> *). MonadDES m => Event m () -> Process m ()
passivateProcessBefore forall a b. (a -> b) -> a -> b
$
                      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$
                      do let loop :: [ProcessId m] -> Event m [ProcessId m]
loop [ProcessId m]
acc =
                               do Bool
f <- forall (m :: * -> *) s a.
QueueStrategy m s =>
StrategyQueue m s a -> Event m Bool
strategyQueueNull (forall (m :: * -> *).
AssemblySet m
-> StrategyQueue m (TransactQueueStrategy FCFS) (ProcessId m)
assemblySetGatheringTransacts AssemblySet m
s)
                                  if Bool
f
                                    then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [ProcessId m]
acc)
                                    else do ProcessId m
x <- forall (m :: * -> *) s a.
DequeueStrategy m s =>
StrategyQueue m s a -> Event m a
strategyDequeue (forall (m :: * -> *).
AssemblySet m
-> StrategyQueue m (TransactQueueStrategy FCFS) (ProcessId m)
assemblySetGatheringTransacts AssemblySet m
s)
                                            [ProcessId m] -> Event m [ProcessId m]
loop (ProcessId m
xforall a. a -> [a] -> [a]
: [ProcessId m]
acc)
                             act :: [ProcessId m] -> Event m ()
act [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
                             act (ProcessId m
pid: [ProcessId m]
pids') =
                               do forall (m :: * -> *). MonadDES m => ProcessId m -> Event m ()
reactivateProcessImmediately ProcessId m
pid
                                  forall (m :: * -> *). MonadDES m => Event m () -> Event m ()
yieldEvent forall a b. (a -> b) -> a -> b
$ [ProcessId m] -> Event m ()
act [ProcessId m]
pids'
                         [ProcessId m]
pids <- [ProcessId m] -> Event m [ProcessId m]
loop []
                         forall {m :: * -> *}. MonadDES m => [ProcessId m] -> Event m ()
act [ProcessId m]
pids
                 else forall (m :: * -> *). MonadDES m => Process m ()
passivateProcess

-- | Test whether another transact is assembled for the corresponding assembly set.
transactAssembling :: MonadDES m => Transact m a -> Event m Bool
{-# INLINABLE transactAssembling #-}
transactAssembling :: forall (m :: * -> *) a. MonadDES m => Transact m a -> Event m Bool
transactAssembling Transact m a
t =
  do AssemblySet m
s <- forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Event m (AssemblySet m)
transactAssemblySet Transact m a
t
     Int
a <- forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *). AssemblySet m -> Ref m Int
assemblySetAssemblingCounter AssemblySet m
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 :: MonadDES m => Transact m a -> Event m Bool
{-# INLINABLE transactGathering #-}
transactGathering :: forall (m :: * -> *) a. MonadDES m => Transact m a -> Event m Bool
transactGathering Transact m a
t =
  do AssemblySet m
s <- forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Event m (AssemblySet m)
transactAssemblySet Transact m a
t
     Int
a <- forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *). AssemblySet m -> Ref m Int
assemblySetGatheringCounter AssemblySet m
s)
     forall (m :: * -> *) a. Monad m => a -> m a
return (Int
a forall a. Ord a => a -> a -> Bool
> Int
0)