一个简单网格游戏，可以寻找到网格最短路径（源代码）

程序界面如下：

界面很简单：

一个长宽360像素的PICTUREBOX，     Name=picturebox1

2个label控件，名称分别为LABEL1、LABEL3，label3显示坐标用，label1用于显示得分

2个button控件，名称分别为BUTTON2、BUTTON3，BUTTON2的TEXT设为“开始”，BUTTON3的TEXT属性设为“显示数组”

 

窗体代码如下：

Public Class Form1    Private idX As Integer    Private idY As Integer    Private canMove As Boolean = False    Private gezi(2) As Integer    Private Sub Form1_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load        drawWangGe(PictureBox1)    End Sub    Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click        resetSUZU()        drawWangGe(PictureBox1)        deFen = 0        get3p(PictureBox1)    End Sub    Private Sub PictureBox1_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseDown        If e.Button = Windows.Forms.MouseButtons.Left Then            If canMove Then                idX = CInt(e.X \ 40)                idY = CInt(e.Y \ 40)                If idX = gezi(0) And idY = gezi(1) Then                    canMove = False                Else                    getPath(gezi(0), gezi(1), idX, idY)                    If CloseList.Items.Count >= 1 Then                        showPath(PictureBox1, gezi(0), gezi(1), idX, idY)                        get3p(PictureBox1)                        HideWG(PictureBox1, idX, idY, 4)                        Label1.Text = "空格数：" + suzukongNum().ToString + vbCrLf + "得分：" + deFen.ToString                    End If                    canMove = False                End If            Else                idX = CInt(e.X \ 40)                idY = CInt(e.Y \ 40)                ' HideWG(PictureBox1, idX, idY, 3)                gezi(0) = idX                gezi(1) = idY                gezi(2) = FGpandc(idX, idY, 1)                If gezi(2) <> 0 Then                    canMove = True                Else                    canMove = False                End If                Dim FGnum As Integer = suzukongNum()                If FGnum = 0 Then                    MsgBox("游戏结束了！")                End If            End If        End If    End Sub    Private Sub PictureBox1_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseMove        Label3.Text = "X=" + CInt(e.X \ 40).ToString + ", Y=" + CInt(e.Y \ 40).ToString    End Sub    Private Sub Button3_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button3.Click        showSuzu()    End Sub    Public Sub showSuzu() '显示数组        Dim str As String = ""        Dim i As Integer, j As Integer        For j = 0 To 8            For i = 0 To 8                str += FGpandc(i, j, 0).ToString & " "            Next            str += vbCrLf        Next        str += vbCrLf        For j = 0 To 8            For i = 0 To 8                str += FGpandc(i, j, 1).ToString & " "            Next            str += vbCrLf        Next        For i = 0 To Openlist.Items.Count - 1            str += Openlist.Items.Item(i).ToString & vbCrLf        Next        str += "////" + vbCrLf        For i = 0 To CloseList.Items.Count - 1            str += CloseList.Items.Item(i).ToString & vbCrLf        Next        MsgBox(str)    End SubEnd Class

一个模块名称为"FG" ,代码如下：

