Editing Shootout/Chameneos (section)

== STM version ==

This version does not use a separate manager thread.  It employs STM to ensure the semantics of "meet".  The code is not easy to follow, especially since I tweaked things to get it down to 7.6 seconds user time.

<haskell>
{- The Computer Language Shootout
   http://shootout.alioth.debian.org/
   http://shootout.alioth.debian.org/benchmark.php?test=chameneos&lang=all

   contributed by Chris Kuklewicz, 28 Dec 2005
   modified by ...

   This entry does not use a separate thread to manage the meetings
-}

import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad (mapM,foldM,join,liftM)
import System (getArgs)
import Data.IORef

data Color = Red | Yellow | Blue | Faded deriving (Eq)

complement a      b | a==b = a
complement Red    b        = if b==Yellow then Blue   else Yellow
complement Yellow b        = if b==Blue   then Red    else Blue
complement Blue   b        = if b==Red    then Yellow else Red

spawn enter startingColor = do
  metVar <- newEmptyMVar
  let child havemet color = let cps = (\other -> case other of
                                  Faded -> let color = Faded in do putMVar metVar havemet
                                  _ -> (child  $! (havemet+1)) (complement color other))
                            in enter color cps
  forkIO $ child 0 startingColor
  return metVar

main = do args <- getArgs
          let meetings = case args of
                           [] -> 100 :: Int
                           (n:_) -> read n
          togoVar <- newIORef (2*meetings)
          firstVar <- atomically $ newEmptyTMVar
          secondVar <- atomically $ newEmptyTMVar
          let enter color cps = cps =<< (join $ atomicModifyIORef togoVar 
                             (\v -> if (v>0) then let v' = v-1 in v' `seq` (v',meet color) 
                                             else (0,return Faded) ) )
              meet color = join $ atomically $ do
                inFirst <- tryPutTMVar firstVar color
                if inFirst
                  then return $ atomically $ do other <- takeTMVar secondVar
                                                takeTMVar firstVar
                                                return other
                  else do putTMVar secondVar color
                          other <- readTMVar firstVar
                          return $ return other
          metVars <- mapM (spawn enter) [Blue,Red,Yellow,Blue]
          total <- foldM (\tot mv -> takeMVar mv >>= return.(tot+)) (0::Int) metVars
          print total
</haskell>