読者です 読者をやめる 読者になる 読者になる

bitterharvest’s diary

A Bitter Harvestは小説の題名。作者は豪州のPeter Yeldham。苦闘の末に勝ちえた偏見からの解放は命との引換になったという悲しい物語

解釈次第で!(2)

1.三目並べ

オペレーショナル・モナドには、いくつかの例が紹介されてるが、その中から、三目並べ(Tic Tac Tow)を詳しく調べてみる。オペレーショナル・モナドの使用に当たっては、次のモジュールをロードしておく必要がある。

cabal install operational

三目並べは、二人が戦う対戦ゲームである。一方が盤面を見て次の手を打ち、次に、他方が盤面を見て次の手を打ち、どちらかが勝つか、引き分けになるまで、この動作を繰り返すこととなる。従って、このゲームの命令は、「盤面を読む」と「次の手を打つ」という二つの命令があればよさそうである。

これは、プログラムの冒頭で定義されている。

data PlayerI a where
    ReadBoard :: PlayerI Board
    PlayMove  :: Int -> PlayerI Bool
    

ReadBoardとPlayMoveは代数的データ型(dataで定義)でのデータコンストラクタと呼ばれている。PlayerIのIはInstruction(命令)を意味している。簡単にいうと、プレイヤーが取れる命令は、ReadBoard(盤面を読む)とPlayMove(次の手を打つ)の二つである。それぞれの命令は、PlayerIを再帰的に読んでいる。ReadBoardはPlayerI Boardとなっている。ここで、PlayerIをInt -> PlayerI Boolで書き換えると、(Int -> PlayerI Bool) Boardとなる。さらに、PlayerIをPlayerI Boardで置き換えると(Int -> (PlayerI Board) Bool) Boardとなる。少し分かりにくくなってきたので、これを図示する。プレイヤーは二人いるので、自分と相手ということにし、それぞれについて、再帰的な命令を繰り返し使ったとすると、例えば、以下のものが得られる。
f:id:bitterharvest:20140817115116p:plain
なんと、PlayerIはゲームの進行状況を示している。

ところで、haskellは純粋関数型のプログラミング言語である。変数に一度値を設定したら後から変えることはできない。ところで、盤面の状態はゲームの進行とともに変化してゆく。このように、変化するものは純粋関数型で記述することはできないので、Haskellでは特別な手段を許している。それがモナドである。現実の世界を表す時に使われる。

PlayerIを現実の世界に移したのが、次の型シノニムである。

type Player m a = ProgramT PlayerI m a

上述のシノニムPlayerは、PlayerIを現実の世界に移したプログラムである。この記述はオペレーショナル・モナドを用いるときの定型文である。

次に、命令も現実の世界に移さなければならないが、それは次のようになってる。

readBoard = singleton ReadBoard
playMove  = singleton . PlayMove

これも、オペレーショナル・モナドを用いるときの定型文である。

2.プレーヤの動作

ここで説明中のプログラムは、人間とコンピュータ(AIと呼んでいる)が戦うようになっている。人間側のプログラムを見ると次のようになってる。

playerHuman :: Player IO ()
playerHuman = forever $ readBoard >>= liftIO . printBoard >> doMove
    where
    -- ask the player where to move
    doMove :: Player IO ()
    doMove = do
        liftIO . putStrLn $ "At which number would you like to play?"
        n <- liftIO getLine
        b <- playMove (read n)
        unless b $ do
            liftIO . putStrLn $ "Position " ++ show n ++ " is already full."
            doMove

上述のプログラムは、盤面の出力や入力名の催促などがあって、少し長いプログラムになっているが、基本的には、readBoardとplayMoveを繰り返していることが分かる(playMoveではすでに石が置かれているところは受け付けないことが分かる)。

コンピュータの方は、AIとうたっているが、ランダムに打つ場所を決めているだけで、同じように、readBoardとplayMoveとを繰り返している。

3.ゲームの状態

ゲームの状態は、レコード構文を用いて次のようになってる。

data GameState = Game { board :: Board, activePlayer :: Symbol }

ここで、盤面は

data Symbol = X | O deriving (Eq,Show)
type Square = Either Int Symbol
type Board = [[Square]]

とする。
ゲームの初期状態は次のようになってる。(先手はXである。これは人間)

