DouKaku?

module Main (main) where

import Control.Concurrent
import Data.List
import Data.Time
import System.Environment
import System.IO
import System.Random
import Text.Printf

type Done     = ()      -- ワーカ終了合図
type Work     = IO ()   -- 仕事
type WorkID   = Int     -- 仕事番号
type Task     = (QSemN, Either Done Work) -- タスク(１クールセマフォ，仕事)
type Conn     = MVar Task -- ワーカにタスクを渡す口
type Worker   = IO ()     -- ワーカ
type WorkerID = Int       -- ワーカ番号

main :: IO ()
main = do {
; a:_ <- getArgs
; g <- getStdGen
; let { n = read a; rs = map (10^6*) $ randomRs (5,15) g ; cours = mkcours n rs}
; ps <- workerSems  n -- ワーカの状態を知るためのセマフォ
; cs <- connections n -- メインスレッドからワーカスレッドへの仕事を渡すための口
; mapM_ forkIO $ zipWith3 mkWorker [1..n] ps cs -- ワーカスレッドプール作成
; qn <- newQSemN n                           -- ワークの終了を知るためのセマフォ
; deliver qn cs (map Right $ cours !! 0)     -- 一回目の仕事の割り振り
; waitQSemN qn (2*n);                        -- 一クールの終了待ち
; signalQSemN qn n                           -- セマフォのリセット
; deliver qn cs (map Right $ cours !! 1)     -- 二回目の仕事の割り振り
; waitQSemN qn (2*n);                        -- 一クールの終了待ち
; signalQSemN qn n                           -- セマフォのリセット
; deliver qn cs (replicate n $ Left ())      -- ワーカに終了の合図
; mapM_ waitQSem ps                          -- すべてのワーカの終了を待ち
; hPutStrLn stderr "Main thread finished."
}

workerSems :: Int -> IO [QSem]
workerSems n = mapM (const $ newQSem 1) [1..n]

deliverSem :: Int -> IO QSemN
deliverSem = newQSemN

connections :: Int -> IO [Conn]
connections n = mapM (const newEmptyMVar) [1..n]

mkWorker :: WorkerID -> QSem -> Conn -> Worker
mkWorker wid wq conn 
 = do { waitQSem wq
      ; s <- getCurrentTime
      ; hPutStrLn stderr (printf "Worker %d starts at %s" wid (show s))
      ; worker
      ; e <- getCurrentTime
      ; hPutStrLn stderr (printf "Worker %d ends   at %s" wid (show e))
      ; signalQSem wq
      }
 where 
   worker
    = do { mt <- tryTakeMVar conn
         ; case mt of
             Nothing -> yield >> worker
             Just (q,dw)
               -> case dw of
                    Left  ()   -> return ()
                    Right work -> waitQSemN q 1 >> work >> signalQSemN q 2 >> worker
         }

deliver :: QSemN -> [Conn] -> [Either Done Work] -> IO ()
deliver q cs ws = mapM_ (uncurry putMVar) (zip cs (map ((,) q) ws))

slices :: Int -> [a] -> [[a]]
slices n = unfoldr phi
  where phi [] = Nothing
        phi xs = Just $ splitAt n xs

mkcours :: Int -> [Int] -> [[Work]]
mkcours n = slices n . zipWith mkWork [1..]

type MuSec = Int                   -- 遅延microsec(サンプル用)
mkWork :: WorkID -> MuSec -> Work  -- サンプルの仕事作成
mkWork wid musec
 = do { s <- getCurrentTime 
      ; hPutStrLn stderr (printf "Work %d starts at %s" wid (show s))
      ; threadDelay musec
      ; e <- getCurrentTime
      ; hPutStrLn stderr (printf "Work %d ends   at %s" wid (show e))
      }