※ワークシート側の処理
Option Explicit '「ゲーム開始」ボタンクリック処理 Private Sub CommandButton1_Click() Call Init End Sub '盤上のマスをダブルクリックしたときの処理 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'セルの行と列 Dim row As Integer, col As Integer Dim resultValue As Boolean, resultCheckAll As Integer row = Target.row col = Target.Column '盤の外とか、すでに石が置いてあるマスには置けない。 If ((8 < row) Or (8 < col)) Then Exit Sub ElseIf (CELLKIND.NOPEACE <> board(row, col)) Then MsgBox "すでに石がある場所には置けません。", vbOKOnly + vbExclamation, GAME_NAME Exit Sub End If '現在の手番のプレーヤーが、そこに石を置けるかのチェック resultValue = checkPutPeace(row, col, True) If resultValue Then '置けた場合、相手が石を置けるマスがあるかをチェック resultCheckAll = checkPutPeaceAllCell() If (1 = resultCheckAll) Then 'マスがない場合、パス扱いにして、次の手番のプレーヤーが石を置ける益があるかチェックする。 Dim strTeban As String If (CELLKIND.SENTE = turn) Then strTeban = "先手" ElseIf (CELLKIND.GOTE = turn) Then strTeban = "後手" End If MsgBox strTeban & "は相手の石を裏返せないので、パスします。", vbOKOnly + vbInformation, GAME_NAME turn = 3 - turn resultCheckAll = checkPutPeaceAllCell() If (1 = resultCheckAll) Then '2人共石を置けない場合は、試合終了。勝敗判定へ。 If (CELLKIND.SENTE = turn) Then strTeban = "先手" ElseIf (CELLKIND.GOTE = turn) Then strTeban = "後手" End If MsgBox strTeban & "も相手の石を裏返せないので、ゲームを終了し、勝敗を判定します。", vbOKOnly + vbInformation, GAME_NAME Call judge End If ElseIf (-1 = resultCheckAll) Then 'マスが全部埋まった場合、勝敗判定へ。 Call judge End If Else 'ダブルクリックした場所に置いても相手の石を裏返せない場合、そこには置けない。 MsgBox "相手の石を裏返せないので、そこには置けません。", vbOKOnly + vbExclamation, GAME_NAME End If End Sub '石を置いた時、相手が石をおけるマスがあるかどうかをチェックする。 Private Function checkPutPeaceAllCell() As Integer Dim i As Integer, j As Integer Dim isPut As Boolean, isExistEmpty As Boolean isPut = False isExistEmpty = False For i = 1 To 8 For j = 1 To 8 If (board(i, j) = CELLKIND.NOPEACE) Then '石が置いてないマスがあったら、isExistEmptyフラグを立てる。 '(全部のマスに石が置いてあるなら、相手の処理を行わずに勝敗判定を行えば良いから。) isExistEmpty = True isPut = checkPutPeace(i, j, False) End If '1つでも石を置けるマスがあるなら、そこで処理終了。(下も同じ) If (isPut) Then Exit For End If Next If (isPut) Then Exit For End If Next '戻り値の設定 If (isPut) Then '石を置けるマスがある。 checkPutPeaceAllCell = 0 Else If (isExistEmpty) Then '相手が石を置けるマスはないが、石が置いていないマス自体はある。 checkPutPeaceAllCell = 1 Else '全部のマスが埋まっている。 checkPutPeaceAllCell = -1 End If End If End Function
※標準モジュール側の処理
Option Explicit Option Base 0 '「インデックスが有効範囲にありません」エラーのエラー番号 Const INDEX_OUT_OF_RANGE As Integer = 9 'メッセージボックスに表示するタイトル Public Const GAME_NAME As String = "リバーシ" '盤の状態を保持する2次元配列 Public board(1 To 8, 1 To 8) As CELLKIND '手番の状態 Public turn As CELLKIND '盤や手番の状態を定義してある列挙体 Public Enum CELLKIND NOPEACE = 0 '石がない SENTE = 1 '先手 GOTE = 2 '後手 GAME_END = -1 'ゲーム終了 End Enum 'checkReverse()で使用する、各方向のオフセット値を格納する配列 Private range_value(0 To 7) '裏返すマス情報を保持するコレクション(裏返せるマス全て, 方向単位の裏返せるマス) Private turnCellCollection As New Collection, turnCellCollection_tmp As New Collection '初期化処理 Public Sub Init() On Error Resume Next Dim i As Integer, j As Integer '各方向のオフセット値を設定 range_value(0) = Array(-1, -1) range_value(1) = Array(-1, 0) range_value(2) = Array(-1, 1) range_value(3) = Array(0, -1) range_value(4) = Array(0, 1) range_value(5) = Array(1, -1) range_value(6) = Array(1, 0) range_value(7) = Array(1, 1) For i = 1 To 8 For j = 1 To 8 '盤の情報を設定。 If (((4 = i) And (4 = j)) Or ((5 = i) And (5 = j))) Then board(i, j) = CELLKIND.SENTE ElseIf (((4 = i) And (5 = j)) Or ((5 = i) And (4 = j))) Then board(i, j) = CELLKIND.GOTE Else board(i, j) = CELLKIND.NOPEACE End If Call draw(i, j) Next Next turn = CELLKIND.SENTE Set turnCellCollection = New Collection Call writeText End Sub 'そのマスに手番の石が置けるかどうか。 '(isPutActuallyはTrueなら実際に裏返す。falseなら裏返せるかチェックするだけで、実際には裏返さない) Public Function checkPutPeace(ByVal row As Integer, ByVal col As Integer, ByVal isPutActually As Boolean) Dim resultValue As Boolean, isExistTurn As Boolean Dim i As Integer, j As Integer isExistTurn = False 'そもそも石があるなら、絶対に置けない。 If (CELLKIND.NOPEACE <> board(row, col)) Then checkPutPeace = isExistTurn Exit Function End If For i = LBound(range_value) To UBound(range_value) resultValue = checkReverse(row + range_value(i)(0), col + range_value(i)(1), range_value(i)(0), range_value(i)(1), True) '石が置ける、かつ実際に裏返すなら、「裏返すマス」に「その方向の裏返せるマス」を追加。 If resultValue Then If (isPutActually) Then For j = 1 To turnCellCollection_tmp.count turnCellCollection.Add turnCellCollection_tmp(j) Next End If isExistTurn = True End If '「その方向の裏返せるマス」を初期化。 Set turnCellCollection_tmp = New Collection '実際には裏返さない場合、1つでも石を置けるマスがあった時点で処理終了。(全チェックする必要はない) If ((Not isPutActually) And isExistTurn) Then Exit For End If Next If (isExistTurn And isPutActually) Then '実際に裏返す場合、盤の情報を更新して、手番を交代する。 If (0 < turnCellCollection.count) Then For i = 1 To turnCellCollection.count Dim collection_val As Variant, collection_row As Integer, collection_col As Integer collection_val = turnCellCollection(i) collection_row = collection_val(0) collection_col = collection_val(1) board(collection_row, collection_col) = turn Call draw(collection_row, collection_col) Next End If board(row, col) = turn Call draw(row, col) turn = 3 - turn Call writeText End If '「すべての裏返せるマス」を初期化。 Set turnCellCollection = New Collection checkPutPeace = isExistTurn End Function '「そのマスの石が裏返せるか」をチェックする。 'range_value_row,range_value_colはそれぞれ基準のマスから見たチェックするマスのオフセット、isFirstChackはそのマスが基準となるマスの隣かどうか。 Function checkReverse(ByVal row As Integer, ByVal col As Integer, ByVal range_value_row As Integer, ByVal range_value_col As Integer, ByVal isFirstCheck As Boolean) As Boolean On Error GoTo checkReverseException Dim targetCellValue As CELLKIND Dim resultValue As Boolean 'チェックするマスの情報を格納 resultValue = False targetCellValue = board(row, col) If (isFirstCheck) Then '基準のマスの隣のマスが相手の石でなければ裏返せない。相手の石ならさらに次のマスを再帰処理でチェック。 If ((turn <> targetCellValue) And (CELLKIND.NOPEACE <> targetCellValue)) Then turnCellCollection_tmp.Add Array(row, col) resultValue = checkReverse(row + range_value_row, col + range_value_col, range_value_row, range_value_col, False) End If Else '隣のマスではない場合 If (turn = targetCellValue) Then '自分の石があったら、そこまでの石は裏返せる。(=挟んでいる状態) resultValue = True ElseIf (CELLKIND.NOPEACE = targetCellValue) Then '自分の石の前に何もないマスがあったら、裏返せない。 resultValue = False Else '相手の石の場合は、さらに次のマスをチェック。 turnCellCollection_tmp.Add Array(row, col) resultValue = checkReverse(row + range_value_row, col + range_value_col, range_value_row, range_value_col, False) End If End If checkReverse = resultValue Exit Function checkReverseException: '「(board(row, col)の)インデックスが有効範囲にない」エラー。(一番端まで相手の石しか無い場合)。 'その場合、もちろん裏返せない。 If (INDEX_OUT_OF_RANGE = Err.Number) Then Debug.Print "abc" Err.Clear resultValue = False Else MsgBox Err.Number & " " & Err.Description resultValue = False End If End Function '勝敗判定 Public Sub judge() Dim count_sente As Integer, count_gote As Integer Dim strMessage As String turn = CELLKIND.GAME_END count_sente = countPeace(CELLKIND.SENTE) count_gote = countPeace(CELLKIND.GOTE) strMessage = "先手:" & count_sente & " 対 後手:" & count_gote & vbCrLf If (count_sente > count_gote) Then strMessage = strMessage & "先手の勝ち!" ElseIf (count_sente < count_gote) Then strMessage = strMessage & "後手の勝ち!" Else strMessage = strMessage & "引けわけです。" End If MsgBox strMessage, vbOKOnly + vbInformation, GAME_NAME Call writeText End Sub 'tebanで指定された手番の石の数を調べる。 Private Function countPeace(ByVal teban As CELLKIND) As Integer Dim count As Integer, i As Integer, j As Integer count = 0 For i = 1 To 8 For j = 1 To 8 If teban = board(i, j) Then count = count + 1 End If Next Next countPeace = count End Function '盤を描画する。 Private Sub draw(ByVal row As Integer, col As Integer) If (CELLKIND.SENTE = board(row, col)) Then Sheets("Sheet1").Cells(row, col).Value = "○" ElseIf (CELLKIND.GOTE = board(row, col)) Then Sheets("Sheet1").Cells(row, col).Value = "●" Else Sheets("Sheet1").Cells(row, col).Value = "" End If End Sub '右フレームのテキストを描画する。 Public Sub writeText() If (CELLKIND.SENTE = turn) Then Range("J7").Value = "先手(白) の番です。" ElseIf (CELLKIND.GOTE = turn) Then Range("J7").Value = "後手(黒) の番です。" ElseIf (CELLKIND.GAME_END = turn) Then Range("J7").Value = "ゲーム終了!" End If Range("J3").Value = "先手(白): " & countPeace(CELLKIND.SENTE) Range("J4").Value = "後手(黒): " & countPeace(CELLKIND.GOTE) End Sub
詰めが甘い部分もあるとは思いますが(特にcheckPutPeace()の一連の処理など)、ひとまずはこんな感じでしょうか。
本格的に作るなら、こういう本で思考アルゴリズムとか勉強したら、もっと面白くなるんでしょうね。
(※上記のソースコードに、対CPU戦の機能はありません。)