白石さんと黒石さん

気晴らしに 緑の上で 戯れる

準備

'Sheet1.cls
Option Explicit
Const 位置 = "C3", 辺 = 8, 石 = "●", サイズ = 36, 決定 = "{END}"
Dim 手番 As 配色
Private Enum 配色
    白石 = vbWhite
    黒石 = vbBlack
    盤面 = vbGreen
    盤外 = vbBlue
    思案 = vbCyan
    示唆 = vbYellow
End Enum
Private Function 裏(色 As 配色) As 配色
    裏 = IIf(色 = 黒石, 白石, 黒石)
End Function
Private Property Get 今の色() As 配色
    今の色 = 手番
End Property
Private Property Get 次の色() As 配色
    次の色 = 裏(手番)
End Property
Private Sub 攻守交替()
    手番 = 次の色
End Sub

舞台

Private Property Get 盤() As Range
    Set 盤 = Me.Range(位置).Resize(辺, 辺)
End Property
Private Property Get 通知() As Range
    Set 通知 = Me.Range(位置).Offset(0, 辺 + 1)
End Property
Private Property Get 状況() As Range
    Set 状況 = Me.Range(位置).Offset(2, 辺 + 1).Resize(2)
End Property

Private Sub 盤面作成()
    ActiveWindow.DisplayGridlines = False
    With Me.Cells
        .Clear
        .Font.Size = サイズ
        .Font.Color = 盤外
        .HorizontalAlignment = xlHAlignCenter
        .VerticalAlignment = xlVAlignCenter
    End With
    With 盤
        .Interior.Color = 盤面
        .Font.Color = 盤面
        .Value = 石
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
        .Borders.LineStyle = xlContinuous
    End With
    With 盤.Resize(2, 2).Offset(辺 / 2 - 1, 辺 / 2 - 1)
        Union(.Cells(1, 1), .Cells(2, 2)).Font.Color = 黒石
        Union(.Cells(1, 2), .Cells(2, 1)).Font.Color = 白石
    End With
    With 通知
        .HorizontalAlignment = xlHAlignLeft
    End With
    With 状況
        .Interior.Color = 盤面
        .Font.Bold = True
        .Value = "____"
        .EntireColumn.AutoFit
        .Borders.LineStyle = xlContinuous
        .Rows(1).Font.Color = 黒石
        .Rows(2).Font.Color = 白石
    End With
End Sub

Private Sub 手番通知()
    通知.Value = Join(Array(色名(今の色), "の番です"))
End Sub
Private Function 色名(色 As 配色) As String
    色名 = IIf(色 = 黒石, "黒", "白")
End Function

Private Sub 状況更新()
    Dim c As Range
    For Each c In 状況
        c.Borders(xlEdgeRight).Weight = IIf(c.Font.Color = 今の色, xlThick, xlThin)
        c.Value = 数(c.Font.Color)
    Next
End Sub
Private Property Get 数(色 As 配色)
    Dim c As Range
    For Each c In 盤
        If c.Font.Color = 色 Then 数 = 数 + 1
    Next
End Property
Private Function 勝敗判定() As String
    Dim 黒, 白, 結果 As String
    黒 = 数(黒石)
    白 = 数(白石)
    Select Case True
        Case 黒 > 白: 結果 = 色名(黒石)
        Case 黒 < 白: 結果 = 色名(白石)
        Case Else: 結果 = "引き分け"
    End Select
    勝敗判定 = Join(Array(黒, "対", 白, "で", 結果))
End Function

開始

Sub 初期処理()
    盤面作成
    状況更新
    手番通知
    決定割当
End Sub

Private Sub 決定割当(Optional 設定 As Boolean = True)
    If 設定 Then
        Application.OnKey "+" & 決定, Me.CodeName & ".示唆表示"
        Application.OnKey 決定, Me.CodeName & ".置石実施"
    Else
        Application.OnKey "+" & 決定
        Application.OnKey 決定
    End If
End Sub
Private Sub Worksheet_Activate()
    決定割当 True
End Sub
Private Sub Worksheet_Deactivate()
    決定割当 False
End Sub

思案

Private Sub Worksheet_SelectionChange(ByVal target As Range)
    思案表示 target.Resize(1, 1)
End Sub
Private Sub 思案表示(置く場所 As Range)
    盤.Interior.Color = 盤面
    Dim col As Collection, c As Range
    Set col = 裏返る場所(置く場所, 今の色)
    If col.Count > 0 Then
        通知.Value = col.Count & "枚裏返ります。（Endで決定）"
        col.Add 置く場所
        For Each c In col
            c.Interior.Color = 思案
        Next
    Else
        通知.Value = "そこには置けません。（Shift＋Endでヒント表示）"
    End If
End Sub
Private Function 裏返る場所(置く場所 As Range, 色 As 配色) As Collection
    Set 裏返る場所 = New Collection
    Dim x, y, c As Range, buf As Collection
    If Not 置く場所.Font.Color = 盤面 Then Exit Function
    For x = -1 To 1: For y = -1 To 1
        Set c = 置く場所(1)
        Set buf = New Collection
        Do: DoEvents
            Set c = c.Offset(x, y)
            Select Case c.Font.Color
                Case 裏(色)
                    buf.Add c
                Case 色
                    For Each c In buf
                        裏返る場所.Add c
                    Next
                    Exit Do
                Case Else
                    Exit Do
            End Select
        Loop
    Next: Next
End Function

示唆

Sub 示唆表示()
    Dim col As Collection
    Set col = 置ける場所(今の色)
    Dim c As Range
    For Each c In col
        c.Interior.Color = 示唆
    Next
    通知.Value = "黄色の場所に置けます"
    伝言表示 "黄色の場所に置けます", 1
    盤.Interior.Color = 盤面
    Set c = col(1)
    c.Select
End Sub
Private Function 置ける場所(色 As 配色) As Collection
    Set 置ける場所 = New Collection
    Dim c As Range
    For Each c In 盤
        If 裏返る場所(c, 色).Count > 0 Then 置ける場所.Add c
    Next
End Function
Private Sub 伝言表示(text As String, Optional sec As Integer = 1, Optional title = "伝言")
    CreateObject("WScript.Shell").Popup text, sec, title
End Sub

決断

Sub 置石実施()
    Dim c As Range, col As Collection
    Set col = 裏返る場所(置く場所:=ActiveCell, 色:=今の色)
    If col.Count = 0 Then Exit Sub
    col.Add ActiveCell
    For Each c In col
        c.Font.Color = 今の色
        c.Interior.Color = 盤面
    Next
    攻守交替
    終了判定
End Sub
Private Sub 終了判定()
    Dim パス As Boolean, 終了 As Boolean, 伝言 As String
    状況更新
    パス = (置ける場所(今の色).Count = 0)
    終了 = パス And (置ける場所(次の色).Count = 0)
    If 終了 Then
        伝言表示 勝敗判定, 5, "終了"
        初期処理
        Exit Sub
    End If
    If パス Then
        伝言 = Join(Array(色名(今の色), "の置ける場所がありません。一手パスします。"), "")
        伝言表示 伝言, 2, "パス"
        攻守交替
    End If
    手番通知
End Sub