a-sanの日記

■ ○×ゲーム

前回のオセロをベースに○×ゲームを作ってみました。

ルールが簡単な分、簡単にできました。

しかも、人VSコンピュータもできます。結構賢いですよ。

以下のようにすると、人VS人もできます。

main = playGame playerMan playerMan

-------------------------------------------------------------------------------
-- ○×ゲーム（三目並べ）
-- ○×ゲームは先手必勝でも後手必勝でもなく、両者が最善の手を打つと引き分けます。
-------------------------------------------------------------------------------
import System.Random

data Piece = Empty | O | X deriving (Eq, Show)
type Board = [[Piece]]
type Pt = (Int,Int)

boardSize::Int
boardSize = 3   -- ３固定

-------------------------------------------------------------------------------
-- 盤面の初期化
-------------------------------------------------------------------------------
initBoard:: Board
initBoard = [[ Empty | x <- [0,1,2]] | y <- [0,1,2]]

-------------------------------------------------------------------------------
-- 盤面の指定された場所のコマを返す。
-------------------------------------------------------------------------------
getBoard:: Board -> Pt -> Piece
getBoard board (x,y) = board !! y !! x

-------------------------------------------------------------------------------
-- 盤面の指定された場所にコマを置いて、新しい盤面を返す。
-------------------------------------------------------------------------------
setBoard:: Board -> Pt -> Piece -> Board
setBoard board (x,y) val = bs1 ++ [ps1 ++ [val] ++ ps2] ++ bs2 where
    (bs1,b:bs2) = splitAt y board
    (ps1,_:ps2) = splitAt x b

-------------------------------------------------------------------------------
-- 盤面の内容を表示する
-------------------------------------------------------------------------------
showBoard:: Board -> IO ()
showBoard board = putStr (concat (map showLine board))
    where
        showLine line = unwords (map getSymbol line) ++ "\n"
        getSymbol val = case val of
            Empty -> "- "
            O     -> "O "
            X     -> "X "

-------------------------------------------------------------------------------
-- 相手の色
-------------------------------------------------------------------------------
opponent:: Piece -> Piece
opponent ox = if ox==O then X else O

-------------------------------------------------------------------------------
-- 盤面上の白黒いずれかの個数を返す．
-------------------------------------------------------------------------------
getCount:: Board -> Piece -> Int
getCount board ox =
    length (filter (\val -> val == ox) (concat board))

-------------------------------------------------------------------------------
-- 盤面の外か？
-------------------------------------------------------------------------------
outOfBounds (x,y) =
    x < 0 || x > 2 || y < 0 || y > 2

-------------------------------------------------------------------------------
-- 石を置く
-- oxの手番で，pointに石を置く．
-- 手が有効であれば，石を置く処理を行ってTrueと盤面を返す．
-- そうでなければ，Falseと盤面を返す．
-------------------------------------------------------------------------------
doMove:: Piece -> Pt -> Board -> (Bool,Board)
doMove ox pt board =
    if getBoard board pt == Empty
        then (True, setBoard board pt ox)
        else (False, board)

-------------------------------------------------------------------------------
-- MANプレイヤ操作関数
-- 手を入力して 局面を進めて，Trueと盤面を返す．
-- -1,-1を入力した場合，投了であるとして，Falseと盤面を返す．
-------------------------------------------------------------------------------
playerMan:: Piece -> Board -> IO (Bool,Board)
playerMan ox board = do
    -- プロンプト
    putStrLn (show ox ++ ">> ")
    -- 手を読み込む
    x <- getLine >>= return . read
    y <- getLine >>= return . read
    if x == -1
        then return (False, board)  -- Falseを返して終了
        else
            if outOfBounds (x,y)
                then do
                    putStrLn "illegal position"
                    playerMan ox board      -- 手が無効(盤の外)
                else
                    let
                        (done,newBoard) = doMove ox (x,y) board -- 指定された石を置く
                    in
                        if done 
                            then return (done,newBoard)
                            else do
                                putStrLn "illegal position"
                                playerMan ox board

