-- |
-- Module     : Simulation.Aivika.Trans.GPSS.MatchChain
-- 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 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 { MatchChain m -> Ref m (HashMap (AssemblySet m) (ProcessId m))
matchChainMap :: Ref m (HM.HashMap (AssemblySet m) (ProcessId m)),
               MatchChain m -> SignalSource m (AssemblySet m)
matchChainSource :: SignalSource m (AssemblySet m)
             }

-- | Create a new Match Chain.
newMatchChain :: MonadDES m => Simulation m (MatchChain m)
{-# INLINABLE newMatchChain #-}
newMatchChain :: Simulation m (MatchChain m)
newMatchChain =
  do Ref m (HashMap (AssemblySet m) (ProcessId m))
map <- HashMap (AssemblySet m) (ProcessId m)
-> Simulation m (Ref m (HashMap (AssemblySet m) (ProcessId m)))
forall (m :: * -> *) a. MonadDES m => a -> Simulation m (Ref m a)
newRef HashMap (AssemblySet m) (ProcessId m)
forall k v. HashMap k v
HM.empty
     SignalSource m (AssemblySet m)
src <- Simulation m (SignalSource m (AssemblySet m))
forall (m :: * -> *) a.
MonadDES m =>
Simulation m (SignalSource m a)
newSignalSource
     MatchChain m -> Simulation m (MatchChain m)
forall (m :: * -> *) a. Monad m => a -> m a
return MatchChain :: forall (m :: * -> *).
Ref m (HashMap (AssemblySet m) (ProcessId m))
-> SignalSource m (AssemblySet m) -> MatchChain m
MatchChain { matchChainMap :: Ref m (HashMap (AssemblySet m) (ProcessId m))
matchChainMap = Ref m (HashMap (AssemblySet m) (ProcessId m))
map,
                         matchChainSource :: SignalSource m (AssemblySet m)
matchChainSource = SignalSource m (AssemblySet m)
src
                       }

-- | Match the transact.
matchTransact :: MonadDES m => MatchChain m -> Transact m a -> Process m ()
{-# INLINABLE matchTransact #-}
matchTransact :: MatchChain m -> Transact m a -> Process m ()
matchTransact MatchChain m
chain Transact m a
t =
  do (HashMap (AssemblySet m) (ProcessId m)
map, AssemblySet m
set) <-
       Event m (HashMap (AssemblySet m) (ProcessId m), AssemblySet m)
-> Process m (HashMap (AssemblySet m) (ProcessId m), AssemblySet m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent (Event m (HashMap (AssemblySet m) (ProcessId m), AssemblySet m)
 -> Process
      m (HashMap (AssemblySet m) (ProcessId m), AssemblySet m))
-> Event m (HashMap (AssemblySet m) (ProcessId m), AssemblySet m)
-> Process m (HashMap (AssemblySet m) (ProcessId m), AssemblySet m)
forall a b. (a -> b) -> a -> b
$
       do HashMap (AssemblySet m) (ProcessId m)
map <- Ref m (HashMap (AssemblySet m) (ProcessId m))
-> Event m (HashMap (AssemblySet m) (ProcessId m))
forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (MatchChain m -> Ref m (HashMap (AssemblySet m) (ProcessId m))
forall (m :: * -> *).
MatchChain m -> Ref m (HashMap (AssemblySet m) (ProcessId m))
matchChainMap MatchChain m
chain)
          AssemblySet m
set <- Transact m a -> Event m (AssemblySet m)
forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Event m (AssemblySet m)
transactAssemblySet Transact m a
t
          (HashMap (AssemblySet m) (ProcessId m), AssemblySet m)
-> Event m (HashMap (AssemblySet m) (ProcessId m), AssemblySet m)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap (AssemblySet m) (ProcessId m)
map, AssemblySet m
set)
     case AssemblySet m
-> HashMap (AssemblySet m) (ProcessId m) -> Maybe (ProcessId m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup AssemblySet m
set HashMap (AssemblySet m) (ProcessId m)
map of
       Just ProcessId m
pid ->
         Event m () -> Process m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent (Event m () -> Process m ()) -> Event m () -> Process m ()
forall a b. (a -> b) -> a -> b
$
           do Ref m (HashMap (AssemblySet m) (ProcessId m))
-> (HashMap (AssemblySet m) (ProcessId m)
    -> HashMap (AssemblySet m) (ProcessId m))
-> Event m ()
forall (m :: * -> *) a.
MonadDES m =>
Ref m a -> (a -> a) -> Event m ()
modifyRef (MatchChain m -> Ref m (HashMap (AssemblySet m) (ProcessId m))
forall (m :: * -> *).
MatchChain m -> Ref m (HashMap (AssemblySet m) (ProcessId m))
matchChainMap MatchChain m
chain) ((HashMap (AssemblySet m) (ProcessId m)
  -> HashMap (AssemblySet m) (ProcessId m))
 -> Event m ())
-> (HashMap (AssemblySet m) (ProcessId m)
    -> HashMap (AssemblySet m) (ProcessId m))
-> Event m ()
forall a b. (a -> b) -> a -> b
$
                AssemblySet m
-> HashMap (AssemblySet m) (ProcessId m)
-> HashMap (AssemblySet m) (ProcessId m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete AssemblySet m
set
              Event m () -> Event m ()
forall (m :: * -> *). MonadDES m => Event m () -> Event m ()
yieldEvent (Event m () -> Event m ()) -> Event m () -> Event m ()
forall a b. (a -> b) -> a -> b
$
                SignalSource m (AssemblySet m) -> AssemblySet m -> Event m ()
forall (m :: * -> *) a. SignalSource m a -> a -> Event m ()
triggerSignal (MatchChain m -> SignalSource m (AssemblySet m)
forall (m :: * -> *).
MatchChain m -> SignalSource m (AssemblySet m)
matchChainSource MatchChain m
chain) AssemblySet m
set
              ProcessId m -> Event m ()
forall (m :: * -> *). MonadDES m => ProcessId m -> Event m ()
reactivateProcess ProcessId m
pid
       Maybe (ProcessId m)
Nothing ->
         do Event m () -> Process m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent (Event m () -> Process m ()) -> Event m () -> Process m ()
forall a b. (a -> b) -> a -> b
$
              do ProcessId m
pid <- Transact m a -> Event m (ProcessId m)
forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Event m (ProcessId m)
requireTransactProcessId Transact m a
t
                 Ref m (HashMap (AssemblySet m) (ProcessId m))
-> (HashMap (AssemblySet m) (ProcessId m)
    -> HashMap (AssemblySet m) (ProcessId m))
-> Event m ()
forall (m :: * -> *) a.
MonadDES m =>
Ref m a -> (a -> a) -> Event m ()
modifyRef (MatchChain m -> Ref m (HashMap (AssemblySet m) (ProcessId m))
forall (m :: * -> *).
MatchChain m -> Ref m (HashMap (AssemblySet m) (ProcessId m))
matchChainMap MatchChain m
chain) ((HashMap (AssemblySet m) (ProcessId m)
  -> HashMap (AssemblySet m) (ProcessId m))
 -> Event m ())
-> (HashMap (AssemblySet m) (ProcessId m)
    -> HashMap (AssemblySet m) (ProcessId m))
-> Event m ()
forall a b. (a -> b) -> a -> b
$
                   AssemblySet m
-> ProcessId m
-> HashMap (AssemblySet m) (ProcessId m)
-> HashMap (AssemblySet m) (ProcessId m)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert AssemblySet m
set ProcessId m
pid
                 Event m () -> Event m ()
forall (m :: * -> *). MonadDES m => Event m () -> Event m ()
yieldEvent (Event m () -> Event m ()) -> Event m () -> Event m ()
forall a b. (a -> b) -> a -> b
$
                   SignalSource m (AssemblySet m) -> AssemblySet m -> Event m ()
forall (m :: * -> *) a. SignalSource m a -> a -> Event m ()
triggerSignal (MatchChain m -> SignalSource m (AssemblySet m)
forall (m :: * -> *).
MatchChain m -> SignalSource m (AssemblySet m)
matchChainSource MatchChain m
chain) AssemblySet m
set
            Process m ()
forall (m :: * -> *). MonadDES m => Process m ()
passivateProcess

-- | Test whether there is a matching transact.
transactMatching :: MonadDES m => MatchChain m -> AssemblySet m -> Event m Bool
{-# INLINABLE transactMatching #-}
transactMatching :: MatchChain m -> AssemblySet m -> Event m Bool
transactMatching MatchChain m
chain AssemblySet m
set =
  do HashMap (AssemblySet m) (ProcessId m)
map <- Ref m (HashMap (AssemblySet m) (ProcessId m))
-> Event m (HashMap (AssemblySet m) (ProcessId m))
forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (MatchChain m -> Ref m (HashMap (AssemblySet m) (ProcessId m))
forall (m :: * -> *).
MatchChain m -> Ref m (HashMap (AssemblySet m) (ProcessId m))
matchChainMap MatchChain m
chain)
     Bool -> Event m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (AssemblySet m -> HashMap (AssemblySet m) (ProcessId m) -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HM.member AssemblySet m
set HashMap (AssemblySet m) (ProcessId m)
map)

-- | Signal each time the 'transactMatching' flag changes.
transactMatchingChangedByAssemblySet_ :: MonadDES m => MatchChain m -> AssemblySet m -> Signal m ()
{-# INLINABLE transactMatchingChangedByAssemblySet_ #-}
transactMatchingChangedByAssemblySet_ :: MatchChain m -> AssemblySet m -> Signal m ()
transactMatchingChangedByAssemblySet_ MatchChain m
chain AssemblySet m
set =
  (AssemblySet m -> ()) -> Signal m (AssemblySet m) -> Signal m ()
forall (m :: * -> *) a b.
MonadDES m =>
(a -> b) -> Signal m a -> Signal m b
mapSignal (() -> AssemblySet m -> ()
forall a b. a -> b -> a
const ()) (Signal m (AssemblySet m) -> Signal m ())
-> Signal m (AssemblySet m) -> Signal m ()
forall a b. (a -> b) -> a -> b
$
  (AssemblySet m -> Bool)
-> Signal m (AssemblySet m) -> Signal m (AssemblySet m)
forall (m :: * -> *) a.
MonadDES m =>
(a -> Bool) -> Signal m a -> Signal m a
filterSignal (AssemblySet m -> AssemblySet m -> Bool
forall a. Eq a => a -> a -> Bool
== AssemblySet m
set) (Signal m (AssemblySet m) -> Signal m (AssemblySet m))
-> Signal m (AssemblySet m) -> Signal m (AssemblySet m)
forall a b. (a -> b) -> a -> b
$
  MatchChain m -> Signal m (AssemblySet m)
forall (m :: * -> *).
MonadDES m =>
MatchChain m -> Signal m (AssemblySet m)
transactMatchingChanged MatchChain m
chain

-- | Signal each time the 'transactMatching' flag changes.
transactMatchingChangedByTransact_ :: MonadDES m => MatchChain m -> Transact m a -> Signal m ()
{-# INLINABLE transactMatchingChangedByTransact_ #-}
transactMatchingChangedByTransact_ :: MatchChain m -> Transact m a -> Signal m ()
transactMatchingChangedByTransact_ MatchChain m
chain Transact m a
t =
  (AssemblySet m -> ()) -> Signal m (AssemblySet m) -> Signal m ()
forall (m :: * -> *) a b.
MonadDES m =>
(a -> b) -> Signal m a -> Signal m b
mapSignal (() -> AssemblySet m -> ()
forall a b. a -> b -> a
const ()) (Signal m (AssemblySet m) -> Signal m ())
-> Signal m (AssemblySet m) -> Signal m ()
forall a b. (a -> b) -> a -> b
$
  (AssemblySet m -> Event m Bool)
-> Signal m (AssemblySet m) -> Signal m (AssemblySet m)
forall (m :: * -> *) a.
MonadDES m =>
(a -> Event m Bool) -> Signal m a -> Signal m a
filterSignalM AssemblySet m -> Event m Bool
pred (Signal m (AssemblySet m) -> Signal m (AssemblySet m))
-> Signal m (AssemblySet m) -> Signal m (AssemblySet m)
forall a b. (a -> b) -> a -> b
$
  MatchChain m -> Signal m (AssemblySet m)
forall (m :: * -> *).
MonadDES m =>
MatchChain m -> Signal m (AssemblySet m)
transactMatchingChanged MatchChain m
chain
    where pred :: AssemblySet m -> Event m Bool
pred AssemblySet m
set =
            do AssemblySet m
set' <- Transact m a -> Event m (AssemblySet m)
forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Event m (AssemblySet m)
transactAssemblySet Transact m a
t
               Bool -> Event m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (AssemblySet m
set AssemblySet m -> AssemblySet m -> Bool
forall a. Eq a => a -> a -> Bool
== AssemblySet m
set')

-- | Signal each time the 'transactMatching' flag changes.
transactMatchingChanged :: MonadDES m => MatchChain m -> Signal m (AssemblySet m)
{-# INLINABLE transactMatchingChanged #-}
transactMatchingChanged :: MatchChain m -> Signal m (AssemblySet m)
transactMatchingChanged MatchChain m
chain =
  SignalSource m (AssemblySet m) -> Signal m (AssemblySet m)
forall (m :: * -> *) a. SignalSource m a -> Signal m a
publishSignal (MatchChain m -> SignalSource m (AssemblySet m)
forall (m :: * -> *).
MatchChain m -> SignalSource m (AssemblySet m)
matchChainSource MatchChain m
chain)