gistfile1.hs

import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import Data.Int
import System.Environment

sendSidewards :: Chan Int -> Chan Int -> IO ()
sendSidewards from to = do
    n <- readChan from
    writeChan to n
    sendSidewards from to

sendLeft :: Chan Int -> IO ()
sendLeft left = do
    n <- readChan left
    writeChan left n
    sendLeft left

makeTrack :: Chan Int -> Int -> IO ()
makeTrack left nRemaining =
    if nRemaining > 0
    then midTrack left nRemaining
    else sendLeft left

midTrack :: Chan Int -> Int -> IO ()
midTrack left nRemaining = do
    right <- newChan
    forkIO $ makeTrack right (nRemaining - 1)
    forkIO $ sendSidewards left right
    sendSidewards right left

launchRunner :: Chan Int -> Int -> IO ()
launchRunner chan num = do
    writeChan chan num

doRace :: Chan Int -> TMVar [Int] -> Int -> IO ()
doRace start resultChan numRunners = do
    let runners = [1..numRunners]
    let launchRunnerOnChan = launchRunner start
    forkIO $ mapM_ launchRunnerOnChan runners
    finishLine start numRunners [] resultChan

finishLine :: Chan Int -> Int -> [Int] -> TMVar [Int] -> IO ()
finishLine inChan remaining results resultChan =
    if remaining > 0 then do
        res <- receiveResults inChan
        finishLine inChan (remaining - 1) (res:results) resultChan
    else atomically $ putTMVar resultChan results

receiveResults :: Chan Int -> IO Int
receiveResults inChan = readChan inChan

main = do
    numRunners:numThreads:_ <- getArgs
    racerA <- newChan
    racerB <- newChan
    forkIO $ makeTrack racerA $ read numThreads
    forkIO $ makeTrack racerB $ read numThreads
    resultsA <- newEmptyTMVarIO
    resultsB <- newEmptyTMVarIO
    forkIO $ doRace racerA resultsA $ read numRunners
    forkIO $ doRace racerB resultsB $ read numRunners
    awaitWinner resultsA resultsB

readFrom :: a -> TMVar b -> STM (a, b)
readFrom tag var = do
    val <- takeTMVar var
    return (tag, val)

awaitWinner :: TMVar [Int] -> TMVar [Int] -> IO ()
awaitWinner aResult bResult = do
    (name, result) <- atomically $
        readFrom "a" aResult `orElse` readFrom "b" bResult
    printWinner result name

varReady :: MVar [Int] -> IO Bool
varReady var = do
    empty <- isEmptyMVar var
    return (not empty)

printWinner :: [Int] -> String -> IO ()
printWinner nums name = do
    putStrLn $ name ++ " won!"
    putStrLn $ show nums