Real World HakellのSTMの章がなんか消化不良だったのでなんかないかなぁと探したら、ビューティフルコードにSTMの章があったのを思い出したので、早速読んだ。

ちなみに英語のはここ

• Beautiful concurrency

サンタクロース問題わかりやすい。ついでに動かしてみたけどControl.Monadもインポートしないと動かない@GHC6.12.3

module Main where
import Control.Concurrent.STM
import Control.Concurrent
import Control.Monad
import System.Random

meetInStudy :: Int -> IO ()
meetInStudy id = putStr ("Elf " ++ show id ++ " meeting in the study\n")

deliverToys :: Int -> IO ()
deliverToys id = putStr ("Reindeer " ++ show id ++ " delivering toys\n")

helper1 :: Group -> IO () -> IO ()
helper1 group do_task = do
  (in_gate, out_gate) <- joinGroup group
  passGate in_gate
  do_task
  passGate out_gate

elf1, reindeer1 :: Group -> Int -> IO ()
elf1      gp id = helper1 gp (meetInStudy id)
reindeer1 gp id = helper1 gp (deliverToys id)

data Gate = MkGate Int (TVar Int)

newGate :: Int -> STM Gate
newGate n = do { tv <- newTVar 0; return (MkGate n tv)}

passGate :: Gate -> IO ()
passGate (MkGate n tv) = atomically (do n_left <- readTVar tv
                                        check (n_left > 0)
                                        writeTVar tv (n_left-1))

operateGate :: Gate -> IO ()
operateGate (MkGate n tv) = do
  atomically (writeTVar tv n)
  atomically (do {n_left <- readTVar tv; check (n_left == 0)})


data Group = MkGroup Int (TVar (Int, Gate, Gate))

newGroup :: Int -> IO Group
newGroup n = atomically ( do g1 <- newGate n
                             g2 <- newGate n
                             tv <- newTVar (n, g1, g2)
                             return (MkGroup n tv))

joinGroup :: Group -> IO (Gate, Gate)
joinGroup (MkGroup n tv) 
    = atomically (do (n_left, g1, g2) <- readTVar tv
                     check (n_left > 0)
                     writeTVar tv (n_left-1, g1, g2)
                     return (g1,g2))

awaitGroup :: Group -> STM (Gate, Gate)
awaitGroup (MkGroup n tv)
    = do (n_left, g1, g2) <- readTVar tv
         check (n_left == 0)
         new_g1 <- newGate n; new_g2 <- newGate n
         writeTVar tv (n,new_g1,new_g2)
         return (g1, g2)

randomDelay :: IO ()
randomDelay = do
  waitTime <- getStdRandom (randomR (1, 1000000))
  threadDelay waitTime

elf :: Group -> Int -> IO ThreadId
elf gp id = forkIO (forever (do {elf1 gp id; randomDelay}))

reindeer :: Group -> Int -> IO ThreadId
reindeer gp id = forkIO (forever (do {reindeer1 gp id; randomDelay}))

santa :: Group -> Group -> IO ()
santa elf_gp rein_gp = do
  putStr "--------------------------\n"
  choose [(awaitGroup rein_gp, run "deliver toys"), (awaitGroup elf_gp, run "meet in my study")]
  where
    run :: String -> (Gate, Gate) -> IO ()
    run task (in_gate, out_gate) = do
                         putStr ("Ho! Ho! Ho! let's " ++ task ++ "\n")
                         operateGate in_gate
                         operateGate out_gate

choose :: [(STM a, a -> IO ())] -> IO ()
choose choices = do act <- atomically (foldr1 orElse actions)
                    act
    where 
      actions :: [STM (IO ())]
      actions = [do {val <- guard; return (rhs val)} | (guard, rhs) <- choices ]

main = do
  elf_group <- newGroup 3
  sequence_ [ elf elf_group n | n <- [1..10]]
  rein_group <- newGroup 9
  sequence_ [reindeer rein_group n | n <- [1..9]]
  forever (santa elf_group rein_group)

で、なんでputStrLn使わないのかなぁとか思いつつ、自分でputStrLn使って書いたコードを実行したら

--------------------------
Ho! Ho! Ho! let's deliver toys
Reindeer 4 delivering toys
Reindeer 6 delivering toysReindeer 5 delivering toysReindeer 7 delivering \
toysReindeer 2 delivering toysReindeer 3 delivering toysReindeer 9 \
delivering toysReindeer 8 delivering toysReindeer 1 delivering toys

みたいに文字が出力された後に改行がずらずら出力されることがある。

あー！と思ってソースを見たら

putStrLn        :: String -> IO ()
putStrLn s      =  do putStr s
                      putChar '\n'

という定義だった。というわけで、putStrじゃないといけない理由がわかった。

ビューティフルコード
Brian Kernighan,Jon Bentley,まつもとゆきひろ
オライリージャパン / ￥ 3,990 ()
在庫あり。