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

-- |
-- Module     : Simulation.Aivika.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.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
import qualified Simulation.Aivika.DoubleLinkedList as DLL

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

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

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

  newStrategyQueue :: forall i.
TransactQueueStrategy s
-> Simulation (StrategyQueue (TransactQueueStrategy s) i)
newStrategyQueue TransactQueueStrategy s
s =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    do IORef (IntMap (DoubleLinkedList i))
r <- forall a. a -> IO (IORef a)
newIORef forall a. IntMap a
M.empty
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s a.
TransactQueueStrategy s
-> IORef (IntMap (DoubleLinkedList a))
-> StrategyQueue (TransactQueueStrategy s) a
TransactStrategyQueue TransactQueueStrategy s
s IORef (IntMap (DoubleLinkedList i))
r

  strategyQueueNull :: forall i. StrategyQueue (TransactQueueStrategy s) i -> Event Bool
strategyQueueNull StrategyQueue (TransactQueueStrategy s) i
q =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    do IntMap (DoubleLinkedList i)
m <- forall a. IORef a -> IO a
readIORef (forall s a.
StrategyQueue (TransactQueueStrategy s) a
-> IORef (IntMap (DoubleLinkedList a))
transactStrategyQueue StrategyQueue (TransactQueueStrategy s) i
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 i)
m

instance DequeueStrategy (TransactQueueStrategy FCFS) where

  strategyDequeue :: forall i. StrategyQueue (TransactQueueStrategy FCFS) i -> Event i
strategyDequeue StrategyQueue (TransactQueueStrategy FCFS) i
q =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 
    do IntMap (DoubleLinkedList i)
m <- forall a. IORef a -> IO a
readIORef (forall s a.
StrategyQueue (TransactQueueStrategy s) a
-> IORef (IntMap (DoubleLinkedList a))
transactStrategyQueue StrategyQueue (TransactQueueStrategy FCFS) i
q)
       let (Key
k, DoubleLinkedList i
xs) = forall a. IntMap a -> (Key, a)
M.findMin IntMap (DoubleLinkedList i)
m
       i
i <- forall a. DoubleLinkedList a -> IO a
DLL.listFirst DoubleLinkedList i
xs
       forall a. DoubleLinkedList a -> IO ()
DLL.listRemoveFirst DoubleLinkedList i
xs
       Bool
