echo("備忘録");

IT技術やプログラミング関連など、技術系の事を備忘録的にまとめています。

【やってみた】1時間プログラミング(ソースコード)

昨日書いた、オセロのソースコードです。

※ワークシート側の処理

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()の一連の処理など)、ひとまずはこんな感じでしょうか。

http://ecx.images-amazon.com/images/I/51P83V533KL._SL75_.jpg
本格的に作るなら、こういう本で思考アルゴリズムとか勉強したら、もっと面白くなるんでしょうね。
(※上記のソースコードに、対CPU戦の機能はありません。)