Imports System.ThreadingModule FG    Public deFen As Integer = 0    Public FGbiao(8, 8) As Integer '用于标记的网格数组    Public FGpandc(8, 8, 1) As Integer '网格数组    Public HideID(35, 1) As Integer '存储相同颜色格子的坐标    Const N As Integer = 9 '网格数    Public CloseList As New System.Windows.Forms.ListBox '存放路径    Public Openlist As New System.Windows.Forms.ListBox '存放备用路径    Public HasPath As Boolean = True '用于判断某格子四周是否有空位    Public Sub drawWangGe(ByVal pict As PictureBox)        '画线，清除界面颜色        Dim a As New Bitmap(360, 360)        Dim mye As Graphics = Graphics.FromImage(a)        mye.Clear(Color.WhiteSmoke)        Dim i As Integer        For i = 0 To 360 Step 40            mye.DrawLine(Pens.RoyalBlue, 0, i, 360, i)            mye.DrawLine(Pens.RoyalBlue, i, 0, i, 360)        Next        pict.Image = a        mye.Dispose()    End Sub    Public Sub get3p(ByVal pic As PictureBox) '随机得到3个位置        Dim xID(2) As Integer        Dim yID(2) As Integer        Dim xyColor(2) As Integer        Dim n As Integer = 0        Dim x As Integer, y As Integer        Dim loopnum As Integer = 0        loopnum = suzukongNum()        Dim i As Integer, j As Integer        If loopnum >= 3 Then            Do While n < 3                Randomize()                x = Int(Rnd() * 9)                Randomize()                y = Int(Rnd() * 9)                If FGpandc(x, y, 0) = 1 Then                Else                    xID(n) = x                    yID(n) = y                    xyColor(n) = Int(Rnd() * 5 + 1)                    FGpandc(x, y, 0) = 1                    FGpandc(x, y, 1) = xyColor(n)                    HideWG(pic, x, y, 4)                    n += 1                End If            Loop        Else            For i = 0 To 8                For j = 0 To 8                    If FGpandc(i, j, 0) = 0 Then                        FGpandc(i, j, 0) = 1                        FGpandc(i, j, 1) = Int(Rnd() * 5 + 1)                    End If                Next            Next        End If        For i = 0 To 8            For j = 0 To 8                FillGe(pic, i, j, getcolor(i, j))            Next        Next    End Sub    Public Function suzukongNum() As Integer        '判断整个数组还有几个空位        Dim i As Integer        Dim j As Integer        Dim num As Integer = 0        For i = 0 To 8            For j = 0 To 8                If FGpandc(i, j, 0) = 1 Then                    num += 1                End If            Next        Next        Return 81 - num    End Function    '根据数组下标对网格填充    Public Sub FillGe(ByVal pict As PictureBox, ByVal x As Integer, ByVal y As Integer, ByVal c As Color)        Dim a As Bitmap = pict.Image        Dim mye As Graphics = Graphics.FromImage(a)        mye.FillRectangle(New SolidBrush(c), New Rectangle(x * 40, y * 40, 40, 40))        Dim i As Integer        For i = 0 To 360 Step 40            mye.DrawLine(Pens.RoyalBlue, 0, i, 360, i)            mye.DrawLine(Pens.RoyalBlue, i, 0, i, 360)        Next        pict.Image = a        mye.Dispose()    End Sub    '得到颜色    Public Function getcolor(ByVal x As Integer, ByVal y As Integer) As Color        Select Case FGpandc(x, y, 1)            Case 1                Return Color.Red            Case 2                Return Color.Blue            Case 3                Return Color.Green            Case 4                Return Color.Yellow            Case 5                Return Color.Pink            Case Else                Return Color.WhiteSmoke        End Select    End Function    Public Sub resetSUZU()        '重置数组，全部为零        Dim i As Integer        Dim j As Integer        For i = 0 To N - 1            For j = 0 To N - 1                FGpandc(i, j, 0) = 0                FGpandc(i, j, 1) = 0            Next        Next    End Sub#Region "消格子"    Private Sub hideWGH(ByVal x As Integer, ByVal y As Integer, ByRef a(,) As Integer)        ReDim a(8, 1)        ReSetSZ(a)        Dim idx As Integer = x, xNum As Integer = 0        Do While idx < 8            idx += 1            If FGpandc(idx, y, 1) = FGpandc(x, y, 1) Then                xNum += 1                a(xNum - 1, 0) = idx                a(xNum - 1, 1) = y            Else                idx = 8            End If        Loop        idx = x        Do While idx > 0            idx -= 1            If FGpandc(idx, y, 1) = FGpandc(x, y, 1) Then                xNum += 1                a(xNum - 1, 0) = idx                a(xNum - 1, 1) = y            Else                idx = 0            End If        Loop    End Sub    Private Sub hideWGS(ByVal x As Integer, ByVal y As Integer, ByRef a(,) As Integer)        ReDim a(8, 1)        ReSetSZ(a)        Dim idy As Integer = y, yNum As Integer = 0        Do While idy < 8            idy += 1            If FGpandc(x, idy, 1) = FGpandc(x, y, 1) Then                yNum += 1                a(yNum - 1, 0) = x                a(yNum - 1, 1) = idy            Else                idy = 8            End If        Loop        idy = y        Do While idy > 0            idy -= 1            If FGpandc(x, idy, 1) = FGpandc(x, y, 1) Then                yNum += 1                a(yNum - 1, 0) = x                a(yNum - 1, 1) = idy            Else                idy = 0            End If        Loop    End Sub    Private Sub ReSetSZ(ByRef D(,) As Integer)        ReDim D(8, 1)        Dim i As Integer        For i = 0 To 8            D(i, 0) = -1            D(i, 1) = -1        Next    End Sub    Private Sub ReSetSZ11()        Dim I As Integer        For I = 0 To 35            HideID(I, 0) = -2            HideID(I, 1) = -2        Next    End Sub    Private Sub hideWGXZ(ByVal x As Integer, ByVal y As Integer, ByRef a(,) As Integer)        ReDim a(8, 1)        ReSetSZ(a)        Dim idX As Integer = x, Num As Integer = 0, idY As Integer = y        Do While idY > 0 And idX > 0            idY -= 1            idX -= 1            If FGpandc(idX, idY, 1) = FGpandc(x, y, 1) Then                Num += 1                a(Num - 1, 0) = idX                a(Num - 1, 1) = idY            Else                idY = 0            End If        Loop        idX = x : idY = y        Do While idX < 8 And idY < 8            idX += 1            idY += 1            If FGpandc(idX, idY, 1) = FGpandc(x, y, 1) Then                Num += 1                a(Num - 1, 0) = idX                a(Num - 1, 1) = idY            Else                idX = 8            End If        Loop    End Sub    Private Sub hideWGXY(ByVal x As Integer, ByVal y As Integer, ByRef a(,) As Integer)        ReDim a(8, 1)        ReSetSZ(a)        Dim idX As Integer = x, Num As Integer = 0, idY As Integer = y        Do While idY > 0 And idX < 8            idY -= 1            idX += 1            If FGpandc(idX, idY, 1) = FGpandc(x, y, 1) Then                Num += 1                a(Num - 1, 0) = idX                a(Num - 1, 1) = idY            Else                idY = 0            End If        Loop        idX = x : idY = y        Do While idY < 8 And idX > 0            idX -= 1            idY += 1            If FGpandc(idX, idY, 1) = FGpandc(x, y, 1) Then                Num += 1                a(Num - 1, 0) = idX                a(Num - 1, 1) = idY            Else                idY = 8            End If        Loop    End Sub    Public Sub HideWG(ByVal pic As PictureBox, ByVal x As Integer, ByVal y As Integer, ByVal nnn As Integer)        Dim aaH(8, 1) As Integer, aaS(8, 1) As Integer, aaXY(8, 1) As Integer, aaXZ(8, 1) As Integer        Dim i As Integer        hideWGH(x, y, aaH)        hideWGS(x, y, aaS)        hideWGXZ(x, y, aaXY)        hideWGXY(x, y, aaXZ)        ReSetSZ11()        Dim NUM As Integer        NUM = 0        For i = 0 To 8            If getnumSZ(aaH) >= nnn - 1 Then                If aaH(i, 0) <> -1 Then                    NUM += 1                    HideID(NUM - 1, 0) = aaH(i, 0)                    HideID(NUM - 1, 1) = aaH(i, 1)                End If            End If            If getnumSZ(aaS) >= nnn - 1 Then                If aaS(i, 0) <> -1 Then                    NUM += 1                    HideID(NUM - 1, 0) = aaS(i, 0)                    HideID(NUM - 1, 1) = aaS(i, 1)                End If            End If            If getnumSZ(aaXY) >= nnn - 1 Then                If aaXY(i, 0) <> -1 Then                    NUM += 1                    HideID(NUM - 1, 0) = aaXY(i, 0)                    HideID(NUM - 1, 1) = aaXY(i, 1)                End If            End If            If getnumSZ(aaXZ) >= nnn - 1 Then                If aaXZ(i, 0) <> -1 Then                    NUM += 1                    HideID(NUM - 1, 0) = aaXZ(i, 0)                    HideID(NUM - 1, 1) = aaXZ(i, 1)                End If            End If        Next        For i = 0 To 35            If HideID(i, 0) <> -2 Then                FillGe(pic, HideID(i, 0), HideID(i, 1), Color.WhiteSmoke)                FGpandc(HideID(i, 0), HideID(i, 1), 0) = 0                FGpandc(HideID(i, 0), HideID(i, 1), 1) = 0            End If        Next        If NUM >= nnn - 1 Then            FillGe(pic, x, y, Color.WhiteSmoke)            FGpandc(x, y, 0) = 0            FGpandc(x, y, 1) = 0            ' MsgBox(NUM)            Select Case NUM                Case 3                    deFen += 10                Case 4                    deFen += 15                Case 5                    deFen += 20                Case 6                    deFen += 25                Case 7                    deFen += 30                Case 8                    deFen += 35                Case 9                    deFen += 40            End Select        End If           End Sub    Private Function getnumSZ(ByVal a(,) As Integer) As Integer        Dim i As Integer, NUM As Integer = 0        For i = 0 To 8            If a(i, 0) <> -1 Then                NUM += 1            End If        Next        Return NUM    End Function#End Region#Region "查找路径"    Public Sub getPath(ByVal x0 As Integer, ByVal y0 As Integer, ByVal x1 As Integer, ByVal y1 As Integer)        '得到最短路径        Dim endTag As Boolean = False        Openlist.Items.Clear() 'close表清零        CloseList.Items.Clear() 'open表清零        resBiaoji()        getOpenlist(x0, y0)        CloseList.Items.Add(x0.ToString + "," + y0.ToString)        Do Until Openlist.Items.Count < 1 Or endTag            setCloseList(x1, y1)            Dim i As Integer            For i = 0 To CloseList.Items.Count - 1                Dim xx As Integer = CInt(CloseList.Items.Item(i).ToString.Substring(0, 1))                Dim yy As Integer = CInt(CloseList.Items.Item(i).ToString.Substring(2, 1))                'MsgBox(xx.ToString + "," + yy.ToString)                If xx = x1 And yy = y1 Then                    endTag = True                Else                End If            Next            If endTag Then            Else                Dim xx1 As Integer = CInt(CloseList.Items.Item(CloseList.Items.Count - 1).ToString.Substring(0, 1))                Dim yy1 As Integer = CInt(CloseList.Items.Item(CloseList.Items.Count - 1).ToString.Substring(2, 1))                getOpenlist(xx1, yy1)            End If        Loop        If endTag Then            Dim i As Integer, strr As String = ""            If CloseList.Items.Count >= 1 Then                For i = 0 To CloseList.Items.Count - 1                    strr += CloseList.Items.Item(i) + "|"                Next                ' MsgBox(strr)            Else                MsgBox("no data")            End If        Else            MsgBox("no path")            CloseList.Items.Clear()        End If    End Sub    Public Sub showPath(ByVal pict As PictureBox, ByVal X As Integer, ByVal Y As Integer, ByVal X1 As Integer, ByVal Y1 As Integer)        '显示路径        Dim i As Integer        If CloseList.Items.Count >= 1 Then            Dim s1 As String = CloseList.Items.Item(CloseList.Items.Count - 1)            Dim xx0 As Integer = Val(s1.Substring(0, 1))            Dim yy0 As Integer = Val(s1.Substring(2, 1))            Dim forNum As Integer            If xx0 = X1 And yy0 = Y1 Then                forNum = CloseList.Items.Count - 1            Else                forNum = CloseList.Items.Count - 2            End If            For i = 0 To forNum                Dim s As String = CloseList.Items.Item(i)                Dim xx As Integer = Val(s.Substring(0, 1))                Dim yy As Integer = Val(s.Substring(2, 1))                'FillGe(pict, xx, yy, getcolor(X, Y))                FillGe(pict, xx, yy, Color.Bisque)                'Thread.Sleep(500)                FillGe(pict, xx, yy, Color.WhiteSmoke)            Next            FillGe(pict, X1, Y1, getcolor(X, Y))            FGpandc(X1, Y1, 0) = 1            FGpandc(X1, Y1, 1) = FGpandc(X, Y, 1)            FillGe(pict, X, Y, Color.WhiteSmoke)            FGpandc(X, Y, 0) = 0            FGpandc(X, Y, 1) = 0        Else            MsgBox("no path")        End If    End Sub    Private Function getJuli(ByVal x As Integer, ByVal y As Integer, ByVal x0 As Integer, ByVal y0 As Integer) As Double        '得到两点的距离        Return ((x - x0) ^ 2 + (y - y0) ^ 2) ^ 0.5    End Function    Private Sub getOpenlist(ByVal x As Integer, ByVal y As Integer)        '得到点x，y 周围4个点,并将之加入OPEN表        If x - 1 >= 0 Then            If FGbiao(x - 1, y) <> 1 Then                If inList(x - 1, y, Openlist) Then                Else                    If inList(x - 1, y, CloseList) Then                    Else                        Openlist.Items.Add((x - 1).ToString + "," + y.ToString)                    End If                End If            End If        End If        If x + 1 <= 8 Then            If FGbiao(x + 1, y) <> 1 Then                If inList(x + 1, y, Openlist) Then                Else                    If inList(x + 1, y, CloseList) Then                    Else                        Openlist.Items.Add((x + 1).ToString + "," + y.ToString)                    End If                End If            End If        End If        If y - 1 >= 0 Then            If FGbiao(x, y - 1) <> 1 Then                If inList(x, y - 1, Openlist) Then                Else                    If inList(x, y - 1, CloseList) Then                    Else                        Openlist.Items.Add(x.ToString + "," + (y - 1).ToString)                    End If                End If            End If        End If        If y + 1 <= 8 Then            If FGbiao(x, y + 1) <> 1 Then                If inList(x, y + 1, Openlist) Then                Else                    If inList(x, y + 1, CloseList) Then                    Else                        Openlist.Items.Add(x.ToString + "," + (y + 1).ToString)                    End If                End If            End If        End If    End Sub    Private Sub setCloseList(ByVal x1 As Integer, ByVal y1 As Integer)        '从开放列表中查找一最小的值，放入到CLOSE列表中        Dim i As Integer, s As String = ""        Dim xx As Integer, yy As Integer        Dim b As Double        If Openlist.Items.Count >= 1 Then            Dim xx2 As Integer = Val((Openlist.Items.Item(0)).ToString.Substring(0, 1))            Dim yy2 As Integer = Val((Openlist.Items.Item(0)).ToString.Substring(2, 1))            b = getJuli(xx2, yy2, x1, y1)            For i = 0 To Openlist.Items.Count - 1                s = Openlist.Items.Item(i).ToString                xx = Val(s.Substring(0, 1))                yy = Val(s.Substring(2, 1))                If getJuli(xx, yy, x1, y1) <= b Then                    b = getJuli(xx, yy, x1, y1)                Else                End If            Next            For i = 0 To Openlist.Items.Count - 1                s = Openlist.Items.Item(i).ToString                xx = Val(s.Substring(0, 1))                yy = Val(s.Substring(2, 1))                If getJuli(xx, yy, x1, y1) = b Then                    CloseList.Items.Add(s)                    Openlist.Items.Remove(s)                    FGbiao(xx, yy) = 1                    Exit For                End If            Next        End If    End Sub    Private Function inList(ByVal xx As Integer, ByVal yy As Integer, ByVal aList As ListBox) As Boolean        '判断某点（x,y）是否在某列表中        Dim i As Integer        Dim s As String = xx.ToString + "," + yy.ToString        Dim a As Boolean = False        For i = 0 To aList.Items.Count - 1            If s = aList.Items.Item(i) Then                a = True            End If        Next        Return a    End Function    Private Sub resBiaoji() '建立网格数组的拷贝        Dim i As Integer, j As Integer        For i = 0 To 8            For j = 0 To 8                FGbiao(i, j) = FGpandc(i, j, 0)            Next        Next    End Sub#End Region   End Module

模块FG中的SHOWPATH()显示路径中的 “Thread.Sleep(500)”这句执行时有问题。

不能显示动画效果。。。。