Shootout/Chameneos

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{- The Computer Language Shootout
 
   contributed by Tom Pledger, 13 Nov 2006
 
   compile with "ghc -o chameneos.ghc_run chameneos.hs"
   run with "./chameneos.ghc_run %A"
 
   http://shootout.alioth.debian.org/
   http://shootout.alioth.debian.org/benchmark.php?test=chameneos&lang=all
   http://www.haskell.org/haskellwiki/Great_language_shootout
 
   This entry economises on MVar use, and is so symmetric that the
   main thread becomes the fourth creature
-}
 
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
          let meetings = case args of [] -> 1000000; s:_ -> read s
          mpv    <- newMVar MP{ quota = meetings, waiter = Nothing, done = [] }
          wakerv <- newEmptyMVar
 
          let arrive colour tally
                  = do mp <- takeMVar mpv
                       case mp of
                           MP{ quota = 0, done = d }
                               | 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]

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

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

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

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

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

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;

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

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

{-  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
   putStrLn $ show (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

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

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

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