> import Prelude hiding (Either(..))
> import Array
> import List
> import Monad(guard)
> import ReaderMonad
> import IOExts

> data Card = Card { up, left, down, right :: Int }
> data Owner = Red | Blue | Wall deriving (Eq, Show)

> newtype Board = Board (Array (Int,Int) (Maybe (Card,Owner)))

> data Dir = Up | Left | Down | Right deriving (Eq, Ord, Ix, Bounded, Enum, Show)

> opp :: Dir -> Dir
> opp Up    = Down
> opp Left  = Right
> opp Down  = Up
> opp Right = Left

> instance Show Board where
>   show (Board cards) =  concatMap showRow [1,2,3]
>     where showCard Nothing = " "
>           showCard (Just (_,o)) = case o of Red -> "1"
>                                             Blue -> "2"
>           showRow n = concat (intersperse " " [ showCard (cards!i) | i <- range ((n,1),(n,3)) ]) ++ "\n"

Access functions.

> upOf    (r,c) = (r-1,c)
> leftOf  (r,c) = (r,c-1)
> downOf  (r,c) = (r+1,c)
> rightOf (r,c) = (r,c+1)

> get (Board cards) dir p = do (c,_) <- cards ! p
>                              (c',_) <- cards ! (pos dir) p
>                              return ((val dir) c, (val (opp dir)) c')

> get' (Board cards) dir p = do (c,_) <- cards ! p
>                               (c',o) <- cards ! (pos dir) p
>                               guard (o /= Wall)
>                               return ((val dir) c, (val (opp dir)) c')

> val dir = vals ! dir
>   where vals = listArray (minBound, maxBound) [up, left, down, right]

> pos dir = poses ! dir
>   where
>   poses = listArray (minBound, maxBound) [upOf, leftOf, downOf, rightOf]

> place p c (Board cards) = Board (cards // [(p, Just c)])

Change ownership of a card.

> newOwner b@(Board cards) p owner =
>   if o==Wall || o==owner then (b,False)
>      else (Board (cards // [(p, Just (c,owner))]), True)
>   where Just (c,o) = cards ! p

Basic rule.

> basic p board@(Board cards) = foldl f board [minBound..maxBound]
>   where
>   f b@(Board cards) dir =
>     case get b dir p
>     of Nothing -> b
>        Just (v,v') -> if v>v' then fst (newOwner b (pos dir p) owner) else b
>   Just (_,owner) = cards ! p

Same rule.

> same p b@(Board cards) = if length list >= 2 then foldl f (b,[]) list
>                          else (b, [])
>   where list = [ dir | dir <- [minBound..maxBound],
>                        case get b dir p of Nothing -> False
>                                            Just (v,v') -> v == v' ]
>         f (b,ds) d = let (b',t) = newOwner b (pos d p) owner
>                      in if t then (b',d:ds) else (b,ds)
>         Just (_,owner) = cards ! p

Plus rule.

> plus p b@(Board cards) = foldl f (b,[]) list
>   where list = map snd $ concat $ filter (\l -> length l >= 2) $
>                groupBy (\ (x,_) (y,_) -> x==y) $
>                sort $
>                [ (v+v',dir) | dir <- [minBound..maxBound],
>                               (v,v') <- case get' b dir p of Nothing -> []
>                                                              Just x -> [x] ]
>         f (b,ds) d = let (b',t) = newOwner b (pos d p) owner
>                      in if t then (b',d:ds) else (b,ds)
>         Just (_,owner) = cards ! p

> main = do f <- readFlags
>           let (b,_,_,_,_) = f
>           if not b then return () else do playGame f
>                                           main
>   where
>   playGame (_,s,pl,c,sw) =
>     do player <- newIORef Red
>        elements <- readElements
>        let board = newBoard sw
>        let playTurn b = do (p, card', e) <- readCard
>                            let card = if elements!p == 0 then card'
>                                       else if elements!p == e then changeValues 1 card'
>                                            else changeValues (-1) card'
>                            owner <- readIORef player
>                            let b1 = place p (card, owner) b
>                                b2 = if s
>                                     then let (b',l') = same p b1
>                                          in if c
>                                             then foldr basic b' (map (($ p) . pos) l')
>                                             else b'
>                                     else b1
>                                b3 = if pl
>                                     then let (b',l') = plus p b2
>                                          in if c
>                                             then foldr basic b' (map (($ p) . pos) l')
>                                             else b'
>                                     else b2
>                                b' = basic p b3
>                            nextplayer player
>                            -- print b'
>                            return b'
>        b <- foldl (>>=) (return board) (replicate 9 playTurn)
>        let Board a = b
>            r = length [ o | i <- range ((1,1),(3,3)), let Just (_,o) = a!i, o==Red ]
>            w = if r > 5 then 1 else if r < 5 then 2 else 0
>        putStrLn (show r ++ " " ++ show (9-r) ++ " " ++ show w)
>        print b
>        return ()
>   newBoard t = Board (array ((0,0),(4,4)) (normal ++ wall))
>     where normal = zip (range ((1,1),(3,3))) (repeat Nothing)
>           wall = zip is (repeat (if t then Just (Card 10 10 10 10, Wall) else Nothing))
>           is = zip (repeat 0) [1,2,3] ++ zip [1,2,3] (repeat 0) ++
>                zip (repeat 4) [1,2,3] ++ zip [1,2,3] (repeat 4)
>   readCard = rreadLn r
>     where r = do x <- reader
>                  y <- reader
>                  u <- reader
>                  l <- reader
>                  d <- reader
>                  r <- reader
>                  e <- reader
>                  return ((x,y), Card u l d r, e)
>   readFlags = rreadLn r
>     where r = do b <- reader
>                  s <- reader
>                  p <- reader
>                  c <- reader
>                  sw <- reader
>                  return (f b, f s, f p, f c, f sw)
>             where f x = x/=0
>   readElements = do l <- mapM readrow [1,2,3]
>                     return (array ((1,1),(3,3)) (concat l))
>     where readrow n = do l <- rreadLn (sequence [reader, reader, reader])
>                          return (zip (zip (repeat n) [1,2,3]) l)
>   nextplayer player = do p <- readIORef player
>                          writeIORef player (case p of Red -> Blue
>                                                       Blue -> Red)
>   changeValues i (Card u l d r) = Card (u+i) (l+i) (d+i) (r+i)