Dining philosophers solution in Haskell using STM. Taken from http://rosettacode.org/wiki/Dining_philosophers#Haskell with some minor modifications.
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", "Russel"] | |
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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment