Shootout/Chameneos

From HaskellWiki
Jump to navigation Jump to search

For this problem, each program should

  • create four differently coloured (blue, red, yellow, blue) concurrent chameneos creatures
  • each creature will repeatedly go to the meeting place and meet, or wait to meet, another chameneos
  • each creature will change colour to complement the colour of the chameneos that they met
  • after N total meetings have taken place, any creature entering the meeting place will take on a faded colour, report the number of creatures it has met, and end
  • write the sum of reported creatures met

Correct output N = 100 is: 200

Compile with "ghc -O2" for better performance. Run with command line parameter of "1000000" (one million).

As of Jan 11 06 they do not accept the meeting thread submissions, as they are not symmetrical. Alternatives will have to be submitted

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

{- 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]

Proposed version

Make Tom's great solution a bit more idiomatic/compress better.

Submitted 2006-11-18

It's lost a bit of speed, which I suspect is because of the boxed pairs in complement. Perhaps this...

complement a b
    = case a of
          Red    -> case b of Yellow -> Blue;   Blue   -> Yellow; _ -> b
          Yellow -> case b of Blue   -> Red;    Red    -> Blue;   _ -> b
          Blue   -> case b of Red    -> Yellow; Yellow -> Red;    _ -> b

...would combine speed and brevity? -- Tom Pledger

{- The Computer Language Shootout
   http://shootout.alioth.debian.org/
   Written by Tom Pledger, 13 Nov 2006. modified by Don Stewart -}

import Control.Concurrent
import Control.Monad
import System

data Colour = Blue | Red | Yellow

complement a b = case (a,b) of
    (Red,Yellow)    -> Blue
    (Red,Blue)      -> Yellow
    (Red,Red)       -> Red
    (Yellow,Blue)   -> Red
    (Yellow,Red)    -> Blue
    (Yellow,Yellow) -> Yellow
    (Blue,Red)      -> Yellow
    (Blue,Yellow)   -> Red
    (Blue,Blue)     -> Blue

colors = [Blue, Red, Yellow]

data MP = MP !Int !(Maybe Colour) ![Int]

main = do n     <- getArgs >>= readIO . head
          waker <- newEmptyMVar
          mpv   <- newMVar $ MP n Nothing []

          let arrive c t = do
                MP q w d <- takeMVar mpv
                case w of
                    _ | q == 0 -> if length d /= 3 then putMVar mpv $ MP 0 w (t:d)
                                                   else print $ t + sum d

                    Nothing    -> do putMVar mpv $ MP q (Just c) d
                                     c' <- takeMVar waker
                                     arrive c' $! t+1

                    Just k     -> do let c' = complement k c
                                     putMVar waker $! c'
                                     putMVar mpv $ MP (q-1) Nothing d
                                     arrive c' $! t+1

          mapM_ (forkIO . flip arrive 0) colors
          arrive Blue 0
          replicateM_ 3 yield

Rejected due to asymmetry and/or colour arithmetic

25% shorter. Also, using -optc-O3 gives a big speedup.

This entry was rejected as "Not a symmetric" (even though it is semantically equivalent to the accepted entry) *sigh*

