{-# LANGUAGE FlexibleContexts #-}
module Simulation.Aivika.Trans.Queue.Infinite
(
FCFSQueue,
LCFSQueue,
SIROQueue,
PriorityQueue,
Queue,
newFCFSQueue,
newLCFSQueue,
newSIROQueue,
newPriorityQueue,
newQueue,
enqueueStoringStrategy,
dequeueStrategy,
queueNull,
queueCount,
queueCountStats,
enqueueStoreCount,
dequeueCount,
dequeueExtractCount,
enqueueStoreRate,
dequeueRate,
dequeueExtractRate,
queueWaitTime,
dequeueWaitTime,
queueRate,
dequeue,
dequeueWithOutputPriority,
tryDequeue,
enqueue,
enqueueWithStoringPriority,
queueDelete,
queueDelete_,
queueDeleteBy,
queueDeleteBy_,
queueContains,
queueContainsBy,
clearQueue,
resetQueue,
queueSummary,
queueNullChanged,
queueNullChanged_,
queueCountChanged,
queueCountChanged_,
enqueueStoreCountChanged,
enqueueStoreCountChanged_,
dequeueCountChanged,
dequeueCountChanged_,
dequeueExtractCountChanged,
dequeueExtractCountChanged_,
queueWaitTimeChanged,
queueWaitTimeChanged_,
dequeueWaitTimeChanged,
dequeueWaitTimeChanged_,
queueRateChanged,
queueRateChanged_,
enqueueStored,
dequeueRequested,
dequeueExtracted,
queueChanged_) where
import Data.Monoid
import Data.Maybe
import Control.Monad
import Control.Monad.Trans
import Simulation.Aivika.Trans.Ref.Base
import Simulation.Aivika.Trans.DES
import Simulation.Aivika.Trans.Internal.Specs
import Simulation.Aivika.Trans.Internal.Parameter
import Simulation.Aivika.Trans.Internal.Simulation
import Simulation.Aivika.Trans.Internal.Dynamics
import Simulation.Aivika.Trans.Internal.Event
import Simulation.Aivika.Trans.Internal.Process
import Simulation.Aivika.Trans.Signal
import Simulation.Aivika.Trans.Resource.Base
import Simulation.Aivika.Trans.QueueStrategy
import Simulation.Aivika.Trans.Statistics
type FCFSQueue m a = Queue m FCFS FCFS a
type LCFSQueue m a = Queue m LCFS FCFS a
type SIROQueue m a = Queue m SIRO FCFS a
type PriorityQueue m a = Queue m StaticPriorities FCFS a
data Queue m sm so a =
Queue { enqueueStoringStrategy :: sm,
dequeueStrategy :: so,
queueStore :: StrategyQueue m sm (QueueItem a),
dequeueRes :: Resource m so,
queueCountRef :: Ref m Int,
queueCountStatsRef :: Ref m (TimingStats Int),
enqueueStoreCountRef :: Ref m Int,
dequeueCountRef :: Ref m Int,
dequeueExtractCountRef :: Ref m Int,
queueWaitTimeRef :: Ref m (SamplingStats Double),
dequeueWaitTimeRef :: Ref m (SamplingStats Double),
enqueueStoredSource :: SignalSource m a,
dequeueRequestedSource :: SignalSource m (),
dequeueExtractedSource :: SignalSource m a }
data QueueItem a =
QueueItem { itemValue :: a,
itemStoringTime :: Double
}
newFCFSQueue :: MonadDES m => Event m (FCFSQueue m a)
{-# INLINABLE newFCFSQueue #-}
newFCFSQueue = newQueue FCFS FCFS
newLCFSQueue :: MonadDES m => Event m (LCFSQueue m a)
{-# INLINABLE newLCFSQueue #-}
newLCFSQueue = newQueue LCFS FCFS
newSIROQueue :: (MonadDES m, QueueStrategy m SIRO) => Event m (SIROQueue m a)
{-# INLINABLE newSIROQueue #-}
newSIROQueue = newQueue SIRO FCFS
newPriorityQueue :: (MonadDES m, QueueStrategy m StaticPriorities) => Event m (PriorityQueue m a)
{-# INLINABLE newPriorityQueue #-}
newPriorityQueue = newQueue StaticPriorities FCFS
newQueue :: (MonadDES m,
QueueStrategy m sm,
QueueStrategy m so) =>
sm
-> so
-> Event m (Queue m sm so a)
{-# INLINABLE newQueue #-}
newQueue sm so =
do t <- liftDynamics time
i <- liftSimulation $ newRef 0
is <- liftSimulation $ newRef $ returnTimingStats t 0
cm <- liftSimulation $ newRef 0
cr <- liftSimulation $ newRef 0
co <- liftSimulation $ newRef 0
qm <- liftSimulation $ newStrategyQueue sm
ro <- liftSimulation $ newResourceWithMaxCount so 0 Nothing
w <- liftSimulation $ newRef mempty
wo <- liftSimulation $ newRef mempty
s3 <- liftSimulation newSignalSource
s4 <- liftSimulation newSignalSource
s5 <- liftSimulation newSignalSource
return Queue { enqueueStoringStrategy = sm,
dequeueStrategy = so,
queueStore = qm,
dequeueRes = ro,
queueCountRef = i,
queueCountStatsRef = is,
enqueueStoreCountRef = cm,
dequeueCountRef = cr,
dequeueExtractCountRef = co,
queueWaitTimeRef = w,
dequeueWaitTimeRef = wo,
enqueueStoredSource = s3,
dequeueRequestedSource = s4,
dequeueExtractedSource = s5 }
queueNull :: MonadDES m => Queue m sm so a -> Event m Bool
{-# INLINABLE queueNull #-}
queueNull q =
Event $ \p ->
do n <- invokeEvent p $ readRef (queueCountRef q)
return (n == 0)
queueNullChanged :: MonadDES m => Queue m sm so a -> Signal m Bool
{-# INLINABLE queueNullChanged #-}
queueNullChanged q =
mapSignalM (const $ queueNull q) (queueNullChanged_ q)
queueNullChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()
{-# INLINABLE queueNullChanged_ #-}
queueNullChanged_ = queueCountChanged_
queueCount :: MonadDES m => Queue m sm so a -> Event m Int
{-# INLINABLE queueCount #-}
queueCount q =
Event $ \p -> invokeEvent p $ readRef (queueCountRef q)
queueCountStats :: MonadDES m => Queue m sm so a -> Event m (TimingStats Int)
{-# INLINABLE queueCountStats #-}
queueCountStats q =
Event $ \p -> invokeEvent p $ readRef (queueCountStatsRef q)
queueCountChanged :: MonadDES m => Queue m sm so a -> Signal m Int
{-# INLINABLE queueCountChanged #-}
queueCountChanged q =
mapSignalM (const $ queueCount q) (queueCountChanged_ q)
queueCountChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()
{-# INLINABLE queueCountChanged_ #-}
queueCountChanged_ q =
mapSignal (const ()) (enqueueStored q) <>
mapSignal (const ()) (dequeueExtracted q)
enqueueStoreCount :: MonadDES m => Queue m sm so a -> Event m Int
{-# INLINABLE enqueueStoreCount #-}
enqueueStoreCount q =
Event $ \p -> invokeEvent p $ readRef (enqueueStoreCountRef q)
enqueueStoreCountChanged :: MonadDES m => Queue m sm so a -> Signal m Int
{-# INLINABLE enqueueStoreCountChanged #-}
enqueueStoreCountChanged q =
mapSignalM (const $ enqueueStoreCount q) (enqueueStoreCountChanged_ q)
enqueueStoreCountChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()
{-# INLINABLE enqueueStoreCountChanged_ #-}
enqueueStoreCountChanged_ q =
mapSignal (const ()) (enqueueStored q)
dequeueCount :: MonadDES m => Queue m sm so a -> Event m Int
{-# INLINABLE dequeueCount #-}
dequeueCount q =
Event $ \p -> invokeEvent p $ readRef (dequeueCountRef q)
dequeueCountChanged :: MonadDES m => Queue m sm so a -> Signal m Int
{-# INLINABLE dequeueCountChanged #-}
dequeueCountChanged q =
mapSignalM (const $ dequeueCount q) (dequeueCountChanged_ q)
dequeueCountChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()
{-# INLINABLE dequeueCountChanged_ #-}
dequeueCountChanged_ q =
mapSignal (const ()) (dequeueRequested q)
dequeueExtractCount :: MonadDES m => Queue m sm so a -> Event m Int
{-# INLINABLE dequeueExtractCount #-}
dequeueExtractCount q =
Event $ \p -> invokeEvent p $ readRef (dequeueExtractCountRef q)
dequeueExtractCountChanged :: MonadDES m => Queue m sm so a -> Signal m Int
{-# INLINABLE dequeueExtractCountChanged #-}
dequeueExtractCountChanged q =
mapSignalM (const $ dequeueExtractCount q) (dequeueExtractCountChanged_ q)
dequeueExtractCountChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()
{-# INLINABLE dequeueExtractCountChanged_ #-}
dequeueExtractCountChanged_ q =
mapSignal (const ()) (dequeueExtracted q)
enqueueStoreRate :: MonadDES m => Queue m sm so a -> Event m Double
{-# INLINABLE enqueueStoreRate #-}
enqueueStoreRate q =
Event $ \p ->
do x <- invokeEvent p $ readRef (enqueueStoreCountRef q)
let t0 = spcStartTime $ pointSpecs p
t = pointTime p
return (fromIntegral x / (t - t0))
dequeueRate :: MonadDES m => Queue m sm so a -> Event m Double
{-# INLINABLE dequeueRate #-}
dequeueRate q =
Event $ \p ->
do x <- invokeEvent p $ readRef (dequeueCountRef q)
let t0 = spcStartTime $ pointSpecs p
t = pointTime p
return (fromIntegral x / (t - t0))
dequeueExtractRate :: MonadDES m => Queue m sm so a -> Event m Double
{-# INLINABLE dequeueExtractRate #-}
dequeueExtractRate q =
Event $ \p ->
do x <- invokeEvent p $ readRef (dequeueExtractCountRef q)
let t0 = spcStartTime $ pointSpecs p
t = pointTime p
return (fromIntegral x / (t - t0))
queueWaitTime :: MonadDES m => Queue m sm so a -> Event m (SamplingStats Double)
{-# INLINABLE queueWaitTime #-}
queueWaitTime q =
Event $ \p -> invokeEvent p $ readRef (queueWaitTimeRef q)
queueWaitTimeChanged :: MonadDES m => Queue m sm so a -> Signal m (SamplingStats Double)
{-# INLINABLE queueWaitTimeChanged #-}
queueWaitTimeChanged q =
mapSignalM (const $ queueWaitTime q) (queueWaitTimeChanged_ q)
queueWaitTimeChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()
{-# INLINABLE queueWaitTimeChanged_ #-}
queueWaitTimeChanged_ q =
mapSignal (const ()) (dequeueExtracted q)
dequeueWaitTime :: MonadDES m => Queue m sm so a -> Event m (SamplingStats Double)
{-# INLINABLE dequeueWaitTime #-}
dequeueWaitTime q =
Event $ \p -> invokeEvent p $ readRef (dequeueWaitTimeRef q)
dequeueWaitTimeChanged :: MonadDES m => Queue m sm so a -> Signal m (SamplingStats Double)
{-# INLINABLE dequeueWaitTimeChanged #-}
dequeueWaitTimeChanged q =
mapSignalM (const $ dequeueWaitTime q) (dequeueWaitTimeChanged_ q)
dequeueWaitTimeChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()
{-# INLINABLE dequeueWaitTimeChanged_ #-}
dequeueWaitTimeChanged_ q =
mapSignal (const ()) (dequeueExtracted q)
queueRate :: MonadDES m => Queue m sm so a -> Event m Double
{-# INLINABLE queueRate #-}
queueRate q =
Event $ \p ->
do x <- invokeEvent p $ readRef (queueCountStatsRef q)
y <- invokeEvent p $ readRef (queueWaitTimeRef q)
return (timingStatsMean x / samplingStatsMean y)
queueRateChanged :: MonadDES m => Queue m sm so a -> Signal m Double
{-# INLINABLE queueRateChanged #-}
queueRateChanged q =
mapSignalM (const $ queueRate q) (queueRateChanged_ q)
queueRateChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()
{-# INLINABLE queueRateChanged_ #-}
queueRateChanged_ q =
mapSignal (const ()) (enqueueStored q) <>
mapSignal (const ()) (dequeueExtracted q)
dequeue :: (MonadDES m,
DequeueStrategy m sm,
EnqueueStrategy m so)
=> Queue m sm so a
-> Process m a
{-# INLINABLE dequeue #-}
dequeue q =
do t <- liftEvent $ dequeueRequest q
requestResource (dequeueRes q)
liftEvent $ dequeueExtract q t
dequeueWithOutputPriority :: (MonadDES m,
DequeueStrategy m sm,
PriorityQueueStrategy m so po)
=> Queue m sm so a
-> po
-> Process m a
{-# INLINABLE dequeueWithOutputPriority #-}
dequeueWithOutputPriority q po =
do t <- liftEvent $ dequeueRequest q
requestResourceWithPriority (dequeueRes q) po
liftEvent $ dequeueExtract q t
tryDequeue :: (MonadDES m, DequeueStrategy m sm)
=> Queue m sm so a
-> Event m (Maybe a)
{-# INLINABLE tryDequeue #-}
tryDequeue q =
do x <- tryRequestResourceWithinEvent (dequeueRes q)
if x
then do t <- dequeueRequest q
fmap Just $ dequeueExtract q t
else return Nothing
queueDelete :: (MonadDES m,
Eq a,
DeletingQueueStrategy m sm,
DequeueStrategy m so)
=> Queue m sm so a
-> a
-> Event m Bool
{-# INLINABLE queueDelete #-}
queueDelete q a = fmap isJust $ queueDeleteBy q (== a)
queueDelete_ :: (MonadDES m,
Eq a,
DeletingQueueStrategy m sm,
DequeueStrategy m so)
=> Queue m sm so a
-> a
-> Event m ()
{-# INLINABLE queueDelete_ #-}
queueDelete_ q a = fmap (const ()) $ queueDeleteBy q (== a)
queueDeleteBy :: (MonadDES m,
DeletingQueueStrategy m sm,
DequeueStrategy m so)
=> Queue m sm so a
-> (a -> Bool)
-> Event m (Maybe a)
{-# INLINABLE queueDeleteBy #-}
queueDeleteBy q pred =
do x <- tryRequestResourceWithinEvent (dequeueRes q)
if x
then do i <- strategyQueueDeleteBy (queueStore q) (pred . itemValue)
case i of
Nothing ->
do releaseResourceWithinEvent (dequeueRes q)
return Nothing
Just i ->
do t <- dequeueRequest q
fmap Just $ dequeuePostExtract q t i
else return Nothing
queueDeleteBy_ :: (MonadDES m,
DeletingQueueStrategy m sm,
DequeueStrategy m so)
=> Queue m sm so a
-> (a -> Bool)
-> Event m ()
{-# INLINABLE queueDeleteBy_ #-}
queueDeleteBy_ q pred = fmap (const ()) $ queueDeleteBy q pred
queueContains :: (MonadDES m,
Eq a,
DeletingQueueStrategy m sm)
=> Queue m sm so a
-> a
-> Event m Bool
{-# INLINABLE queueContains #-}
queueContains q a = fmap isJust $ queueContainsBy q (== a)
queueContainsBy :: (MonadDES m,
DeletingQueueStrategy m sm)
=> Queue m sm so a
-> (a -> Bool)
-> Event m (Maybe a)
{-# INLINABLE queueContainsBy #-}
queueContainsBy q pred =
do x <- strategyQueueContainsBy (queueStore q) (pred . itemValue)
case x of
Nothing -> return Nothing
Just i -> return $ Just (itemValue i)
clearQueue :: (MonadDES m,
DequeueStrategy m sm)
=> Queue m sm so a
-> Event m ()
{-# INLINABLE clearQueue #-}
clearQueue q =
do x <- tryDequeue q
case x of
Nothing -> return ()
Just a -> clearQueue q
enqueue :: (MonadDES m,
EnqueueStrategy m sm,
DequeueStrategy m so)
=> Queue m sm so a
-> a
-> Event m ()
{-# INLINABLE enqueue #-}
enqueue = enqueueStore
enqueueWithStoringPriority :: (MonadDES m,
PriorityQueueStrategy m sm pm,
DequeueStrategy m so)
=> Queue m sm so a
-> pm
-> a
-> Event m ()
{-# INLINABLE enqueueWithStoringPriority #-}
enqueueWithStoringPriority = enqueueStoreWithPriority
enqueueStored :: MonadDES m => Queue m sm so a -> Signal m a
{-# INLINABLE enqueueStored #-}
enqueueStored q = publishSignal (enqueueStoredSource q)
dequeueRequested :: MonadDES m => Queue m sm so a -> Signal m ()
{-# INLINABLE dequeueRequested #-}
dequeueRequested q = publishSignal (dequeueRequestedSource q)
dequeueExtracted :: MonadDES m => Queue m sm so a -> Signal m a
{-# INLINABLE dequeueExtracted #-}
dequeueExtracted q = publishSignal (dequeueExtractedSource q)
enqueueStore :: (MonadDES m,
EnqueueStrategy m sm,
DequeueStrategy m so)
=> Queue m sm so a
-> a
-> Event m ()
{-# INLINE enqueueStore #-}
enqueueStore q a =
Event $ \p ->
do let i = QueueItem { itemValue = a,
itemStoringTime = pointTime p }
invokeEvent p $
strategyEnqueue (queueStore q) i
c <- invokeEvent p $
readRef (queueCountRef q)
let c' = c + 1
t = pointTime p
c' `seq` invokeEvent p $
writeRef (queueCountRef q) c'
invokeEvent p $
modifyRef (queueCountStatsRef q) (addTimingStats t c')
invokeEvent p $
modifyRef (enqueueStoreCountRef q) (+ 1)
invokeEvent p $
releaseResourceWithinEvent (dequeueRes q)
invokeEvent p $
triggerSignal (enqueueStoredSource q) (itemValue i)
enqueueStoreWithPriority :: (MonadDES m,
PriorityQueueStrategy m sm pm,
DequeueStrategy m so)
=> Queue m sm so a
-> pm
-> a
-> Event m ()
{-# INLINE enqueueStoreWithPriority #-}
enqueueStoreWithPriority q pm a =
Event $ \p ->
do let i = QueueItem { itemValue = a,
itemStoringTime = pointTime p }
invokeEvent p $
strategyEnqueueWithPriority (queueStore q) pm i
c <- invokeEvent p $
readRef (queueCountRef q)
let c' = c + 1
t = pointTime p
c' `seq` invokeEvent p $
writeRef (queueCountRef q) c'
invokeEvent p $
modifyRef (queueCountStatsRef q) (addTimingStats t c')
invokeEvent p $
modifyRef (enqueueStoreCountRef q) (+ 1)
invokeEvent p $
releaseResourceWithinEvent (dequeueRes q)
invokeEvent p $
triggerSignal (enqueueStoredSource q) (itemValue i)
dequeueRequest :: MonadDES m
=> Queue m sm so a
-> Event m Double
{-# INLINE dequeueRequest #-}
dequeueRequest q =
Event $ \p ->
do invokeEvent p $
modifyRef (dequeueCountRef q) (+ 1)
invokeEvent p $
triggerSignal (dequeueRequestedSource q) ()
return $ pointTime p
dequeueExtract :: (MonadDES m, DequeueStrategy m sm)
=> Queue m sm so a
-> Double
-> Event m a
{-# INLINE dequeueExtract #-}
dequeueExtract q t' =
Event $ \p ->
do i <- invokeEvent p $
strategyDequeue (queueStore q)
invokeEvent p $
dequeuePostExtract q t' i
dequeuePostExtract :: (MonadDES m,
DequeueStrategy m sm)
=> Queue m sm so a
-> Double
-> QueueItem a
-> Event m a
{-# INLINE dequeuePostExtract #-}
dequeuePostExtract q t' i =
Event $ \p ->
do c <- invokeEvent p $
readRef (queueCountRef q)
let c' = c - 1
t = pointTime p
c' `seq` invokeEvent p $
writeRef (queueCountRef q) c'
invokeEvent p $
modifyRef (queueCountStatsRef q) (addTimingStats t c')
invokeEvent p $
modifyRef (dequeueExtractCountRef q) (+ 1)
invokeEvent p $
dequeueStat q t' i
invokeEvent p $
triggerSignal (dequeueExtractedSource q) (itemValue i)
return $ itemValue i
dequeueStat :: MonadDES m
=> Queue m sm so a
-> Double
-> QueueItem a
-> Event m ()
{-# INLINE dequeueStat #-}
dequeueStat q t' i =
Event $ \p ->
do let t1 = itemStoringTime i
t = pointTime p
invokeEvent p $
modifyRef (dequeueWaitTimeRef q) $
addSamplingStats (t - t')
invokeEvent p $
modifyRef (queueWaitTimeRef q) $
addSamplingStats (t - t1)
queueChanged_ :: MonadDES m => Queue m sm so a -> Signal m ()
{-# INLINABLE queueChanged_ #-}
queueChanged_ q =
mapSignal (const ()) (enqueueStored q) <>
dequeueRequested q <>
mapSignal (const ()) (dequeueExtracted q)
queueSummary :: (MonadDES m, Show sm, Show so) => Queue m sm so a -> Int -> Event m ShowS
{-# INLINABLE queueSummary #-}
queueSummary q indent =
do let sm = enqueueStoringStrategy q
so = dequeueStrategy q
null <- queueNull q
count <- queueCount q
countStats <- queueCountStats q
enqueueStoreCount <- enqueueStoreCount q
dequeueCount <- dequeueCount q
dequeueExtractCount <- dequeueExtractCount q
enqueueStoreRate <- enqueueStoreRate q
dequeueRate <- dequeueRate q
dequeueExtractRate <- dequeueExtractRate q
waitTime <- queueWaitTime q
dequeueWaitTime <- dequeueWaitTime q
let tab = replicate indent ' '
return $
showString tab .
showString "the storing (memory) strategy = " .
shows sm .
showString "\n" .
showString tab .
showString "the dequeueing (output) strategy = " .
shows so .
showString "\n" .
showString tab .
showString "empty? = " .
shows null .
showString "\n" .
showString tab .
showString "the current size = " .
shows count .
showString "\n" .
showString tab .
showString "the size statistics = \n\n" .
timingStatsSummary countStats (2 + indent) .
showString "\n\n" .
showString tab .
showString "the enqueue store count (number of the input items that were stored) = " .
shows enqueueStoreCount .
showString "\n" .
showString tab .
showString "the dequeue count (number of requests for dequeueing an item) = " .
shows dequeueCount .
showString "\n" .
showString tab .
showString "the dequeue extract count (number of the output items that were dequeued) = " .
shows dequeueExtractCount .
showString "\n" .
showString tab .
showString "the enqueue store rate (how many input items were stored per time) = " .
shows enqueueStoreRate .
showString "\n" .
showString tab .
showString "the dequeue rate (how many requests for dequeueing per time) = " .
shows dequeueRate .
showString "\n" .
showString tab .
showString "the dequeue extract rate (how many output items were dequeued per time) = " .
shows dequeueExtractRate .
showString "\n" .
showString tab .
showString "the wait time (when was stored -> when was dequeued) = \n\n" .
samplingStatsSummary waitTime (2 + indent) .
showString "\n\n" .
showString tab .
showString "the dequeue wait time (when was requested for dequeueing -> when was dequeued) = \n\n" .
samplingStatsSummary dequeueWaitTime (2 + indent)
resetQueue :: MonadDES m => Queue m sm so a -> Event m ()
{-# INLINABLE resetQueue #-}
resetQueue q =
Event $ \p ->
do let t = pointTime p
queueCount <- invokeEvent p $ readRef (queueCountRef q)
invokeEvent p $ writeRef (queueCountStatsRef q) $
returnTimingStats t queueCount
invokeEvent p $ writeRef (enqueueStoreCountRef q) 0
invokeEvent p $ writeRef (dequeueCountRef q) 0
invokeEvent p $ writeRef (dequeueExtractCountRef q) 0
invokeEvent p $ writeRef (queueWaitTimeRef q) mempty
invokeEvent p $ writeRef (dequeueWaitTimeRef q) mempty