Editing Shootout/Chameneos (section)

== MVar version, no manager ==
Posted by AaronDenney

<haskell>
{-# OPTIONS -O2 -funbox-strict-fields #-}
{- The Computer Language Shootout
   http://shootout.alioth.debian.org/
   http://shootout.alioth.debian.org/benchmark.php?test=chameneos&lang=all
-}
import Control.Concurrent
import Control.Monad
import System (getArgs)
import GHC.Base

type Color = Int
red = 0; yellow = 1; blue = 2; faded = 3

complement :: Color -> Color -> Color
complement a b | a == b    = a
               | otherwise = 3 - a - b

data Meeting = M !(MVar ()) !(MVar Int) !(MVar (Color, MVar Color))

new_meeting = do
        lock <- newMVar ()
        meets <- newMVar 0
        chameno <- newEmptyMVar
        return $ M lock meets chameno

wait_other (M lock meets waiting) wake_up color = do
        _ <- takeMVar lock
        global_meets <- readMVar meets
        other_in <- tryTakeMVar waiting
        other_c  <- case other_in of Nothing     -> sleep_on lock waiting color wake_up
                                     Just (c, w) -> wake_waiter lock w c color meets
        return (other_c, global_meets + 1)

wake_waiter lock wake_up c color meets = do
        met <- takeMVar meets
        putMVar meets (met + 1)
        putMVar wake_up color
        putMVar lock ()
        return c

sleep_on lock waiting color wake_up =
    do putMVar waiting (color, wake_up)
       putMVar lock ()
       takeMVar wake_up

creature meeting_place max_meets report wake_up start_color =
        do meets <- inner_creature start_color 0
           putMVar report meets
        where inner_creature color have_met = do
                color `seq` have_met `seq` return ()
                (other, global_meets) <- wait_other meeting_place wake_up color
                if (global_meets > max_meets) then
                   return (have_met) else
                   inner_creature (complement color other) (have_met + 1)

main = do 
  args <- getArgs
  meeting_place <- new_meeting
  let meetings = if null args then (1000000::Int) else (read . head) args
      spawn :: Int -> IO (MVar Int)
      spawn startingColor = do
        metVar <- newEmptyMVar
        pobox  <- newEmptyMVar
        forkIO $ creature meeting_place meetings metVar pobox startingColor 
        return metVar

  metVars <- mapM spawn [blue, red, yellow, blue]
  vals <- mapM takeMVar metVars
  print $ sum vals
</haskell>

[[Category:Code]]