哲学家晚餐问题的Haskell求解

最近上课讲到，哲学家晚餐死锁避免，然后发现张凇这里的代码是空白，0Bite,以为是我自己的下载错了，点开第一版源代码，发现：
也是空白，然后第二版的代码好像也没找了，然后找到了神网站http://rosettacode.org/wiki/Rosetta_Code

哲学家晚餐问题全家桶

 
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import System.Random
 
-- TMVars are transactional references. They can only be used in transactional actions.
-- They are either empty or contain one value. Taking an empty reference fails and
-- putting a value in a full reference fails. A transactional action only succeeds
-- when all the component actions succeed, else it rolls back and retries until it
-- succeeds.
-- The Int is just for display purposes.
type Fork = TMVar Int
 
newFork :: Int -> IO Fork
newFork i = newTMVarIO i
 
-- The basic transactional operations on forks
takeFork :: Fork -> STM Int
takeFork fork = takeTMVar fork
 
releaseFork :: Int -> Fork -> STM ()
releaseFork i fork = putTMVar fork i
 
type Name = String
 
runPhilosopher :: Name -> (Fork, Fork) -> IO ()
runPhilosopher name (left, right) = forever $ do
  putStrLn (name ++ " is hungry.")
 
  -- Run the transactional action atomically.
  -- The type system ensures this is the only way to run transactional actions.
  (leftNum, rightNum) <- atomically $ do
    leftNum <- takeFork left
    rightNum <- takeFork right
    return (leftNum, rightNum)
 
  putStrLn (name ++ " got forks " ++ show leftNum ++ " and " ++ show rightNum ++ " and is now eating.")
  delay <- randomRIO (1,10)
  threadDelay (delay * 1000000) -- 1, 10 seconds. threadDelay uses nanoseconds.
  putStrLn (name ++ " is done eating. Going back to thinking.")
 
  atomically $ do
    releaseFork leftNum left
    releaseFork rightNum right
 
  delay <- randomRIO (1, 10)
  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.
  getLine
 

然后网站的Haskell上述源代码好像出了点问题，

好吧，其实我也很好奇这个乱码部分的原因是什么，求解。
然后，换个写法吧。

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

type Fork = TVar Bool
type StringBuffer = TChan String

philosopherNames :: [String]
philosopherNames = map show ([1..] :: [Int])

logThinking :: String -> StringBuffer -> STM ()
logThinking name buffer = writeTChan buffer $ name ++ " is thinking..."

logEating :: String -> StringBuffer -> STM ()
logEating name buffer = writeTChan buffer $ name ++ " is eating..."

firstLogEntry :: StringBuffer -> STM String
firstLogEntry buffer = do empty <- isEmptyTChan buffer
                          if empty then retry
                                   else readTChan buffer

takeForks :: Fork -> Fork -> STM ()
takeForks left right = do leftUsed <- readTVar left
                          rightUsed <- readTVar right
                          if leftUsed || rightUsed
                             then retry
                             else do writeTVar left True
                                     writeTVar right True

putForks :: Fork -> Fork -> STM ()
putForks left right = do writeTVar left False
                         writeTVar right False

philosopher :: String -> StringBuffer -> Fork -> Fork -> IO ()
philosopher name out left right = do atomically $ logThinking name out
                                     randomDelay
                                     atomically $ takeForks left right
                                     atomically $ logEating name out
                                     randomDelay
                                     atomically $ putForks left right

randomDelay :: IO ()
randomDelay = do delay <- getStdRandom(randomR (1,3))
                 threadDelay (delay * 1000000)

main :: IO ()
main = do let n = 8
          forks <- replicateM n $ newTVarIO False
          buffer <- newTChanIO
          forM_ [0 .. n - 1] $ \i ->
              do let left = forks !! i
                     right = forks !! ((i + 1) `mod` n)
                     name = philosopherNames !! i
                 forkIO $ forever $ philosopher name buffer left right

          forever $ do str <- atomically $ firstLogEntry buffer
                       putStrLn str

老铁，没毛病，(-_-#.