initialGameState :: GameState
initialGameState = Game (map (map Left) [[1,2,3],[4,5,6],[7,8,9]]) X

4.プログラムの解釈

プログラムは先頭の命令を取り出し、それを解釈するが、次のようになってる。

runGame :: Player IO () -> Player IO () -> IO ()
runGame player1 player2 = eval' initialGameState player1 player2
    where
    eval' game p1 p2 = viewT p1 >>= \p1view -> eval game p1view p2
    
    eval :: GameState
         -> ProgramViewT PlayerI IO () -> Player IO ()
         -> IO ()
    eval game (Return _)            _  = return ()
    eval game (ReadBoard   :>>= p1) p2 = eval' game (p1 (board game)) p2
    eval game (PlayMove mv :>>= p1) p2 =
        case makeMove mv game of
            Nothing         -> eval' game (p1 False) p2
            Just game'
                | won game' -> let p = activePlayer game in
                               putStrLn $ "Player " ++ show p ++ " has won!"
                | draw game'-> putStrLn $ "It's a draw."
                | otherwise -> eval' game' p2 (p1 True)

今、プレイヤーをp1とする。p1がdoMoveを実行したとする。doMoveに対する処理は、パターン照合で選択される。パターン照合は、純粋世界の命令との照合となっているので、doMoveを受け取ると、PlayMoveが一致する。従って、次の部分が実行される。

    eval game (PlayMove mv :>>= p1) p2 =
        case makeMove mv game of
            Nothing         -> eval' game (p1 False) p2
            Just game'
                | won game' -> let p = activePlayer game in
                               putStrLn $ "Player " ++ show p ++ " has won!"
                | draw game'-> putStrLn $ "It's a draw."
                | otherwise -> eval' game' p2 (p1 True)

もし有効な打ち手であれば次が実行される。即ち、打ち手がp2へと移る。

                | otherwise -> eval' game' p2 (p1 True)

なお、新しい手を打った時の新しい盤面の状態は次のプログラムで得られる。

