'五子棋程序 人機對戰版本
'需要2個Label控件   2個CommandButton控件

Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long

'Dim PlayStep() As String       '記錄棋譜的數組
'Dim Label2Cap As String
Private Const BoxL As Single = 50, BoxT As Single = 50, BoxW As Single = 25, BoxN As Integer = 18

Dim Table() As Long             '棋盤(0-BoxN,0-BoxN)     0-空 1-黑子 2-白子
Dim PsCore() As Long            '定義當前玩家桌面空格的分數
Dim CsCore() As Long            '定義當前電腦桌面空格的分數
Dim pWin() As Boolean           '定義玩家的獲勝組合
Dim cWin() As Boolean           '定義電腦的獲勝組合
Dim pFlag() As Boolean          '定義玩家的獲勝組合標志
Dim cFlag() As Boolean          '定義電腦的獲勝組合標志
Dim ThePlayFlag As Boolean      '定義游戲有效標志









Private Sub Command1_Click()
     If Not ThePlayFlag Then Call InitPlayEnvironment: Exit Sub
     If MsgBox("本局還沒有下完，是否重新開始？(Y/N)", vbYesNo) = vbNo Then Exit Sub
     Call InitPlayEnvironment
End Sub








Private Sub Command2_Click()
     End
End Sub

Private Sub Form_Load()
   Dim i As Long, lw As Long, lh As Long
     'Label2Cap = "000   黑方    行 00    列 00"
     Me.Width = 10815: Me.Height = 8040: Me.Caption = "五子棋 - 人機對戰": Me.Show
     lw = Me.Width \ Screen.TwipsPerPixelX: lh = Me.Height \ Screen.TwipsPerPixelY
     SetWindowRgn Me.hWnd, CreateRoundRectRgn(0, 0, lw, lh, 60, 60), True
     With Label1
        .Alignment = vbCenter: .FontSize = 12: .FontBold = True
        .ForeColor = vbRed: .BackStyle = 0: .AutoSize = True: .Move 8910, 510
     End With
     Label2.AutoSize = True: Label2.WordWrap = True
     Label2.BackStyle = 0: Label2.Move 8040, 1050, 2280
     Command1.Move 8025, 7035, 1020, 435: Command1.Caption = "再來一局"
     Command2.Move 9300, 7035, 1020, 435: Command2.Caption = "不玩了"
     Call DrawChessBoard: Me.FillStyle = 0: Call InitPlayEnvironment
End Sub



Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
     End
End Sub











Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   Dim iRow As Long, iCol As Long, i As Long, k As Long, t As String
     If Not ThePlayFlag Then Exit Sub
     If Button = vbLeftButton Then    '左鍵下棋
        iRow = -1: iCol = -1
        For i = 0 To BoxN     '鼠標必須落在交叉點 半徑10以內 若是則給出行列號
           If (Y + 10) > (BoxT + i * BoxW) And (Y - 10) <= (BoxT + i * BoxW) Then iRow = i
           If (X + 10) > (BoxL + i * BoxW) And (X - 10) <= (BoxL + i * BoxW) Then iCol = i
        Next
        If (iRow = -1) Or (iCol = -1) Then Beep: Exit Sub
        If Table(iCol, iRow) > 0 Then Exit Sub
        Table(iCol, iRow) = 2: Label1.Caption = "下一步 黑方"
        Me.FillColor = vbWhite: Me.Circle (iCol * BoxW + BoxT, iRow * BoxW + BoxL), 8
        For i = 0 To UBound(cWin, 3)
           If cWin(iCol, iRow, i) = True Then cFlag(i) = False
        Next
        Call CheckWin: Call DianNao    '檢查當前玩家是否獲勝 調用電腦算法
     End If
End Sub











