【五子棋AI循序渐进】发布一个完整的有一定棋力的版本（含源码）

 本博文来自于： http://www.cnblogs.com/zcsor/archive/2012/12/25/2832820.html

      经过这半年左右的学习和探索，现在对五子棋AI有了一定的认识，给大家发出来现在的版本。因为最近有些事情很生气，要是年轻时真就先灭了这些王八羔子，省的它们继续祸害好人。不过它们也祸害不了几天了，祸害人者人祸害之。心情不好，就少打几个字，说一下基本思路：

1、每一个点的重要性，决定于四个方向上的棋型；棋型是可以相互转化的，可以枚举出每一种变化以及它们之间的关联关系。

    例如：（0=白、1=黑、2=空，程序中和下面全文均如此）

    一行空棋 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 当白棋要下的时候，就要考察更好的点，我们如果给这一行棋评分如下

                0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0  那么，白棋的走法生成器就会知道1的那些点，排在0前面。同样道理，

     一行棋型 2   2   2   1   1   1   2   2   2   2   2   2   2   2   2   2 当白棋要下的时候，就会选择分数更高的点先进行测试：

                  2   4  8  -1  -1  -1   8   4   2   1   1   1   1   1   1   0 于是会先测试8分，然后4分，然后2分1分，当然，因为8分点已经可以导致胜利（活4）那么可以不生成其他点。而此时如果我们下在第3个位置上，即第一个评分为8的点上，则得到棋型：

     一行棋型 2   2   1   1   1   1   2   2   2   2   2   2   2   2   2   2  对这个棋型的评分我们也可以预先评价好：

                 4   F  -1  -1  -1  -1   F   4   2   1   1   1   1   1   1   0 

所以，我们可以建立一个结构数组来保存棋型及其对应的各个点的冲棋值，这样很容易得到下某一个点后的新棋盘评价。

2、VCT\VCF。这个话题可以说是五子棋中非常重要的，可以说一个AI的VCT\VCF能力体现了它的棋力（呵呵，不过我的现在还不怎么样）。我没有看到这方面的源码，但实际上，VCN搜索无非是象棋中的“将军延伸”技术而已！虽然我的代码中我进行了一些修改而且看起来不伦不类（因为没有详细的记录每一方的冲棋程度），但我在网上搜索时经常看到有人问你的VCT,VCF做的怎么样了？我就很茫然的说……

3、走法顺序。这确实是一个非常值得深入思考的问题，但是从冲棋点的角度来考虑，这似乎不是问题，我们完全可以根据冲棋点分值大小进行排列，可实际上代码会很长，至少我的程序里面它是仅次于剪裁函数的家伙，而且我对那些代码很不满意。

好了，贴上一些核心代码，说明一下：

Public Class mShape529
    Public tShapeObj() As mShape529             '转换结果的引用
    Public cLine() As mConstValue.LinkType      '冲棋信息（由空点决定）

    Sub New(len As Integer)
        ReDim tShapeObj(len * 3 - 1)
        ReDim cLine(len * 2 - 1)
    End Sub

    Public Overrides Function ToString() As String
        Dim tmp As String = String.Empty
        For i As Integer = 0 To cLine.Length - 1
            tmp &= cLine(i).ToString & " "
            If i + 1 = cLine.Length \ 2 Then tmp &= " |  "
        Next
        Return tmp
    End Function

End Class

Public Class mShapeManeger
    Private Shared allShapes(4) As List(Of mShape529)    '长度为len的全部形态

    Shared Sub New()
        Dim i As Integer
        For i = 0 To 4
            allShapes(i) = New List(Of mShape529)
            allShapes(i) = ReadByteFile59(i + 5)
        Next
    End Sub

    '返回指定长度的模板
    Public Shared ReadOnly Property ShapeList(len As Integer) As List(Of mShape529)
        Get
            Return allShapes(IIf(len > 9, 4, len - 5))
        End Get
    End Property

    Private Shared Function ReadByteFile59(len As Integer) As List(Of mShape529)
        ' tShape() As Integer               'len*3*2
        ' cLine() As byte                   'len*2
        Dim bytes() As Byte = My.Resources.ResourceManager.GetObject("_" & len)
        Dim i, j, l As Integer, tmps(1) As Byte
        Dim ret As New List(Of mShape529)
        Dim stp As Integer = len * 3 * 2 + len * 2
        Dim tmpint As Integer
        For i = 0 To bytes.Length - 1 Step stp
            ret.Add(New mShape529(len))
        Next
        For i = 0 To ret.Count - 1
            Dim tmp = ret(i)
            For j = 0 To len * 3 - 1
                tmps(0) = bytes(l)
                tmps(1) = bytes(l + 1)
                l += 2
                tmpint = CInt(BitConverter.ToInt16(tmps, 0))
                If tmpint <> -1 Then tmp.tShapeObj(j) = ret(tmpint)
            Next
            For j = 0 To len * 2 - 1
                Select Case bytes(l)
                    Case 0
                        tmp.cLine(j) = mConstValue.LinkTypelnl
                    Case 1
                        tmp.cLine(j) = mConstValue.LinkTypel00
                    Case 2
                        tmp.cLine(j) = mConstValue.LinkTypel11
                    Case 3
                        tmp.cLine(j) = mConstValue.LinkTypel12
                    Case 4
                        tmp.cLine(j) = mConstValue.LinkTypel21
                    Case 5
                        tmp.cLine(j) = mConstValue.LinkTypel22
                    Case 6
                        tmp.cLine(j) = mConstValue.LinkTypel31
                    Case 7
                        tmp.cLine(j) = mConstValue.LinkTypel32
                    Case 8
                        tmp.cLine(j) = mConstValue.LinkTypel32
                    Case 9
                        tmp.cLine(j) = mConstValue.LinkTypel41
                    Case 10
                        tmp.cLine(j) = mConstValue.LinkTypel415
                    Case 11
                        tmp.cLine(j) = mConstValue.LinkTypel42
                    Case 12
                        tmp.cLine(j) = mConstValue.LinkTypel50
                    Case 13
                        tmp.cLine(j) = mConstValue.LinkTypel60
                    Case 14
                        tmp.cLine(j) = mConstValue.LinkTypel70
                End Select
                l += 1
            Next
            ret(i) = tmp
        Next
        Return ret
    End Function

