vbcch.frm

VB版的中国象棋人机对战源程序

        Case 106:
            CchessWord = "士"
        Case 105:
            CchessWord = "象"
        Case 104:
            CchessWord = "车"
            
        Case 103:
            CchessWord = "马"
        Case 102:
            CchessWord = "包"
        Case 101:
            CchessWord = "卒"
        Case 207:
            CchessWord = "帅"
        Case 206:
            CchessWord = "仕"
        Case 205:
            CchessWord = "相"
        Case 204:
            CchessWord = "车"
        Case 203:
            CchessWord = "马"
        Case 202:
            CchessWord = "炮"
        Case 201:
            CchessWord = "兵"
            
    End Select
    
End Function

Rem 根据ChessBoard数组显示棋子
Public Function DisplayImageCchess()
    
    Dim i As Byte, j As Byte, k As Byte

    k = 0
    
    For j = 1 To 10
    
        For i = 1 To 9
            
            Cchess1(k).Value = ChessBoard(i, j).Value     ''得知屏幕位置为何棋
            
            If ChessBoard(i, j).Value = 0 Then
                
                Cchess1(k).NoneCchess = True
                
            Else
                
                Cchess1(k).Visible = True
                Cchess1(k).NoneCchess = False
                Cchess1(k).Text = CchessWord(ChessBoard(i, j).Value)
                If Int(ChessBoard(i, j).Value / 100) = 1 Then Cchess1(k).FillColor = vbBlue Else Cchess1(k).FillColor = vbRed ''颜色
                
            End If
            
            k = k + 1
        
        Next i
    
    Next j

End Function

Rem 将棋盘中x1,y1位置的棋移到到x2,y2
Public Function MoveCchess(ByVal x1 As Byte, ByVal y1 As Byte, ByVal x2 As Byte, ByVal y2 As Byte)
    
    Dim T1 As Byte, T2 As Byte
    
    T1 = 0
    
    If x1 = x2 And y1 = y2 Or ChessBoard(x1, y1).Value = 0 _
        Or (Int(ChessBoard(x1, y1).Value / 100) = Int(ChessBoard(x2, y2).Value / 100) And ChessBoard(x1, y1).Value > 0) _
        Then Call MsgBox("运算出错!" & x1 & "," & y1 & "," & x2 & "," & y2, vbOKOnly + 32, "提示:"): Exit Function
    
    'Call MsgBox("运算!" & x1 & "," & y1 & "," & x2 & "," & y2, vbOKOnly + 32, "提示:")
    
    If ChessBoard(x2, y2).Value Mod 100 = 7 Then
    
        If ChessBoard(x2, y2).Value = 107 Then Call MsgBox("红方胜利了!", vbOKOnly, "提示:") Else Call MsgBox("黑方胜利了!", vbOKOnly, "提示:")
        'End
    
    End If
    
    ''使图像从原本位置移动到目标的动画效果
    T1 = ChessBoard(x1, y1).Value
    T2 = 0
    
    ChessBoard(x1, y1).Value = 0
    
    T2 = ChessBoard(x1, y1).Value
    
    Do
        
        ChessBoard(x1, y1).Value = T2
        If x1 = x2 And y1 = y2 Then Exit Do
        If y1 < y2 Then
            
            y1 = y1 + 1
        
        Else
        
            If y1 > y2 Then
                
                y1 = y1 - 1
            
            Else
            
                If x1 < x2 Then x1 = x1 + 1 Else x1 = x1 - 1
            
            End If
            
        End If
        
        T2 = ChessBoard(x1, y1).Value
        ChessBoard(x1, y1).Value = T1
        Call DisplayImageCchess
    Loop
    
    ChessBoard(x2, y2).Value = T1
    
End Function

Rem 清除当前棋盘所有棋
Public Function ClearChessBoard()
    
    Dim i As Byte, j As Byte

    For i = 1 To 9
        
        For j = 1 To 10
            
            ChessBoard(i, j).Value = 0
        
        Next
    Next

End Function

