昨日書いた、オセロのソースコードです。
※ワークシート側の処理
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
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 = True
isPut = checkPutPeace(i, j, False)
End If
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 = "リバーシ"
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
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
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
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
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:
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
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戦の機能はありません。）