End Class

上面是基础形态和基础形态管理器，思路是5-14长度的72个向量中，5-9长度的，直接使用生成好的模板，而10-14的，利用9长度的模板进行合成。因为这是初始化时的代码不影响计算速度，所以没有任何优化。

Public Class mVector52E
    Private mss As List(Of mShape529)           '当前形态模板
    Public len As Byte                          '向量长度
    Public shapes() As mShape529                '所包含的形态
    Public cLine() As Integer                   '冲棋信息
    Public key As Integer                       '键。由低20-30位记录形态。同一位置用2位表示，白棋在低位黑棋在高位。没有初始化的必要。
    Private ps() As Byte                        '包含的棋盘点（实际坐标）。
    Private dx, dy As Integer                   '方向:右=(1,0),下=(0,1),右上=(1,-1),左上=(-1,-1)

    Sub New(points() As Byte, xoffset As Integer, yoffset As Integer)
        Dim i As Integer
        len = points.Length
        ReDim ps(len - 1)
        Array.Copy(points, ps, len)
        dx = xoffset
        dy = yoffset
        '本向量对应的形态模板
        mss = mShapeManeger.ShapeList(len)
        '定义冲棋信息
        ReDim cLine(len * 2 - 1)
        '若长度为9以内，则用一个长度相等的形态表示即可。否则用一组长度为9的形态表示。
        If len <= 9 Then
            ReDim shapes(0)
            shapes(0) = mss(0)
        Else
            ReDim shapes(len - 9)
            For i = 0 To shapes.Length - 1
                shapes(i) = mss(0)
            Next
        End If
    End Sub

    Sub SetPlayer(point As Byte, player As Integer)
        Dim i, j, p As Integer, tkm, tks As Integer
        Dim n As Integer = Math.Min(len - 1, 8)     '最大下标
        Dim ts As mShape529
        '更新所属形态
        For i = 0 To shapes.Length - 1
            p = point - i
            '当点在需要更新的形态内
            If p > -1 AndAlso p <= n Then
                ts = shapes(i).tShapeObj(3 * p + player)
                If ts Is Nothing Then
                    Throw New Exception("该点已经有子")
                Else
                    shapes(i) = ts
                End If
            End If
        Next
        '更新key和检查置换表。
        Dim keyindex As Integer = (point - 2) * 2
        If player = 2 Then
            key = key And Not (1 << keyindex)           '删除白棋
            key = key And Not (1 << keyindex + 1)       '删除黑棋
        Else
            key = key Or (1 << keyindex + player)       '设置棋子
        End If
        If len > 9 AndAlso mZobristForVector.ProbeHash(Me) Then Return

        '清理冲棋信息
        For i = 0 To len * 2 - 1
            cLine(i) = 0
        Next

        '由子形态合成向量冲棋信息
        For i = 0 To shapes.Length - 1
            ts = shapes(i)
            For j = 0 To n
                tkm = cLine(j + i)
                tks = ts.cLine(j)
                If tks > tkm OrElse tks = mConstValue.LinkTypelnl OrElse tks = mConstValue.LinkTypel70 Then cLine(j + i) = tks
                tkm = cLine(j + i + len)
                tks = ts.cLine(j + n + 1)
                If tks > tkm OrElse tks = mConstValue.LinkTypelnl OrElse tks = mConstValue.LinkTypel70 Then cLine(j + i + len) = tks
            Next
        Next
        '保存到置换表
        If len > 9 Then mZobristForVector.RecordHash(Me)
    End Sub

    Function InLine(p As Byte) As Boolean
        Dim i As Integer
        For i = 0 To ps.Length - 1
            If ps(i) = CByte(p) Then Return True
        Next
        Return False
    End Function

    Sub Clear()
        Dim i As Integer
        key = 0
        For i = 0 To shapes.Length - 1
            shapes(i) = mss(0)
        Next
    End Sub

    Public Function BoardPoint2VectorPoint(p As Byte) As Byte
        '右=(1,0),下=(0,1),右上=(1,-1),左上=(-1,-1)
        If dy = 0 Then  '右
            '0 1 2 3 4 5 …… 14
            '1 2 3 4 5 6 …… 15
            Return p - ps(0)
        End If
        If dx = 0 Then  '下
            ' 0 15 30 45
            ' 1 16 31 46
            Return (p - ps(0)) / 15
        End If
        If dx = 1 Then  '右上
            '60 46 32 18  4
            '75 61 47 33 19 5
            Return (ps(0) - p) / 14
        End If
        If dx = -1 Then '左上
            '214 198 182 166 150
            '209 193 177 161
            Return (ps(0) - p) / 16
        End If
        Throw New Exception("err")
    End Function

    Public Function VectorPoint2BoardPoint(p As Byte) As Byte
        '右=(1,0),下=(0,1),右上=(1,-1),左上=(-1,-1)
        If dy = 0 Then  '右
            '0 1 2 3 4 5 …… 14
            '1 2 3 4 5 6 …… 15
            Return p + ps(0)
        End If
        If dx = 0 Then  '下
            ' 0 15 30 45
            ' 1 16 31 46
            Return p * 15 + ps(0)
        End If
        If dx = 1 Then  '右上
            '60 46 32 18  4
            '75 61 47 33 19 5
            Return ps(0) - p * 14
        End If
        If dx = -1 Then '左上
            '214 198 182 166 150
            '209 193 177 161
            Return ps(0) - p * 16
        End If
        Throw New Exception("err")
    End Function

    Public Overrides Function ToString() As String
        Dim tmp As String = String.Empty
        For i As Integer = 0 To len * 2 - 1
            tmp &= ps(i) & Space(6 - cLine(i).ToString.Length) & cLine(i) & vbCrLf
        Next
        Return tmp
    End Function

