{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}

-- |
-- Module     : Simulation.Aivika.IO.QueueStrategy
-- Copyright  : Copyright (c) 2009-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 'IO' computation.
--
module Simulation.Aivika.IO.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.IO.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 QueueStrategy IO FCFS where
-- instance (Monad m, MonadComp m, MonadIO m, MonadTemplate m)
--          => QueueStrategy m FCFS where

  {-# SPECIALISE instance QueueStrategy IO FCFS #-}

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

  {-# INLINABLE newStrategyQueue #-}
  newStrategyQueue :: forall a. FCFS -> Simulation IO (StrategyQueue IO FCFS a)
newStrategyQueue FCFS
s =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. DoubleLinkedList a -> StrategyQueue IO 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 IO FCFS a -> Event IO 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 DequeueStrategy IO FCFS where
-- instance (QueueStrategy m FCFS, MonadComp m, MonadIO m, MonadTemplate m)
--          => DequeueStrategy m FCFS where

  {-# SPECIALISE instance DequeueStrategy IO FCFS #-}

  {-# INLINABLE strategyDequeue #-}
  strategyDequeue :: forall a. StrategyQueue IO FCFS a -> Event IO 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 EnqueueStrategy IO FCFS where
-- instance (DequeueStrategy m FCFS, MonadComp m, MonadIO m, MonadTemplate m)
--          => EnqueueStrategy m FCFS where

  {-# SPECIALISE instance EnqueueStrategy IO FCFS #-}

  {-# INLINABLE strategyEnqueue #-}
  strategyEnqueue :: forall a. StrategyQueue IO FCFS a -> a -> Event IO ()
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 DeletingQueueStrategy IO FCFS where
-- instance (DequeueStrategy m FCFS, MonadComp m, MonadIO m, MonadTemplate m)
--          => DeletingQueueStrategy m FCFS where

  {-# SPECIALISE instance DeletingQueueStrategy IO FCFS #-}

  {-# INLINABLE strategyQueueDeleteBy #-}
  strategyQueueDeleteBy :: forall a.
StrategyQueue IO FCFS a -> (a -> Bool) -> Event IO (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 IO FCFS a -> (a -> Bool) -> Event IO (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 QueueStrategy IO LCFS where
-- instance (MonadComp m, MonadIO m, MonadTemplate m)
--          => QueueStrategy m LCFS where

  {-# SPECIALISE instance QueueStrategy IO LCFS #-}

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

  {-# INLINABLE newStrategyQueue #-}
  newStrategyQueue :: forall a. LCFS -> Simulation IO (StrategyQueue IO LCFS a)
newStrategyQueue LCFS
s =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. DoubleLinkedList a -> StrategyQueue IO 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 IO LCFS a -> Event IO 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 DequeueStrategy IO LCFS where
-- instance (QueueStrategy m LCFS, MonadComp m, MonadIO m, MonadTemplate m)
--          => DequeueStrategy m LCFS where

  {-# SPECIALISE instance DequeueStrategy IO LCFS #-}

  {-# INLINABLE strategyDequeue #-}
  strategyDequeue :: forall a. StrategyQueue IO LCFS a -> Event IO 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 EnqueueStrategy IO LCFS where
-- instance (DequeueStrategy m LCFS, MonadComp m, MonadIO m, MonadTemplate m)
--          => EnqueueStrategy m LCFS where

  {-# SPECIALISE instance EnqueueStrategy IO LCFS #-}

  {-# INLINABLE strategyEnqueue #-}
  strategyEnqueue :: forall a. StrategyQueue IO LCFS a -> a -> Event IO ()
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 DeletingQueueStrategy IO LCFS where
-- instance (DequeueStrategy m LCFS, MonadComp m, MonadIO m, MonadTemplate m)
--          => DeletingQueueStrategy m LCFS where

  {-# SPECIALISE instance DeletingQueueStrategy IO LCFS #-}

  {-# INLINABLE strategyQueueDeleteBy #-}
  strategyQueueDeleteBy :: forall a.
StrategyQueue IO LCFS a -> (a -> Bool) -> Event IO (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 IO LCFS a -> (a -> Bool) -> Event IO (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 QueueStrategy IO StaticPriorities where
-- instance (MonadComp m, MonadIO m, MonadTemplate m)
--          => QueueStrategy m StaticPriorities where

  {-# SPECIALISE instance QueueStrategy IO StaticPriorities #-}

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

  {-# INLINABLE newStrategyQueue #-}
  newStrategyQueue :: forall a.
StaticPriorities
-> Simulation IO (StrategyQueue IO StaticPriorities a)
newStrategyQueue StaticPriorities
s =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. PriorityQueue a -> StrategyQueue IO 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 IO StaticPriorities a -> Event IO 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 DequeueStrategy IO StaticPriorities where
-- instance (QueueStrategy m StaticPriorities, MonadComp m, MonadIO m, MonadTemplate m)
--          => DequeueStrategy m StaticPriorities where

  {-# SPECIALISE instance DequeueStrategy IO StaticPriorities #-}

  {-# INLINABLE strategyDequeue #-}
  strategyDequeue :: forall a. StrategyQueue IO StaticPriorities a -> Event IO 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 PriorityQueueStrategy IO StaticPriorities Double where
-- instance (DequeueStrategy m StaticPriorities, MonadComp m, MonadIO m, MonadTemplate m)
--          => PriorityQueueStrategy m StaticPriorities Double where

  {-# SPECIALISE instance PriorityQueueStrategy IO StaticPriorities Double #-}

  {-# INLINABLE strategyEnqueueWithPriority #-}
  strategyEnqueueWithPriority :: forall a.
StrategyQueue IO StaticPriorities a -> Double -> a -> Event IO ()
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 DeletingQueueStrategy IO StaticPriorities where
-- instance (DequeueStrategy m StaticPriorities, MonadComp m, MonadIO m, MonadTemplate m)
--          => DeletingQueueStrategy m StaticPriorities where

  {-# SPECIALISE instance DeletingQueueStrategy IO StaticPriorities #-}

  {-# INLINABLE strategyQueueDeleteBy #-}
  strategyQueueDeleteBy :: forall a.
StrategyQueue IO StaticPriorities a
-> (a -> Bool) -> Event IO (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 IO StaticPriorities a
-> (a -> Bool) -> Event IO (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 QueueStrategy IO SIRO where
-- instance (MonadComp m, MonadIO m, MonadTemplate m)
--          => QueueStrategy m SIRO where

  {-# SPECIALISE instance QueueStrategy IO SIRO #-}

  -- | A queue used by the 'SIRO' strategy.
  newtype StrategyQueue IO SIRO a = SIROQueue (V.Vector a)
  
  {-# INLINABLE newStrategyQueue #-}
  newStrategyQueue :: forall a. SIRO -> Simulation IO (StrategyQueue IO SIRO a)
newStrategyQueue SIRO
s =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Vector a -> StrategyQueue IO 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 IO SIRO a -> Event IO 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 DequeueStrategy IO SIRO where
-- instance (QueueStrategy m SIRO, MonadComp m, MonadIO m, MonadTemplate m)
--          => DequeueStrategy m SIRO where

  {-# SPECIALISE instance DequeueStrategy IO SIRO #-}

  {-# INLINABLE strategyDequeue #-}
  strategyDequeue :: forall a. StrategyQueue IO SIRO a -> Event IO 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

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

  {-# SPECIALISE instance EnqueueStrategy IO SIRO #-}

  {-# INLINABLE strategyEnqueue #-}
  strategyEnqueue :: forall a. StrategyQueue IO SIRO a -> a -> Event IO ()
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 DeletingQueueStrategy IO SIRO where
-- instance (DequeueStrategy m SIRO, MonadComp m, MonadIO m, MonadTemplate m)
--          => DeletingQueueStrategy m SIRO where

  {-# SPECIALISE instance DeletingQueueStrategy IO SIRO #-}

  {-# INLINABLE strategyQueueDeleteBy #-}
  strategyQueueDeleteBy :: forall a.
StrategyQueue IO SIRO a -> (a -> Bool) -> Event IO (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 IO SIRO a -> (a -> Bool) -> Event IO (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