[Haskell-cafe] process simulation in functional style

[Alexander Vodomerov]

  Hello!

I'm writing a program that simulates multiple processes. The processes may
send/receive messages, do some work, or sleep for some amount of time.

I have seen that many such things can be expressed in Haskell in very
elegant manner using it functional or lazy properties. For example,
client/server interaction may be expressed via inifinite lists as shown
in "Gentle Introduction to Haskell". Another way of process simulation
is describied in http://citeseer.ist.psu.edu/harcourt95extensible.html,
where simple and concise CCS interperter is constructed.

I've tried to apply the idea of infinite lists or CCS-style processes,
but fail. The main reason is that:

1) messages are asynchronous (it may be received and handled while
process are sleeping, without waking them)
2) in some cases received message may wake up process
3) all activity in system is ordered by time
4) there are >2 process and during simulations new processes may be
created

I've no idea how to implement 1, 2 in CCS interpeter.
The approach of infinite lists seems to have problems with 3, 4.

Have somebody any ideas how this can be solved in simple and concise way? 

With best regards,
    Alexander.

PS. Currently I have some code (see below), but it is VERY UGLY. The
main drawback is that is very "imperative". It employs notion of "Global
state".  It doesn't use features of Haskell and can be rewritten in ML
or C++ without changes. Another flaws is that it is very unextensible,
and all processes must have the same state.

-- example code

latency = 0.001

type Message = String
type MsgM = WriterT [(Int, Message)] IO  -- process may send messages

-- process states

next id = (id + 1) `mod` 3

type State = (Int, Int, Double) -- proc. number, counter, interval

do_step :: State -> MsgM (Double, State) --- do something and then sleep
do_step (id, cnt, delay) = do
  tell [(next id, "ping " ++ show id ++ " cnt " ++ show cnt)]
  return (delay, (id, cnt + 1, delay))

handle_message :: Message -> State -> MsgM State
handle_message msg (id, cnt, delay) = do
    -- liftIO $ putStrLn $ show id ++ " received  msg " ++ msg
    if msg !! 0 == 'p' then tell [(next id, "reply " ++ show id ++ " to " ++ msg)] else return ()
    return (id, cnt, delay)

-- global event queue

data Event = MsgRecv Message | Work deriving Show
type EventQueue = [(Double, Int, Event)]
    
compare_event (t1, n1, e1) (t2, n2, e2) = compare t1 t2

type EventM = WriterT EventQueue IO

queue_event :: Int -> Event -> Double -> EventM ()
queue_event dest ev time = tell [(time, dest, ev)]

type FullState = Map.Map Int State

handle_event :: Int -> Double -> Event -> FullState -> EventM FullState
handle_event procnum time ev fullstate  = do
    let localstate = (fullstate Map.! procnum)
    case ev of
      MsgRecv msg -> do
              (nstate, messages) <- lift $ runWriterT (handle_message msg localstate)
              sequence_ $ map (\(dst, msg) -> queue_event dst (MsgRecv msg) (time + latency)) messages
              return $ Map.insert procnum nstate fullstate
      Work -> do
              ((pause, nstate), messages) <- lift $ runWriterT (do_step localstate)
              sequence_ $ map (\(dst, msg) -> queue_event dst (MsgRecv msg) (time + latency)) messages
              queue_event procnum Work (time + pause)
              return $ Map.insert procnum nstate fullstate                                

run_queue :: FullState -> EventQueue -> IO ()
run_queue st eventqueue =
    case eventqueue of
      [] -> return ()
      (time, dest, ev) : rest -> do
                      putStrLn $ "processing event " ++ (showFFloat (Just 3) time) "" ++ " at procnum " ++ show dest ++ " "  ++ show ev
                      (nst, nev) <- runWriterT (handle_event dest time ev st)
                      let nqueue = foldl (\res -> \e -> insertBy compare_event e res) rest nev
                      run_queue nst nqueue

init_state = Map.fromList [(0, (0, 0, 0.3)), (1, (1, 0, 0.4)), (2, (2, 0, 0.5))]

main = run_queue init_state [(0, 0, Work), (0, 1, Work)]