End Class
Public Class mVectorManager
    '所有行
    Public AllVectors(71) As mVector52E
    '点对应的行
    Public VectorsOfPoint(224)() As mVector52E

    Sub New()
        '求所有的向量
        Dim x, y, n, levindex As Integer
        Dim lev(4) As Integer
        '右,0-14
        For y = 0 To 14
            AllVectors(n) = GetVector(0, y, 14, y, 1, 0)
            n += 1
        Next
        levindex += 1
        lev(levindex) = n
        '下
        For x = 0 To 14
            AllVectors(n) = GetVector(x, 0, x, 14, 0, 1)
            n += 1
        Next
        levindex += 1
        lev(levindex) = n
        '右上
        For y = 4 To 14
            AllVectors(n) = GetVector(0, y, y, 0, 1, -1)
            n += 1
        Next
        For x = 1 To 10
            AllVectors(n) = GetVector(x, 14, 14, x, 1, -1)
            n += 1
        Next
        levindex += 1
        lev(levindex) = n
        '左上
        For x = 4 To 14
            AllVectors(n) = GetVector(x, 14, 0, 14 - x, -1, -1)
            n += 1
        Next
        For y = 13 To 4 Step -1
            AllVectors(n) = GetVector(14, y, 14 - y, 0, -1, -1)
            n += 1
        Next
        levindex += 1
        lev(levindex) = n
        '分配到点记录表
        Dim i As Integer

        For y = 0 To 14
            For x = 0 To 14
                Dim ls(3) As mVector52E
                '遍历全部向量，将点所在的向量保存到ls。
                For levindex = 0 To 3
                    For i = lev(levindex) To lev(levindex + 1) - 1
                        Dim tmpvector As mVector52E = AllVectors(i)
                        If tmpvector.InLine(y * 15 + x) Then
                            ls(levindex) = tmpvector
                            Exit For
                        End If
                    Next
                Next
                VectorsOfPoint(y * 15 + x) = ls
            Next
        Next
    End Sub

    '根据起点终点初始化全部坐标点（用一个字节表示）
    Private Function GetVector(x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, dx As Integer, dy As Integer) As mVector52E
        '向量上的全部点。
        Dim ps() As Byte = Nothing
        '当前坐标X,Y,记数。
        Dim x As Integer = -1, y As Integer = -1, cst As Integer
        '从向量起点遍历，直到终点，把每一个点记录下来。
        Do Until x = x2 AndAlso y = y2
            x = x1 + dx * cst
            y = y1 + dy * cst
            ReDim Preserve ps(cst)
            ps(cst) = y * 15 + x        '将坐标转换为数组下标
            cst += 1
        Loop
        '将向量分割为长度5-9的若干个子向量。
        Return New mVector52E(ps, dx, dy)
    End Function

    Public Sub Clear()
        Dim i As Integer
        For i = 0 To 71
            AllVectors(i).Clear()
        Next
    End Sub

End Class

Public Class mZobristForVector

    Private Structure mVectorItem
        Public cLine() As Integer               '冲棋信息,30
        Public key As Integer                   '键,31
        Public len As Integer                   '长,32

        Sub New(vlen As Integer)
            len = vlen  '因为10-14长度都保存在一个表里，而key的计算方法是按位排列，所以重复非常多，必须用len加以区分。覆盖策略是长度大的优先保存。
            ReDim cLine(vlen - 1)
        End Sub

        Shared Sub Clear(ByRef mvi As mVectorItem)
            mvi.key = -1
            mvi.len = mConstValue.ZeroLinkArrLen
            ReDim mvi.cLine(mConstValue.ZeroLinkArrLen - 1)
        End Sub

    End Structure

    Private Shared hstb(mConstValue.HASH_SIZEOFVECTOR - 1) As mVectorItem   '表

    Shared Sub New()
        Dim i As Integer
        For i = 0 To mConstValue.HASH_SIZEOFVECTOR - 1
            hstb(i) = New mVectorItem(mConstValue.ZeroLinkArrLen - 1) '用最长长度（30）来初始化，这样每一项大小一样大。
            mVectorItem.Clear(hstb(i))
        Next
    End Sub

    Shared Sub Clear()
        Dim i As Integer
        For i = 0 To mConstValue.HASH_SIZEOFVECTOR - 1
            mVectorItem.Clear(hstb(i))
        Next
    End Sub

    '保存置换表项。返回值：0=未替换，1=替换空项，2=替换已有项。
    Shared Function RecordHash(vector As mVector52E) As Integer
        Dim ret As Integer = 0
        Dim hsh As mVectorItem = hstb(vector.key And (mConstValue.HASH_SIZEOFVECTOR - 1))
        '空项
        If hsh.key = -1 Then
            ret = 1
        Else
            '已有项长度小于等于新长度，且最大冲棋值小于等于要保存值
            If hsh.len <= vector.len Then ret = 2
        End If
        '替换
        If ret > 0 Then
            Array.Copy(vector.cLine, hsh.cLine, vector.len * 2)
            hsh.key = vector.key
            hsh.len = vector.len
        End If
        hstb(vector.key And (mConstValue.HASH_SIZEOFVECTOR - 1)) = hsh
        Return ret
    End Function

    '提取置换表项。返回值表示是否成功。
    Shared Function ProbeHash(vector As mVector52E) As Boolean
        Dim hsh As mVectorItem = hstb(vector.key And (mConstValue.HASH_SIZEOFVECTOR - 1))
        '空项或不等
        If hsh.len <> vector.len OrElse hsh.key <> vector.key Then Return False
        '返回置换表项
        Array.Copy(hsh.cLine, vector.cLine, vector.len * 2)
        Return True
    End Function

End Class

上面是向量和向量管理器以及对应的置换表的代码。向量一共有72个，都存储在管理器中。用9长度合成10-14的长度，并且计算点所对应的向量，实现下子、提子函数。

