{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}

-- |
-- Module     : Simulation.Aivika.Trans.GPSS.TransactQueueStrategy
-- 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 transact queue strategy.
--
module Simulation.Aivika.Trans.GPSS.TransactQueueStrategy
       (TransactQueueStrategy(..),
        transactStrategyQueueDeleteBy,
        transactStrategyQueueContainsBy) where

import Control.Monad
import Control.Monad.Trans

import Data.IORef
import qualified Data.IntMap as M

import Simulation.Aivika.Trans
import qualified Simulation.Aivika.Trans.DoubleLinkedList as DLL

-- | The transact queue strategy.
data TransactQueueStrategy s = TransactQueueStrategy s

-- | An implementation of the 'QueueStrategy' class.
instance MonadDES m => QueueStrategy m (TransactQueueStrategy s) where

  -- | A queue used by the 'TransactQueueStrategy' strategy.
  data StrategyQueue m (TransactQueueStrategy s) a =
    TransactStrategyQueue { forall (m :: * -> *) s a.
StrategyQueue m (TransactQueueStrategy s) a
-> TransactQueueStrategy s
transactStrategy :: TransactQueueStrategy s,
                            -- ^ the strategy itself
                            forall (m :: * -> *) s a.
StrategyQueue m (TransactQueueStrategy s) a
-> Ref m (IntMap (DoubleLinkedList m a))
transactStrategyQueue :: Ref m (M.IntMap (DLL.DoubleLinkedList m a))
                            -- ^ the transact queue
                          }

  {-# INLINABLE newStrategyQueue #-}
  newStrategyQueue :: forall a.
TransactQueueStrategy s
-> Simulation m (StrategyQueue m (TransactQueueStrategy s) a)
newStrategyQueue TransactQueueStrategy s
s =
    do Ref m (IntMap (DoubleLinkedList m a))
r <- forall (m :: * -> *) a. MonadDES m => a -> Simulation m (Ref m a)
newRef forall a. IntMap a
M.empty
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a.
TransactQueueStrategy s
-> Ref m (IntMap (DoubleLinkedList m a))
-> StrategyQueue m (TransactQueueStrategy s) a
TransactStrategyQueue TransactQueueStrategy s
s Ref m (IntMap (DoubleLinkedList m a))
r

  {-# INLINABLE strategyQueueNull #-}
  strategyQueueNull :: forall a.
StrategyQueue m (TransactQueueStrategy s) a -> Event m Bool
strategyQueueNull StrategyQueue m (TransactQueueStrategy s) a
q =
    do IntMap (DoubleLinkedList m a)
m <- forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) s a.
StrategyQueue m (TransactQueueStrategy s) a
-> Ref m (IntMap (DoubleLinkedList m a))
transactStrategyQueue StrategyQueue m (TransactQueueStrategy s) a
q)
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IntMap a -> Bool
M.null IntMap (DoubleLinkedList m a)
m

instance MonadDES m => DequeueStrategy m (TransactQueueStrategy FCFS) where

  {-# INLINABLE strategyDequeue #-}
  strategyDequeue :: forall a.
StrategyQueue m (TransactQueueStrategy FCFS) a -> Event m a
strategyDequeue StrategyQueue m (TransactQueueStrategy FCFS) a
q =
    do IntMap (DoubleLinkedList m a)
m <- forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) s a.
StrategyQueue m (TransactQueueStrategy s) a
-> Ref m (IntMap (DoubleLinkedList m a))
transactStrategyQueue StrategyQueue m (TransactQueueStrategy FCFS) a
q)
       let (Key
k, DoubleLinkedList m a
xs) = forall a. IntMap a -> (Key, a)
M.findMin IntMap (DoubleLinkedList m a)
m
       a
i <- forall (m :: * -> *) a.
MonadRef m =>
DoubleLinkedList m a -> Event m a
DLL.listFirst DoubleLinkedList m a
xs
       forall (m :: * -> *) a.
MonadRef m =>
DoubleLinkedList m a -> Event m ()
DLL.listRemoveFirst DoubleLinkedList m a
xs
       Bool
empty <- forall (m :: * -> *) a.
MonadRef m =>
DoubleLinkedList m a -> Event m Bool
DLL.listNull DoubleLinkedList m a
xs
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
empty forall a b. (a -> b) -> a -> b
$
         forall (m :: * -> *) a.
