mirror of
https://github.com/logos-storage/transport-over-mix.git
synced 2026-07-22 02:20:21 +00:00
59 lines
1.7 KiB
Haskell
59 lines
1.7 KiB
Haskell
|
|
-- | Discrete event simulation
|
|
|
|
{-# LANGUAGE BangPatterns, StrictData, ScopedTypeVariables #-}
|
|
module Simulate.DiscreteEvents where
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
import Data.List
|
|
import qualified Data.PQueue.Prio.Min as Prio
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
type Time = Double
|
|
|
|
type Queue a = Prio.MinPQueue Time a
|
|
|
|
data Event a = Event
|
|
{ eventOccuredAt :: !Time
|
|
, eventPayload :: !a
|
|
}
|
|
deriving (Eq,Show)
|
|
|
|
data Action a
|
|
= NewEvent (Event a)
|
|
deriving (Eq,Show)
|
|
|
|
insertNewEvent :: Action a -> Queue a -> Queue a
|
|
insertNewEvent (NewEvent (Event !t !payload)) !queue = Prio.insert t payload queue
|
|
|
|
insertNewEvents :: [Action a] -> Queue a -> Queue a
|
|
insertNewEvents actions !queue = foldl' (flip insertNewEvent) queue actions
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
type KickStart s a = IO ([Action a],s)
|
|
type EventHandler s a = Event a -> s -> IO ([Action a],s)
|
|
|
|
simulateEvents :: forall s a. KickStart s a -> EventHandler s a -> Time -> IO s
|
|
simulateEvents kickStart handler stopTime =
|
|
|
|
do
|
|
(!actions0,!state0) <- kickStart
|
|
let !queue0 = insertNewEvents actions0 Prio.empty
|
|
go queue0 state0
|
|
|
|
where
|
|
go :: Queue a -> s -> IO s
|
|
go !queue !state = case Prio.getMin queue of
|
|
Nothing -> return state
|
|
Just (!time, !payload) -> do
|
|
(!actions, !state') <- handler (Event time payload) state
|
|
let !queue' = insertNewEvents actions queue
|
|
if time <= stopTime
|
|
then go queue' state'
|
|
else return state'
|
|
|
|
--------------------------------------------------------------------------------
|