empty <- forall a. DoubleLinkedList a -> IO Bool
DLL.listNull DoubleLinkedList i
xs
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
empty forall a b. (a -> b) -> a -> b
$
         forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (forall s a.
StrategyQueue (TransactQueueStrategy s) a
-> IORef (IntMap (DoubleLinkedList a))
transactStrategyQueue StrategyQueue (TransactQueueStrategy FCFS) i
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 i
i

instance DequeueStrategy (TransactQueueStrategy LCFS) where

  strategyDequeue :: forall i. StrategyQueue (TransactQueueStrategy LCFS) i -> Event i
strategyDequeue StrategyQueue (TransactQueueStrategy LCFS) i
q =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 
    do IntMap (DoubleLinkedList i)
m <- forall a. IORef a -> IO a
readIORef (forall s a.
StrategyQueue (TransactQueueStrategy s) a
-> IORef (IntMap (DoubleLinkedList a))
transactStrategyQueue StrategyQueue (TransactQueueStrategy LCFS) i
q)
       let (Key
k, DoubleLinkedList i
xs) = forall a. IntMap a -> (Key, a)
M.findMin IntMap (DoubleLinkedList i)
m
       i
i <- forall a. DoubleLinkedList a -> IO a
DLL.listLast DoubleLinkedList i
xs
       forall a. DoubleLinkedList a -> IO ()
DLL.listRemoveLast DoubleLinkedList i
xs
       Bool
empty <- forall a. DoubleLinkedList a -> IO Bool
DLL.listNull DoubleLinkedList i
xs
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
empty forall a b. (a -> b) -> a -> b
$
         forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (forall s a.
StrategyQueue (TransactQueueStrategy s) a
-> IORef (IntMap (DoubleLinkedList a))
transactStrategyQueue StrategyQueue (TransactQueueStrategy LCFS) i
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 i
i

instance DequeueStrategy (TransactQueueStrategy s) => PriorityQueueStrategy (TransactQueueStrategy s) Int where

  {-# SPECIALISE instance PriorityQueueStrategy (TransactQueueStrategy FCFS) Int #-}
  {-# SPECIALISE instance PriorityQueueStrategy (TransactQueueStrategy LCFS) Int #-}
  
  strategyEnqueueWithPriority :: forall i.
StrategyQueue (TransactQueueStrategy s) i -> Key -> i -> Event ()
strategyEnqueueWithPriority StrategyQueue (TransactQueueStrategy s) i
q Key
priority i
i =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    do IntMap (DoubleLinkedList i)
m <- forall a. IORef a -> IO a
readIORef (forall s a.
StrategyQueue (TransactQueueStrategy s) a
-> IORef (IntMap (DoubleLinkedList a))
transactStrategyQueue StrategyQueue (TransactQueueStrategy s) i
q)
       let k :: Key
k  = - Key
priority
           xs :: Maybe (DoubleLinkedList i)
xs = forall a. Key -> IntMap a -> Maybe a
M.lookup Key
k IntMap (DoubleLinkedList i)
m
       case Maybe (DoubleLinkedList i)
xs of
         Maybe (DoubleLinkedList i)
Nothing ->
           do DoubleLinkedList i
xs <- forall a. IO (DoubleLinkedList a)
DLL.newList
              forall a. DoubleLinkedList a -> a -> IO ()
DLL.listAddLast DoubleLinkedList i
xs i
i
              forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (forall s a.
StrategyQueue (TransactQueueStrategy s) a
-> IORef (IntMap (DoubleLinkedList a))
transactStrategyQueue StrategyQueue (TransactQueueStrategy s) i
q) forall a b. (a -> b) -> a -> b
$
                forall a. Key -> a -> IntMap a -> IntMap a
M.insert Key
k DoubleLinkedList i
xs
         Just DoubleLinkedList i
xs ->
           forall a. DoubleLinkedList a -> a -> IO ()
DLL.listAddLast DoubleLinkedList i
xs i
i

instance DeletingQueueStrategy (TransactQueueStrategy FCFS) where

  strategyQueueDeleteBy :: forall i.
StrategyQueue (TransactQueueStrategy FCFS) i
-> (i -> Bool) -> Event (Maybe i)
strategyQueueDeleteBy StrategyQueue (TransactQueueStrategy FCFS) i
q i -> Bool
pred =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    do IntMap (DoubleLinkedList i)
m <- forall a. IORef a -> IO a
readIORef (forall s a.
StrategyQueue (TransactQueueStrategy s) a
-> IORef (IntMap (DoubleLinkedList a))
transactStrategyQueue StrategyQueue (TransactQueueStrategy FCFS) i
q)
       let loop :: [(Key, DoubleLinkedList i)] -> IO (Maybe i)
loop [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
           loop ((Key
k, DoubleLinkedList i
xs): [(Key, DoubleLinkedList i)]
tail) =
             do Maybe i
a <- forall a. DoubleLinkedList a -> (a -> Bool) -> IO (Maybe a)
DLL.listRemoveBy DoubleLinkedList i
xs i -> Bool
pred
                case Maybe i
a of
                  Maybe i
Nothing -> [(Key, DoubleLinkedList i)] -> IO (Maybe i)
loop [(Key, DoubleLinkedList i)]
tail
                  Just i
_  ->
                    do Bool
empty <- forall a. DoubleLinkedList a -> IO Bool
DLL.listNull DoubleLinkedList i
xs
                       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
empty forall a b. (a -> b) -> a -> b
$
                         forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (forall s a.
StrategyQueue (TransactQueueStrategy s) a
-> IORef (IntMap (DoubleLinkedList a))
transactStrategyQueue StrategyQueue (TransactQueueStrategy FCFS) i
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 i
a
       [(Key, DoubleLinkedList i)] -> IO (Maybe i)
loop (forall a. IntMap a -> [(Key, a)]
M.assocs IntMap (DoubleLinkedList i)
m)

  strategyQueueContainsBy :: forall i.
StrategyQueue (TransactQueueStrategy FCFS) i
-> (i -> Bool) -> Event (Maybe i)
strategyQueueContainsBy StrategyQueue (TransactQueueStrategy FCFS) i
q i -> Bool
pred =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    do IntMap (DoubleLinkedList i)
m <- forall a. IORef a -> IO a
readIORef (forall s a.
StrategyQueue (TransactQueueStrategy s) a
-> IORef (IntMap (DoubleLinkedList a))
transactStrategyQueue StrategyQueue (TransactQueueStrategy FCFS) i
q)
       let loop :: [(Key, DoubleLinkedList i)] -> IO (Maybe i)
loop [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
           loop ((Key
k, DoubleLinkedList i
xs): [(Key, DoubleLinkedList i)]
tail) =
             do Maybe i
a <- forall a. DoubleLinkedList a -> (a -> Bool) -> IO (Maybe a)
DLL.listContainsBy DoubleLinkedList i
xs i -> Bool
pred
                case Maybe i
a of
                  Maybe i
Nothing -> [(Key, DoubleLinkedList i)] -> IO (Maybe i)
loop [(Key, DoubleLinkedList i)]
tail
                  Just i
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe i
a
       [(Key, DoubleLinkedList i)] -> IO (Maybe i)
loop (forall a. IntMap a -> [(Key, a)]
M.assocs IntMap (DoubleLinkedList i)
m)

-- | Try to delete the transact by the specified priority and satisfying to the provided predicate.
transactStrategyQueueDeleteBy :: StrategyQueue (TransactQueueStrategy s) a
                                 -- ^ the queue
                                 -> Int
                                 -- ^ the transact priority
                                 -> (a -> Bool)
                                 -- ^ the predicate
                                 -> Event (Maybe a)
transactStrategyQueueDeleteBy :: forall s a.
StrategyQueue (TransactQueueStrategy s) a
-> Key -> (a -> Bool) -> Event (Maybe a)
transactStrategyQueueDeleteBy StrategyQueue (TransactQueueStrategy s) a
q Key
priority a -> Bool
pred =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
  do IntMap (DoubleLinkedList a)
m <- forall a. IORef a -> IO a
readIORef (forall s a.
StrategyQueue (TransactQueueStrategy s) a
-> IORef (IntMap (DoubleLinkedList a))
transactStrategyQueue StrategyQueue (TransactQueueStrategy s) a
q)
     let k :: Key
k  = - Key
priority
         xs :: Maybe (DoubleLinkedList a)
xs = forall a. Key -> IntMap a -> Maybe a
M.lookup Key
k IntMap (DoubleLinkedList a)
m
     case Maybe (DoubleLinkedList a)
xs of
       Maybe (DoubleLinkedList a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
       Just DoubleLinkedList a
xs ->
         do Maybe a
a <- forall a. DoubleLinkedList a -> (a -> Bool) -> IO (Maybe a)
DLL.listRemoveBy DoubleLinkedList a
xs a -> Bool
pred
            Bool
empty <- forall a. DoubleLinkedList a -> IO Bool
DLL.listNull DoubleLinkedList a
xs
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
empty forall a b. (a -> b) -> a -> b
$
              forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (forall s a.
StrategyQueue (TransactQueueStrategy s) a
-> IORef (IntMap (DoubleLinkedList a))
transactStrategyQueue StrategyQueue (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 :: StrategyQueue (TransactQueueStrategy s) a
                                   -- ^ the queue
                                   -> Int
                                   -- ^ the transact priority
                                   -> (a -> Bool)
                                   -- ^ the predicate
                                   -> Event (Maybe a)
transactStrategyQueueContainsBy :: forall s a.
StrategyQueue (TransactQueueStrategy s) a
-> Key -> (a -> Bool) -> Event (Maybe a)
transactStrategyQueueContainsBy StrategyQueue (TransactQueueStrategy s) a
q Key
priority a -> Bool
pred =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
  do IntMap (DoubleLinkedList a)
m <- forall a. IORef a -> IO a
readIORef (forall s a.
StrategyQueue (TransactQueueStrategy s) a
-> IORef (IntMap (DoubleLinkedList a))
transactStrategyQueue StrategyQueue (TransactQueueStrategy s) a
q)
     let k :: Key
k  = - Key
priority
         xs :: Maybe (DoubleLinkedList a)
xs = forall a. Key -> IntMap a -> Maybe a
M.lookup Key
k IntMap (DoubleLinkedList a)
m
     case Maybe (DoubleLinkedList a)
xs of
       Maybe (DoubleLinkedList a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
       Just DoubleLinkedList a
xs -> forall a. DoubleLinkedList a -> (a -> Bool) -> IO (Maybe a)
DLL.listContainsBy DoubleLinkedList a
xs a -> Bool
pred