MonadDES m =>
Ref m a -> (a -> a) -> Event m ()
modifyRef (forall (m :: * -> *) s a.
StrategyQueue m (TransactQueueStrategy s) a
-> Ref m (IntMap (DoubleLinkedList m a))
transactStrategyQueue StrategyQueue m (TransactQueueStrategy FCFS) a
q) forall a b. (a -> b) -> a -> b
$
         forall a. Key -> IntMap a -> IntMap a
M.delete Key
k
       forall (m :: * -> *) a. Monad m => a -> m a
return a
i

instance MonadDES m => DequeueStrategy m (TransactQueueStrategy LCFS) where

  {-# INLINABLE strategyDequeue #-}
  strategyDequeue :: forall a.
StrategyQueue m (TransactQueueStrategy LCFS) a -> Event m a
strategyDequeue StrategyQueue m (TransactQueueStrategy LCFS) a
q =
    do IntMap (DoubleLinkedList m a)
m <- forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) s a.
StrategyQueue m (TransactQueueStrategy s) a
-> Ref m (IntMap (DoubleLinkedList m a))
transactStrategyQueue StrategyQueue m (TransactQueueStrategy LCFS) a
q)
       let (Key
k, DoubleLinkedList m a
xs) = forall a. IntMap a -> (Key, a)
M.findMin IntMap (DoubleLinkedList m a)
m
       a
i <- forall (m :: * -> *) a.
MonadRef m =>
DoubleLinkedList m a -> Event m a
DLL.listLast DoubleLinkedList m a
xs
       forall (m :: * -> *) a.
MonadRef m =>
DoubleLinkedList m a -> Event m ()
DLL.listRemoveLast DoubleLinkedList m a
xs
       Bool
empty <- forall (m :: * -> *) a.
MonadRef m =>
DoubleLinkedList m a -> Event m Bool
DLL.listNull DoubleLinkedList m a
xs
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
empty forall a b. (a -> b) -> a -> b
$
         forall (m :: * -> *) a.
MonadDES m =>
Ref m a -> (a -> a) -> Event m ()
modifyRef (forall (m :: * -> *) s a.
StrategyQueue m (TransactQueueStrategy s) a
-> Ref m (IntMap (DoubleLinkedList m a))
transactStrategyQueue StrategyQueue m (TransactQueueStrategy LCFS) a
q) forall a b. (a -> b) -> a -> b
$
         forall a. Key -> IntMap a -> IntMap a
M.delete Key
k
       forall (m :: * -> *) a. Monad m => a -> m a
return a
i

instance (MonadDES m, DequeueStrategy m (TransactQueueStrategy s)) => PriorityQueueStrategy m (TransactQueueStrategy s) Int where

  {-# INLINABLE strategyEnqueueWithPriority #-}
  strategyEnqueueWithPriority :: forall a.
StrategyQueue m (TransactQueueStrategy s) a
-> Key -> a -> Event m ()
strategyEnqueueWithPriority StrategyQueue m (TransactQueueStrategy s) a
q Key
priority a
i =
    do IntMap (DoubleLinkedList m a)
m <- forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) s a.
StrategyQueue m (TransactQueueStrategy s) a
-> Ref m (IntMap (DoubleLinkedList m a))
transactStrategyQueue StrategyQueue m (TransactQueueStrategy s) a
q)
       let k :: Key
k  = - Key
priority
           xs :: Maybe (DoubleLinkedList m a)
xs = forall a. Key -> IntMap a -> Maybe a
M.lookup Key
k IntMap (DoubleLinkedList m a)
m
       case Maybe (DoubleLinkedList m a)
xs of
         Maybe (DoubleLinkedList m a)
Nothing ->
           do DoubleLinkedList m a
xs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
SimulationLift t m =>
Simulation m a -> t m a
liftSimulation forall (m :: * -> *) a.
MonadRef m =>
Simulation m (DoubleLinkedList m a)
DLL.newList
              forall (m :: * -> *) a.
MonadRef m =>
DoubleLinkedList m a -> a -> Event m ()
DLL.listAddLast DoubleLinkedList m a
xs a
i
              forall (m :: * -> *) a.
MonadDES m =>
Ref m a -> (a -> a) -> Event m ()
modifyRef (forall (m :: * -> *) s a.
StrategyQueue m (TransactQueueStrategy s) a
-> Ref m (IntMap (DoubleLinkedList m a))
transactStrategyQueue StrategyQueue m (TransactQueueStrategy s) a
q) forall a b. (a -> b) -> a -> b
$
                forall a. Key -> a -> IntMap a -> IntMap a
