Tick-Tack-Toe(2012.7.6の過去問)

1日1個 @nabetani さんの作った問題を解くAdventCalendarの18日目です。

今日の問題は http://nabetani.sakura.ne.jp/hena/1/ にあります。

{-# LANGUAGE TupleSections #-}
module Doukaku.Gobang (solve) where
import Data.Char (intToDigit)

data Player = O | X deriving (Eq, Show)
type Gobang = [[(Char, Maybe Player)]]

solve :: String -> String
solve = go O X gobang
  where
    go _  _  _ [] = "Draw game."
    go p1 p2 g (h:hs) = case turn p1 h g of
      Nothing -> "Foul : " ++ toChar p2 : " won."
      Just g' | settled p1 g' -> toChar p1 : " won."
              | filled g'     -> "Draw game."
              | otherwise     -> go p2 p1 g' hs

toChar :: Player -> Char
toChar O = 'o'
toChar X = 'x'

gobang :: Gobang
gobang = map (line [0, 1, 2]) [1, 4, 7] ++
         map (line [0, 3, 6]) [1, 2, 3] ++
         map (line [0, 4, 8]) [1] ++
         map (line [0, 2, 4]) [3]
  where
    line :: [Int] -> Int -> [(Char, Maybe Player)]
    line xs x = map ((, Nothing) . intToDigit . (+ x)) $ xs

turn :: Player -> Char -> Gobang -> Maybe Gobang
turn p h = sequence . map (sequence . map (put p h))
  where
    put :: Player -> Char -> (Char, Maybe Player) -> Maybe (Char, Maybe Player)
    put p' h' x@(k, Nothing) | h' == k   = Just (k, Just p')
                             | otherwise = Just x
    put _ h' x@(k, _) | h' == k   = Nothing
                      | otherwise = Just x

settled :: Player -> Gobang -> Bool
settled p = any (all ((== Just p) . snd))

filled :: Gobang -> Bool
filled = all (all ((/= Nothing) . snd))

URLからもわかるように、記念すべき第一回目の問題です。最初三目並べのルールを間違えるというまさかの大失態をしまして、これは改めて実装し直したものです。3×3の面ではなく、ライン8個分をgobangに持たせています。この持ち方は同じマスが複数のラインに入るので非常に冗長ですが、ラインが揃ったという判定が楽になるという利点もあります。

filledはものすごく非効率なので実装したくなかったのですが、最初にtail 9やるというad-hocな解決方法よりはマシかなということで採用しました。