Rem 设置开始棋局
Private Sub SetCchess()
    
    Call ClearChessBoard       ''棋盘无子
    
    ChessBoard(5, 1).Value = 107     ''黑帅
    ChessBoard(4, 1).Value = 106     ''黑士
    ChessBoard(6, 1).Value = 106     ''黑士
    ChessBoard(3, 1).Value = 105     ''黑象
    ChessBoard(7, 1).Value = 105     ''黑象
    ChessBoard(2, 1).Value = 103     ''黑马
    ChessBoard(8, 1).Value = 103     ''黑马
    ChessBoard(1, 1).Value = 104     ''黑车
    ChessBoard(9, 1).Value = 104     ''黑车
    ChessBoard(2, 3).Value = 102     ''黑炮
    ChessBoard(8, 3).Value = 102     ''黑炮
    ChessBoard(1, 4).Value = 101     ''黑卒
    ChessBoard(3, 4).Value = 101     ''黑卒
    ChessBoard(5, 4).Value = 101     ''黑卒
    ChessBoard(7, 4).Value = 101     ''黑卒
    ChessBoard(9, 4).Value = 101     ''黑卒
    
    ChessBoard(5, 10).Value = 207     ''红帅
    ChessBoard(4, 10).Value = 206     ''红士
    ChessBoard(6, 10).Value = 206     ''红士
    ChessBoard(3, 10).Value = 205     ''红象
    ChessBoard(7, 10).Value = 205     ''红象
    ChessBoard(2, 10).Value = 203     ''红马
    ChessBoard(8, 10).Value = 203     ''红马
    ChessBoard(1, 10).Value = 204     ''红车
    ChessBoard(9, 10).Value = 204     ''红车
    ChessBoard(2, 8).Value = 202     ''红炮
    ChessBoard(8, 8).Value = 202     ''红炮
    ChessBoard(1, 7).Value = 201     ''红卒
    ChessBoard(3, 7).Value = 201     ''红卒
    ChessBoard(5, 7).Value = 201     ''红卒
    ChessBoard(7, 7).Value = 201     ''红卒
    ChessBoard(9, 7).Value = 201     ''红卒

End Sub

Rem 恢复当前棋盘
Public Function RestoreChessBoard()
    
    Dim i As Byte, j As Byte
    
    For i = 1 To 9
        
        For j = 1 To 10
            
            ChessBoard(i, j).Value = ChessBoardCopy(i, j).Value
        
        Next
    
    Next
    
End Function

Rem 将当前棋盘备份
Public Function CopyChessBoard()
    
    Dim i As Byte, j As Byte
    
    For i = 1 To 9
        
        For j = 1 To 10
            
            ChessBoardCopy(i, j).Value = ChessBoard(i, j).Value
        
        Next
    
    Next
    
End Function

Rem 如果Cer为1(黑方)，则返回2(红方),否则返加1(黑方)
Public Function NextCer(ByVal Cer As Byte) As Byte
    
    NextCer = 1
    If Cer = 1 Then NextCer = 2
    
End Function


Rem 中国象棋最佳着点算法
Rem 返回:
Rem    BestLocate.Chess 最高分的棋子
Rem    BestLocate.InitX 落棋的原始位置
Rem    BestLocate.InitY 落棋的原始位置
Rem    BestLocate.ObjX  最佳落子点
Rem    BestLocate.ObjY  最佳落子点
Rem    BestLocate.Value 落子点得分
Rem     以上棋盘以(上)黑(下)红的运算方式
Rem 注：在运算前必须先将BestLocate.Value置值为INITVALUE，即:
Rem    BestLocate.Value = INITVALUE
Rem 否则运算结果将不准

Public Function Search(ByVal Cer As Byte, ByVal Steps As Byte, IsTop As Boolean, UpMax As Integer) As Integer
    ''Cer=1计算黑方的棋子 Cer=2计算红方的棋子
    ''Setp要计算几步
    ''UpMax：上层最高分
    ''返回分数
    Dim i As Byte, j As Byte
    Dim T As Byte, T1 As Integer, T2 As Byte, T3 As Integer, T4 As Integer, Gzs As Byte      ''临时变量
    Dim hh1 As Byte, hh2 As Byte
    Dim i1 As Byte, j1 As Byte
    Dim a As Byte
    Dim xGzx As Byte, xGzy As Byte      ''保存“象”当前位置向目标的隔址地址,如该棋盘xGzx,xGzy位置有棋则不允许通过
    Dim BakBestLocate As CHESSER        ''用于备份运算结果
    Dim cValue As Integer
    Dim Tt As Boolean
    
    Dim BestLocate As CHESSER           ''最后运算分数最高的结果

    Dim X(MAXDOWNPOINT) As Integer, Y(MAXDOWNPOINT) As Integer            ''存储找到的所有落子点
    
    Dim ChessValue(16, MAXDOWNPOINT) As CHESSER   ''棋盘我方最多只有16个棋子，记录每个棋子的每个落子点的分数不清
    
    Dim MaxValue As Integer
    
    If IsTop Then List1.Clear
    
    MaxValue = -10000

    Steps = Steps - 1
    
    For i = 1 To 16: For j = 0 To MAXDOWNPOINT: ChessValue(i, j).Value = -10000: Next j: Next i        ''每个落子点得分为0
    
    
    Rem 搜索整个棋盘
    For i = 1 To 9
        
        For j = 1 To 10
            
            ''置当前棋的各个落子点的分数为0
            For i1 = 1 To MAXDOWNPOINT: X(i1) = 200: Next
        
            ''如果棋盘i,j位置的棋子为Cer所执
            If Int(ChessBoard(i, j).Value / 100) = Cer Then
                
                
                'If Cer = 2 Then Stop
                
                T = ChessBoard(i, j).Value Mod 100        ''求知该棋为何棋
                
                ''盘断棋盘i,j位置为何棋,求出其走法
                
                Select Case T
                    
                    Case 7:
                        
                        ''将(在不出格内有九个着点及王不见王着点) x横y竖
                        If Cer = 2 Then
                            ''Cer=2为红方
                            ''将只能走左、右、上、下且不能超出中间格
                            X(0) = i - 1: Y(0) = j      ''左
                            X(1) = i + 1: Y(1) = j      ''右
                            X(2) = i: Y(2) = j - 1      ''上
                            X(3) = i: Y(3) = j + 1      ''下
                            ''判断有无超格
                            For j1 = 0 To 3
                                If X(j1) < 4 Or X(j1) > 6 Or Y(j1) < 8 Or Y(j1) > 10 Then X(j1) = 200
                            Next

                            '原位置不能走
                            For j1 = 0 To 8
                                If X(j1) = i And Y(j1) = j Then X(j1) = 200
                            Next
                            
                            '王不见王(竖向寻找)
                            j1 = j - 1
                            
                            Do While j1 > 0
                            
                                If ChessBoard(i, j1).Value <> 0 And ChessBoard(i, j1).Value Mod 100 <> 7 Then Exit Do     ''有隔子，不形成王不见王
                                If ChessBoard(i, j1).Value Mod 100 = 7 Then X(9) = i: Y(9) = j1   ''对面有王，可以吃掉
                                
                                j1 = j1 - 1
                                
                            Loop
                        
                        Else
                            ''将只能走左、右、上、下且不能超出中间格
                            X(0) = i - 1: Y(0) = j      ''左
                            X(1) = i + 1: Y(1) = j      ''右
                            X(2) = i: Y(2) = j - 1      ''上
                            X(3) = i: Y(3) = j + 1      ''下
                            ''判断有无超格
                            For j1 = 0 To 3
                                If X(j1) < 4 Or X(j1) > 6 Or Y(j1) < 1 Or Y(j1) > 3 Then X(j1) = 200
                                'If x(j1) < 4 Or x(j1) > 6 Or y(j1) < 8 Or y(j1) > 10 Then Stop: x(j1) = 100
                            Next
                            
                            '原位置不能走
                            For j1 = 0 To 3
                                If X(j1) = i And Y(j1) = j Then X(j1) = 200
                            Next
                            
                            '王不见王(竖向寻找)
                            For j1 = j + 1 To 10
                                
                                If ChessBoard(i, j1).Value <> 0 And ChessBoard(i, j1).Value Mod 100 <> 7 Then Exit For     ''有隔子，不形成王不见王
                                If ChessBoard(i, j1).Value Mod 100 = 7 Then X(9) = i: Y(9) = j1 ''对面有王，可以吃掉
                                
                            Next
                            
                        End If
                        
                    Case 6:

                        ''士(走斜1,最多有5个着点) x横y竖
                        If Cer = 2 Then
                            ''Cer=2为红方
                            ''士只能走左斜、右斜、上斜、下斜
                            X(0) = i - 1: Y(0) = j - 1    ''左
                            X(1) = i + 1: Y(1) = j - 1    ''右
                            X(2) = i - 1: Y(2) = j + 1    ''上
                            X(3) = i + 1: Y(3) = j + 1    ''下
                            
                            '原位置及越界不能走
                            For j1 = 0 To 3
                                If X(j1) = i And Y(j1) = j Then X(j1) = 200
                            Next
                            
                            ''判断有无超格