Public Sub InitPlayEnvironment()
'*****************************************************************************
' 模塊名稱: InitPlayEnvironment   [初始化過程]
'
' 描述:   1. 設置背景音樂。               2. 設置游戲狀態有效。
'         3. 初始化游戲狀態標簽。         4. 直接指定電腦的第一步走法。
'         5. 初始化基本得分桌面。         6. 電腦和玩家獲勝標志初始化。
'         7. 初始化所有獲勝組合。         8. 重新設定玩家的獲勝標志。
'*****************************************************************************
   Dim i As Long, j As Long, m As Long, n As Long

     ThePlayFlag = True: Label1.Caption = "下一步 白方": Label2.Caption = ""
     Me.FillColor = vbBlack: Me.FillStyle = 0: Me.AutoRedraw = True
     Me.Cls: Me.Circle (9 * BoxW + BoxL, 9 * BoxW + BoxT), 8
     ReDim Table(0 To BoxN, 0 To BoxN) As Long
     ReDim pFlag(NumsWin(BoxN + 1) - 1) As Boolean
     ReDim cFlag(UBound(pFlag)) As Boolean
     ReDim PsCore(BoxN, BoxN) As Long, CsCore(BoxN, BoxN) As Long
     ReDim pWin(BoxN, BoxN, UBound(pFlag)) As Boolean
     ReDim cWin(BoxN, BoxN, UBound(pFlag)) As Boolean
    
     For i = 0 To UBound(pFlag): pFlag(i) = True: cFlag(i) = True: Next
     Table(9, 9) = 1     '假定電腦先手 并下了(9, 9)位 將其值設為1
     '******** 初始化獲勝組合 ****************************************
     For i = 0 To BoxN: For j = 0 To BoxN - 4
        For m = 0 To 4
           pWin(j + m, i, n) = True: cWin(j + m, i, n) = True
        Next
        n = n + 1
     Next: Next
     For i = 0 To BoxN: For j = 0 To BoxN - 4
        For m = 0 To 4
           pWin(i, j + m, n) = True: cWin(i, j + m, n) = True
        Next
        n = n + 1
     Next: Next
     For i = 0 To BoxN - 4: For j = 0 To BoxN - 4
        For m = 0 To 4
           pWin(j + m, i + m, n) = True: cWin(j + m, i + m, n) = True
        Next
        n = n + 1
     Next: Next
     For i = 0 To BoxN - 4: For j = BoxN To 4 Step -1
        For m = 0 To 4
           pWin(j - m, i + m, n) = True: cWin(j - m, i + m, n) = True
        Next
        n = n + 1
     Next: Next
     '******** 初始化獲勝組合結束 *************************************
     For i = 0 To UBound(pWin, 3) '由于電腦已下了(9, 9)位 所以需要重新設定玩家的獲勝標志
         If pWin(9, 9, i) = True Then pFlag(i) = False
     Next
     End Sub
















Public Function DrawChessBoard() As Long
'容器的(BoxL, BoxT)為左上角坐標畫一個 BoxN*BoxN, 每格邊長為 BoxW 象素的棋盤
   Dim i As Long, j As Long, cx As Long, cy As Long
     Me.ScaleMode = 3: Me.FillStyle = 1: Me.AutoRedraw = True: Me.Cls
     For i = 0 To BoxN   '畫棋盤
        Me.Line (BoxL + i * BoxW, BoxT)-(BoxL + i * BoxW, BoxT + BoxN * BoxW)
        Me.Line (BoxL, BoxT + i * BoxW)-(BoxL + BoxN * BoxW, BoxT + i * BoxW)
        Me.CurrentX = BoxL + i * BoxW - IIf(i > 9, 6, 2)
        Me.CurrentY = BoxT - 20: Me.Print Format(i)
        Me.CurrentX = BoxL - IIf(i > 9, 23, 20)
        Me.CurrentY = BoxT + i * BoxW - 6: Me.Print Format(i)
     Next
     For i = 3 To 16 Step 6: For j = 3 To 16 Step 6   '畫小標志
        cx = BoxL + j * BoxW - 3: cy = BoxT + i * BoxW - 3
        Me.Line (cx, cy)-(cx + 6, cy + 6), , B
     Next: Next
     Me.AutoRedraw = False: Set Me.Picture = Me.Image
