Skip to content

Instantly share code, notes, and snippets.

@luisgabriel
Forked from egonSchiele/diners.hs
Last active October 9, 2015 18:54
Show Gist options
  • Save luisgabriel/9fe8b782e44a72ac94e8 to your computer and use it in GitHub Desktop.
Save luisgabriel/9fe8b782e44a72ac94e8 to your computer and use it in GitHub Desktop.
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 ()
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 $
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment