diners.hs

import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import System.Random
import Text.Printf

-- Forks
type Fork = TMVar Int
 
newFork :: Int -> IO Fork
newFork i = newTMVarIO i

takeFork :: Fork -> STM Int
takeFork fork = takeTMVar fork
 
releaseFork :: Int -> Fork -> STM ()
releaseFork i fork = putTMVar fork i

-- Philosophers
runPhilosopher :: String -> (Fork, Fork) -> IO ()
runPhilosopher name (left, right) = forever $ do
  putStrLn (name ++ " is hungry.")
 
  (leftNum, rightNum) <- atomically $ do
    leftNum <- takeFork left
    rightNum <- takeFork right
    return (leftNum, rightNum)
 
  putStrLn $ printf "%s got forks %d and %d and is now eating" name leftNum rightNum
  delay <- randomRIO (1,3)
  threadDelay (delay * 1000000)
  putStrLn (name ++ " is done eating. Going back to thinking.")
 
  atomically $ do
    releaseFork leftNum left
    releaseFork rightNum right
 
  delay <- randomRIO (1, 3)
  threadDelay (delay * 1000000)
 
philosophers :: [String]
philosophers = ["Aristotle", "Kant", "Spinoza", "Marx", "Russell"]
 
main = do
  forks <- mapM newFork [1..5]
  let namedPhilosophers     = map runPhilosopher philosophers
      forkPairs             = zip forks (tail . cycle $ forks)
      philosophersWithForks = zipWith ($) namedPhilosophers forkPairs
 
  putStrLn "Running the philosophers. Press enter to quit."
 
  mapM_ forkIO philosophersWithForks
 
  -- All threads exit when the main thread exits.
  getLine