|
|
用动态规划实现规则迷宫最短通路 |
|
|
作者:未知 来源:月光软件站 加入时间:2005-2-28 月光软件站 |
''用动态规划实现规则迷宫最短通路
''希望这段代码给写游戏的朋友有些帮助
''动态规划:不做已经做过的工作(由后向前) ''回 溯:向前走,碰壁回头
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 循环每个位置周围的4个相邻位置 ' 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 循环每个位置周围的4个相邻位置 ' 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
|
|
相关文章:相关软件: |
|