import Control.Concurrent import Control.Concurrent.STM import Control.Monad import System.Random type Fork = TVar Bool newFork :: STM Fork newFork = newTVar True grabFork :: Fork -> STM () grabFork f = do { free <- readTVar f; if free then writeTVar f False else retry } releaseFork :: Fork -> STM () releaseFork f = writeTVar f True -- Grundschema eines Philosophen philosopher :: Int -> Int -> Fork -> Fork -> IO () philosopher iter id fork1 fork2 = forM_ [1..iter] (\_ -> (do { putStrLn (show id ++ " thinking"); randomDelay ; -- Thinking atomically ( do { grabFork fork1 ; grabFork fork2 }); putStrLn (show id ++ " eating"); randomDelay ; -- Eating atomically ( do { releaseFork fork1 ; releaseFork fork2 }) })) randomDelay = do { r <- randomRIO (100000,500000); threadDelay r} main0 = do { forks <- replicateM n (atomically newFork); sequence_ [forkIO (philosopher numiter i (forks!!i) (forks!!((i+1) `mod` n))) | i <- [0..n-1]] ; putStrLn "FINISH!" } n = 5 numiter = 10 type Buffer a = TVar [a] newBuffer :: STM (Buffer a) newBuffer = newTVar [] putBuffer :: Buffer a -> a -> STM () putBuffer b item = do {ls <- readTVar b ; writeTVar b (ls ++ [item]) } getBuffer :: Buffer a -> STM a getBuffer b = do {ls <- readTVar b ; case ls of [] -> retry (item:rest) -> do { writeTVar b rest ; return item }} outputBuffer :: Buffer String -> IO () outputBuffer b = forM_ [1..(n*numiter*2)] (\_ -> (do {str <- atomically (getBuffer b) ; putStrLn str })) philosopher2 :: Int -> Int -> Buffer String -> Fork -> Fork -> IO () philosopher2 iter id out fork1 fork2 = forM_ [1..iter] (\ _ -> (do { atomically (putBuffer out ("Philosopher " ++ show id ++ " is thinking.") ) ; randomDelay ; -- Thinking atomically ( do { grabFork fork1 ; grabFork fork2 }); atomically (putBuffer out ("Philosopher " ++ show id ++ " is eating.") ) ; randomDelay ; -- Eating atomically ( do { releaseFork fork1 ; releaseFork fork2 }) })) main = do { buffer <- atomically newBuffer ; forks <- replicateM n (atomically newFork); sequence_ [forkIO (philosopher2 numiter i buffer (forks!!i) (forks!!((i+1) `mod` n))) | i <- [0..n-1]] ; outputBuffer buffer; putStrLn "FINISH!" }