initial commit

Author: exFalso

CWSim.hs

@@ -0,0 +1,47 @@
+module Main where
+
+import Sim
+import ChainDef
+import Distribution
+import Node
+import EventResult
+
+_LAMBDA = 0.00234797779287925
+_MU     = 0.01690544010873064
+
+chainDef = do
+  src <- createSource (Logged "Customer")
+  sink <- createSink (Logged "Server") (ExpDistr _MU)
+  trans src sink (ExpDistr _LAMBDA)
+
+_DEADLINE = 10000000
+
+simulation = flushAt _DEADLINE
+
+main = do
+  results <- runSimT simulation chainDef
+  
+  let serverResults = reverse $ (map (\(EventResult _ _ t0 t1) -> (t0, t1)) . snd) (head results)
+  print (length serverResults)
+  let diffs = map (uncurry (flip (-))) serverResults
+  let lol = map (\(a, (b, c)) -> (a, c - b)) . uncurry ($)
+            . foldl (\(f, r) x -> let (g, r2) = insert 0 x r in (f . g, r2)) (id, []) $ serverResults
+  let meanQueue = sum (map (\(a, b) -> fromIntegral a * b) lol) / _DEADLINE
+  print meanQueue
+
+type Queuey = (Integer, (Double, Double))
+
+mean m = sum m / fromIntegral (length m)
+
+insert :: Double -> (Double, Double) -> [Queuey] -> ([Queuey] -> [Queuey], [Queuey])
+insert z (s, b) [] = (((0, (z, s)) :), [(1, (s, b))])
+insert z (s, b) ((n, (s2, b2)) : rest) = if s > b2
+                                       then let (f, rst) = insert b2 (s, b) rest in
+                                         (((n, (s2, b2)) :) . f, rst)
+                                       else
+                                         (((n, (s2, s)) :), insertRest b b2 ((n, (s, b2)) : rest))
+                                           where
+                                             insertRest x l [] = [(1, (l, x))]
+                                             insertRest x _ ((n, (s, b)) : rest) =
+                                               if x < b then ((n + 1, (s, x)) : (n, (x, b)) : rest)
+                                               else (n + 1, (s, b)) : insertRest x b rest

ChainDef.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes #-}
+
+module ChainDef where
+
+import Node
+import Distribution
+
+import Data.Map as Map
+import Control.Monad.State
+import Control.Monad.Identity
+
+type Graph = Map.Map NodeId AnyNode
+
+newtype ChainDef a = ChainDef { unChainDef :: StateT NodeId (StateT Graph Identity) a }
+                   deriving (Monad)
+
+runChainDef :: ChainDef a -> (a, Graph)
+runChainDef = (\((a, _), b) -> (a, b)) 
+              . runIdentity
+              . flip runStateT Map.empty
+              . flip runStateT 2 -- 0 and 1 reserved for source/sink
+              . unChainDef
+
+newId :: ChainDef NodeId
+newId = do
+  ChainDef get >>= \n -> ChainDef (put (n + 1)) >> return n
+
+getGraph :: ChainDef Graph
+getGraph = ChainDef (lift get)
+
+putGraph :: Graph -> ChainDef ()
+putGraph = ChainDef . lift . put
+
+trans :: (Distribution d, SrcNode src, DstNode dest) => src -> dest -> d -> ChainDef ()
+trans source target distr = do
+  graph <- getGraph
+  let newNode = addTrans (MkDestNode target, MkDistr distr) (MkSourceNode source)
+  putGraph $ Map.insert (nodeId (nodeInfo newNode)) (toAny newNode) graph
+
+createNode :: NodeClass n => (NodeId -> n) -> ChainDef n
+createNode newNode = do
+  i <- newId
+  graph <- getGraph
+  let node = newNode i
+  putGraph $ Map.insert i (toAny node) graph
+  return node
+  
+
+createInter :: Logged -> ChainDef Inter
+createInter l = createNode (\i -> Inter (NodeInfo i l) [])
+
+createSink :: (Distribution d) => Logged -> d -> ChainDef Sink
+createSink l d = createNode (\i -> Sink (NodeInfo i l) (MkDistr d))
+
+createSource :: Logged -> ChainDef Source
+createSource l = createNode (\i -> Source (NodeInfo i l) [])
+

