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

-- |
-- Module     : Simulation.Aivika.RealTime.QueueStrategy
-- Copyright  : Copyright (c) 2016-2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 8.0.1
--
-- This module defines some queue strategy instances
-- for the 'RT' computations.
--
module Simulation.Aivika.RealTime.QueueStrategy () where

import Control.Monad.Trans

import Simulation.Aivika.Trans.Comp
import Simulation.Aivika.Trans.Parameter
import Simulation.Aivika.Trans.Parameter.Random
import Simulation.Aivika.Trans.Simulation
import Simulation.Aivika.Trans.Event
import Simulation.Aivika.Trans.QueueStrategy

import Simulation.Aivika.RealTime.Internal.RT
import Simulation.Aivika.RealTime.Comp

import qualified Simulation.Aivika.DoubleLinkedList as LL
import qualified Simulation.Aivika.PriorityQueue as PQ
import qualified Simulation.Aivika.Vector as V

-- | An implementation of the 'FCFS' queue strategy.
instance (Monad m, MonadComp m, MonadIO m)
         => QueueStrategy (RT m) FCFS where

  {-# SPECIALISE instance QueueStrategy (RT IO) FCFS #-}

  -- | A queue used by the 'FCFS' strategy.
  newtype StrategyQueue (RT m) FCFS a = FCFSQueue (LL.DoubleLinkedList a)

  {-# INLINABLE newStrategyQueue #-}
  newStrategyQueue :: forall a. FCFS -> Simulation (RT m) (StrategyQueue (RT m) FCFS a)
newStrategyQueue FCFS
s =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a.
DoubleLinkedList a -> StrategyQueue (RT m) FCFS a
FCFSQueue forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (DoubleLinkedList a)
LL.newList

  {-# INLINABLE strategyQueueNull #-}
  strategyQueueNull :: forall a. StrategyQueue (RT m) FCFS a -> Event (RT m) Bool
strategyQueueNull (FCFSQueue DoubleLinkedList a
q) =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. DoubleLinkedList a -> IO Bool
LL.listNull DoubleLinkedList a
q

-- | An implementation of the 'FCFS' queue strategy.
instance (QueueStrategy (RT m) FCFS, MonadComp m, MonadIO m)
         => DequeueStrategy (RT m) FCFS where

  {-# SPECIALISE instance DequeueStrategy (RT IO) FCFS #-}

  {-# INLINABLE strategyDequeue #-}
  strategyDequeue :: forall a. StrategyQueue (RT m) FCFS a -> Event (RT m) a
strategyDequeue (FCFSQueue DoubleLinkedList a
q) =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    do a
i <- forall a. DoubleLinkedList a -> IO a
LL.listFirst DoubleLinkedList a
q
       forall a. DoubleLinkedList a -> IO ()
LL.listRemoveFirst DoubleLinkedList a
q
       forall (m :: * -> *) a. Monad m => a -> m a
return a
i

-- | An implementation of the 'FCFS' queue strategy.
instance (DequeueStrategy (RT m) FCFS, MonadComp m, MonadIO m)
         => EnqueueStrategy (RT m) FCFS where

  {-# SPECIALISE instance EnqueueStrategy (RT IO) FCFS #-}

  {-# INLINABLE strategyEnqueue #-}
  strategyEnqueue :: forall a. StrategyQueue (RT m) FCFS a -> a -> Event (RT m) ()
strategyEnqueue (FCFSQueue DoubleLinkedList a
q) a
i =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. DoubleLinkedList a -> a -> IO ()
LL.listAddLast DoubleLinkedList a
q a
i

-- | An implementation of the 'FCFS' queue strategy.
instance (DequeueStrategy (RT m) FCFS, MonadComp m, MonadIO m)
         => DeletingQueueStrategy (RT m) FCFS where

  {-# SPECIALISE instance DeletingQueueStrategy (RT IO) FCFS #-}

  {-# INLINABLE strategyQueueDeleteBy #-}
  strategyQueueDeleteBy :: forall a.
StrategyQueue (RT m) FCFS a
-> (a -> Bool) -> Event (RT m) (Maybe a)
strategyQueueDeleteBy (FCFSQueue DoubleLinkedList a
q) a -> Bool
p =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. DoubleLinkedList a -> (a -> Bool) -> IO (Maybe a)
LL.listRemoveBy DoubleLinkedList a
q a -> Bool
p

  {-# INLINABLE strategyQueueContainsBy #-}
  strategyQueueContainsBy :: forall a.
StrategyQueue (RT m) FCFS a
-> (a -> Bool) -> Event (RT m) (Maybe a)
strategyQueueContainsBy (FCFSQueue DoubleLinkedList a
q) a -> Bool
p =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. DoubleLinkedList a -> (a -> Bool) -> IO (Maybe a)
LL.listContainsBy DoubleLinkedList a
q a -> Bool
p

-- | An implementation of the 'LCFS' queue strategy.
instance (MonadComp m, MonadIO m)
         => QueueStrategy (RT m) LCFS where

  {-# SPECIALISE instance QueueStrategy (RT IO) LCFS #-}

  -- | A queue used by the 'LCFS' strategy.
  newtype StrategyQueue (RT m) LCFS a = LCFSQueue (LL.DoubleLinkedList a)

  {-# INLINABLE newStrategyQueue #-}
  newStrategyQueue :: forall a. LCFS -> Simulation (RT m) (StrategyQueue (RT m) LCFS a)
newStrategyQueue LCFS
s =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a.
DoubleLinkedList a -> StrategyQueue (RT m) LCFS a
LCFSQueue forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (DoubleLinkedList a)
LL.newList
       
  {-# INLINABLE strategyQueueNull #-}
  strategyQueueNull :: forall a. StrategyQueue (RT m) LCFS a -> Event (RT m) Bool
strategyQueueNull (LCFSQueue DoubleLinkedList a
q) =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. DoubleLinkedList a -> IO Bool
LL.listNull DoubleLinkedList a
q

-- | An implementation of the 'LCFS' queue strategy.
instance (QueueStrategy (RT m) LCFS, MonadComp m, MonadIO m)
         => DequeueStrategy (RT m) LCFS where

  {-# SPECIALISE instance DequeueStrategy (RT IO) LCFS #-}

  {-# INLINABLE strategyDequeue #-}
  strategyDequeue :: forall a. StrategyQueue (RT m) LCFS a -> Event (RT m) a
strategyDequeue (LCFSQueue DoubleLinkedList a
q) =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    do a
i <- forall a. DoubleLinkedList a -> IO a
LL.listFirst DoubleLinkedList a
q
       forall a. DoubleLinkedList a -> IO ()
LL.listRemoveFirst DoubleLinkedList a
q
       forall (m :: * -> *) a. Monad m => a -> m a
return a
i

-- | An implementation of the 'LCFS' queue strategy.
instance (DequeueStrategy (RT m) LCFS, MonadComp m, MonadIO m)
         => EnqueueStrategy (RT m) LCFS where

  {-# SPECIALISE instance EnqueueStrategy (RT IO) LCFS #-}

  {-# INLINABLE strategyEnqueue #-}
  strategyEnqueue :: forall a. StrategyQueue (RT m) LCFS a -> a -> Event (RT m) ()
strategyEnqueue (LCFSQueue DoubleLinkedList a
q) a
i =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. DoubleLinkedList a -> a -> IO ()
LL.listInsertFirst DoubleLinkedList a
q a
i

-- | An implementation of the 'LCFS' queue strategy.
instance (DequeueStrategy (RT m) LCFS, MonadComp m, MonadIO m)
         => DeletingQueueStrategy (RT m) LCFS where

  {-# SPECIALISE instance DeletingQueueStrategy (RT IO) LCFS #-}

  {-# INLINABLE strategyQueueDeleteBy #-}
  strategyQueueDeleteBy :: forall a.
StrategyQueue (RT m) LCFS a
-> (a -> Bool) -> Event (RT m) (Maybe a)
strategyQueueDeleteBy (LCFSQueue DoubleLinkedList a
q) a -> Bool
p =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. DoubleLinkedList a -> (a -> Bool) -> IO (Maybe a)
LL.listRemoveBy DoubleLinkedList a
q a -> Bool
p

  {-# INLINABLE strategyQueueContainsBy #-}
  strategyQueueContainsBy :: forall a.
StrategyQueue (RT m) LCFS a
-> (a -> Bool) -> Event (RT m) (Maybe a)
strategyQueueContainsBy (LCFSQueue DoubleLinkedList a
q) a -> Bool
p =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. DoubleLinkedList a -> (a -> Bool) -> IO (Maybe a)
LL.listContainsBy DoubleLinkedList a
q a -> Bool
p

-- | An implementation of the 'StaticPriorities' queue strategy.
instance (MonadComp m, MonadIO m)
         => QueueStrategy (RT m) StaticPriorities where

  {-# SPECIALISE instance QueueStrategy (RT IO) StaticPriorities #-}

  -- | A queue used by the 'StaticPriorities' strategy.
  newtype StrategyQueue (RT m) StaticPriorities a = StaticPriorityQueue (PQ.PriorityQueue a)

  {-# INLINABLE newStrategyQueue #-}
  newStrategyQueue :: forall a.
StaticPriorities
-> Simulation (RT m) (StrategyQueue (RT m) StaticPriorities a)
newStrategyQueue StaticPriorities
s =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a.
PriorityQueue a -> StrategyQueue (RT m) StaticPriorities a
StaticPriorityQueue forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO (PriorityQueue a)
PQ.newQueue

  {-# INLINABLE strategyQueueNull #-}
  strategyQueueNull :: forall a.
StrategyQueue (RT m) StaticPriorities a -> Event (RT m) Bool
strategyQueueNull (StaticPriorityQueue PriorityQueue a
q) =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. PriorityQueue a -> IO Bool
PQ.queueNull PriorityQueue a
q

-- | An implementation of the 'StaticPriorities' queue strategy.
instance (QueueStrategy (RT m) StaticPriorities, MonadComp m, MonadIO m)
         => DequeueStrategy (RT m) StaticPriorities where

  {-# SPECIALISE instance DequeueStrategy (RT IO) StaticPriorities #-}

  {-# INLINABLE strategyDequeue #-}
  strategyDequeue :: forall a. StrategyQueue (RT m) StaticPriorities a -> Event (RT m) a
strategyDequeue (StaticPriorityQueue PriorityQueue a
q) =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    do (Double
_, a
i) <- forall a. PriorityQueue a -> IO (Double, a)
PQ.queueFront PriorityQueue a
q
       forall a. PriorityQueue a -> IO ()
PQ.dequeue PriorityQueue a
q
       forall (m :: * -> *) a. Monad m => a -> m a
return a
i

-- | An implementation of the 'StaticPriorities' queue strategy.
instance (DequeueStrategy (RT m) StaticPriorities, MonadComp m, MonadIO m)
         => PriorityQueueStrategy (RT m) StaticPriorities Double where

  {-# SPECIALISE instance PriorityQueueStrategy (RT IO) StaticPriorities Double #-}

  {-# INLINABLE strategyEnqueueWithPriority #-}
  strategyEnqueueWithPriority :: forall a.
StrategyQueue (RT m) StaticPriorities a
-> Double -> a -> Event (RT m) ()
strategyEnqueueWithPriority (StaticPriorityQueue PriorityQueue a
q) Double
p a
i =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. PriorityQueue a -> Double -> a -> IO ()
PQ.enqueue PriorityQueue a
q Double
p a
i

-- | An implementation of the 'StaticPriorities' queue strategy.
instance (DequeueStrategy (RT m) StaticPriorities, MonadComp m, MonadIO m)
         => DeletingQueueStrategy (RT m) StaticPriorities where

  {-# SPECIALISE instance DeletingQueueStrategy (RT IO) StaticPriorities #-}

  {-# INLINABLE strategyQueueDeleteBy #-}
  strategyQueueDeleteBy :: forall a.
StrategyQueue (RT m) StaticPriorities a
-> (a -> Bool) -> Event (RT m) (Maybe a)
strategyQueueDeleteBy (StaticPriorityQueue PriorityQueue a
q) a -> Bool
p =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. PriorityQueue a -> (a -> Bool) -> IO (Maybe a)
PQ.queueDeleteBy PriorityQueue a
q a -> Bool
p

  {-# INLINABLE strategyQueueContainsBy #-}
  strategyQueueContainsBy :: forall a.
StrategyQueue (RT m) StaticPriorities a
-> (a -> Bool) -> Event (RT m) (Maybe a)
strategyQueueContainsBy (StaticPriorityQueue PriorityQueue a
q) a -> Bool
p =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. PriorityQueue a -> (a -> Bool) -> IO (Maybe a)
PQ.queueContainsBy PriorityQueue a
q a -> Bool
p

-- | An implementation of the 'SIRO' queue strategy.
instance (MonadComp m, MonadIO m)
         => QueueStrategy (RT m) SIRO where

  {-# SPECIALISE instance QueueStrategy (RT IO) SIRO #-}

  -- | A queue used by the 'SIRO' strategy.
  newtype StrategyQueue (RT m) SIRO a = SIROQueue (V.Vector a)
  
  {-# INLINABLE newStrategyQueue #-}
  newStrategyQueue :: forall a. SIRO -> Simulation (RT m) (StrategyQueue (RT m) SIRO a)
newStrategyQueue SIRO
s =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Vector a -> StrategyQueue (RT m) SIRO a
SIROQueue forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO (Vector a)
V.newVector

  {-# INLINABLE strategyQueueNull #-}
  strategyQueueNull :: forall a. StrategyQueue (RT m) SIRO a -> Event (RT m) Bool
strategyQueueNull (SIROQueue Vector a
q) =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    do Int
n <- forall a. Vector a -> IO Int
V.vectorCount Vector a
q
       forall (m :: * -> *) a. Monad m => a -> m a
return (Int
n forall a. Eq a => a -> a -> Bool
== Int
0)

-- | An implementation of the 'SIRO' queue strategy.
instance (QueueStrategy (RT m) SIRO, MonadComp m, MonadIO m)
         => DequeueStrategy (RT m) SIRO where

  {-# SPECIALISE instance DequeueStrategy (RT IO) SIRO #-}

  {-# INLINABLE strategyDequeue #-}
  strategyDequeue :: forall a. StrategyQueue (RT m) SIRO a -> Event (RT m) a
strategyDequeue (SIROQueue Vector a
q) =
    do Int
n <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> IO Int
V.vectorCount Vector a
q
       Int
i <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
ParameterLift t m =>
Parameter m a -> t m a
liftParameter forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadComp m => Int -> Int -> Parameter m Int
randomUniformInt Int
0 (Int
n forall a. Num a => a -> a -> a
- Int
1)
       a
x <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Int -> IO a
V.readVector Vector a
q Int
i
       forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Int -> IO ()
V.vectorDeleteAt Vector a
q Int
i
       forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | A template-based implementation of the 'SIRO' queue strategy.
instance (DequeueStrategy (RT m) SIRO, MonadComp m, MonadIO m)
         => EnqueueStrategy (RT m) SIRO where

  {-# SPECIALISE instance EnqueueStrategy (RT IO) SIRO #-}

  {-# INLINABLE strategyEnqueue #-}
  strategyEnqueue :: forall a. StrategyQueue (RT m) SIRO a -> a -> Event (RT m) ()
strategyEnqueue (SIROQueue Vector a
q) a
i =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> a -> IO ()
V.appendVector Vector a
q a
i

-- | An implementation of the 'SIRO' queue strategy.
instance (DequeueStrategy (RT m) SIRO, MonadComp m, MonadIO m)
         => DeletingQueueStrategy (RT m) SIRO where

  {-# SPECIALISE instance DeletingQueueStrategy (RT IO) SIRO #-}

  {-# INLINABLE strategyQueueDeleteBy #-}
  strategyQueueDeleteBy :: forall a.
StrategyQueue (RT m) SIRO a
-> (a -> Bool) -> Event (RT m) (Maybe a)
strategyQueueDeleteBy (SIROQueue Vector a
q) a -> Bool
p =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> (a -> Bool) -> IO (Maybe a)
V.vectorDeleteBy Vector a
q a -> Bool
p

  {-# INLINABLE strategyQueueContainsBy #-}
  strategyQueueContainsBy :: forall a.
StrategyQueue (RT m) SIRO a
-> (a -> Bool) -> Event (RT m) (Maybe a)
strategyQueueContainsBy (SIROQueue Vector a
q) a -> Bool
p =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> (a -> Bool) -> IO (Maybe a)
V.vectorContainsBy Vector a
q a -> Bool
p