マルバツゲーム

RWHでモナド変換子とか色々覚えたので、それらを使ってマルバツゲーム作ってみた。

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Control.Applicative
import Control.Monad.Error
import Control.Monad.Instances
import Control.Monad.State
import Data.Array
import Data.Char
import System.IO

-- ゲームの進行用モナド。
newtype Game t e a = Game { getGame :: ErrorT e (State t) a }
    deriving (Monad, MonadError e, MonadState t)

runGame :: Game Board GameError a -> Board -> (Either GameError a, Board)
runGame = runState . runErrorT . getGame

-- 盤面。
data CellState = Maru | Batsu | Blank deriving (Eq,Show)

showCellState :: CellState -> String
showCellState Maru = "O"
showCellState Batsu = "X"

type Board = Array Int CellState

initBoard :: Board
initBoard = listArray (1,9) . repeat $ Blank

updateBoard :: Int -> CellState -> Board -> Either GameError Board
updateBoard n cst brd
    | n < 1 || 9 < n || brd ! n /= Blank = Left . strMsg $ "そこには置けません。"
    | otherwise = Right $ brd // [(n,cst)]

renderBoard :: Board -> String
renderBoard brd = line [1..3] ++ "-----" ++ line [4..6] ++ "-----" ++ line [7..9]
    where
    line (a:b:c:_) = "\n" ++ cell a ++ "|" ++ cell b ++ "|" ++ cell c ++ "\n"
    cell n = let a = brd!n in if a == Blank then show n else showCellState a

-- 勝敗判定。
data Judge = Win | Continue deriving (Eq,Show)

judge :: Board -> Judge
judge brd = if any line pat then Win else Continue
    where
        pat = [ [1,2,3], [4,5,6], [7,8,9], [1,4,7], [2,5,8], [3,6,9], [1,5,9], [3,5,7] ]
        line (x:xs) = case brd ! x of
            Blank -> False
            x' -> all (==x') . map (brd!) $ xs

-- ゲーム進行上のエラー
newtype GameError = GameError String deriving Show

instance Error GameError where
    strMsg = GameError

errMsg :: GameError -> String
errMsg (GameError msg) = "ERROR: " ++ msg

-- Main
main :: IO ()
main = game initBoard Maru

game :: Board -> CellState -> IO ()
game b p = do
    putStrLn $ showCellState p ++ "のターン"
    putStrLn $ renderBoard b
    putStr "置きたい場所の番号を選んでください >"
    hFlush stdout
    n <- (\s -> if all isDigit s then read s else 0) <$> getLine
    let (res,b') = runGame (process p n) b
    either err (next b' p) res
    where
        err e = putStrLn (errMsg e) >> game b p
        next b p Continue = game b $ if p == Maru then Batsu else Maru
        next b p Win = do
            putStrLn $ renderBoard b
            putStrLn $ showCellState p ++ "の勝利です。"

process :: CellState -> Int -> Game Board GameError Judge
process cst n = do
    get >>= either throwError put . updateBoard n cst
    get >>= return . judge