Skip to content

Instantly share code, notes, and snippets.

Last active April 23, 2022 17:29
  • Star 12 You must be signed in to star a gist
  • Fork 6 You must be signed in to fork a gist
Star You must be signed in to star a gist
What would you like to do?
Dining philosophers solution in Haskell using STM. Taken from 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.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment