diners.hs

import Control.Concurrent
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class

type Fork = MVar Int

newFork :: Int -> IO Fork
newFork i = newMVar i

takeFork :: Fork -> IO Int
takeFork fork = takeMVar fork

releaseFork :: Int -> Fork -> IO ()
releaseFork i fork = putMVar fork i

runPhilosopher :: MVar Int -> String -> (Fork, Fork) -> IO ()
runPhilosopher sem name (left, right) = do
    forM_ [1..5] $ \_ -> do
        leftNum <- takeFork left
        rightNum <- takeFork right

        threadDelay 100000 -- threadDelay uses nanoseconds.

        releaseFork leftNum left
        releaseFork rightNum right

        threadDelay 100000

    takeMVar sem >>= (\s -> putMVar sem (s + 1))

philosophers = ["Aristotle", "Kant", "Spinoza", "Marx", "Russel"]

main = do
    forks <- mapM newFork [1..5]
    sem <- newMVar 0

    let namedPhilosophers     = map (runPhilosopher sem) philosophers
        forkPairs             = zip forks (tail . cycle $ forks)
        philosophersWithForks = zipWith ($) namedPhilosophers forkPairs

    mapM_ forkIO philosophersWithForks

    runMaybeT $ forever $ do
        s <- lift $ readMVar sem
        when (s == 5) mzero
        lift $ threadDelay 100000

    return ()

output

luisgabriel ~/dining  $ ghc --make diners.hs -o main -O2 -threaded -rtsopts
[1 of 1] Compiling Main             ( diners.hs, diners.o )
Linking main ...
luisgabriel ~/dining  $ time ./main +RTS -N4

real    0m1.409s
user    0m0.003s
sys     0m0.013s
luisgabriel ~/dining  $ time ./main +RTS -N4

real    0m1.409s
user    0m0.013s
sys     0m0.000s
luisgabriel ~/dining  $ time ./main +RTS -N4

real    0m1.409s
user    0m0.003s
sys     0m0.010s
luisgabriel ~/dining  $