End Function









Public Sub CheckWin()
'*****************************************************************************
' 模塊名稱:   CheckWin    [獲勝檢查算法]
'
' 描述:    1. 檢查是否和棋。   2. 檢查電腦是否獲勝。    3. 檢查玩家是否獲勝。
'*****************************************************************************
   Dim i As Long, j As Long, k As Long, m As Long, n As Long
   Dim cA As Long, pA As Long, cN As Long
    
     For i = 0 To UBound(cFlag): cN = IIf(cFlag(i) = False, cN + 1, cN): Next
    
     If cN = UBound(cFlag) - 1 Then   '設定和棋規則
        Label1.Caption = "雙方和棋！": ThePlayFlag = False: Exit Sub
     End If
     For i = 0 To UBound(cFlag)       '檢查電腦是否獲勝
        If cFlag(i) = True Then
           cA = 0: For j = 0 To BoxN: For k = 0 To BoxN
              If Table(j, k) = 1 And cWin(j, k, i) = True Then cA = cA + 1
           Next: Next
           If cA = 5 Then Label1.Caption = "電腦獲勝！": ThePlayFlag = False: Exit Sub
        End If
     Next
     For i = 0 To UBound(pFlag)       '檢查玩家是否獲勝
        If pFlag(i) = True Then
           pA = 0: For j = 0 To BoxN: For k = 0 To BoxN
              If Table(j, k) = 2 And pWin(j, k, i) = True Then pA = pA + 1
           Next: Next
           If pA = 5 Then Label1.Caption = "玩家獲勝！": ThePlayFlag = False: Exit Sub
        End If
     Next
End Sub











Public Sub DianNao()
'*****************************************************************************
' 模塊名稱:   DianNao      [電腦算法]