M.insert Key
k DoubleLinkedList m a
xs
         Just DoubleLinkedList m a
xs ->
           forall (m :: * -> *) a.
MonadRef m =>
DoubleLinkedList m a -> a -> Event m ()
DLL.listAddLast DoubleLinkedList m a
xs a
i

instance MonadDES m => DeletingQueueStrategy m (TransactQueueStrategy FCFS) where

  {-# INLINABLE strategyQueueDeleteBy #-}
  strategyQueueDeleteBy :: forall a.
StrategyQueue m (TransactQueueStrategy FCFS) a
-> (a -> Bool) -> Event m (Maybe a)
strategyQueueDeleteBy StrategyQueue m (TransactQueueStrategy FCFS) a
q a -> Bool
pred =
    do IntMap (DoubleLinkedList m a)
m <- forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) s a.
StrategyQueue m (TransactQueueStrategy s) a
-> Ref m (IntMap (DoubleLinkedList m a))
transactStrategyQueue StrategyQueue m (TransactQueueStrategy FCFS) a
q)
       let loop :: [(Key, DoubleLinkedList m a)] -> Event m (Maybe a)
loop [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
           loop ((Key
k, DoubleLinkedList m a
xs): [(Key, DoubleLinkedList m a)]
tail) =
             do Maybe a
a <- forall (m :: * -> *) a.
MonadRef m =>
DoubleLinkedList m a -> (a -> Bool) -> Event m (Maybe a)
DLL.listRemoveBy DoubleLinkedList m a
xs a -> Bool
pred
                case Maybe a
a of
                  Maybe a
Nothing -> [(Key, DoubleLinkedList m a)] -> Event m (Maybe a)
loop [(Key, DoubleLinkedList m a)]
tail
                  Just a
_  ->
                    do Bool
empty <- forall (m :: * -> *) a.
MonadRef m =>
DoubleLinkedList m a -> Event m Bool
DLL.listNull DoubleLinkedList m a
xs
                       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
empty forall a b. (a -> b) -> a -> b
$
                         forall (m :: * -> *) a.
MonadDES m =>
Ref m a -> (a -> a) -> Event m ()
modifyRef (forall (m :: * -> *) s a.
StrategyQueue m (TransactQueueStrategy s) a
-> Ref m (IntMap (DoubleLinkedList m a))
transactStrategyQueue StrategyQueue m (TransactQueueStrategy FCFS) a
q) forall a b. (a -> b) -> a -> b
$
                         forall a. Key -> IntMap a -> IntMap a
M.delete Key
k
                       forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
a
       [(Key, DoubleLinkedList m a)] -> Event m (Maybe a)
loop (forall a. IntMap a -> [(Key, a)]
M.assocs IntMap (DoubleLinkedList m a)
m)

  {-# INLINABLE strategyQueueContainsBy #-}
  strategyQueueContainsBy :: forall a.
StrategyQueue m (TransactQueueStrategy FCFS) a
-> (a -> Bool) -> Event m (Maybe a)
strategyQueueContainsBy StrategyQueue m (TransactQueueStrategy FCFS) a
q a -> Bool
pred =
    do IntMap (DoubleLinkedList m a)
m <- forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) s a.
StrategyQueue m (TransactQueueStrategy s) a
-> Ref m (IntMap (DoubleLinkedList m a))
transactStrategyQueue StrategyQueue m (TransactQueueStrategy FCFS) a
q)
       let loop :: [(Key, DoubleLinkedList m a)] -> Event m (Maybe a)