{-# OPTIONS_GHC -O2 -optc-O3 -funbox-strict-fields #-}
--
-- The Computer Language Shootout
-- http://shootout.alioth.debian.org/
--
-- contributed by Aaron Denney
-- modified by Chris Kuklewicz and Don Stewart
--
-- compile with "ghc --make -O2 -funbox-strict-fields chameneos.hs -o chameneos.ghc_run"
-- run with "./chameneos.ghc_run %A" where %A is the number of meetings
--
-- This is a symmetric solution that does not use a manager thread.
--

import Control.Concurrent
import Control.Monad
import System

data Color = C !Int deriving Eq
red = C 0; yellow = C 1; blue = C 2; faded = C 3

complement (C a) (C b) = if a == b then C a else C (3 - a - b)

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

new_meeting maxMeetings = liftM2 M (newMVar maxMeetings) newEmptyMVar

wait_other (M meets waiting) color wake_up = do
  remainingMeets <- takeMVar meets -- used as lock
  let sleep_on = do putMVar waiting (color, wake_up)
                    putMVar meets remainingMeets
                    takeMVar wake_up
      wake_waiter (other_c,other_wake_up) = do putMVar other_wake_up color
                                               putMVar meets (remainingMeets - 1)
                                               return other_c
  case remainingMeets of
    0 -> putMVar meets 0 >> return faded
    _ -> tryTakeMVar waiting >>= maybe sleep_on wake_waiter

spawnCreature meeting_place startingColor = do
  metVar <- newEmptyMVar
  wake_up  <- newEmptyMVar
  let creature = putMVar metVar =<< inner_creature startingColor (0::Int)
        where inner_creature color have_met = do
                color `seq` have_met `seq` return ()
                other <- wait_other meeting_place color wake_up
                if other == faded
                  then return have_met
                  else inner_creature (complement color other) (have_met + 1)
  forkIO $ creature -- One thread per creature
  return metVar

main = do args <- getArgs
          let meetings = if null args then (1000000::Int) else (read . head) args
          meeting_place <- new_meeting meetings
          metVars       <- mapM (spawnCreature meeting_place) [blue, red, yellow, blue]
          mapM takeMVar metVars >>= print . sum -- Main thread waits for completion

Current Fastest version, no meeting thread

I have taken Aaron Denney's excellent entry (see bottom of page) and tweaked it. -- ChrisKuklewicz

This entry was winning both debian and gentoo benchmarks on 13 Jan 2006.

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{- The Computer Language Shootout
   
   contributed by Aaron Denney
   modified by Chris Kuklewicz, 11 Jan 2006

   compile with "ghc --make -O2 -funbox-strict-fields chameneos.hs -o chameneos.ghc_run"
   run with "./chameneos.ghc_run %A"

   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)

data Color = C !Int deriving (Eq)
red = C 0; yellow = C 1; blue = C 2; faded = C 3

complement :: Color -> Color -> Color
complement (C a) (C b) | a == b    = C a
                       | otherwise = C (3 - a - b)

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

new_meeting maxMeetings = liftM2 M (newMVar maxMeetings) newEmptyMVar

wait_other (M meets waiting) color wake_up = do
  remainingMeets <- takeMVar meets -- used as lock
  let sleep_on = do putMVar waiting (color, wake_up)
                    putMVar meets remainingMeets
                    takeMVar wake_up
      wake_waiter (other_c,other_wake_up) = do putMVar other_wake_up color
                                               putMVar meets (remainingMeets - 1)
                                               return other_c
  case remainingMeets of
    0 -> putMVar meets 0 >> return faded
    _ -> tryTakeMVar waiting >>= maybe sleep_on wake_waiter

spawnCreature meeting_place startingColor = do
  metVar <- newEmptyMVar
  wake_up  <- newEmptyMVar
  let creature = putMVar metVar =<< inner_creature startingColor (0::Int)
        where inner_creature color have_met = do
                color `seq` have_met `seq` return ()
                other <- wait_other meeting_place color wake_up
                if other == faded
                  then return have_met
                  else inner_creature (complement color other) (have_met + 1)
  forkIO $ creature
  return metVar

main = do 
  args <- getArgs
  let meetings = if null args then (1000000::Int) else (read . head) args
  meeting_place <- new_meeting meetings
  metVars <- mapM (spawnCreature meeting_place) [blue, red, yellow, blue]
  vals <- mapM takeMVar metVars
  print $ sum vals


Even faster version

This has been submitted to the shootout, but the rules no longer allow a meeting thread

Modification of tweaked version below by SimonMarlow to make use of -funbox-strict-fields, and to avoid using explicit unboxed Int# (it looks ugly, to me).

{-# 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

   contributed by Chris Kuklewicz, 28 Dec 2005, 2 Jan 2006
   modified by Einar Karttunen, 31 Dec 2005

   further modified by Chris Kuklewicz to use Int# on 6 Jan 2006

   further modified by Simon Marlow using -funbox-strict-fields, and
   avoiding use of explicit unboxed Int#.

   This entry uses a separate thread to manage the meetings.
-}

import Control.Concurrent
import Control.Monad
import System (getArgs)
import GHC.Base

{- Ch : fast unordered channel implementation -}
data Ch a = Ch !(MVar [a]) !(MVar a)

newCh = do w <- newMVar []; r <- newEmptyMVar; return (Ch w r)

readCh (Ch w r) = do 
  lst <- takeMVar w
  case lst of (x:xs) -> do putMVar w xs; return x
              []     -> do putMVar w []; takeMVar r

writeCh (Ch w r) x = do
  ok <- tryPutMVar r x -- opportunistic, helps for this problem
  unless ok $ do
    lst <- takeMVar w
    ok <- tryPutMVar r x  -- safe inside take/put
    putMVar w $! if ok then lst else (x:lst)

data Element = E !Int !(MVar Int)

red = 0; yellow = 1; blue = 2; faded = 3

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

main = do 
  args <- getArgs
  goMeet <- newCh
  let meetings = if null args then (1000000::Int) else (read . head) args

      meetingPlace = replicateM_ meetings match >> fade
        where match = do E color1 pobox1 <- readCh goMeet
                         E color2 pobox2 <- readCh goMeet
                         putMVar pobox1 color2
                         putMVar pobox2 color1
              fade = do E _ pobox <- readCh goMeet
                        putMVar pobox faded
                        fade

      spawn :: Int -> IO (MVar Int)
      spawn startingColor = do
        metVar <- newEmptyMVar
        pobox  <- newEmptyMVar
        let creature havemet color = do
              	havemet `seq` color `seq` return ()
		writeCh goMeet (E color pobox)
              	other <- takeMVar pobox
              	if other == faded
                   then putMVar metVar havemet
                   else creature (havemet+1) (complement color other)
        forkIO $ creature 0 startingColor
        return metVar

  forkIO meetingPlace
  metVars <- sequence [spawn blue,spawn red,spawn yellow,spawn blue]
  total <- liftM sum $ mapM takeMVar metVars
  print total


Fastest version, in Shootout

As of 5 Jan 2006, this is the fastest entry on the shootout, beating "Forth GForth" by 10%.

Like the erlang entry, this uses a separate thread to match up two chameneos in the meeting room. It does not need to use STM, and runs in about 2.3 seconds of user time on my powerbook. The code is easy to follow. Einar Kartunen added a 2min tweak to use a more efficient Chan representation for the case, makes things 2x faster for now. Chris Kuklewicz got ten percent faster execution by further optimizing the Ch implementation.

{- 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, 2 Jan 2005
   modified by Einar Karttunen, 31 Dec 2005

   This entry uses a separate thread to manage the meetings.
-}

import Control.Concurrent
import Control.Monad
import System (getArgs)

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

{- Ch : fast unordered channel implementation -}
newtype Ch a = Ch (MVar [a], MVar a)

newCh = liftM2 (,) (newMVar []) newEmptyMVar >>= return.Ch

readCh (Ch (w,r)) = takeMVar w >>= \lst ->
  case lst of (x:xs) -> putMVar w xs >> return x
              []     -> putMVar w [] >> takeMVar r

writeCh (Ch (w,r)) x = do
  ok <- tryPutMVar r x -- opportunistic, helps for this problem
  unless ok $ takeMVar w >>= \lst -> do 
    ok <- tryPutMVar r x  -- safe inside take/put
    putMVar w $ if ok then lst else (x:lst)

main = do 
  args <- getArgs
  goMeet <- newCh
  let meetings = if null args then (100::Int) else (read . head) args

      meetingPlace = replicateM_ meetings match >> fade
        where match = do (color1,pobox1) <- readCh goMeet
                         (color2,pobox2) <- readCh goMeet
                         putMVar pobox1 color2
                         putMVar pobox2 color1
              fade = do (_,pobox) <- readCh goMeet
                        putMVar pobox Faded
                        fade

      spawn startingColor = do
        metVar <- newEmptyMVar
        pobox  <- newEmptyMVar
        let creature havemet color = do 
              writeCh goMeet (color,pobox)
              other <- takeMVar pobox
              case other of 
                Faded -> let color = Faded in putMVar metVar havemet
                _     -> (creature  $! (havemet+1)) $! (complement color other)
        forkIO $ creature 0 startingColor
        return metVar

  forkIO meetingPlace
  metVars <- mapM spawn [Blue,Red,Yellow,Blue]
  total <- foldM (\tot mv -> takeMVar mv >>= return.(tot+)) (0::Int) metVars
  print total

Unboxed Tweak of submitted version

I converted the data Color to Int# and this improved the speed of the submitted entry. This is the fastest version on my powerbook, but only by 6% margin.

I am learning that (if boxed==boxed) is slow, (case boxed) is better, (case unboxed) is better still, (if unboxed ==# unboxed) is best.

{-# OPTIONS -O2 #-}
{- 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, 2 Jan 2006
   modified by Einar Karttunen, 31 Dec 2005

   further modified by Chris Kuklewicz to use Int# on 6 Jan 2006

   This entry uses a separate thread to manage the meetings.
-}

import Control.Concurrent
import Control.Monad
import System (getArgs)
import GHC.Base

{- Ch : fast unordered channel implementation -}
newtype Ch a = Ch (MVar [a], MVar a)

newCh = liftM2 (,) (newMVar []) newEmptyMVar >>= return.Ch

readCh (Ch (w,r)) = takeMVar w >>= \lst ->
  case lst of (x:xs) -> putMVar w xs >> return x
              []     -> putMVar w [] >> takeMVar r

writeCh (Ch (w,r)) x = do
  ok <- tryPutMVar r x -- opportunistic, helps for this problem
  unless ok $ takeMVar w >>= \lst -> do 
    ok <- tryPutMVar r x  -- safe inside take/put
    putMVar w $ if ok then lst else (x:lst)

main = do 
  let red = 0# ; yellow = 1# ; blue = 2# ; faded = 3# ;
      complement :: Int# -> Int# -> Int#
      complement a b | a ==# b = a
                     | otherwise = 3# -# a -# b;
  args <- getArgs
  goMeet <- newCh
  let meetings = if null args then (1000000::Int) else (read . head) args

      meetingPlace = replicateM_ meetings match >> fade
        where match = do (color1,pobox1) <- readCh goMeet
                         (color2,pobox2) <- readCh goMeet
                         putMVar pobox1 color2
                         putMVar pobox2 color1
              fade = do (_,pobox) <- readCh goMeet
                        putMVar pobox (I# faded)
                        fade

      spawn :: Int# -> IO (MVar Int)
      spawn startingColor = do
        metVar <- newEmptyMVar
        pobox  <- newEmptyMVar
        let creature havemet color = do 
              writeCh goMeet (I# color,pobox)
              (I# other) <- takeMVar pobox
              if (other ==# faded) 
                then let color = faded in putMVar metVar havemet
                else (creature  $! (havemet+1)) (complement color other)
        forkIO $ creature 0 startingColor
        return metVar

  forkIO meetingPlace
  metVars <- sequence [spawn blue,spawn red,spawn yellow,spawn blue]
  total <- liftM sum $ mapM takeMVar metVars
  print total

Full case tweak of older version

The following rewrite of complement from the above entry gains another 10%, it generates much better code as Eq is slower than case. I think we should use it. -- DonStewart

data Color = Red | Yellow | Blue | Faded

complement a b = case (a,b) of  -- faster than Eq
    (Red,Yellow)  -> Blue;   (Red,Blue)    -> Yellow; (Red,Red)       -> Red;
    (Yellow,Blue) -> Red;    (Yellow,Red)  -> Blue;   (Yellow,Yellow) -> Yellow;
    (Blue,Red)    -> Yellow; (Blue,Yellow) -> Red;    (Blue,Blue)     -> Blue;

previous version before the 10% tweak to Ch, runs in 2.6 seconds of user time:

{- 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 Einar Karttunen

   This entry uses a separate thread to manage the meetings
-}

import Control.Concurrent
import Control.Monad(replicateM_,foldM,mapM,when)
import System (getArgs)

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

newtype Ch a = Ch (MVar ([a], [MVar a]))
newCh = newMVar ([], []) >>= return . Ch
readCh (Ch mv) = takeMVar mv >>= \lst ->
  case lst of
    ([],l)     -> do m <- newEmptyMVar
                     putMVar mv ([],(m:l))
                     takeMVar m
    ((x:xs),l) -> do putMVar mv (xs,l) >> return x

writeCh (Ch mv) v = takeMVar mv >>= \lst ->
  case lst of
   (p,(w:ws)) -> putMVar mv (p,ws) >> putMVar w v
   (p,ws)     -> putMVar mv ((v:p),ws)

main = do 
  args <- getArgs
  goMeet <- newCh
  let meetings = if null args then (100::Int) else (read . head) args

      meetingPlace = replicateM_ meetings match >> fade
        where match = do (color1,pobox1) <- readCh goMeet
                         (color2,pobox2) <- readCh goMeet
                         putMVar pobox1 color2
                         putMVar pobox2 color1
              fade = do (_,pobox) <- readCh goMeet
                        putMVar pobox Faded
                        fade

      spawn startingColor = do
        metVar <- newEmptyMVar
        pobox  <- newEmptyMVar
        let creature havemet color = do 
              writeCh goMeet (color,pobox)
              other <- takeMVar pobox
              case other of
                Faded -> let color = Faded in putMVar metVar havemet
                _     -> (creature  $! (havemet+1)) $! (complement color other)
        forkIO $ creature 0 startingColor
        return metVar

  forkIO meetingPlace
  metVars <- mapM spawn [Blue,Red,Yellow,Blue]
  total <- foldM (\tot mv -> takeMVar mv >>= return.(tot+)) (0::Int) metVars
  print total

I don't this this tweak to use the full case statement is faster than the submitted entry, though is it faster than the previous version you are comparing to (which has an older Ch implementation) -- ChrisKuklewicz

Other versions

This is the older fastest entry which uses Chans and is slower, at 6 seconds of user time:

{- 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 uses a separate thread to manage the meetings
-}

import Control.Concurrent
import Control.Monad(replicateM_,foldM,mapM)
import System (getArgs)

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

main = do 
  args <- getArgs
  goMeet <- newChan
  let meetings = if null args then (100::Int) else (read . head) args

      meetingPlace = replicateM_ meetings match >> fade
        where match = do (color1,pobox1) <- readChan goMeet
                         (color2,pobox2) <- readChan goMeet
                         putMVar pobox1 color2
                         putMVar pobox2 color1
              fade = do (_,pobox) <- readChan goMeet
                        putMVar pobox Faded
                        fade

      spawn startingColor = do
        metVar <- newEmptyMVar
        pobox  <- newEmptyMVar
        let creature havemet color = do 
              writeChan goMeet (color,pobox)
              other <- takeMVar pobox
              case other of
                Faded -> let color = Faded in putMVar metVar havemet
                _     -> (creature  $! (havemet+1)) $! (complement color other)
        forkIO $ creature 0 startingColor
        return metVar

  forkIO meetingPlace
  metVars <- mapM spawn [Blue,Red,Yellow,Blue]
  total <- foldM (\tot mv -> takeMVar mv >>= return.(tot+)) (0::Int) metVars
  print total

Josh Goldfoot

Josh submitted the first haskell entry:

{-  The Great Computer Language Shootout
    http://shootout.alioth.debian.org/
    contributed by Josh Goldfoot
-}

import Control.Concurrent
import System(getArgs)

data Color = Blue | Red | Yellow | Faded deriving (Eq, Show)
data MeetingPlace = MeetingPlace { first :: Maybe Color, second :: Maybe (MVar Color), meetingsLeft :: Int }
data Creature = Creature {meetings :: Int, color :: Color, mp :: MVar MeetingPlace}

main = do
   [nstring] <- getArgs
   theMeetingPlace <- newMVar MeetingPlace { first = Nothing, second = Nothing, meetingsLeft = (read nstring) }
   result1 <- newEmptyMVar  -- Create MVars, through which the 4 creature threads will report their # of meetings
   result2 <- newEmptyMVar
   result3 <- newEmptyMVar
   result4 <- newEmptyMVar
   let creatures = [runCreature Creature { meetings = 0, color = col, mp = theMeetingPlace } res | (col, res) <-
                     [ (Blue, result1), (Red, result2), (Yellow, result3), (Blue, result4)]]
   mapM forkIO creatures  -- This one line starts the 4 "creature" threads
   d1 <- takeMVar result1 -- This waits until the 1st creature thread reports a result
   d2 <- takeMVar result2
   d3 <- takeMVar result3
   d4 <- takeMVar result4
   print (sum [d1, d2, d3, d4]) -- We have all 4 results; sum them, and print.

runCreature creature resultVar
   | (color creature) == Faded = putMVar resultVar ((meetings creature) - 1)  -- If we are faded, report & die
   | otherwise = do
      mpdata <- takeMVar (mp creature)  -- Waits for there to be a meeting place variable to take
      if (first mpdata) == Nothing
         then do  -- The meeting place is empty.  Let the next guy know how to find us.
            secondCreatureColor <- newEmptyMVar
            putMVar (mp creature) MeetingPlace { first = Just (color creature), second = Just secondCreatureColor, meetingsLeft = (meetingsLeft mpdata) }
            secondCreatureColorData <- takeMVar secondCreatureColor
            putMVar (mp creature) MeetingPlace { first = Nothing, second = Nothing, meetingsLeft = decrement (meetingsLeft mpdata) }
            runCreature Creature { meetings = (meetings creature) + 1,
               color = newColor (meetingsLeft mpdata) (color creature) (Just secondCreatureColorData),
               mp = (mp creature) } resultVar
         else do -- We are the second creature here.  Let the first guy know we arrived.
            putMVar (unjust (second mpdata)) (color creature)
            runCreature Creature { meetings = (meetings creature) + 1,
               color = newColor (meetingsLeft mpdata) (color creature) (first mpdata),
               mp = (mp creature) } resultVar

newColor 0 _ _ = Faded
newColor _ me (Just other) = complement me other

unjust (Just x) = x

complement me other
   | other == Faded = Faded
   | me == other = me
   | me == Blue = if other == Red then Yellow else Red
   | me == Red = if other == Blue then Yellow else Blue
   | me == Yellow = if other == Blue then Red else Blue
   | me == Faded = Faded

decrement 0 = 0
decrement n = n - 1


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.

{- 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

Over annotated original version

This is the first version I posted, in annotated form. It runs in about 8.5 seconds user time on my powerbook.

{- 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 ...
-}

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

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

{- complement is commutative.
   complement acts over the domain Red, Yellow, Blue only
-}
complement :: Color -> Color -> Color
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 : the action to try and enter the room to meet another thread
   startingColor : the inital color of this thread
   return value metVar : where the thread puts its answer before exiting

   The returned MVar is used to allow an easy thread-join operation

-} 
spawn :: (Color -> IO Color) -> Color -> IO (MVar Word32)
spawn enter startingColor = do
  metVar <- newEmptyMVar
  {- child calls itself tail-recursively until passed Faded
      havemet : running total for this thread of other thread met
      color : current color of this thread
      End by putting total into metVar, then the thread exits
  -}
  let child :: Word32 -> Color -> IO ()
      child havemet Faded = putMVar metVar havemet
      child havemet color = do result <- enter color -- returns color of other thread or Faded
                               case result of
                                 Faded -> child havemet Faded
                                 -- Use strictness to ensure running total is computed here
                                 -- Use strictness to enture next color is computed here
                                 other -> (child  $! (havemet+1)) (complement color other)
  forkIO $ child 0 startingColor -- create new child thread, running child
  return metVar -- return metVar to parent thread

main = do args <- getArgs
          let meetings :: Word32
              meetings = case args of
                           [] -> 100
                           (n:_) -> read n
          togoVar <- newMVar (2*meetings) -- final total will also be 2*meetings
          -- firstVar and secondVar hold colors for two threads meeting in the room
          firstVar <- atomically $ newEmptyTMVar
          secondVar <- atomically $ newEmptyTMVar
          -- define functions in lexical scopr of togoVar,firstVar,secondVar
          let 
              {- canProceed decrement the value in togoVar
                 It returns True if the original value was above zero
                 Otherwise it returns False
              -}
              canProceed :: IO Bool
              canProceed = modifyMVar togoVar (\v -> if (v>0) then let v' = v-1
                                                                   in return $ v' `seq` (v',True) 
                                                              else return (0,False) )

              {- meet holds most of the semantics of the thread interactions 

                 It takes the color of the current thread and returns the
                 color of the thread it meets.

                 This was very tricky to design to ensure that thead 1 and 2
                 get each others' colors and thread 3 cannot intervene.
              -}
              meet :: Color -> IO Color
              -- Note the join...the STM operation returns an IO operation
              -- Thus the IO operation runs after the STM operation commits
              meet color = join $ atomically $ do
                -- This always returns a boolean, never blocks or calls retry
                inFirst <- tryPutTMVar firstVar color
                if inFirst
                  -- immediately commit and return a new operation to perform atomically
                  then return $ atomically $ do
                    -- atomically takeTMVar on both secondVar and firstVar
                    -- This means they are emptied simultaneously
                    other <- takeTMVar secondVar
                    takeTMVar firstVar
                    return other
                  else do
                    -- If firstVar is full, then try secondVar
                    -- This will call retry if secondVar is also full
                    putTMVar secondVar color
                    -- We know this read cannot block is inFirst was false
                    other <- readTMVar firstVar
                    -- commit and return a simple IO action of (return other)
                    return $ return other

              {- enter

                 color : this thread's current color

                 This is the action passed to spawn.  It is self-explanatory.
               -}
              enter color = do proceed <- canProceed
                               if proceed then meet color 
                                          else return Faded

          -- Blue Red Yellow Blue is the specified set of starting
          -- threads. metVars is a list of empty MVars which will hold
          -- each thread's individual total.
          metVars <- mapM (spawn enter) [Blue,Red,Yellow,Blue]
          -- This reads each metVar in turn and adds them up.  This will block
          -- on a metVar until that thread has finished.
          total <- foldM (\tot mv -> takeMVar mv >>= return.(tot+)) 0 metVars
          -- This should print 2*meetings
          print total

MVar version, no manager

Posted by AaronDenney

{-# 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