module Main where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import System.Random


data Fork = Fork Int (TMVar ())

forkID :: Fork -> Int
forkID (Fork id _) = id

newFork :: Int -> STM Fork
newFork id = do v <- newTMVar (); return (Fork id v)

inUse :: Fork -> STM Bool
inUse (Fork _ v) = isEmptyTMVar v

takeFork :: Fork -> STM ()
takeFork (Fork _ v) = takeTMVar v

releaseFork :: Fork -> STM ()
releaseFork (Fork _ v) = putTMVar v ()

forkMnemonic :: Bool -> String
forkMnemonic inUse = if inUse then "    " else "--=="


data Philosopher
    = Philosopher
    { phName   :: String
    , phState  :: TVar PhState
    , phThread :: ThreadId
    , phLeftFork, phRightFork :: Fork
    }
data PhState = Thinking | Eating | Hungry deriving (Show,Eq,Enum,Bounded)

newPhilosopher :: String -> Fork -> Fork -> STM () -> IO Philosopher
newPhilosopher name leftFork rightFork notify =
    do st <- atomically (newTVar Thinking)
       let setState x = writeTVar st x >> notify
           lifecycle = do randomWait
                          atomically $ do setState Hungry
                          atomically $ do takeFork leftFork
                                          takeFork rightFork
                                          setState Eating
                          randomWait
                          atomically $ do releaseFork leftFork
                                          releaseFork rightFork
                                          setState Thinking
                          lifecycle
       th <- forkIO lifecycle
       return Philosopher{ phName = name, phThread = th, phState = st
                         , phLeftFork  = leftFork, phRightFork = rightFork
                         }
    where randomWait = randomRIO (500000, 2000000) >>= threadDelay


data State = State [(Philosopher,PhState)] [(Fork,Bool)]

getState :: [Philosopher] -> [Fork] -> STM State
getState philosophers forks =
    do s1 <- mapM (\p -> do s <- readTVar (phState p); return (p,s)) philosophers
       s2 <- mapM (\f -> do x <- inUse f; return (f,x)) forks
       return (State s1 s2)

showState :: State -> (String,Int)
showState (State s1 s2) = (header ++ body ++ footer, row)
    where row = 2 + length s1
          header = concatMap (\x -> show x ++ ":" ++ show (length $ filter (x==) $ map snd s1) ++ " ")
                             [minBound..maxBound]
                   ++ "   Forks in use:" ++ show (length $ filter (True==) $ map snd s2) ++ "\n"
          body   = concatMap (\(p,s) -> show ( forkID $ phLeftFork  p
                                             , forkID $ phRightFork p
                                             )
                                        ++ " " ++ phName p ++ " is " ++ show s ++ ".    \n") s1
          footer = concatMap (\(f,inUse) -> show (forkID f) ++ ":" ++ forkMnemonic inUse ++ " ") s2 ++ "\n"

displayState :: State -> IO ()
displayState st = do putStr str; putStr $ "\x1B[" ++ show (row+1) ++ "A\n" -- move cursor upward
    where (str,row) = showState st


philosopherNames = ["Socrates", "Plato", "Aristotle", "Zenon", "Epikouros", "Tarres", "Pythagoras"]

main :: IO ()
main = do sig <- atomically newEmptyTMVar
          let num = length philosopherNames
              notify = putTMVar sig ()
          forks <- atomically $ sequence (map newFork [0..num-1])
          philosophers <- sequence [ newPhilosopher name (forks!!l) (forks!!r) notify
                                   | (name,l) <- zip philosopherNames [0..num-1], let r = (l+1) `mod` num ]

          let loop = atomically (takeTMVar sig >> getState philosophers forks) >>= displayState >> loop
          forkIO loop

          getChar
          return ()