Haskell で三目並べ (２)

前回のつづきで三目並べ。
マシン側の指し手の選択を、少しだけ知的にしてみる。

以前の記事で、ルール言語の Drools を使って、下記のようなルールで三目並べを書いた。

1. 後一手で列が完成する盤面なら、その列を完成して終了。
2. ユーザが後一手で一列完成できる盤面なら、それをブロックする。
3. 後一手で二方向の王手が作れる盤面なら、それを作る。
4. ユーザが後一手で二方向の王手が作れる盤面なら、ブロックする。
5. 中央が空いていたら、そこに置く。
6. 相手が角を取っていて対角が空いていたら、そこに置く。
7. 角が空いていたらそこに置く。
8. 空いているマスがあったら、そこに置く。

これを Haskell で書いてみたい。（参考wiki）

◆ 方針

前回の暫定実装した、マシンの指し手を選択する関数をこんな風に書き換えてみる。

machinesTurn :: StateT Board IO Int
machinesTurn = do
    board <- get
    let idx = fromJust $ select board
    updateBoard Machine idx
    return idx
  where
    select = 
        findWinPos       <||>
        findBlockPos     <||>
        findForkPos      <||>
        findForkBlockPos <||>
        tryCenter        <||>
        findAnyBlank
    f1 <||> f2 = mplus <$> f1 <*> f2

select 以下に並べられた findWinPos から findAnyBlank までの関数は、盤面 Board を取って、指し手を Maybe Intとして返すもの。

これらの関数そのものを「(->) r」というタイプの Applicative とみなして合成する演算子を、<||> として定義した。MonadPlus としての Maybe の振る舞いを利用している。

結果として合成された select 関数は、ある関数に盤面を与えて、指し手が得られたらそれを返し、ダメなら次の関数に盤面を与えるという計算を数珠つなぎにしたものになる。 ※((->) r)を Functor や Applicative として扱う手法はこのあたりの記事に詳しい。Applicative 一般の入門としても、超絶わかりやすく解説されている。

◆ コード全体

findWinPos 〜 findAnyBlank の実装は以下のようなものになる（前回書いた部分も含めて全部晒してしまうことにした）。

import Control.Monad.State
import Control.Applicative
import Data.List
import Data.Functor.Identity
import Control.Monad.List
import Data.Maybe
import qualified Data.List.Utils as LU
import System

data Mark = User|Machine|Blank deriving Eq
instance Show Mark where
  show User    = "U"
  show Machine = "M"
  show Blank   = " "

type Board = [Mark]

main :: IO ()
main = do
    args <- getArgs
    let machineFirst = 0 < length args && "m"==args!!0
    evalStateT (play machineFirst) initialBoard >>= putStrLn

initialBoard :: Board
initialBoard = take 9 $ repeat Blank

printBoard :: Board -> IO ()
printBoard board =
    putStrLn $ unlines $ LU.join ["-+-+-"] $ map showRow [0..2]
  where
    showRow row = [LU.join "|" $ map show $ cells row]
    cells   row = take 3 $ snd $ splitAt (row * 3) board

play :: Bool -> StateT Board IO String
play isMachinesTurn = do
    if isMachinesTurn then machinesTurn
                      else usersTurn
    board <- get
    liftIO $ printBoard board
    case judge board of
        Nothing     -> (play $ not isMachinesTurn)
        Just result -> return result

judge :: Board -> Maybe String
judge board
    | wonBy User board                 = return "won by user."
    | wonBy Machine board              = return "won by machine."
    | Nothing == elemIndex Blank board = return "drawn."
    | otherwise                        = Nothing

wonBy :: Mark -> Board -> Bool
wonBy mark board = any threeInRow rows
  where
    threeInRow indices = all (mark==) $ rowStates indices
    rowStates indices  = map (board!!) indices

rows :: [[Int]]
rows = [[0,3,6],[1,4,7],[2,5,8],
        [0,1,2],[3,4,5],[6,7,8],
        [0,4,8],[2,4,6]]

updateBoard :: Mark -> Int -> StateT Board IO ()
updateBoard mark pos = get >>= put.(update mark pos)

