philosophers.hs

import qualified Data.Map as M
import Data.Map ((!))
import Text.Printf

data Queue a = Queue [a] [a]
             deriving Show

data Fork = Free | Used
          deriving Show
type ForkMap = M.Map Int Fork

type Phil = (Int, PhilState)
data PhilState = Waiting | Dinning
               deriving Show

type Dinner = (Queue Phil, ForkMap)

enq :: Queue a -> a -> Queue a
enq (Queue xs ys) y = Queue xs (y:ys)

queue :: [a] -> Queue a
queue ls = Queue ls []

isEmpty :: Queue a -> Bool
isEmpty (Queue [] []) = True
isEmpty (Queue _ _) = False

deq :: Queue a -> (a, Queue a)
deq (Queue [] []) = error "empty queue"
deq (Queue (x:xs) ys) = (x, Queue xs ys)
deq (Queue [] ys) = deq $ Queue (reverse ys) []

acquireFork :: Int -> ForkMap -> Maybe ForkMap
acquireFork (-1) fm = acquireFork 4 fm
acquireFork 5 fm = acquireFork 0 fm
acquireFork n fm = case fm!n of
  Used -> Nothing
  Free -> Just $ M.insert n Used fm

acquireForks :: Int -> ForkMap -> Maybe ForkMap
acquireForks n fm = acquireFork n fm >>= acquireFork (n+1)

freeFork :: Int -> ForkMap -> ForkMap
freeFork (-1) fm = freeFork 4 fm
freeFork 5 fm = freeFork 0 fm
freeFork n fm = M.insert n Free fm

freeForks :: Int -> ForkMap -> ForkMap
freeForks n = freeFork n . freeFork (n+1)

-- Return count of iterations to feed them all
feed :: Int -> Dinner -> Int
feed n (q, fm)
  | isEmpty q = n
  | otherwise = feed (n+1) next
    where
      (p@(pid, pstate), q') = deq q
      next = case pstate of
        Waiting -> case acquireForks pid fm of
          Nothing -> (enq q' p, fm)
          Just fm' -> (enq q' (pid, Dinning), fm')
        Dinning -> (q', freeForks pid fm)

initForks = M.fromList [(i, Free) | i <- [0..4]]
initPhils = queue [(i, Waiting) | i <- [0..4]]

startDinner = feed 1 (initPhils, initForks)