程序界面如下:
界面很简单:
一个长宽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 Sub
End Class
一个模块名称为"FG" ,代码如下:
Imports System.Threading
Module 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)”这句执行时有问题。
不能显示动画效果。。。。