-- |
-- Module     : Simulation.Aivika.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.GPSS.MatchChain
       (MatchChain,
        newMatchChain,
        matchTransact,
        transactMatching,
        transactMatchingChanged,
        transactMatchingChangedByTransact_,
        transactMatchingChangedByAssemblySet_) where

import Data.IORef

import Control.Monad
import Control.Monad.Trans

import qualified Data.HashMap.Lazy as HM

import Simulation.Aivika
import Simulation.Aivika.GPSS.Transact
import Simulation.Aivika.GPSS.AssemblySet

-- | Represents a Match Chain.
data MatchChain =
  MatchChain { MatchChain -> IORef (HashMap AssemblySet ProcessId)
matchChainMap :: IORef (HM.HashMap AssemblySet ProcessId),
               MatchChain -> SignalSource AssemblySet
matchChainSource :: SignalSource AssemblySet
             }

-- | Create a new Match Chain.
newMatchChain :: Simulation MatchChain
newMatchChain :: Simulation MatchChain
newMatchChain =
  do IORef (HashMap AssemblySet ProcessId)
map <- IO (IORef (HashMap AssemblySet ProcessId))
-> Simulation (IORef (HashMap AssemblySet ProcessId))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (HashMap AssemblySet ProcessId))
 -> Simulation (IORef (HashMap AssemblySet ProcessId)))
-> IO (IORef (HashMap AssemblySet ProcessId))
-> Simulation (IORef (HashMap AssemblySet ProcessId))
forall a b. (a -> b) -> a -> b
$ HashMap AssemblySet ProcessId
-> IO (IORef (HashMap AssemblySet ProcessId))
forall a. a -> IO (IORef a)
newIORef HashMap AssemblySet ProcessId
forall k v. HashMap k v
HM.empty
     SignalSource AssemblySet
src <- Simulation (SignalSource AssemblySet)
forall a. Simulation (SignalSource a)
newSignalSource
     MatchChain -> Simulation MatchChain
forall (m :: * -> *) a. Monad m => a -> m a
return MatchChain :: IORef (HashMap AssemblySet ProcessId)
-> SignalSource AssemblySet -> MatchChain
MatchChain { matchChainMap :: IORef (HashMap AssemblySet ProcessId)
matchChainMap = IORef (HashMap AssemblySet ProcessId)
map,
                         matchChainSource :: SignalSource AssemblySet
matchChainSource = SignalSource AssemblySet
src
                       }

-- | Match the transact.
matchTransact :: MatchChain -> Transact a -> Process ()
matchTransact :: MatchChain -> Transact a -> Process ()
matchTransact MatchChain
chain Transact a
t =
  do (HashMap AssemblySet ProcessId
map, AssemblySet
set) <-
       Event (HashMap AssemblySet ProcessId, AssemblySet)
-> Process (HashMap AssemblySet ProcessId, AssemblySet)
forall (m :: * -> *) a. EventLift m => Event a -> m a
liftEvent (Event (HashMap AssemblySet ProcessId, AssemblySet)
 -> Process (HashMap AssemblySet ProcessId, AssemblySet))
-> Event (HashMap AssemblySet ProcessId, AssemblySet)
-> Process (HashMap AssemblySet ProcessId, AssemblySet)
forall a b. (a -> b) -> a -> b
$
       do HashMap AssemblySet ProcessId
map <- IO (HashMap AssemblySet ProcessId)
-> Event (HashMap AssemblySet ProcessId)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HashMap AssemblySet ProcessId)
 -> Event (HashMap AssemblySet ProcessId))
-> IO (HashMap AssemblySet ProcessId)
-> Event (HashMap AssemblySet ProcessId)
forall a b. (a -> b) -> a -> b
$ IORef (HashMap AssemblySet ProcessId)
-> IO (HashMap AssemblySet ProcessId)
forall a. IORef a -> IO a
readIORef (MatchChain -> IORef (HashMap AssemblySet ProcessId)
matchChainMap MatchChain
chain)
          AssemblySet
set <- Transact a -> Event AssemblySet
forall a. Transact a -> Event AssemblySet
transactAssemblySet Transact a
t
          (HashMap AssemblySet ProcessId, AssemblySet)
-> Event (HashMap AssemblySet ProcessId, AssemblySet)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap AssemblySet ProcessId
map, AssemblySet
set)
     case AssemblySet -> HashMap AssemblySet ProcessId -> Maybe ProcessId
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup AssemblySet
set HashMap AssemblySet ProcessId
map of
       Just ProcessId