Distribution.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE GADTs, StandaloneDeriving #-}
+
+module Distribution where
+
+class (Show d) => Distribution d where
+  -- | give a value provided an x with uniform(0,1) distr
+  poke :: d -> Double -> Double
+  
+
+data UniDistr = UniDistr
+              deriving (Show)
+
+instance Distribution UniDistr where
+  poke UniDistr = id
+
+data ExpDistr = ExpDistr { lambda :: Double }
+              deriving (Show)
+
+instance Distribution ExpDistr where
+  poke d x = let l = lambda d in (log (1 - x)) / (-l)
+
+data Distr where
+  MkDistr :: (Show d, Distribution d) => d -> Distr
+deriving instance Show Distr
+

EventResult.hs

@@ -0,0 +1,9 @@
+module EventResult where
+
+import Node
+
+data EventResult = EventResult { eventFrom :: NodeId
+                               , eventTo :: NodeId
+                               , timeFrom :: Double
+                               , timeTo :: Double }
+                   deriving (Show)

Makefile

@@ -0,0 +1,2 @@
+all:
+	ghc --make Sim.hs && ghc --make CWSim.hs -o cwsim

Node.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE GADTs, StandaloneDeriving #-}
+module Node where
+
+import Distribution
+
+import Control.Monad.IO.Class
+
+-- | "flag" passed from user
+data Logged = Logged { logName :: String }
+            | Unlogged
+            deriving (Show)
+class (Show n, NodeClass n) => SrcNode n where
+  addTrans :: Transition -> n -> n
+class (Show n, NodeClass n) => DstNode n where
+
+type NodeId = Integer
+
+type Transition = (DestNode, Distr)
+
+data NodeInfo = NodeInfo { nodeId :: NodeId
+                         , nodeLogged :: Logged }
+              deriving (Show)
+
+data Source = Source NodeInfo [Transition]
+            deriving (Show)
+instance SrcNode Source where
+  addTrans t (Source inf ts) = Source inf (t : ts)
+
+data Sink = Sink NodeInfo Distr
+          deriving (Show)
+instance DstNode Sink where
+
+data Inter = Inter NodeInfo [Transition]
+          deriving (Show)
+instance SrcNode Inter where
+  addTrans t (Inter inf ts) = Inter inf (t : ts)
+instance DstNode Inter where
+  
+data AnyNode = AnyInter Inter
+             | AnySource Source
+             | AnySink Sink
+             deriving (Show)
+
+foldAny :: (Inter -> a) -> (Source -> a) -> (Sink -> a) -> AnyNode -> a
+foldAny a b c d = case d of
+  AnyInter x -> a x
+  AnySource x -> b x
+  AnySink x -> c x
+
+data SourceNode where
+  MkSourceNode :: (NodeClass n, SrcNode n) => n -> SourceNode
+deriving instance Show SourceNode
+
+instance SrcNode SourceNode where
+  addTrans t (MkSourceNode n) = MkSourceNode (addTrans t n)
+  
+data DestNode where
+  MkDestNode :: (NodeClass n, DstNode n) => n -> DestNode
+deriving instance Show DestNode
+  
+
+class (Show n) => NodeClass n where
+  nodeInfo :: n -> NodeInfo
+  transitions :: n -> [Transition]
+  toAny :: n -> AnyNode
+
+instance NodeClass Sink where
+  nodeInfo (Sink n _) = n
+  transitions _ = []
+  toAny = AnySink
+
+instance NodeClass Source where
+  nodeInfo (Source n _) = n
+  transitions (Source _ ts) = ts
+  toAny = AnySource
+
+instance NodeClass Inter where
+  nodeInfo (Inter n _) = n
+  transitions (Inter _ ts) = ts
+  toAny = AnyInter
+
+instance NodeClass AnyNode where
+  nodeInfo a = foldAny nodeInfo nodeInfo nodeInfo a
+  transitions a = foldAny transitions transitions transitions a
+  toAny = id
+
+instance NodeClass DestNode where
+  nodeInfo (MkDestNode n) = nodeInfo n
+  transitions (MkDestNode n) = transitions n
+  toAny (MkDestNode n) = toAny n
+
+instance NodeClass SourceNode where
+  nodeInfo (MkSourceNode n) = nodeInfo n
+  transitions (MkSourceNode n) = transitions n
+  toAny (MkSourceNode n) = toAny n

Random.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}
+module Random ( RandomT, MonadRandom
+               , nextRandom
+               , runRandomT
+               , runRandomTStd) where
+
+import Control.Monad.State
+import Control.Monad.Reader
+import Control.Monad.Trans
+import Control.Monad.Cont
+
+import qualified System.Random as R
+
+newtype RandomT m a = Random { unRandom :: StateT R.StdGen m a }
+                    deriving (Monad, MonadTrans, MonadState R.StdGen, MonadIO)
+
+class Monad m => MonadRandom m where
+  nextRandom :: R.Random a => m a
+
+instance Monad m => MonadRandom (RandomT m) where
+  nextRandom = do
+    g <- get
+    let (r, newG) = R.random g
+    put newG
+    return r
+
+instance (MonadRandom m) => MonadRandom (StateT s m) where
+  nextRandom = lift nextRandom
+
+instance (MonadRandom m) => MonadRandom (ReaderT r m) where
+  nextRandom = lift nextRandom
+
+instance (MonadRandom m) => MonadRandom (ContT r m) where
+  nextRandom = lift nextRandom
+
+runRandomT :: Monad m => RandomT m a -> R.StdGen -> m a
+runRandomT r gen = liftM fst $ runStateT (unRandom r) gen
+
+runRandomTSeed :: Monad m => RandomT m a -> Int -> m a
+runRandomTSeed r seed = liftM fst $ runStateT (unRandom r) (R.mkStdGen seed)
+
+runRandomTStd :: MonadIO m => RandomT m a -> m a
+runRandomTStd r = liftM fst (runStateT (unRandom r) =<< liftIO R.getStdGen)
+
+
+

Sim.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Sim where
+
+import SimChainDef
+import Random
+import Distribution
+import ChainDef
+import Node
+import EventResult
+import SimNode
+
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Identity
+import Control.Monad.IO.Class
+import Control.Monad.Cont
+import Control.Concurrent
+import Control.Concurrent.STM
+import Data.Maybe
+
+import qualified System.Random as R
+import qualified Data.Heap as Heap
+import qualified Data.Map as Map
+
+
+-- | SimT is a transformer representing a simulation
+newtype SimT m a = Sim
+                   { unSim :: ReaderT (ChainDef ())
+                              (ReaderT (Channel MasterEvent)
+                               (ReaderT [ResultVar] m)) a }
+                 deriving (Monad, MonadIO)
+
+instance MonadTrans SimT where
+  lift = Sim . lift . lift . lift
+
+askMaster :: MonadIO m => SimT m (Channel MasterEvent)
+askMaster = Sim . lift $ ask
+
+askResVars :: MonadIO m => SimT m [ResultVar]
+askResVars = Sim . lift . lift $ ask
+
+tellMaster :: Channel MasterEvent -> Double -> MasterEvent -> IO ()
+tellMaster master time event = atomically $ writeTChan master (time, event)
+
+runSimT :: MonadIO m => SimT m a -> ChainDef () -> m a
+runSimT simulation chainDef = do
+  (masterChannel, resultVars, initGraph) <- liftIO $ initialiseSimGraph chainDef
+  let graph = wireUpIncomingSimGraph initGraph
+  let ((), simpleGraph) = runChainDef chainDef
+  let rng = R.getStdGen
+  liftIO $ startThreads graph simpleGraph rng
+  ret <- flip runReaderT resultVars
+         . flip runReaderT masterChannel
+         . flip runReaderT chainDef
+    $ unSim simulation
+  liftIO $ tellMaster masterChannel 0 EventShutdown
+  return ret
+
+startThreads :: SimGraph -> Graph -> IO R.StdGen -> IO R.StdGen
+startThreads graph simpleGraph rng =
+  (\f -> Map.foldWithKey f rng graph) $
+    \nid initInfo lastGen -> do
+      gen <- lastGen
+      anyNode <- return $ 
+                 fromJust (Map.lookup nid simpleGraph)
+      let (aGen, bGen) = R.split gen
+      let f a = forkIO (runRandomT (runNode a initInfo) aGen)
+      foldAny f f f anyNode
+      return bGen
+
+flushAt :: MonadIO m => Double -> SimT m [(NodeId, [EventResult])]
+flushAt time = do
+  master <- askMaster
+  liftIO $ tellMaster master time EventFlush
+  resVars <- askResVars
+  liftIO . flip mapM resVars $ \(nid, tVar) -> atomically $ do
+    res <- readTVar tVar
+    case res of
+      Nothing -> retry
+      Just results -> return (nid, results)