' 描述:    1. 初始化賦值系統。    2. 賦值加強算法。      3. 計算電腦和玩家的最佳攻擊位。
'          4. 比較電腦和玩家的最佳攻擊位并決定電腦的最佳策略。    5. 執行檢查獲勝函數。
'*****************************************************************************
   Dim i As Long, j As Long, k As Long, m As Long, n As Long
   Dim Dc As Long, cAb As Long, pAb As Long

     ReDim PsCore(BoxN, BoxN) As Long, CsCore(BoxN, BoxN) As Long     '初始化賦值數組
    
     '******** 電腦加強算法 ********
     For i = 0 To UBound(cFlag)
        If cFlag(i) = True Then
           cAb = 0
           For j = 0 To BoxN: For k = 0 To BoxN
              If Table(j, k) = 1 And cWin(j, k, i) = True Then cAb = cAb + 1
           Next: Next
           Select Case cAb
              Case 3
                 For m = 0 To BoxN: For n = 0 To BoxN
                    If Table(m, n) = 0 And cWin(m, n, i) = True Then CsCore(m, n) = CsCore(m, n) + 5
                 Next: Next
              Case 4
                 For m = 0 To BoxN: For n = 0 To BoxN
                    If Table(m, n) = 0 And cWin(m, n, i) = True Then
                       Table(m, n) = 1: Label1.Caption = "下一步 白方"
                       Me.FillColor = vbBlack: Me.Circle (m * BoxW + BoxL, n * BoxW + BoxT), 8
                       For Dc = 0 To UBound(pWin, 3)
                          If pWin(m, n, Dc) = True Then pFlag(Dc) = False: Call CheckWin: Exit Sub
                       Next
                    End If
                 Next: Next
           End Select
        End If
     Next

     For i = 0 To UBound(pFlag)
        If pFlag(i) = True Then
           pAb = 0
           For j = 0 To BoxN: For k = 0 To BoxN
              If Table(j, k) = 2 And pWin(j, k, i) = True Then pAb = pAb + 1
           Next: Next
           Select Case pAb
              Case 3
                 For m = 0 To BoxN: For n = 0 To BoxN
                    If Table(m, n) = 0 And pWin(m, n, i) = True Then PsCore(m, n) = PsCore(m, n) + 30
                 Next: Next
              Case 4
                 For m = 0 To BoxN: For n = 0 To BoxN
                    If Table(m, n) = 0 And pWin(m, n, i) = True Then
                       Table(m, n) = 1: Label1.Caption = "下一步 白方"
                       Me.FillColor = vbBlack: Me.Circle (m * BoxW + BoxL, n * BoxW + BoxT), 8
                       For Dc = 0 To UBound(pWin, 3)
                          If pWin(m, n, Dc) = True Then pFlag(Dc) = False: Call CheckWin: Exit Sub
                       Next
                    End If
                  Next: Next
           End Select
        End If
     Next
     '******** 電腦加強算法結束 ********











     '******** 賦值系統 ****************
     For i = 0 To UBound(cFlag)
        If cFlag(i) = True Then
           For j = 0 To BoxN: For k = 0 To BoxN
              If (Table(j, k) = 0) And cWin(j, k, i) Then
                 For m = 0 To BoxN: For n = 0 To BoxN
                    If (Table(m, n) = 1) And cWin(m, n, i) Then CsCore(j, k) = CsCore(j, k) + 1
                 Next: Next
              End If
           Next: Next
        End If
     Next
        
     For i = 0 To UBound(pFlag)
        If pFlag(i) = True Then
           For j = 0 To BoxN: For k = 0 To BoxN
              If (Table(j, k) = 0) And pWin(j, k, i) Then
                 For m = 0 To BoxN: For n = 0 To BoxN
                    If (Table(m, n) = 2) And pWin(m, n, i) Then PsCore(j, k) = PsCore(j, k) + 1
                 Next: Next
              End If
           Next: Next
        End If
     Next
     '******** 賦值系統結束 ************










     '******** 分值比較算法 ************
   Dim a As Long, b As Long, c As Long, d As Long
   Dim cS As Long, pS As Long

     For i = 0 To BoxN: For j = 0 To BoxN
        If CsCore(i, j) > cS Then cS = CsCore(i, j): a = i: b = j
     Next: Next
     For i = 0 To BoxN: For j = 0 To BoxN
        If PsCore(i, j) > pS Then pS = PsCore(i, j): c = i: d = j
     Next: Next
    
     If cS > pS Then
        Table(a, b) = 1: Label1.Caption = "下一步 白方"
        Me.FillColor = vbBlack: Me.Circle (a * BoxW + BoxL, b * BoxW + BoxT), 8
        For i = 0 To UBound(pWin, 3)
           If pWin(a, b, i) = True Then pFlag(i) = False
        Next
     Else
        Table(c, d) = 1: Label1.Caption = "下一步 白方"
        Me.FillColor = vbBlack: Me.Circle (c * BoxW + BoxL, d * BoxW + BoxL), 8
        For i = 0 To UBound(pWin, 3)
           If pWin(c, d, i) = True Then pFlag(i) = False
        Next
     End If
     '******** 分值比較算法結束 ********
        
     Call CheckWin

End Sub














Public Function NumsWin(ByVal n As Long) As Long
'根據輸入的棋盤布局 n*n   計算總共有多少種獲勝組合
'假定棋盤為 10 * 10 相應的棋盤數組就是 Table(9, 9)
'水平方向 每一列獲勝組合是6 共10列 6*10=60
'垂直方向 每一行獲勝組合是6 共10行 8*10=60
'正對角線方向 6 + (5 + 4 + 3 + 2 + 1) * 2 = 36
'反對角線方向 6 + (5 + 4 + 3 + 2 + 1) * 2 = 36
'總的獲勝組合數為 60 + 60 + 36 + 36 = 192
   Dim i As Long, t As Long
     For i = n - 5 To 1 Step -1: t = t + i: Next
     NumsWin = 2 * (2 * t + n - 4) + 2 * n * (n - 4)