-------------------------------------------------------------------------------
-- 勝ったか？
-------------------------------------------------------------------------------
isWin:: Piece -> Board -> Bool
isWin ox board =
    any (\pts -> isAllSameColor pts)
        [
            [(0,0),(0,1),(0,2)],
            [(1,0),(1,1),(1,2)],
            [(2,0),(2,1),(2,2)],
            [(0,0),(1,0),(2,0)],
            [(0,1),(1,1),(2,1)],
            [(0,2),(1,2),(2,2)],
            [(0,0),(1,1),(2,2)],
            [(0,2),(1,1),(2,0)]]
    where
        isAllSameColor pts =
            -- どれか１つでもそれ以外の色ならダメ
            not $ any (\pt -> getBoard board pt /= ox) pts

-------------------------------------------------------------------------------
-- ゲームの補助関数
-------------------------------------------------------------------------------
playGame':: (Piece->Board->IO(Bool,Board)) -> (Piece->Board->IO(Bool,Board)) -> Piece -> Board -> IO()
playGame' playerO playerX ox board = do
    -- 局面の表示
    showBoard board
    if getCount board Empty == 0
        -- 盤面が全て埋めつくされているか，
        then putGameOver board Empty
        else do
            -- 一手進める
            (done,newBoard) <- (if ox == O then playerO else playerX) ox board
            -- 次の手番(*-player-moveが True を返した場合)
            if done
                then if isWin ox newBoard
                    then do
                        showBoard newBoard
                        putStrLn ("Winner:" ++ show ox)
                    else playGame' playerO playerX (opponent ox) newBoard
                -- 投了(*-player-moveが False を返した場合)
                else putGameOver board (opponent ox)
    where
        putGameOver board winner = do
            putStrLn "*** GAME OVER ***"
            putStrLn ("winner: " ++ (if winner == Empty then "draw" else show winner))

-------------------------------------------------------------------------------
-- ゲームを行う
-- 引数
--   playerO ○の操作を行う関数
--   playerX ×の操作を行う関数
-- playerManを使うとユーザが操作を行うことになる．
-------------------------------------------------------------------------------
playGame:: (Piece->Board->IO(Bool,Board)) -> (Piece->Board->IO(Bool,Board)) -> IO()
playGame playerO playerX =
    -- gameの本体(game-auxの呼びだし)
    -- 現在の状態が与えられない場合は，初期状態からスタート
    playGame' playerO playerX O initBoard

-------------------------------------------------------------------------------
-- ゲームを行う
-------------------------------------------------------------------------------
main = playGame playerMan playerCom        -- 人VSコンピュータ
-- main = playGame playerMan playerMan        -- 人VS人

-------------------------------------------------------------------------------
-- COMプレイヤ操作関数
-- 最善と思われる手を打ち、盤面を返す。
-------------------------------------------------------------------------------
playerCom:: Piece -> Board -> IO(Bool,Board)
playerCom ox board = do
    hand <- getBestHand board ox
    putStrLn (show ox ++ ">> " ++ show hand)
    return $ doMove ox hand board


-------------------------------------------------------------------------------
-- 空いている位置のリストを返す
-------------------------------------------------------------------------------
getHands:: Board -> [Pt]
getHands board = 
    [(x,y) | x<-[0..boardSize-1], y<-[0..boardSize-1], getBoard board (x,y) == Empty]

-------------------------------------------------------------------------------
-- oxを置くと勝ちになる位置のリストを返す
-------------------------------------------------------------------------------
getCheckmatePts:: Board -> Piece -> [Pt]
getCheckmatePts board ox =
    [pt | pt <- getHands board, isWin ox (setBoard board pt ox)]


-------------------------------------------------------------------------------
-- 最善と思われる手を返す
-------------------------------------------------------------------------------
getBestHand:: Board -> Piece -> IO (Pt)
getBestHand board ox = 
    let
        -- 優先度１：自分が打って勝てる場所のリスト
        hands1 = getCheckmatePts board ox
        -- 優先度２：相手が打つと勝つ場所のリスト
        hands2 = getCheckmatePts board (opponent ox)
        -- 優先度３：真ん中
        hands3 = if getBoard board (1,1) == Empty
                    then [(1,1)]
                    else []
        -- 優先度４：四つ角
        hands4 = [pt | pt <- [(0,0),(0,2),(2,0),(2,2)], getBoard board pt == Empty]
        hands = (hands1 ++ hands2 ++ hands3 ++ hands4)
    in
        if length hands > 0
            then return $ head hands
            -- ランダムに打つ
            else getRandomHand board ox


-------------------------------------------------------------------------------
-- 空いている箇所にランダムに打つ
-------------------------------------------------------------------------------
getRandomHand:: Board -> Piece -> IO (Pt)
getRandomHand board ox = do
    seed <- getStdGen
    rs <- return $ randomRs(0,boardSize-1) seed
    return $ getRandomHand' rs
    where
        getRandomHand' rs =
            let
                x = head rs
                y = head $ tail rs
            in
                if getBoard board (x,y) == Empty
                    then (x,y)
                    else getRandomHand' (tail rs)
{-
Hugs> :l "OXGame.hs"
Main> main
-  -  -
-  -  -
-  -  -
O>>
1
1
-  -  -
-  O  -
-  -  -
X>> (0,0)
X  -  -
-  O  -
-  -  -
O>>
0
1
X  -  -
O  O  -
-  -  -
X>> (2,1)
X  -  -
O  O  X
-  -  -
O>>
0
2
X  -  -
O  O  X
O  -  -
X>> (2,0)
X  -  X
O  O  X
O  -  -
O>>
1
0
X  O  X
O  O  X
O  -  -
X>> (2,2)
X  O  X
O  O  X
O  -  X
Winner:X
-}

■ Haskellでオセロ

とりあえず「ハスケリ本」と「ふつケル本」は読んで、例題の数行ぐらいなら何とか書けるようになったぐらいです。

年末からオセロを移植していたのだけれど、やっとマトモに動くレベルまでこぎつけました。添削歓迎

{------------------------------------------------------------------------------
Reversi
Haskellの習得のため、Schemeで書かれたリバーシ（オセロ）をHaskellに移植してみる。
参考：
http://www.stdio.h.kyoto-u.ac.jp/~hioki/gairon-enshuu/kadai2005/7.html
盤面上のマスは(x,y)で指定する(1<= x,y <= 8)．
-------------------------------------------------------------------------------}
data Piece = Empty | Black | White | Wall deriving (Eq, Show)
type Board = [[Piece]]
type Pt = (Int,Int)

-------------------------------------------------------------------------------
-- 盤面サイズ
-------------------------------------------------------------------------------
boardSize :: Int
boardSize = 8

-------------------------------------------------------------------------------
-- 8方向(dx,dy)のリスト
-------------------------------------------------------------------------------
directions :: [Pt]
directions = [(0, 1),(-1, 1),(-1, 0),(-1, -1),(0, -1),(1,-1),(1, 0),(1, 1)]

-------------------------------------------------------------------------------
-- 盤面の初期化
-- 境界に「壁」をダミーとして置いてある．
-------------------------------------------------------------------------------
initBoard:: Board
initBoard = [[ (f x y) | x <- [0..9]] | y <- [0..9]]
    where f x y
        | x == 0 || y == 0 || x == 9 || y == 9  = Wall
        | x == 4 && y == 4  = White
        | x == 5 && y == 5  = White
        | x == 4 && y == 5  = Black
        | x == 5 && y == 4  = Black
        | otherwise         = Empty

-------------------------------------------------------------------------------
-- 盤面の指定された場所のコマを返す。
-------------------------------------------------------------------------------
getBoard:: Board -> Pt -> Piece
getBoard board (x,y) = board !! y !! x

-------------------------------------------------------------------------------
-- 盤面の指定された場所にコマを置いて、新しい盤面を返す。
-------------------------------------------------------------------------------
setBoard:: Board -> Pt -> Piece -> Board
setBoard board (x,y) val = 
    (take y board) ++ ((take x b) ++ val : (drop (x+1) b)) : (drop (y+1) board)
    where
        b = board !! y

-------------------------------------------------------------------------------
-- 盤面の内容を表示する
-------------------------------------------------------------------------------
showBoard:: Board -> IO ()
showBoard board = putStr (concat (map showLine board))
    where
        showLine line =
            concat (map getSymbol line) ++ "\n"
        getSymbol val = case val of
            Empty -> "- "
            Black -> "B "
            White -> "W "
            Wall  -> "X "

-------------------------------------------------------------------------------
-- 相手の色
-------------------------------------------------------------------------------
opponent:: Piece -> Piece
opponent bw = if bw==White then Black else White

-------------------------------------------------------------------------------
-- 盤面上の白黒いずれかの個数を返す．
-------------------------------------------------------------------------------
pcount:: Board -> Piece -> Int
pcount board bw =
    length (filter (\val -> val == bw) (concat board))

{-
-------------------------------------------------------------------------------
-- 盤面上の白黒の個数を返す．
-- (黒の個数 白の個数)というタプルを返す
-------------------------------------------------------------------------------
bw_count:: Board -> (Int,Int)
bw_count board = (pcount board Black, pcount board White)
-}

-------------------------------------------------------------------------------
-- 与えられた点のある方向の位置 neighbor (5,3) (-1,1) のとき (4,4) を返す
-------------------------------------------------------------------------------
neighbor:: Pt -> Pt -> Pt
neighbor (x,y) (dx,dy) = (x+dx, y+dy)

-------------------------------------------------------------------------------
-- 同一色のrunの終点を調べる．
-- pointのdir方向の隣接点から延びるbwのrunの終点を調べる．
-- そのようなrunがなければ，pointそのものを返す．
--   pt    調べ始める場所
--   dir   方向
--   bw    調べる色
--   board 局面
-------------------------------------------------------------------------------
run_end:: Pt -> Pt -> Piece -> Board -> Pt
run_end pt dir bw board =
    if getBoard board p == bw
        then (run_end p dir bw board)
        else pt
    where
        p = neighbor pt dir

-------------------------------------------------------------------------------
-- p1 と p2 は同一地点か??
-------------------------------------------------------------------------------
the_same_point:: Pt -> Pt -> Bool
the_same_point (x1,y1) (x2,y2) = x1==x2 && y1==y2

-------------------------------------------------------------------------------
-- dirは有効な方向の指定か?
-------------------------------------------------------------------------------
valid_direction:: Pt -> Bool
valid_direction (dx,dy) =
     ((abs dx <= 1) && (abs dy <= 1)) &&
     (not ((dx==0)&&(dy==0)))

-------------------------------------------------------------------------------
-- pointが盤面の境界を越えているか??
-------------------------------------------------------------------------------
out_of_bounds:: Pt -> Bool
out_of_bounds (x,y) =
    (y<0) || (x<0) || (y>=boardSize) || (x>=boardSize)

-------------------------------------------------------------------------------
-- flippable-range+-dir: 1方向に関して石の挟むことのできる範囲を返す．
-- bwの手番でpointのdir方向で挟むことのできる石の範囲を返す．
-- 挟める石がなければ[]を返す．
-- 範囲は，(反転できる始点 反転できる終点の隣)を返す
--   bw    手番
--   point 石を置く場所
--   dir   方向
--   board 局面
-- 例:
-- flippable_range_dir Black (1,1) (0,1) board => [(1,2),(1,6)]
-- (1,2) (1,3) (1,4) (1,5)が反転できることを意味する．
-- つまり，(1,2)--(1,5)は相手の石，(1,6)はbwの石である．
-------------------------------------------------------------------------------
flippable_range_dir:: Piece -> Pt -> Pt -> Board -> [Pt]
flippable_range_dir bw point dir board =
    if
        (getBoard board point == Empty) && (valid_direction dir)
    then
        if (the_same_point s_end point)
        then []
        else
            if (getBoard board s_end_next) == bw
            then [(neighbor point dir), s_end_next]
            else []
    else
        []
    where
        s_end = (run_end point dir (opponent bw) board)
        s_end_next = (neighbor s_end dir)
