Answers for http://nabetani.sakura.ne.jp/hena/1/

.gitignore

*~

KamomeTickTackToe.hs

{-# LANGUAGE ViewPatterns #-}
module KamomeTickTackToe (KamomeTickTackToe(..)) where

{-
  This is seagull_kamome's implementation. See http://qiita.com/items/9cbaca1ef8519fb8a039
-}

import Data.Word (Word16)
import Data.Bits ((.|.),(.&.),setBit,testBit)
import Data.Ix (index)
import TickTackToe (TickTackToeSolver(..))

data KamomeTickTackToe = KamomeTickTackToe

solve :: String -> String
solve = go 'o' 'x' 0 0
  where
    go :: Char -> Char -> Word16 -> Word16 -> String -> String
    go _ _ _ _ [] = undefined -- 勝敗が決まらないまま終了
    go color oponent mhands ohands ((index ('0', '9') -> x):xs)
      | testBit (mhands .|. ohands) x = "Foul : " ++ [oponent] ++ " won."
      | or (map (\x -> x .&. mhands' == x) goals) = [color] ++ " won."
      | (mhands' .|. ohands) == 0x3fe = "Draw game."
      | otherwise = go oponent color ohands mhands' xs
      where
        mhands' = setBit mhands x
        goals = map (foldl setBit 0) [[1,2,3],[4,5,6],[7,8,9],[1,4,7],[2,5,8],[3,6,9],[1,5,9],[3,5,7]]

instance TickTackToeSolver KamomeTickTackToe where
    getSolver _ = solve

tick_tack_toe_test.hs

#!/usr/bin/env runghc
{-# LANGUAGE ExistentialQuantification #-}
import Test.HUnit
import TickTackToe
import KamomeTickTackToe
import UchidaTickTackToe

parseLine :: String -> (String, String, String)
parseLine line = let (num, left) = break (== '\t') line
                     (input, output) = break (== '\t') $ tail left
                 in (num, input, tail output)

data AnySolver = forall a. TickTackToeSolver a => S a
solvers :: [AnySolver]
solvers = [S TickTackToe, S KamomeTickTackToe, S UchidaTickTackToe]

runAllTest :: [(String, String, String)] -> IO ()
runAllTest testCases = do
  let tests = TestList $ concat (map (\(S solver) -> map (testLabel solver) testCases) solvers)
  runTestTT tests
  return ()
    where testLabel solver (num, input, output) =
              TestCase $ assertEqual num output (getSolver solver input)

main :: IO ()
main = do
  contents <- readFile "tick_tack_toe_test_case.tsv"
  let testCases = fmap parseLine $ lines contents
  runAllTest testCases

tick_tack_toe_test_case.tsv

TickTackToe.hs

module TickTackToe (TickTackToeSolver(..), TickTackToe(..)) where

class TickTackToeSolver a where
    getSolver :: a -> String -> String

data TickTackToe = TickTackToe

data Player = Player { name :: String }
              deriving (Eq, Show)
data Cell = Empty | Owned Player
            deriving (Eq, Show)
data Result = Draw | Winner Player | Faul Player
              deriving (Eq, Show)
type Point = (Int, Int)
type Board = [[Cell]]

solve :: String -> String
solve input = case process input' (head players) (initialBoard size) of
                Draw -> "Draw game."
                Winner p -> (name p) ++ " won."
                Faul p -> "Foul : " ++ (name $ nextPlayer p) ++ " won."
    where
      input' = take (size * size) input
      process :: String -> Player -> Board -> Result
      process [] _ _ = Draw
      process (x:xs) player board =
          let pt = numberToPoint (read $ x : "") size
          in
            case checkBoard board pt of
              Owned _ -> Faul player
              Empty -> let nextBoard = putBoard board pt player
                       in if (checkHorizontal nextBoard pt ||
                              checkVertical nextBoard pt ||
                              checkDiagonal nextBoard pt)
                          then Winner player
                          else process xs (nextPlayer player) nextBoard

size :: Int
size = 3

initialBoard :: Int -> Board
initialBoard s = replicate s $ replicate s Empty

numberToPoint :: Int -> Int -> Point
numberToPoint n s = (n' `div` s, n' `mod` s)
    where n' = n - 1

putBoard :: Board -> Point -> Player -> Board
putBoard board pt player = fmap processRow $ zip board [0..]
    where processRow (row, y) = fmap ( \(cell, x) ->
                                           if (x, y) == pt
                                           then Owned player
                                           else cell ) $
                                zip row [0..]

checkBoard :: Board -> Point -> Cell
checkBoard board (x, y) = (board !! y) !! x

players :: [Player]
players = [Player "o", Player "x"]

nextPlayer :: Player -> Player
nextPlayer player = nextPlayer' players player
    where nextPlayer' (x:y:ys) p =
              if x == p then y else nextPlayer' (y:ys) p
          nextPlayer' _ _ = head players

checkHorizontal :: Board -> Point -> Bool
checkHorizontal board (_, y) = isOccupied line
    where line = board !! y

checkVertical :: Board -> Point -> Bool
checkVertical board (x, _) =  isOccupied line
    where line = fmap (!! x) board

checkDiagonal :: Board -> Point -> Bool
checkDiagonal board (x, y) = x == y && isOccupied diagonalA
                             || x == (bSize - y - 1) && isOccupied diagonalB
    where diagonalA = fmap (\i -> checkBoard board (i, i)) [0..2]
          diagonalB = fmap (\i -> checkBoard board (i, bSize - i - 1)) [0..2]
          bSize = length board

isOccupied :: [Cell] -> Bool
isOccupied line = isOccupied' (head line) line
    where isOccupied' _ [] = True
          isOccupied' cell (x:xs) =
              if cell /= x then False else isOccupied' cell xs

instance TickTackToeSolver TickTackToe where
    getSolver _ = solve

UchidaTickTackToe.hs

module UchidaTickTackToe (UchidaTickTackToe(..)) where

{-
  This is t_uchida's implementation. See http://qiita.com/items/6fc203c947df212cdab7
-}

import Data.List (transpose, insert)
import TickTackToe (TickTackToeSolver(..))

data UchidaTickTackToe = UchidaTickTackToe

data Cell   = O | X | None deriving (Eq, Show, Ord, Enum)
type Board  = [Cell]
data Result = OWon | XWon | FoulOWon | FoulXWon | Draw deriving Enum

instance Show Result where
  show OWon     = "o won."
  show XWon     = "x won."
  show FoulOWon = "Foul : o won."
  show FoulXWon = "Foul : x won."
  show Draw     = "Draw game."

judge :: String -> Result
judge = judge' O (replicate 9 None) . take 9 . map (subtract 49 . fromEnum)

judge' :: Cell -> Board -> [Int] -> Result
judge' _ _ []     = Draw
judge' c b (i:is) = case put c i b of
  Nothing -> toEnum (3 - fromEnum c)
  Just b' -> if win c b'
    then toEnum $ fromEnum c
    else judge' (toEnum (1 - fromEnum c)) b' is

win :: Cell -> Board -> Bool
win c b = any (all (== c)) $ mat ++ transpose mat ++ map (zipWith (!!) mat) [[0,1,2], [2,1,0]]
  where
    mat = take 3 . map (take 3) $ iterate (drop 3) b

put :: Cell -> Int -> Board -> Maybe Board
put c n b = case b !! n of
  None -> Just . map snd . insert (n, c) . filter ((/= n) . fst) $ zip [0..] b
  _    -> Nothing

instance TickTackToeSolver UchidaTickTackToe where
    getSolver _ = show . judge