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!" 
            }