Public Class mPosition
    '轮到谁走，0=白方，1=黑方
    Public sdPlayer As Integer
    '距离根节点的步数
    Public nDistance As Integer
    '电脑走的棋
    Public mvResult As Integer
    '各点的冲棋值表
    Public cpInfo() As Integer
    '待排序坐标表
    Dim pslst(1)() As Byte
    '根据cpInfo排序
    Dim cplst(1)() As Integer
    '向量管理
    Public mVectorManager As New mVectorManager
    '当前局面密匙结构
    Public poskey As mZobristForPosition.mPosKey

    Sub New()
        sdPlayer = 1
        StartUp()
        ReDim cpInfo(mConstValue.ZerocpPosArrLen - 1)
        ReDim pslst(0)(mConstValue.BoardSize - 1)
        ReDim pslst(1)(mConstValue.BoardSize - 1)
        ReDim cplst(0)(mConstValue.BoardSize - 1)
        ReDim cplst(1)(mConstValue.BoardSize - 1)
        Array.Copy(mConstValue.BoardPointList, pslst(0), mConstValue.BoardSize)
        Array.Copy(mConstValue.BoardPointList, pslst(1), mConstValue.BoardSize)
        mVectorManager.Clear()
        mZobristForPosition.Clear()
        mZobristForPosition.mPosKey.Clear(poskey)
        mZobristForVector.Clear()
    End Sub

    '清理变化，恢复初始值。
    Public Sub StartUp()
        nDistance = 0
        mvResult = -1
    End Sub

    '设置棋盘上点的棋子.
    Public Sub SetPlayer(point As Byte, player As Integer)
        SyncLock cpInfo
            Dim i, j As Integer
            '若是下一个空子（撤销招法），则局面更改玩家为上一步玩家、步数减一；否则，局面更改为当前玩家，步数加一。
            If player = 2 Then
                poskey = mZobristForPosition.SetPlayer(poskey, point, 1 - sdPlayer)     '更新局面KEY
                nDistance -= 1                                                          '更新走棋步数
            Else
                poskey = mZobristForPosition.SetPlayer(poskey, point, sdPlayer)
                nDistance += 1
            End If
            '在指定点上下一个白、黑或空子（撤销招法）。
            Dim tmpvector As mVector52E
            Dim tmpPoint As Integer = -1
            For i = 0 To 3
                tmpvector = mVectorManager.VectorsOfPoint(point)(i)
                If tmpvector IsNot Nothing Then
                    If tmpvector.key <> 0 Then      '只更新有子向量
                        '冲棋表更新第一步：删除原向量产生的影响
                        For j = 0 To tmpvector.len - 1
                            tmpPoint = tmpvector.VectorPoint2BoardPoint(j)
                            cpInfo(tmpPoint) -= tmpvector.cLine(j)
                            cpInfo(tmpPoint + mConstValue.BoardSize) -= tmpvector.cLine(j + tmpvector.len)
                        Next
                    End If
                    tmpvector.SetPlayer(tmpvector.BoardPoint2VectorPoint(point), player)
                    '冲棋表更新第二步：添加新向量的影响
                    If tmpvector.key <> 0 Then
                        For j = 0 To tmpvector.len - 1
                            tmpPoint = tmpvector.VectorPoint2BoardPoint(j)
                            cpInfo(tmpPoint) += tmpvector.cLine(j)
                            cpInfo(tmpPoint + mConstValue.BoardSize) += tmpvector.cLine(j + tmpvector.len)
                        Next
                    End If
                End If
            Next
            '最后，交换走棋方。
            sdPlayer = 1 - sdPlayer
        End SyncLock
    End Sub

    '进行粗略估值
    '已胜利局面中有5个以上2560-N，实际上有一个点大于1024即可判定胜负。
    '一个点上两个活三或更多则可以杀棋，即32*2就是杀棋。
    '一个点上一个活三或更多则是冲棋，即32以上就是冲棋。
    Function Evaluate() As Integer
        SyncLock cpInfo
            Dim csPlayer As Integer = 1 - sdPlayer              '对方
            Dim vl(1) As Integer                                '总分
            Dim curcpInfocLine(1) As Integer                    '当前冲棋值
            '分离
            Array.Copy(cpInfo, 0, cplst(0), 0, mConstValue.BoardSize)
            'CopyMemory(cplst(0), cpInfo, mConstValue.BoardSize)
            Array.Copy(cpInfo, mConstValue.BoardSize, cplst(1), 0, mConstValue.BoardSize)
            '排序
            Array.Sort(cplst(0))
            Array.Sort(cplst(1))
            '遍历
            For i = mConstValue.BoardSize - 1 To 0 Step -1
                curcpInfocLine(0) = cplst(0)(i)
                curcpInfocLine(1) = cplst(1)(i)
                '已有一方胜利
                If curcpInfocLine(csPlayer) >= mConstValue.WIN_VALUE Then Return -mConstValue.MATE_VALUE
                If curcpInfocLine(sdPlayer) >= mConstValue.WIN_VALUE Then Return mConstValue.MATE_VALUE
                '有2个或更多成5（或长连）点
                If curcpInfocLine(csPlayer) >= mConstValue.LinkTypel50 AndAlso cplst(csPlayer)(i - 1) >= mConstValue.LinkTypel50 Then Return -mConstValue.MATE_VALUE
                If curcpInfocLine(sdPlayer) >= mConstValue.LinkTypel50 AndAlso cplst(sdPlayer)(i - 1) >= mConstValue.LinkTypel50 Then Return mConstValue.MATE_VALUE
                '将冲棋值大于l12的点的冲棋值之和作为评价
                If curcpInfocLine(0) > mConstValue.LinkTypel21 Then vl(0) += curcpInfocLine(0)
                If curcpInfocLine(1) > mConstValue.LinkTypel21 Then vl(1) += curcpInfocLine(1)
            Next
            Return vl(sdPlayer) - vl(1 - sdPlayer)
        End SyncLock
    End Function

    '有子棋盘
    Dim tb As New BitArray(mConstValue.BoardSize)
    '排序/分类截取
    Function NextGenerateMove(ByRef retval() As Byte, ByRef InCheck As Integer, InCheckOnly As Boolean) As Integer
        SyncLock cpInfo
            tb.SetAll(False)
            '1、排序
            Array.Copy(cpInfo, 0, cplst(0), 0, mConstValue.BoardSize)
            Array.Copy(cpInfo, mConstValue.BoardSize, cplst(1), 0, mConstValue.BoardSize)
            Array.Sort(pslst(0), New mComparer(cplst(0)))
            Array.Sort(pslst(1), New mComparer(cplst(1)))
            '2、分类截取
            Dim cnt As Integer, csPlayer As Integer = 1 - sdPlayer
            '已经有一方胜利
            If GetcplstByLinkType(cplst(csPlayer), pslst(csPlayer), retval, cnt, mConstValue.WIN_VALUE) > 0 Then Return -1
            If GetcplstByLinkType(cplst(sdPlayer), pslst(sdPlayer), retval, cnt, mConstValue.WIN_VALUE) > 0 Then Return -1
            '成五或长连
            If GetcplstByLinkType(cplst(sdPlayer), pslst(sdPlayer), retval, cnt, mConstValue.LinkTypel50) > 0 Then
                Return cnt - 1
            End If
            If GetcplstByLinkType(cplst(csPlayer), pslst(csPlayer), retval, cnt, mConstValue.LinkTypel50) > 0 Then
                Return cnt - 1
            End If
            '42,41+32,32+32
            If GetcplstByLinkType(cplst(csPlayer), pslst(csPlayer), retval, cnt, mConstValue.LinkTypel32 * 2) > 0 Then
                InCheck = InCheck Or (2 - csPlayer)
            End If
            If GetcplstByLinkType(cplst(sdPlayer), pslst(sdPlayer), retval, cnt, mConstValue.LinkTypel32 * 2) > 0 Then
                InCheck = InCheck Or (2 - sdPlayer)
            End If
            If cnt > 2 Then
                Return cnt - 1
            Else
                GetcplstByLinkType(cplst(sdPlayer), pslst(sdPlayer), retval, cnt, mConstValue.LinkTypel32)
                GetcplstByLinkType(cplst(csPlayer), pslst(csPlayer), retval, cnt, mConstValue.LinkTypel32)
                If cnt > 0 Then
                    InCheck = 0
                    Return cnt - 1
                End If
            End If
            If InCheckOnly Then Return cnt - 1
            GetcplstByLinkType(cplst(csPlayer), pslst(csPlayer), retval, cnt, mConstValue.LinkTypel31)
            GetcplstByLinkType(cplst(sdPlayer), pslst(sdPlayer), retval, cnt, mConstValue.LinkTypel31)
            If cnt > 0 Then Return cnt - 1
            GetcplstByLinkType(cplst(csPlayer), pslst(csPlayer), retval, cnt, mConstValue.LinkTypel22)
            GetcplstByLinkType(cplst(sdPlayer), pslst(sdPlayer), retval, cnt, mConstValue.LinkTypel22)
            Return cnt - 1
        End SyncLock
    End Function

    Private Function GetcplstByLinkType(cplst() As Integer, pslst() As Byte, ByRef retval() As Byte, ByRef cnt As Integer, Threshold As Integer) As Integer
        Dim i, tp, tv, tcnt, bkv As Integer
        For i = 0 To mConstValue.BoardSize - 1
            tp = pslst(i)
            tv = cplst(tp)
            If tv < Threshold Then Exit For
            bkv = tv
            If tb(tp) = False Then
                retval(cnt) = tp
                cnt += 1
                tcnt += 1
                tb(tp) = True
            End If
        Next
        Return tcnt
    End Function

    Public Overrides Function ToString() As String
        Dim i As Integer, s As Integer
        Dim tmpstr As String = String.Empty
        For i = 0 To cpInfo.Length - 1
            tmpstr &= Space(6 - CStr(cpInfo(i)).Length) & cpInfo(i)
            If i + 1 <= cpInfo.Length / 2 Then s = 15 Else s = 30
            If ((i + 1) Mod 15) = 0 Then tmpstr &= Space(6) & (s - (i \ 15)) & "  " & (i Mod mConstValue.BoardSize) & vbCrLf
            If i + 1 = cpInfo.Length / 2 Then tmpstr &= "-----A-----B-----C-----D-----E-----F-----G-----H-----I-----J-----K-----L-----M-----N-----O------" & vbCrLf
        Next
        Return tmpstr & "-----A-----B-----C-----D-----E-----F-----G-----H-----I-----J-----K-----L-----M-----N-----O------" & vbCrLf
    End Function

End Class

Public Class mComparer : Implements IComparer(Of Byte)
    Private cline() As Integer
    Sub New(ps() As Integer)
        cline = ps
    End Sub

    Public Function Compare(x As Byte, y As Byte) As Integer Implements System.Collections.Generic.IComparer(Of Byte).Compare
        Return cline(y) - cline(x)
    End Function

End Class
Imports System.Security.Cryptography

Public Class mZobristForPosition
    '置换表项结构
    Private Structure mPosZobItem
        Public dwLock0 As Long                  '锁
        Public ucDepth As Integer               '深度
        Public ucFlag As mConstValue.HASHType   '节点类型
        Public svl As Integer                   '分值
        Public wmv As Integer                   '招法
        Public nDistance As Integer
        Public dwLock1 As Long                  '锁

        Shared Sub Clear(ByRef mzp As mPosZobItem)
            mzp.dwLock0 = 0L
            mzp.ucDepth = 0
            mzp.ucFlag = mConstValue.HASHType.HASH_ALPHA
            mzp.svl = 0
            mzp.wmv = 0
            mzp.nDistance = 0
            mzp.dwLock1 = 0L
        End Sub
    End Structure

    '密匙结构
    Public Structure mPosKey
        Public key As Integer                   '用以计算存储位置的键
        Public dwLock0 As Long                  '锁
        Public dwLock1 As Long
        Shared Sub Clear(ByRef mpk As mPosKey)
            mpk.key = 0
            mpk.dwLock0 = 0L
            mpk.dwLock1 = 0L
        End Sub
        Public Overrides Function ToString() As String
            Return "key " & Hex(key) & " dwlock0 " & Hex(dwLock0) & " dwlock1 " & Hex(dwLock1)
        End Function
        Public Overrides Function Equals(obj As Object) As Boolean
            Dim tmp As mPosKey = CType(obj, mPosKey)
            Return tmp.key = key AndAlso tmp.dwLock0 = dwLock0 AndAlso tmp.dwLock1 = dwLock1
        End Function
    End Structure

    '密匙流
    Private Shared table(1)() As mPosKey

    '置换表
    Private Shared hstb(mConstValue.HASH_SIZEOFPOS - 1) As mPosZobItem

    Shared Sub New()
        '初始化密匙流
        ReDim table(0)(224)
        ReDim table(1)(224)
        Dim i, j As Integer
        For i = 0 To 224
            For j = 0 To 1
                table(j)(i).key = MD5Zob(j, i)
                table(j)(i).dwLock0 = RC2Zob(j, i)
                table(j)(i).dwLock1 = DESZob(j, i)
            Next
        Next
    End Sub

    Shared Sub Clear()
        Dim i As Integer
        For i = 0 To mConstValue.HASH_SIZEOFPOS - 1
            mPosZobItem.Clear(hstb(i))
        Next
    End Sub

    'MD5加密算法
    Private Shared Function MD5Zob(k1 As Integer, k2 As Integer) As Integer
        Dim md5 As New MD5CryptoServiceProvider
        Dim inputByteArray As Byte() = New Byte() {k1, k2}
        Dim mdByte As Byte() = md5.ComputeHash(inputByteArray)
        Return BitConverter.ToInt32(mdByte, 0)
    End Function

    'RC2，DES算法的键和动量
    Private Shared key As Byte() = New Byte() {&H12, &H34, &H56, &H78, &H90, &HAB, &HCD, &HEF}
    Private Shared iv As Byte() = New Byte() {&H23, &H34, &H45, &H56, &H67, &H78, &H89, &H9A}

    'RC2加密算法
    Private Shared Function RC2Zob(k1 As Byte, k2 As Byte) As Long
        Dim rc2 As New RC2CryptoServiceProvider
        Dim inputByteArray As Byte() = New Byte() {k1, k2}
        rc2.Key = key
        rc2.IV = iv
        Dim ms As New System.IO.MemoryStream
        Dim cs As New CryptoStream(ms, rc2.CreateEncryptor, CryptoStreamMode.Write)
        cs.Write(inputByteArray, 0, inputByteArray.Length)
        cs.FlushFinalBlock()
        Return BitConverter.ToInt64(ms.ToArray(), 0)
    End Function

    'DES加密算法
    Private Shared Function DESZob(k1 As Byte, k2 As Byte) As Long
        Dim rc2 As New DESCryptoServiceProvider
        Dim inputByteArray As Byte() = New Byte() {k1, k2}
        rc2.Key = key
        rc2.IV = iv
        Dim ms As New System.IO.MemoryStream
        Dim cs As New CryptoStream(ms, rc2.CreateEncryptor, CryptoStreamMode.Write)
        cs.Write(inputByteArray, 0, inputByteArray.Length)
        cs.FlushFinalBlock()
        Return BitConverter.ToInt64(ms.ToArray(), 0)
    End Function

    '获取新键值和锁
    Public Shared Function SetPlayer(poskey As mPosKey, point As Integer, player As Integer) As mPosKey
        Dim tmp As mPosKey = table(player)(point)
        Dim ret As New mPosKey
        ret.key = poskey.key Xor tmp.key
        ret.dwLock0 = poskey.dwLock0 Xor tmp.dwLock0
        ret.dwLock1 = poskey.dwLock1 Xor tmp.dwLock1
        Return ret
    End Function

    '提取置换表项。
    Public Shared Function ProbeHash(poskey As mPosKey, vlAlpha As Integer, vlBeta As Integer, nDepth As Integer, nDistance As Integer, ByRef mv As Integer) As Integer
        SyncLock hstb
            Dim bMate As Boolean                                                            '杀棋标志：如果是杀棋，那么不需要满足深度条件
            Dim hsh As mPosZobItem = hstb(poskey.key And (mConstValue.HASH_SIZEOFPOS - 1))         '用and运算代替mod运算
            If (hsh.dwLock0 <> poskey.dwLock0) OrElse (hsh.dwLock1 <> poskey.dwLock1) Then  '未找到
                mv = -1
                Return -mConstValue.MATE_VALUE
            End If
            mv = hsh.wmv
            bMate = False
            If hsh.svl > mConstValue.WIN_VALUE Then             '当前玩家胜利
                hsh.svl -= nDistance        '提取时恢复杀棋步
                bMate = True
            ElseIf hsh.svl < -mConstValue.WIN_VALUE Then        '对方胜利
                hsh.svl += nDistance
                bMate = True
            End If

            If hsh.ucDepth >= nDepth OrElse bMate Then
                If hsh.ucFlag = mConstValue.HASHType.HASH_BETA Then             'BETA截断时，要超出边界。
                    Return IIf(hsh.svl >= vlBeta, hsh.svl, -mConstValue.MATE_VALUE)
                ElseIf (hsh.ucFlag = mConstValue.HASHType.HASH_ALPHA) Then      'ALPHA截断时，要在边界之内。
                    Return IIf(hsh.svl <= vlAlpha, hsh.svl, -mConstValue.MATE_VALUE)
                End If
                Return hsh.svl
            End If
            Return -mConstValue.MATE_VALUE
        End SyncLock
    End Function

    ' 保存置换表项
    Public Shared Sub RecordHash(poskey As mPosKey, nFlag As Integer, vl As Integer, nDepth As Integer, nDistance As Integer, mv As Integer)
        SyncLock hstb
            Dim hsh As mPosZobItem = hstb(poskey.key And (mConstValue.HASH_SIZEOFPOS - 1))     '用and运算代替mod运算
            If hsh.ucDepth > nDepth Then Return '存储深度比现在深度小时，才更新。
            If hsh.ucDepth = nDepth AndAlso hsh.nDistance > nDistance Then Return '冲棋延伸局面计算量更大，所以保存更优先。
            hsh.ucFlag = nFlag
            hsh.ucDepth = nDepth
            hsh.nDistance = nDistance
            If vl > mConstValue.WIN_VALUE Then
                hsh.svl = vl + nDistance        '存储时用杀棋步影响分值，从而使得覆盖过程可以存储到更快的杀棋。
            ElseIf vl < -mConstValue.WIN_VALUE Then
                hsh.svl = vl - nDistance
            Else
                hsh.svl = vl
            End If
            hsh.wmv = mv
            hsh.dwLock0 = poskey.dwLock0
            hsh.dwLock1 = poskey.dwLock1
            hstb(poskey.key And (mConstValue.HASH_SIZEOFPOS - 1)) = hsh
        End SyncLock
    End Sub

End Class

以上是局面和局面置换表。思路很清楚，值得注意的就是置换表保存时，同样深度下，由于冲棋延伸导致步数更多的局面实际上的深度要比以保存的深步数差个，为了方便代码中按同样深度保存了，实际上保存时应该重新计算深度（或许我们可以用深度与步数之和的大小关系作为覆盖依据），但即使现在的代码也可以提高很多命中率，而且显见这些提高的命中都是延伸若干步之后的结果，这为我们赢得了宝贵的时间。

Imports System.Threading
Public Class mPVSAlphaBeta
    Public pos As mPosition             '评价
    Public Event SearchEnd(a As Integer, b As Integer, c As Integer, d As Integer, e As Integer, vlbest As Integer, pline As mPVLine)
    '记数统计
    Public a, b, c, d, e As Integer

    '用局面类初始化
    Sub New(p As mPosition)
        pos = p
    End Sub

    '超出边界(Fail-Soft)的Alpha-Beta搜索过程。
    Public Function AlphaBeta(vlAlpha As Integer, vlBeta As Integer, nDepth As Integer, pLine As mPVLine, chk As Integer) As Integer
        b += 1
        d += 1
        Dim line As New mPVLine                 'pvs走法
        Dim nNewDepth As Integer                '搜索深度
        Dim nGenMove As Integer                 '子节点数
        Dim vl, vlBest, mvBest As Integer       '评价分值，最佳分值，最佳走法
        Dim InCheck As Integer                  '走一步棋时是否形成冲棋
        Dim mvs(224) As Byte                    '子节点走法缓存
        Dim mv As Integer                       '当前走法
        Dim nHashFlag As mConstValue.HASHType   '置换表标志
        Dim mvHash As Integer = -1              '哈希表走法
        Dim InCheckOnly As Boolean              '只生成冲棋走法，用于静态评价（'''''''''''''''''''''''''''注释掉的语句就是静态评价）
        '最深走法步数
        If pos.nDistance > c Then
            c = pos.nDistance
        End If
        '1. 到达水平线，则返回局面评价
        If nDepth <= 0 Then
            '''''''''''''''''''''''''''If chk = 0 Then
            vl = pos.Evaluate
            Return vl
            '''''''''''''''''''''''''''Else
            '''''''''''''''''''''''''''InCheckOnly = True
            '''''''''''''''''''''''''''End If
        End If

        '2.到达极限深度，则返回局面评价
        If pos.nDistance = mConstValue.LIMIT_DEPTH Then Return pos.Evaluate()

        '3.查找置换表，应用剪裁
        vl = mZobristForPosition.ProbeHash(pos.poskey, vlAlpha, vlBeta, nDepth, pos.nDistance, mvHash)
        If vl > -mConstValue.MATE_VALUE Then
            a += 1
            pos.mvResult = mvHash
            Return vl
        End If
        '不尝试空步剪裁，因为空步剪裁适合于走任何一步都使局面更糟的时候，五子棋不会出现该情况。
        '4.初始化最佳值和最佳走法
        vlBest = -mConstValue.MATE_VALUE                    '这样可以知道，是否一个走法都没走过(杀棋)
        mvBest = -1                                         '这样可以知道，是否搜索到了Beta走法或PV走法，以便保存到历史表
        nGenMove = pos.NextGenerateMove(mvs, InCheck, InCheckOnly)       '当nGenMove为-1时，都是无解棋，直接截断。
        '5.逐一走这些走法，并进行递归
        For i As Integer = 0 To nGenMove
            mv = mvs(i)
            pos.SetPlayer(mv, pos.sdPlayer)
            '冲棋延伸
            nNewDepth = IIf(InCheck > 0 AndAlso (InCheck = chk OrElse InCheck > 2 OrElse chk > 2), nDepth, nDepth - 1)
            'PVS
            If vlBest = -mConstValue.MATE_VALUE Then
                vl = -AlphaBeta(-vlBeta, -vlAlpha, nNewDepth, line, InCheck)
            Else
                vl = -AlphaBeta(-vlAlpha - 1, -vlAlpha, nNewDepth, line, InCheck)        '空窗探测
                If vl > vlAlpha AndAlso vl < vlBeta Then                        '<=alpha说明没有更好的棋，>=beta说明发生剪裁。
                    vl = -AlphaBeta(-vlBeta, -vlAlpha, nNewDepth, line, InCheck)
                End If
            End If
            pos.SetPlayer(mvs(i), 2)
            '进行Alpha-Beta大小判断和截断
            If (vl > vlBest) Then                               '找到最佳值(但不能确定是Alpha、PV还是Beta走法)
                vlBest = vl                                     '"vlBest"就是目前要返回的最佳值，可能超出Alpha-Beta边界
                If (vl >= vlBeta) Then                          '找到一个Beta走法
                    nHashFlag = mConstValue.HASHType.HASH_BETA
                    mvBest = mv                                 'Beta走法要保存到历史表
                    Exit For                                    'Beta截断
                End If
                If (vl > vlAlpha) Then                          '找到一个PV走法
                    nHashFlag = mConstValue.HASHType.HASH_PV
                    mvBest = mv                                 'PV走法要保存到置换表
                    vlAlpha = vl                                '缩小Alpha-Beta边界
                    pLine.argmove(0) = mvBest                   '记录最佳走法路径
                    Array.Copy(line.argmove, 0, pLine.argmove, 1, line.cmove + 1)   '加入后续走法
                    pLine.cmove = line.cmove + 1                '更新走法总数
                End If
            End If
        Next
        '6.所有走法都搜索完了，把最佳走法(不能是Alpha走法)保存到历史表，返回最佳值
        If vlBest = -mConstValue.MATE_VALUE Then
            '如果是杀棋，就根据杀棋步数给出评价
            Return pos.nDistance - mConstValue.MATE_VALUE
        End If
        '7.记录最佳招法
        If mvBest <> -1 Then
            '8.记录到置换表
            mZobristForPosition.RecordHash(pos.poskey, nHashFlag, vlBest, nDepth, pos.nDistance, mvBest)
            If pos.nDistance = 1 Then
                'pos.mvResult = mvBest
            End If
        End If
        '9.返回最佳分值
        Return vlBest
    End Function

