前回の機能を組み合わせて、完成したリバーシで実際に遊んでみましょう。
ゲームの進行管理
シート上にボタンを配置し、ボタンに対応した以下の処理を作成します。
'/******************************
' スタートボタンクリック
'******************************/
Private Sub CommandButton1_Click()
initGame 'ゲーム開始
End Sub
'/******************************
' パスボタンクリック
'******************************/
Private Sub CommandButton2_Click()
passHand turn, tekazu
tekazu = tekazu - 1 'パスした分の手数を調整
makeList handList, board, turn '着手リストを更新
comhand 'コンピュータの手番
End Sub
'/******************************
' ゲーム開始時の処理
'******************************/
Sub initGame()
ActiveSheet.Protect UserInterfaceOnly:=True '※シートを保護
ActiveSheet.Unprotect '※最終的にコメントアウトする
Range("A1:H9").ClearContents '盤面をクリア
Erase board() '盤面配列初期化
board(3 * 8 + 3) = DiscColor.White 'd4に白
board(4 * 8 + 3) = DiscColor.Black 'd5に黒
board(3 * 8 + 4) = DiscColor.Black 'e4に黒
board(4 * 8 + 4) = DiscColor.White 'e5に白
tekazu = 0 '手数をセット
mode = IIf(Cells(4, 11) = "○", GameMode.WhitePlayer, GameMode.BlackPlayer) 'プレイヤーの手番をセット
turn = DiscColor.Black '黒の手番をセット
showBoard '盤面表示及び現在の着手リスト更新
comhand 'コンピュータの手番
End Sub
'/******************************
' 手番選択処理
'******************************/
Private Sub CommandButton3_Click()
If Cells(4, 11) = "○" Then
Cells(4, 11) = "●"
Cells(5, 11) = "○"
Else
Cells(5, 11) = "●"
Cells(4, 11) = "○"
End If
End Sub
まず、「対局開始」に対応するスタートボタンクリック処理です。この処理は、ゲーム開始時の処理を呼び出すだけです。
その下は、石を置ける場所がなくなった場合にパスするための機能です。
ゲーム開始時の処理では、盤面配列とシート上の盤面（A1からH8までの範囲）をいったんクリアし、黒石と白石の初期配置を行います。
続いて手数をセットし、プレイヤーの手番（白か黒か）をシートから読み込んで設定します。
このとき、プレイヤーとコンピュータの手番を表す丸印がありますが、これをボタンで選択できるようにするために、手番選択処理を「黒白選択」ボタンに対応付けています。
その後、先手番をセットし、初期盤面を表示させ、コンピュータの手番処理へと進み、以降プレイヤーによる着手位置の選択（又はパス）とコンピュータによる着手が繰り返されます。
「黒白選択」ボタンについては、●、○を直接入力してもよいのですが、間違えやすいのと、もう一つボタンで選択した方が良い理由があります。
ゲーム開始時の処理に「ActiveSheet.Protect UserInterfaceOnly:=True '※シートを保護」という一文があります。
vbaからセルに値を書き込もうとした時、以下のようにセルが編集状態になっていると、正常に書き込みを行うことができず、処理が継続できなくなってしまいます。
石を置く際にセルをダブルクリックしてしまうこともありますし、このような状況を防止するために、上記の一文でセルの手動編集を禁止しています。
ただし、編集禁止のままですと作業がしづらいため、完成するまでは「ActiveSheet.Unprotect '※最終的にコメントアウトする」の行をそのまま（保護解除）にしておき、完成して実行するときにコメントアウトするとよいでしょう。
まとめ
ここで、以下に、これまでのコードをすべてまとめて記載します。
コピペすれば完成です…が、実際にボタンと処理を結び付けたり、といった作業（例えば、「対局開始」ボタン(CommandButton1)にCommandButton1_Click()を対応付けたり）は必要です。
今回は一つのシートで完結するように、標準モジュールを使用せず、シート直下に直接コードを記載しています。
Option Explicit
'/******************************
' 変数と定数
'******************************/
Enum DiscColor '石の色
None = 0 '白でも黒でもない（空き）
Black = 1 '黒
White = 2 '白
End Enum
Enum GameMode '対局モードの種類
BlackPlayer = 1 'プレイヤーが黒
WhitePlayer = 2 'プレイヤーが白
SelfPlay = 3 '自分で両方並べる
End Enum
Const ChangeColor As Byte = DiscColor.Black Or DiscColor.White '黒白反転用データ（00000011B）
Dim mode As Byte '対局モード
Dim turn As Byte '現在の手番(0:操作不可,1:黒の手番,2:白の手番)
Dim tekazu As Integer '現在の手数
Dim handList As Dictionary '現在の手番側が着手可能な位置のディクショナリ
Dim board(63) As Byte '現在の盤面配列(左上のインデックスが0、右下が63)
'/******************************
' スタートボタンクリック
'******************************/
Private Sub CommandButton1_Click()
initGame 'ゲーム開始
End Sub
'/******************************
' パスボタンクリック
'******************************/
Private Sub CommandButton2_Click()
passHand turn, tekazu
tekazu = tekazu - 1 'パスした分の手数を調整
makeList handList, board, turn '着手リストを更新
comhand 'コンピュータの手番
End Sub
'/******************************
' 手番選択処理
'******************************/
Private Sub CommandButton3_Click()
If Cells(4, 11) = "○" Then
Cells(4, 11) = "●"
Cells(5, 11) = "○"
Else
Cells(5, 11) = "●"
Cells(4, 11) = "○"
End If
End Sub
'/******************************
' ゲーム開始時の処理
'******************************/
Sub initGame()
ActiveSheet.Protect UserInterfaceOnly:=True '※シートを保護
ActiveSheet.Unprotect '※最終的にコメントアウトする
Range("A1:H9").ClearContents '盤面をクリア
Erase board() '盤面配列初期化
board(3 * 8 + 3) = DiscColor.White 'd4に白
board(4 * 8 + 3) = DiscColor.Black 'd5に黒
board(3 * 8 + 4) = DiscColor.Black 'e4に黒
board(4 * 8 + 4) = DiscColor.White 'e5に白
tekazu = 0 '手数をセット
mode = IIf(Cells(4, 11) = "○", GameMode.WhitePlayer, GameMode.BlackPlayer) 'プレイヤーの手番をセット
turn = DiscColor.Black '黒の手番をセット
showBoard '盤面表示及び現在の着手リスト更新
comhand 'コンピュータの手番
End Sub
'/******************************
' 盤面表示と着手リストの更新
'******************************/
Sub showBoard()
Dim i As Integer
Dim blackCnt As Long
Dim whiteCnt As Long
For i = 0 To 63
If board(i) = DiscColor.Black Then
Sheets("Board").Cells(Int(i / 8) + 1, i Mod 8 + 1) = "●" '黒の石を表示
blackCnt = blackCnt + 1
ElseIf board(i) = DiscColor.White Then
Sheets("Board").Cells(Int(i / 8) + 1, i Mod 8 + 1) = "○" '白の石を表示
whiteCnt = whiteCnt + 1
End If
Next
makeList handList, board, turn '着手リストを更新
Cells(7, 11) = blackCnt
Cells(8, 11) = whiteCnt
If tekazu = 60 Then
If blackCnt > whiteCnt Then
MsgBox "黒の勝ち！"
ElseIf whiteCnt > blackCnt Then
MsgBox "白の勝ち！"
Else
MsgBox "引き分け"
End If
ElseIf blackCnt = 0 Then
MsgBox "白の勝ち！"
ElseIf blackCnt = 0 Then
MsgBox "黒の勝ち！"
End If
End Sub
'/******************************
' 着手リスト作成処理
'
' 着手可能な位置の条件
' 1.空きマスであること
' 2.相手石に隣接していること
' 3.相手石方向の端に自分の石があること
'******************************/
Sub makeList(ByRef list, checkBoard, checkTurn)
Dim enemyList As New Collection '反転させる相手石の位置リスト
Dim enemy As Variant '相手石の位置
Dim pos As Integer '位置
Dim i As Integer '同一方向の石を数えるためのカウンタ
Dim putR As Integer '着手位置の縦座標
Dim putC As Integer '着手位置の横座標
Dim moveR As Integer '縦方向へのオフセット
Dim moveC As Integer '横方向へのオフセット
Set list = New Dictionary '着手リストを初期化
For putR = 0 To 7 '縦座標
For putC = 0 To 7 '横座標
If checkBoard(putR * 8 + putC) = DiscColor.None Then 'まだ石が置かれていない場合
For moveR = -1 To 1 '縦方向のオフセット
For moveC = -1 To 1 '横方向のオフセット
If Not ((moveR = 0) And (moveC = 0)) Then 'オフセットが(0,0)の場合はスキップ
Set enemyList = New Collection '相手石の位置リスト初期化
For i = 1 To 7 '石を置く位置の隣から直線方向に最大7マス判定
If (putR + moveR * i < 0) Or (putR + moveR * i > 7) Then '盤面の上下端を超える場合
Exit For 'この方向の判定終了(着手不可)
ElseIf (putC + moveC * i < 0) Or (putC + moveC * i > 7) Then '盤面の左右端を超える場合
Exit For 'この方向の判定終了(着手不可)
End If
pos = (putR + moveR * i) * 8 + (putC + moveC * i) '判定するマスの位置
If checkBoard(pos) = DiscColor.None Then '石が置いていない場合
Exit For 'この方向の判定終了(着手不可)
ElseIf checkBoard(pos) = (checkTurn Xor ChangeColor) Then '相手の石が置いてある場合
enemyList.Add pos '相手の石リストに位置を追加
Else '自分の駒
If enemyList.Count > 0 Then '間に相手の駒があった場合(着手可)
If list.Exists(putR * 8 + putC) = False Then '着手位置が着手リストに登録されていない場合
list.Add putR * 8 + putC, New Collection '着手位置を着手リストのキーに追加
End If
For Each enemy In enemyList '相手の石リストの内容を着手リストに反映
list(putR * 8 + putC).Add enemy '着手位置に対応する相手石リストに相手石の位置を追加
Next
End If
Exit For 'この方向の判定終了
End If
Next
End If
Next
Next
End If
Next
Next
End Sub
'/******************************
' 盤面選択時の処理
'******************************/
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim pos As Long
pos = (Target.Row - 1) * 8 + Target.Column - 1 '盤面内換算のインデックス
If (turn And mode) <> 0 Then 'プレイヤーの手番と現在の手番が一致
If Target.Row <= 8 And Target.Column <= 8 Then '選択した位置が盤面内の場合
If handList.Exists(pos) Then '選択位置が着手可能位置リストに登録済みの場合
putDisc pos, turn, handList(pos), board, turn, tekazu '一手進行
showBoard '盤面表示
End If
End If
comhand 'コンピュータの手番
End If
End Sub
'/******************************
' 一手進行処理
'
' 渡された盤面を更新して手番を交代する処理
' 引数 着手位置,着手側の色,反転させる位置リスト,ref 盤面,ref 手番
'******************************/
Sub putDisc(putpos, disc, reverseList, ByRef changeBoard, ByRef changeTurn, ByRef handNum)
Dim revpos '反転させる石の位置
changeBoard(putpos) = disc '手番側の石を置く
For Each revpos In reverseList
changeBoard(revpos) = disc '相手の石を反転
Next
passHand changeTurn, handNum
End Sub
'/******************************
' パス（手番交代及び手数加算処理)
'
'******************************/
Sub passHand(ByRef changeTurn, ByRef handNum)
changeTurn = (changeTurn Xor ChangeColor) '手番を交代する
handNum = handNum + 1 '手数を加算
End Sub
'/******************************
' コンピュータの思考
'******************************/
Sub comhand()
If turn <> 0 And (turn And mode) = 0 Then 'コンピュータの手番
Dim hand
Dim score As New Dictionary
Dim i As Long
If handList.Count = 0 Then 'コンピュータの合法手がない場合
passHand turn, tekazu 'パス
makeList handList, board, turn '着手リストを更新
tekazu = tekazu - 1 'パスした分の手数を調整
Exit Sub
End If
Cells(5, 12) = "思考中"
For Each hand In handList.Keys '現在の合法手
score.Add hand, 0
For i = 0 To 20 '適当な回数繰り返し
DoEvents
score(hand) = score(hand) + simulate(board, turn, tekazu, hand)
Next
Next
Dim besthand
besthand = -1
If turn = DiscColor.Black Then
For Each hand In handList.Keys '現在の合法手
If besthand = -1 Then
besthand = hand
End If
If score(hand) > score(besthand) Then
besthand = hand
End If
Next
Else
For Each hand In handList.Keys '現在の合法手
If besthand = -1 Then
besthand = hand
End If
If score(hand) < score(besthand) Then
besthand = hand
End If
Next
End If
Cells(5, 12) = "" '思考中の表示を消す
putDisc besthand, turn, handList(besthand), board, turn, tekazu '一手進行
showBoard '盤面表示
End If
End Sub
'/******************************
' 終局までランダムシミュレーション
'******************************/
Function simulate(ByVal testBoard, ByVal testTurn, ByVal testTekazu, hand)
Dim ransuu As Long
Dim i As Long
Dim testList As New Dictionary
Dim limit As Long
limit = 60 - testTekazu '終局までの残り手数
putDisc hand, testTurn, handList(hand), testBoard, testTurn, testTekazu '最初の石を置いてみる
makeList testList, testBoard, testTurn 'コンピュータ用の着手リストを更新
For i = 0 To limit '終局までの手数
If testList.Count = 0 Then '合法手がない場合
Exit For
End If
ransuu = Fix(rnd * testList.Count) '合法手の中から手をランダムで選択
putDisc testList.Keys(ransuu), testTurn, testList(testList.Keys(ransuu)), testBoard, testTurn, testTekazu '石を置いてみる
makeList testList, testBoard, testTurn '着手リストを更新
Next
Dim cntBlack As Long
Dim cntWhite As Integer
cntBlack = 0 '黒石の数初期化
cntWhite = 0 '白石の数初期化
For i = 0 To 63
If testBoard(i) = DiscColor.Black Then
cntBlack = cntBlack + 1 '盤面の黒石を数える
ElseIf testBoard(i) = DiscColor.White Then
cntWhite = cntWhite - 1 '盤面の白石を数える
End If
Next
simulate = cntBlack + cntWhite
End Function
シートレイアウトとボタンの設定が完了していれば、対局開始ボタンを押すだけでゲームが開始できるはずです。
遊んでみる
それでは実際に遊んでみます。
今回は自分が黒、相手が白で始めてみましょう。
自分の手番では、自分の石を置ける位置は決定されているはずです。試しに置けない場所をクリックしてみましょう。何も起こらないはずです。
それでは石を置いてみます。
黒石が置かれ、間の白石が黒石に変わり、コンピュータの石数の右側に"思考中"が表示されています。
しばらくしてコンピュータが着手すると、自分の番に変わります。
この繰り返しでゲームを進めていきます。
なかなかいい勝負です。
角を取りました。
このくらい進むと残りの手が少ないため、コンピュータの思考時間が短くなっていきます。黒が優勢に見えますが…
…
はい、コンピュータに逆転されてしまいました。リバーシの醍醐味ですね。
というわけで、いかがだったでしょうか。
今回は単純なゲームでしたが、コンピュータの思考ルーチンが弱いため、強くできる余地は大きいです。
自分で工夫してコンピュータを強くしてみるのも楽しいでしょうし、他のゲーム作りに挑戦してみるのもよいでしょう。
少なくとも、VBAでゲームを作ることができたという経験はきっと他のことにも生かせるはずです。