''用动态规划实现规则迷宫最短通路
''希望这段代码给写游戏的朋友有些帮助
''动态规划：不做已经做过的工作（由后向前）
''回溯：向前走，碰壁回头
Option Explicit
Const z = 30
Dim n As Long
Dim a() As Long
Dim sX As Long, sY As Long
Dim eX As Long, eY As Long
Dim atxt() As String
Private Type Pd
xx As Long
yy As Long
End Type
Private Type fourDir
fx As Long
fy As Long
End Type
Dim fDir() As fourDir
Private Sub Command1_Click()
Dim i As Long, j As Long
Dim b() As Long
ReDim a(z + 1, z + 1)
n = CLng(Text1.Text) + 2
NoRepeatRnd b(), 0, z * z - 1, n
grd.Visible = False
grd.Rows = 1
grd.Cols = 1
grd.Rows = z + 1
grd.Cols = z + 1
ReDim atxt(z)
For i = 0 To z
atxt(i) = "^"
Next
grd.FormatString = Join(atxt, "|")
For i = 1 To n - 2
grd.TextMatrix(Int(b(i) / z) + 1, (b(i) Mod z) + 1) = "*"
Next
grd.TextMatrix(Int(b(n - 1) / z) + 1, (b(n - 1) Mod z) + 1) = "入"
grd.TextMatrix(Int(b(n) / z) + 1, (b(n) Mod z) + 1) = "出"
For i = 0 To z
grd.ColWidth(i) = 250
grd.RowHeight(i) = 250
grd.TextMatrix(i, 0) = i
grd.TextMatrix(0, i) = i
Next
For i = 1 To z
For j = 1 To z
If grd.TextMatrix(i, j) = "*" Then
a(i, j) = -1
ElseIf grd.TextMatrix(i, j) = "入" Then
a(i, j) = -2
sX = i: sY = j
ElseIf grd.TextMatrix(i, j) = "出" Then
a(i, j) = 1
eX = i: eY = j
Else
a(i, j) = 0
End If
Next
Next
For i = 0 To z + 1
a(0, i) = -1
a(i, 0) = -1
a(z + 1, i) = -1
a(i, z + 1) = -1
Next
ReDim fDir(3)
fDir(0).fx = -1: fDir(0).fy = 0
fDir(1).fx = 0: fDir(1).fy = -1
fDir(2).fx = 1: fDir(2).fy = 0
fDir(3).fx = 0: fDir(3).fy = 1
grd.Visible = True
End Sub
'*************************************************************************
'**产生无重复的随机数
'*************************************************************************
Public Sub NoRepeatRnd(ByRef ArrayNum() As Long, ByVal MinNum As Long, ByVal MaxNum As Long, ByVal Number As Long)
Dim lngCyl As Long
Dim lngRnd As Long
Dim lngTemp As Long
ReDim ArrayNum(1 To MaxNum - MinNum + 1)
For lngCyl = MinNum To MaxNum
ArrayNum(lngCyl - MinNum + 1) = lngCyl
Next
For lngCyl = 1 To Number
lngRnd = Int(Rnd * (MaxNum - MinNum - lngCyl + 2) + lngCyl)
lngTemp = ArrayNum(lngCyl)
ArrayNum(lngCyl) = ArrayNum(lngRnd)
ArrayNum(lngRnd) = lngTemp
Next
ReDim Preserve ArrayNum(1 To Number)
End Sub
Private Sub Command2_Click()
Dim ch As Boolean
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim m As Long
Dim pOld() As Pd
Dim pNew() As Pd
'*************************************************************************
' 动态规划出迷宫中各个位置的估价值，并得到最短通路的估价值
'
' ch 判断是否有新位置入队
' i 循环队中的位置
' j 循环每个位置周围的４个相邻位置
' k 队中的位置个数
' l 累积新队中位置个数
' m 记录最短路径
' pOld() 队中位置的坐标
' pNew() 新队位置的坐标
'*************************************************************************
k = 1
ReDim pOld(1 To k)
ReDim pNew(1 To z * z)
pOld(k).xx = eX
pOld(k).yy = eY
l = 0
1001:
ch = False
i = 1
While (i <= k)
For j = 0 To 3
If a(pOld(i).xx + fDir(j).fx, pOld(i).yy + fDir(j).fy) = 0 Then
a(pOld(i).xx + fDir(j).fx, pOld(i).yy + fDir(j).fy) = a(pOld(i).xx, pOld(i).yy) + 1
l = l + 1
pNew(l).xx = pOld(i).xx + fDir(j).fx
pNew(l).yy = pOld(i).yy + fDir(j).fy
ch = True
ElseIf a(pOld(i).xx + fDir(j).fx, pOld(i).yy + fDir(j).fy) = -2 Then
m = a(pOld(i).xx, pOld(i).yy) + 1
a(pOld(i).xx + fDir(j).fx, pOld(i).yy + fDir(j).fy) = m
End If
Next
i = i + 1
Wend
1002:
'判断有无新位置，如果有，继续将新位置入队，如果没有则动态规划完成
If ch = True Then
ReDim Preserve pNew(1 To l)
k = l
l = 0
ReDim pOld(1 To k)
pOld = pNew
ReDim pNew(1 To z * z)
GoTo 1001
End If
If m = 0 Then MsgBox "无路径": Exit Sub
'*************************************************************************
' 回溯出具体路径。其实通过动态规划以后，是不会碰壁的，向前走就可以了
'
' i 循环队中的位置
' j 循环每个位置周围的４个相邻位置
' k 当前队中的位置
' m 记录最短路径
' pOld() 队中位置的坐标
'*************************************************************************
ReDim pOld(1 To m)
k = 0
1003:
j = 0
While j > -1 And j < 4
If m - a(sX + fDir(j).fx, sY + fDir(j).fy) = k + 1 Then
If k = m - 2 Then
For i = 1 To m - 2
grd.TextMatrix(pOld(i).xx, pOld(i).yy) = i
Next
Exit Sub
Else
sX = sX + fDir(j).fx
sY = sY + fDir(j).fy
k = k + 1
pOld(k).xx = sX
pOld(k).yy = sY
GoTo 1003
End If
End If
j = j + 1
Wend
End Sub
Private Sub Command3_Click()
End
End Sub
Private Sub Form_Load()
Randomize
Dim i As Long
grd.Rows = z + 1
grd.Cols = z + 1
ReDim atxt(z)
For i = 0 To z
atxt(i) = "^"
Next
grd.FormatString = Join(atxt, "|")
For i = 0 To z
grd.ColWidth(i) = 250
grd.RowHeight(i) = 250
grd.TextMatrix(i, 0) = i
grd.TextMatrix(0, i) = i
Next
End Sub
''参考文献：
''动态规划的深入讨论－－李刚论文
''谈搜索算法的剪枝优化－－许晋炫http://www.156ok.com/article/article_list.asp?account_id=834