update :: Mark -> Int -> Board -> Board
update mark pos board =
    let (f, (x:xs)) = splitAt pos board in f ++ (mark:xs)

usersTurn :: StateT Board IO Int
usersTurn = do
    position <- liftIO getDigit
    board    <- get
    if Blank /= board!!position
        then (liftIO $putStrLn "wrong position") >> usersTurn
        else updateBoard User position >> return position
  where
    getDigit = do
        ch <- getChar
        putStrLn ""
        if elem ch ['0'..'8']
            then return (read [ch])
            else putStrLn "wrong input" >> getDigit

machinesTurn :: StateT Board IO Int
machinesTurn = do
    board <- get
    let idx = fromJust $ select board
    updateBoard Machine idx
    return idx
  where
    select =
      findWinPos       <||>
      findBlockPos     <||>
      findForkPos      <||>
      findForkBlockPos <||>
      tryCenter        <||>
      findAnyBlank
    f1 <||> f2 = mplus <$> f1 <*> f2

findWinPos :: Board -> Maybe Int
findWinPos   = findWinPos' Machine

findBlockPos :: Board -> Maybe Int
findBlockPos = findWinPos' User

findWinPos' :: Mark -> Board -> Maybe Int
findWinPos' mark board =
    ff ([mark, mark, Blank], 2) `mplus`
    ff ([mark, Blank, mark], 1) `mplus`
    ff ([Blank, mark, mark], 0)
  where
    ff (css, idx) = do findPattern css board >>= return.(!!idx)

findForkPos      :: Board -> Maybe Int
findForkPos      = findForkPos' Machine

findForkBlockPos :: Board -> Maybe Int
findForkBlockPos = findForkPos' User

findForkPos':: Mark -> Board -> Maybe Int
findForkPos' mark brd = do
    let posibles = elemIndices Blank brd
    idx <- findIndex (\pos->containsFork (update mark pos brd)) posibles
    return $ posibles!!idx
  where
    containsFork  b = (2<=) $ length $ findTwoInARow b
    findTwoInARow b = findIndices (matchTwoInARow b) rows
    matchTwoInARow b row =
        let stts = map (b!!) row
        in 2 == (countState mark stts) && 1 == (countState Blank stts)

findOppositeCorner :: Board -> Maybe Int
findOppositeCorner brd = do
    let pairs = [(0,8), (8,0), (2,6), (6,2)]
    r' <- findIndex (\(f,s)-> brd!!f==User && brd!!s==Blank) pairs
    return $ snd $ pairs!!r'

findBlankCorner :: Board -> Maybe Int
findBlankCorner = findBlankCell [0, 2, 8, 6]

findBlankCell   :: [Int] -> Board -> Maybe Int
findBlankCell candidate board =
    findIndex ((Blank==).(board!!)) candidate
    >>= return.(candidate!!)

findAnyBlank :: Board -> Maybe Int
findAnyBlank board = elemIndex Blank board

tryCenter     :: Board -> Maybe Int
tryCenter brd = if Blank == brd!!4 then Just 4 else Nothing

findPattern :: [Mark] -> Board -> Maybe [Int]
findPattern pattern board = do
    idx <- elemIndex pattern $ map (\row->map (\idx->board!!idx) row) rows
    return $ rows!!idx

countState :: Mark -> [Mark] -> Int
countState state cells = length $elemIndices state cells

◆ まとめ

• 実は、上のアルゴリズムではユーザ先手で 0, 8, 6 と指すと、ユーザが勝ってしまう。三目並べはちゃんとやると引き分けになるんだけど、ちょっと手抜きをしている（ユーザのフォークをマシンが防ぐ辺り）。三目並べ自体が目的ではないので、割愛した。
• 少し書いては直し、また書いては直しと常時リファクタしているが、コンパイルが通るだけで、感覚的には JUnit で 6割くらいのコード・カバレッジがあるくらいの安定感がある。この 150行弱のコードだと、デグレ的な事は一回も起きなかった。
• 上で少し触れたサイト、「Learn You a Haskell for Great Good!」の、Functor 〜 Applicative 〜 Monado の解説(この順序で説明されている）が、ものすごくわかりやすくて感動。