makeMove :: Int -> GameState -> Maybe GameState
makeMove k (Game board player)
    | not (k `elem` possibleMoves board) = Nothing   -- illegal move
    | otherwise = Just $ Game (map (map replace) board) (switch player)
    where
    replace (Left k') | k' == k = Right player
    replace x                   = x

    switch X = O
    switch O = X

また、勝敗の判定は次のようになる。

won :: GameState -> Bool
won (Game board _) = any full $ diagonals board ++ rows board ++ cols board
    where
    full [a,b,c] = a == b && b == c
    diagonals [[a1,_,b1],
               [_ ,c,_ ],
               [b2,_,a2]] = [[a1,c,a2],[b1,c,b2]]
    rows = id
    cols = transpose

    -- is the game a draw?
draw :: GameState -> Bool
draw (Game board _) = null (possibleMoves board)

5.課題1

コンピュータの打ち手を改良して、AIらしくしなさい。

6.課題2

オセロゲームを作成しなさい。

7.最後に

全てをまとめたプログラムは次のようになっている。

{------------------------------------------------------------------------------
    Control.Monad.Operational
    
    Example:
    An implementation of the game TicTacToe.
    
    Each player (human, AI, ...) is implemented in a separate monad
    which are then intermingled to run the game. This resembles the
    PoorMansConcurrency.hs example.
    
    
    Many thanks to Yves Par`es and Bertram Felgenhauer
    http://www.haskell.org/pipermail/haskell-cafe/2010-April/076216.html

------------------------------------------------------------------------------}
{-# LANGUAGE GADTs, Rank2Types #-}

import Control.Monad
import Control.Monad.Operational
import Control.Monad.State

import Data.Either
import Data.List

    -- external libraries needed
import System.Random

{------------------------------------------------------------------------------
    The Player monad for implementing players (human, AI, ...)
    provides two operations
    
        readBoard   -- read the current board position
        playMove    -- play a move

    to query the current board position and perform a move, respectively.
    
    Moreover, it's actually a monad transformer intended to be used over IO.
    This way, the players can perform IO computations.
------------------------------------------------------------------------------}
data PlayerI a where
    ReadBoard :: PlayerI Board
    PlayMove  :: Int -> PlayerI Bool
    
type Player m a = ProgramT PlayerI m a

readBoard = singleton ReadBoard
playMove  = singleton . PlayMove

    -- interpreter
runGame :: Player IO () -> Player IO () -> IO ()
runGame player1 player2 = eval' initialGameState player1 player2
    where
    eval' game p1 p2 = viewT p1 >>= \p1view -> eval game p1view p2
    
    eval :: GameState
         -> ProgramViewT PlayerI IO () -> Player IO ()
         -> IO ()
    eval game (Return _)            _  = return ()
    eval game (ReadBoard   :>>= p1) p2 = eval' game (p1 (board game)) p2
    eval game (PlayMove mv :>>= p1) p2 =
        case makeMove mv game of
            Nothing         -> eval' game (p1 False) p2
            Just game'
                | won game' -> let p = activePlayer game in
                               putStrLn $ "Player " ++ show p ++ " has won!"
                | draw game'-> putStrLn $ "It's a draw."
                | otherwise -> eval' game' p2 (p1 True)
    
    -- example: human vs AI
main = do
    g <- getStdGen
    runGame playerHuman (playerAI g)

{------------------------------------------------------------------------------
    TicTacToe Board type and logic
    
    The board looks like this:
    
    +---+---+---+   some squares already played on
    | 1 | 2 | 3 |   the empty squares are numbered
    +---+---+---+
    | 4 | 5 |OOO|
    +---+---+---+
    | 7 |XXX| 9 |
    +---+---+---+
------------------------------------------------------------------------------}
data Symbol = X | O deriving (Eq,Show)
type Square = Either Int Symbol
type Board = [[Square]]
data GameState = Game { board :: Board, activePlayer :: Symbol }

initialGameState :: GameState
initialGameState = Game (map (map Left) [[1,2,3],[4,5,6],[7,8,9]]) X

    -- list the possible moves to play
possibleMoves :: Board -> [Int]
possibleMoves board = [k | Left k <- concat board]

    -- play a stone at a square
makeMove :: Int -> GameState -> Maybe GameState
makeMove k (Game board player)
    | not (k `elem` possibleMoves board) = Nothing   -- illegal move
    | otherwise = Just $ Game (map (map replace) board) (switch player)
    where
    replace (Left k') | k' == k = Right player
    replace x                   = x

    switch X = O
    switch O = X

    -- has somebody won the game?
won :: GameState -> Bool
won (Game board _) = any full $ diagonals board ++ rows board ++ cols board
    where
    full [a,b,c] = a == b && b == c
    diagonals [[a1,_,b1],
               [_ ,c,_ ],
               [b2,_,a2]] = [[a1,c,a2],[b1,c,b2]]
    rows = id
    cols = transpose

    -- is the game a draw?
draw :: GameState -> Bool
draw (Game board _) = null (possibleMoves board)

    -- print the board
showSquare = either (\n -> " " ++ show n ++ " ") (concat . replicate 3 . show)

showBoard :: Board -> String
showBoard board =
      unlines . surround "+---+---+---+"
    . map (concat . surround "|". map showSquare)
    $ board
    where
    surround x xs = [x] ++ intersperse x xs ++ [x]

printBoard = putStr . showBoard

{------------------------------------------------------------------------------
    Player examples
------------------------------------------------------------------------------}
    -- a human player on the command line
playerHuman :: Player IO ()
playerHuman = forever $ readBoard >>= liftIO . printBoard >> doMove
    where
    -- ask the player where to move
    doMove :: Player IO ()
    doMove = do
        liftIO . putStrLn $ "At which number would you like to play?"
        n <- liftIO getLine
        b <- playMove (read n)
        unless b $ do
            liftIO . putStrLn $ "Position " ++ show n ++ " is already full."
            doMove

    -- a random AI,
    -- also demonstrates how to use a custom StateT on top
    --   of the Player monad
playerAI :: Monad m => StdGen -> Player m ()
playerAI = evalStateT ai
    where
    ai :: Monad m => StateT StdGen (ProgramT PlayerI m) ()
    ai = forever $ do
        board <- lift $ readBoard
        n     <- uniform (possibleMoves board) -- select a random move
        lift $ playMove n
        where
        -- select one element at random
        uniform :: Monad m => [a] -> StateT StdGen m a
        uniform xs = do
            gen <- get
            let (n,gen') = randomR (1,length xs) gen
            put gen'
            return (xs !! (n-1))