loop [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
           loop ((Key
k, DoubleLinkedList m a
xs): [(Key, DoubleLinkedList m a)]
tail) =
             do Maybe a
a <- forall (m :: * -> *) a.
MonadRef m =>
DoubleLinkedList m a -> (a -> Bool) -> Event m (Maybe a)
DLL.listContainsBy DoubleLinkedList m a
xs a -> Bool
pred
                case Maybe a
a of
                  Maybe a
Nothing -> [(Key, DoubleLinkedList m a)] -> Event m (Maybe a)
loop [(Key, DoubleLinkedList m a)]
tail
                  Just a
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
a
       [(Key, DoubleLinkedList m a)] -> Event m (Maybe a)
loop (forall a. IntMap a -> [(Key, a)]
M.assocs IntMap (DoubleLinkedList m a)
m)

-- | Try to delete the transact by the specified priority and satisfying to the provided predicate.
transactStrategyQueueDeleteBy :: MonadDES m
                                 => StrategyQueue m (TransactQueueStrategy s) a
                                 -- ^ the queue
                                 -> Int
                                 -- ^ the transact priority
                                 -> (a -> Bool)
                                 -- ^ the predicate
                                 -> Event m (Maybe a)
{-# INLINABLE transactStrategyQueueDeleteBy #-}
transactStrategyQueueDeleteBy :: forall (m :: * -> *) s a.
MonadDES m =>
StrategyQueue m (TransactQueueStrategy s) a
-> Key -> (a -> Bool) -> Event m (Maybe a)
transactStrategyQueueDeleteBy StrategyQueue m (TransactQueueStrategy s) a
q Key
priority a -> Bool
pred =
  do IntMap (DoubleLinkedList m a)
m <- forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) s a.
StrategyQueue m (TransactQueueStrategy s) a
-> Ref m (IntMap (DoubleLinkedList m a))
transactStrategyQueue StrategyQueue m (TransactQueueStrategy s) a
q)
     let k :: Key
k  = - Key
priority
         xs :: Maybe (DoubleLinkedList m a)
xs = forall a. Key -> IntMap a -> Maybe a
M.lookup Key
k IntMap (DoubleLinkedList m a)
m
     case Maybe (DoubleLinkedList m a)
xs of
       Maybe (DoubleLinkedList m a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
       Just DoubleLinkedList m a
xs ->
         do Maybe a
a <- forall (m :: * -> *) a.
MonadRef m =>
DoubleLinkedList m a -> (a -> Bool) -> Event m (Maybe a)
DLL.listRemoveBy DoubleLinkedList m a
xs a -> Bool
pred
            Bool
empty <- forall (m :: * -> *) a.
MonadRef m =>
DoubleLinkedList m a -> Event m Bool
DLL.listNull DoubleLinkedList m a
xs
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
empty forall a b. (a -> b) -> a -> b
$
              forall (m :: * -> *) a.
MonadDES m =>
Ref m a -> (a -> a) -> Event m ()
modifyRef (forall (m :: * -> *) s a.
StrategyQueue m (TransactQueueStrategy s) a
-> Ref m (IntMap (DoubleLinkedList m a))
transactStrategyQueue StrategyQueue m (TransactQueueStrategy s) a
q) forall a b. (a -> b) -> a -> b
$
              forall a. Key -> IntMap a -> IntMap a
M.delete Key
k
            forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
a

-- | Test whether the queue contains a transact with the specified priority satisfying the provided predicate.
transactStrategyQueueContainsBy :: MonadDES m
                                   => StrategyQueue m (TransactQueueStrategy s) a
                                   -- ^ the queue
                                   -> Int
                                   -- ^ the transact priority
                                   -> (a -> Bool)
                                   -- ^ the predicate
                                   -> Event m (Maybe a)
{-# INLINABLE transactStrategyQueueContainsBy #-}
transactStrategyQueueContainsBy :: forall (m :: * -> *) s a.
MonadDES m =>
StrategyQueue m (TransactQueueStrategy s) a
-> Key -> (a -> Bool) -> Event m (Maybe a)
transactStrategyQueueContainsBy StrategyQueue m (TransactQueueStrategy s) a
q Key
priority a -> Bool
pred =
  do IntMap (DoubleLinkedList m a)
m <- forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) s a.
StrategyQueue m (TransactQueueStrategy s) a
-> Ref m (IntMap (DoubleLinkedList m a))
transactStrategyQueue StrategyQueue m (TransactQueueStrategy s) a
q)
     let k :: Key
k  = - Key
priority
         xs :: Maybe (DoubleLinkedList m a)
xs = forall a. Key -> IntMap a -> Maybe a
M.lookup Key
k IntMap (DoubleLinkedList m a)
m
     case Maybe (DoubleLinkedList m a)
xs of
       Maybe (DoubleLinkedList m a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
       Just DoubleLinkedList m a
xs -> forall (m :: * -> *) a.
MonadRef m =>
DoubleLinkedList m a -> (a -> Bool) -> Event m (Maybe a)
DLL.listContainsBy DoubleLinkedList m a
xs a -> Bool
pred