End Class

Public Class mPVLine
    Public cmove As Integer                                     '路线中着法的数量； 
    Public argmove(mConstValue.LIMIT_DEPTH - 1) As Byte         'PV路线上的着法列表
End Class

Public Class mSearch
    Public pos As mPosition             '评价
    Public pvLine As New mPVLine        '走法路线
    Public stopWatch As New Stopwatch   '计时器
    Public Event EndDepth(depth As Integer, nPos As Integer, bestMove As Integer, bestVal As Integer, lastTime As Integer, pvMine As String)
    Public Event EndAllDepth(lastTime As Integer, depth As Integer, nHashTable As Integer, nPos As Integer, maxDistance As Integer, NPS As Integer, bestVal As Integer)
    Public pvs As mPVSAlphaBeta

    Sub New(position As mPosition)
        pos = position
        pvs = New mPVSAlphaBeta(pos)
    End Sub

    '根节点搜索
    Function SearchRoot(nDepth As Integer)
        Dim line As New mPVLine                 'pvs走法
        Dim nGenMove As Integer                 '子节点数
        Dim vl, vlBest, mvBest As Integer       '评价分值，最佳分值，最佳走法
        Dim InCheck As Integer                  '走一步棋时是否形成冲棋
        Dim mvs(224) As Byte                    '子节点走法缓存
        Dim mv As Integer                       '当前走法
        Dim mvHash As Integer = -1
        pvLine.cmove = -1
        vlBest = -mConstValue.MATE_VALUE                    '这样可以知道，是否一个走法都没走过(杀棋)
        mvBest = -1                                         '这样可以知道，是否搜索到了Beta走法或PV走法，以便保存到历史表
        nGenMove = pos.NextGenerateMove(mvs, InCheck, False)       '当nGenMove为-1时，都是无解棋，直接截断。

        For i As Integer = 0 To nGenMove
            mv = mvs(i)
            pos.SetPlayer(mv, pos.sdPlayer)
            'PVS
            If vlBest = -mConstValue.MATE_VALUE Then
                vl = -pvs.AlphaBeta(-mConstValue.MATE_VALUE, mConstValue.MATE_VALUE, nDepth - 1, line, InCheck)
            Else
                vl = -pvs.AlphaBeta(-vlBest - 1, -vlBest, nDepth - 1, line, InCheck)          '空窗探测
                If vl > vlBest Then                                             '<=alpha说明没有更好的棋，>=beta说明发生剪裁。
                    vl = -pvs.AlphaBeta(-mConstValue.MATE_VALUE, -vlBest, nDepth - 1, line, InCheck)
                End If
            End If
            pos.SetPlayer(mvs(i), 2)
            '进行Alpha-Beta大小判断和截断
            If (vl > vlBest) Then                               '找到最佳值(但不能确定是Alpha、PV还是Beta走法)
                vlBest = vl                                     '"vlBest"就是目前要返回的最佳值，可能超出Alpha-Beta边界
                '找到一个PV走法
                mvBest = mv                                     'PV走法要保存到置换表
                pvLine.argmove(0) = mvBest                      '记录最佳走法路径
                Array.Copy(line.argmove, 0, pvLine.argmove, 1, line.cmove)   '加入后续走法
                pvLine.cmove = line.cmove + 1                   '更新走法总数
            End If
        Next

        '7.记录最佳招法
        If mvBest <> -1 Then
            '8.记录到置换表
            mZobristForPosition.RecordHash(pos.poskey, mConstValue.HASHType.HASH_PV, vlBest, nDepth, pos.nDistance, mvBest)
            pos.mvResult = mvBest
        End If
        '9.返回最佳分值
        Return vlBest
    End Function

    '===============================迭代加深===============================
    '迭代加深搜索过程
    Function SearchMain() As Integer
        Dim bctm As Integer '过去的总时间
        pvs.d = 0
        pvs.e = 0
        Dim i, t, vl As Integer
        '迭代加深过程
        For i = 1 To mConstValue.LIMIT_DEPTH - 1
            pvs.b = 0
            pos.StartUp()
            stopWatch.Restart()
            '最多招法记录
            'vl = AlphaBeta(-mConstValue.MATE_VALUE, mConstValue.MATE_VALUE, i, pvLine)
            vl = SearchRoot(i)
            stopWatch.Stop()
            t = stopWatch.ElapsedMilliseconds  '本次运算所用时间
            '若剩余时间小于上层搜索时间则退出搜索
            bctm += t   '至今所用全部时间
            RaiseEvent EndDepth(i, pvs.b, pos.mvResult, vl, t, PVLine2Str())
            '搜索到杀棋，就终止搜索
            If vl > mConstValue.WIN_VALUE Then  '计算机胜利
                Exit For
            End If
            If vl < -mConstValue.WIN_VALUE Then '玩家胜利
                Exit For
            End If
            If mConstValue.OutTime - bctm < t Then
                Exit For
            End If
        Next

        RaiseEvent EndAllDepth(bctm, i, pvs.a, pvs.d, pvs.c, pvs.d * 1000 \ IIf(bctm = 0, 1, bctm), vl)
        Return pos.mvResult
    End Function

    '==============================================================================
    Function PVLine2Str() As String
        Dim tmp As String = "bestmove "
        Dim i As Integer
        For i = 0 To pvLine.cmove - 1
            If i = 1 Then tmp &= " ponder "
            If i = 2 Then tmp &= " moveline "
            tmp &= mConstValue.PosPoint2Str(pvLine.argmove(i) Mod 15) & (15 - (pvLine.argmove(i) \ 15)) & " " ' & "[" & (pvLine.argmove(i) & "]")
        Next
        Return tmp
    End Function

End Class

分类:  VB