Editing Shootout/Chameneos (section)

== Current version ==

This takes 20% (or so) less time than the two other versions I downloaded and tested, probably because it does only 3 putMVar and 3 takeMVar per meeting.  It also shifts the responsibility for printing the result onto the last creature to fade; otherwise the printing by the manager thread could be construed as asymmetry.

I can't bear to ditch the field labels and secondary indentation for the sake of a smaller gzipped source file.  But if you want to, please feel free.  *sniff*

Submitted, 17 Nov 2006

Accepted and ranked #1, 18 Nov 2006

<haskell>
{- The Computer Language Shootout
   http://shootout.alioth.debian.org/

   written by Tom Pledger, 13 Nov 2006
   http://www.haskell.org/haskellwiki/Great_language_shootout
-}

import Control.Concurrent
import System

data Colour = Red | Yellow | Blue | Faded
complement Red    Red    = Red
complement Red    Yellow = Blue
complement Red    Blue   = Yellow
complement Yellow Red    = Blue
complement Yellow Yellow = Yellow
complement Yellow Blue   = Red
complement Blue   Red    = Yellow
complement Blue   Yellow = Red
complement Blue   Blue   = Blue
complement _      _      = Faded

data MeetingPlace
    = MP{ quota :: !Int, waiter :: !(Maybe Colour), done :: ![Int] }

main = do args <- getArgs
          mpv <- newMVar MP{ quota = case args of [] -> 1000000; s:_ -> read s,
                             waiter = Nothing, done = [] }
          wakerv <- newEmptyMVar

          let arrive colour tally
                  = do mp <- takeMVar mpv
                       case mp of
                           MP{ quota = 0, done = d }
                               -- Faded now, but nobody wants to know
                               | length d == length subCols
                                           -> print (tally + sum d)
                               | otherwise -> putMVar mpv mp{ done = tally:d }
                           MP{ waiter = Nothing }
                               -> do putMVar mpv mp{ waiter = Just colour }
                                     colour' <- takeMVar wakerv
                                     arrive colour' $! tally + 1
                           MP{ quota = q, waiter = Just colour0 }
                               -> do let colour' = complement colour0 colour
                                     putMVar wakerv $! colour'
                                     putMVar mpv mp{ quota = q - 1,
                                                     waiter = Nothing }
                                     arrive colour' $! tally + 1
              subCols = [Blue, Red, Yellow]

          sequence_ [forkIO (arrive c 0) | c <- subCols]
          arrive Blue 0
          sequence_ [yield | c <- subCols]
</haskell>