-- flippable_range_dir black [3,4] [1,0] initBoard => [[4,4],[5,4]]


-------------------------------------------------------------------------------
-- run-dirs: 石を挟める方向を列挙する
-- bwの手番でpointで石を挟める方向を列挙する
--   bw    手番
--   point 石を置く場所
--   board 局面
-------------------------------------------------------------------------------
run_dirs:: Piece -> Pt -> Board -> [Pt]
run_dirs bw point board =
    aux [] directions
    where
        aux p dirs
            | (null dirs) = p
            | null (flippable_range_dir bw point (head dirs) board) = aux p (tail dirs)
            | otherwise = aux (p ++ [head dirs]) (tail dirs)
-- run_dirs black [3,4] initBoard => [(1,0)]

-------------------------------------------------------------------------------
-- do-flip-dir: 1方向に関して石の反転処理を行う．
-- pointのdir方向にbwへの反転を実行する．
-- dir方向の隣接点から反転することに注意．
-- (point自体については操作しない)
--   bw    手番
--   point 石を置く場所
--   dir   方向
--   board 局面
-------------------------------------------------------------------------------
do_flip_dir:: Piece -> Pt -> Pt -> Board -> Board
do_flip_dir bw point dir board =
    flip board (neighbor point dir)
    where
        seq = (flippable_range_dir bw point dir board)
        seq_end = head(tail seq)
        flip board p =
            if the_same_point p seq_end
            then board
            else (flip (setBoard board p bw) (neighbor p dir))
-- do_flip_dir black [3,4] [1,0] initBoard => [[1,0]]
-- setBoard initBoard [3,4] black


-------------------------------------------------------------------------------
-- do-move: 石を置く
-- 引数
--   bw    手番
--   point 石を置く場所 (y x)
--   board 局面
-- bwの手番で，pointに石を置く．
-- 手が有効であれば，石を置く処理を行って#tを返す．
-- そうでなければ，#fを返す．
-------------------------------------------------------------------------------
do_move:: Piece -> Pt -> Board -> (Bool,Board)
do_move bw point board =
    let
        d = (run_dirs bw point board)
    in
        if (null d)
        then (False, board)
        else (True, (do_move_aux board d))
    where
        -- do-move-aux: 石を置く処理を行う
        -- 引数 
        --   dirs 反転処理を行う方向のリスト
        -- dirsが空であれば，石をpointに置く．
        -- そうでなければ，dirsに含まれる方向について石の反転処理を行う
        do_move_aux board dirs =
            if null dirs
            then
                (setBoard board point bw)
            else
                (do_move_aux (do_flip_dir bw point (head dirs) board) (tail dirs))
-- do_move black [3,4] initBoard

-------------------------------------------------------------------------------
-- 候補手のリストを生成する．
--   bw    手番
--   board 局面
-------------------------------------------------------------------------------
moves:: Piece -> Board -> [Pt]
moves bw board =
    filter
        (\point -> not $ null (run_dirs bw point board))
        [(x,y) | x<-[1..8], y<-[1..8]]
-- moves black initBoard => [[3,4],[4,3],[5,6],[6,5]]
-- moves white initBoard => [[3,5],[4,6],[5,3],[6,4]]


-------------------------------------------------------------------------------
-- ゲームの補助関数
-- 引数
--   bw     手番
--   board  現在の局面データ
--   count  盤面上の石の個数
--   passed 相手が直前にパスしたか(True/False)
-------------------------------------------------------------------------------
game_aux:: (Piece->Board->IO(Bool,Board)) -> (Piece->Board->IO(Bool,Board)) -> Piece -> Board -> Int -> Bool -> IO()
game_aux black_player white_player bw board count passed = do
    -- 局面の表示
    showBoard board
    if count == boardSize * boardSize || pcount board bw == 0
        then
            -- 盤面が全て埋めつくされているか，
            -- 手番のプレイヤbwの石がないなら終了
            game_end_message board
        else
            -- 一手進める
            if null (moves bw board)
            then
                -- bwの打つ手がない場合(PASS)
                if passed
                    -- 直前に相手もPASSをしていた場合
                    -- お互いに打つところがない→終了
                    then game_end_message board
                    -- そうでない場合は，相手の手番に移る
                    else do
                        putStrLn (show bw ++ " PASS")
                        -- 次の手番(bwはPASSした)
                        game_aux black_player white_player (opponent bw) board count True
            else
                -- bwに手を決めて石を置いてもらう
                do
                    (done,newBoard) <- (if bw == Black then black_player else white_player) bw board
                    -- 次の手番(*-player-moveが True を返した場合)
                    if done
                        then game_aux black_player white_player (opponent bw) newBoard (1 + count) False
                        -- 投了(*-player-moveが False を返した場合)
                        else game_end_message board
    where
        game_end_message board = do
            putStrLn "*** GAME OVER ***"
            putStrLn ("Black vs White " ++ show (pcount board Black) ++ " " ++ show (pcount board White))

