Editing Shootout/Chameneos (section)

== 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
<haskell>
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;
</haskell>

previous version before the 10% tweak to Ch, runs in 2.6 seconds of 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 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
</haskell>

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