pid ->
         Event () -> Process ()
forall (m :: * -> *) a. EventLift m => Event a -> m a
liftEvent (Event () -> Process ()) -> Event () -> Process ()
forall a b. (a -> b) -> a -> b
$
           do IO () -> Event ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Event ()) -> IO () -> Event ()
forall a b. (a -> b) -> a -> b
$ IORef (HashMap AssemblySet ProcessId)
-> (HashMap AssemblySet ProcessId -> HashMap AssemblySet ProcessId)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (MatchChain -> IORef (HashMap AssemblySet ProcessId)
matchChainMap MatchChain
chain) ((HashMap AssemblySet ProcessId -> HashMap AssemblySet ProcessId)
 -> IO ())
-> (HashMap AssemblySet ProcessId -> HashMap AssemblySet ProcessId)
-> IO ()
forall a b. (a -> b) -> a -> b
$
                AssemblySet
-> HashMap AssemblySet ProcessId -> HashMap AssemblySet ProcessId
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete AssemblySet
set
              Event () -> Event ()
yieldEvent (Event () -> Event ()) -> Event () -> Event ()
forall a b. (a -> b) -> a -> b
$
                SignalSource AssemblySet -> AssemblySet -> Event ()
forall a. SignalSource a -> a -> Event ()
triggerSignal (MatchChain -> SignalSource AssemblySet
matchChainSource MatchChain
chain) AssemblySet
set
              ProcessId -> Event ()
reactivateProcess ProcessId
pid
       Maybe ProcessId
Nothing ->
         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 (HashMap AssemblySet ProcessId)
-> (HashMap AssemblySet ProcessId -> HashMap AssemblySet ProcessId)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (MatchChain -> IORef (HashMap AssemblySet ProcessId)
matchChainMap MatchChain
chain) ((HashMap AssemblySet ProcessId -> HashMap AssemblySet ProcessId)
 -> IO ())
-> (HashMap AssemblySet ProcessId -> HashMap AssemblySet ProcessId)
-> IO ()
forall a b. (a -> b) -> a -> b
$
                   AssemblySet
-> ProcessId
-> HashMap AssemblySet ProcessId
-> HashMap AssemblySet ProcessId
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert AssemblySet
set ProcessId
pid
                 Event () -> Event ()
yieldEvent (Event () -> Event ()) -> Event () -> Event ()
forall a b. (a -> b) -> a -> b
$
                   SignalSource AssemblySet -> AssemblySet -> Event ()
forall a. SignalSource a -> a -> Event ()
triggerSignal (MatchChain -> SignalSource AssemblySet
matchChainSource MatchChain
chain) AssemblySet
set
            Process ()
passivateProcess

-- | Test whether there is a matching transact.
transactMatching :: MatchChain -> AssemblySet -> Event Bool
transactMatching :: MatchChain -> AssemblySet -> Event Bool
transactMatching MatchChain
chain AssemblySet
set =
  do HashMap AssemblySet ProcessId
map <- IO (HashMap AssemblySet ProcessId)
-> Event (HashMap AssemblySet ProcessId)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HashMap AssemblySet ProcessId)
 -> Event (HashMap AssemblySet ProcessId))
-> IO (HashMap AssemblySet ProcessId)
-> Event (HashMap AssemblySet ProcessId)
forall a b. (a -> b) -> a -> b
$ IORef (HashMap AssemblySet ProcessId)
-> IO (HashMap AssemblySet ProcessId)
forall a. IORef a -> IO a
readIORef (MatchChain -> IORef (HashMap AssemblySet ProcessId)
matchChainMap MatchChain
chain)
     Bool -> Event Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (AssemblySet -> HashMap AssemblySet ProcessId -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HM.member AssemblySet
set HashMap AssemblySet ProcessId
map)

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

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

-- | Signal each time the 'transactMatching' flag changes.
transactMatchingChanged :: MatchChain -> Signal AssemblySet
transactMatchingChanged :: MatchChain -> Signal AssemblySet
transactMatchingChanged MatchChain
chain =
  SignalSource AssemblySet -> Signal AssemblySet
forall a. SignalSource a -> Signal a
publishSignal (MatchChain -> SignalSource AssemblySet
matchChainSource MatchChain
chain)