-------------------------------------------------------------------------------
-- reversiの対戦を行う
-- 引数
--   black_player 黒番の操作を行う関数
--   white_player 白番の操作を行う関数
--   これらの関数は，手を決めて石を配置する処理を適宜行う
--   ものとする．また次のように真偽値を返すものとする．
--     1. ゲームを続行する場合は True
--     2. 投了する場合は False
-- man_moveを使うとユーザが操作を行うことになる．
-------------------------------------------------------------------------------
game:: (Piece->Board->IO(Bool,Board)) -> (Piece->Board->IO(Bool,Board)) -> IO()
game black_player white_player =
    -- gameの本体(game-auxの呼びだし)
    -- 現在の状態が与えられない場合は，初期状態からスタート
    game_aux black_player white_player Black initBoard 4 False


-------------------------------------------------------------------------------
-- man-move: MANプレイヤ操作関数
-- 引数
--   bw    手番
--   board 局面
-- 手を(y x)で入力して 局面を進めて，#tを返す．
-- 入力が^Dであった場合は，投了であるとして，#fを返す．
-------------------------------------------------------------------------------
man_move:: Piece -> Board -> IO (Bool,Board)
man_move bw board = do
    -- プロンプト
    putStrLn (show bw ++ ">> ")
    -- 手を読み込む
    x <- getLine >>= return . read
    y <- getLine >>= return . read
    if x == -1
        then  return (False, board) -- ^Dなら#fを返して終了
        else
            if out_of_bounds (x,y)
                then do
                    putStrLn "illegal position"
                    man_move bw board       -- 手が無効(盤の外)
                else
                    let
                        (done,newBoard) = do_move bw (x,y) board    -- 指定された石を置く
                    in
                        if done 
                            then return (done,newBoard)
                            else do
                                putStrLn "illegal position"
                                man_move bw board

-------------------------------------------------------------------------------
-- メイン
-------------------------------------------------------------------------------
main:: IO ()
main = game man_move man_move

{------------------------------------------------------------------------------
使用例：
C:\user\lisp\Haskell>ghc Reversi.hs -o Reversi.exe

C:\user\lisp\Haskell>Reversi
X X X X X X X X X X
X - - - - - - - - X
X - - - - - - - - X
X - - - - - - - - X
X - - - W B - - - X
X - - - B W - - - X
X - - - - - - - - X
X - - - - - - - - X
X - - - - - - - - X
X X X X X X X X X X
Black>>
3
4
X X X X X X X X X X
X - - - - - - - - X
X - - - - - - - - X
X - - - - - - - - X
X - - B B B - - - X
X - - - B W - - - X
X - - - - - - - - X
X - - - - - - - - X
X - - - - - - - - X
X X X X X X X X X X
White>>
1
1
illegal position
White>>
-1
-1
*** GAME OVER ***
Black vs White 4 1
------------------------------------------------------------------------------}

■ 入門Haskell正誤表

正誤表がここにあります。

http://book.mycom.co.jp/support/e2/haskell/#ERRATA

ここに載っていないマチガイを見つけたので、出版社にメールしました。

http://d.hatena.ne.jp/a-san/20060511#p1

http://d.hatena.ne.jp/a-san/20060530#p1

まもなく正誤表に追加されるでしょう。