实例介绍
【实例简介】A*（A-Star)算法是一种静态路网中求解最短路径最有效的直接搜索方法，也是解决许多搜索问题的有效算法。算法中的距离估算值与实际值越接近，最终搜索速度越快。
【实例截图】
【核心代码】
Option Explicit
Private Const 障碍 As Integer = 1
Private Const 通道 As Integer = 0
Public Type POINTS
x As Integer
y As Integer
End Type
Private Type AStarNode
pos As POINTS '该节点的坐标
father As POINTS
G As Integer
H As Integer
style As Integer '类型，是否可行走
End Type
Public OpenNum As Integer '开启列表中的总结点数-1
Public CloseNum As Integer '关闭列表中的总结点数-1
Public OpenList() As AStarNode '开启表
Public CloseList() As AStarNode '关闭表
Public AStarMap() As AStarNode '地图
'计算出来的地图尺寸
Private minX As Integer
Private minY As Integer
Private maxX As Integer
Private maxY As Integer
'参数：要寻路的二维地图,寻路起点,寻路终点
'返回值：1找到路径，路径存在AStarPath中 0未找到路径
Public AStarPath() As POINTS '路径
Public PathLength As Integer '路径长度
Public Function AStar(map() As Integer, startP As POINTS, endP As POINTS) As Integer
Dim AstartP As AStarNode '起点
Dim AendP As AStarNode '终点
Dim p As POINTS '指针
Dim ArrLength As Long '数组长度
Dim minFP As AStarNode '最小F值的节点
Dim i As Integer '找最小F值for循环的循环变量
'只算一次，降低时间开销
minX = LBound(map, 1)
maxX = UBound(map, 1)
minY = LBound(map, 2)
maxY = UBound(map, 2)
ArrLength = (UBound(map, 1) - LBound(map, 1) 1) * (UBound(map, 2) - LBound(map, 2) 1) - 1
ReDim OpenList(ArrLength) '确定最大范围
ReDim CloseList(ArrLength)
ReDim AStarPath(ArrLength)
'初始化
OpenNum = -1: CloseNum = -1
PathLength = 0
AstartP.pos = startP '将传进来的坐标转换成AStar的节点类型
AendP.pos = endP
CreateAStarMap map, AstartP, AendP '根据游戏地图创建本次寻路的A星地图
AddOpenList AStarMap(AstartP.pos.x, AstartP.pos.y) '将起点加入开启表
Do
If OpenNum = -1 Then AStar = 0: Exit Do '当开启列表为空时，退出循环（没有找到路径）
'把开启列表中G H值最小的点找出来（有多个相同最小值的话，找出靠前的那个）
minFP = OpenList(0)
For i = 0 To OpenNum
If minFP.G minFP.H > OpenList(i).G OpenList(i).H Then '找数组中最小数
minFP = OpenList(i)
End If
Next i
'把这个点从开启列表中删除，加入到关闭列表
DelOpenList minFP
AddCloseList minFP
'搜索该点的邻居
Call Neighbor_Search(minFP, 0, -1) '上
Call Neighbor_Search(minFP, 0, 1) '下
Call Neighbor_Search(minFP, -1, 0) '左
Call Neighbor_Search(minFP, 1, 0) '右
'这里是八方寻路，用不上可以直接注释掉
Call Neighbor_Search(minFP, -1, -1) '上左
Call Neighbor_Search(minFP, 1, -1) '上右
Call Neighbor_Search(minFP, -1, 1) '下左
Call Neighbor_Search(minFP, 1, 1) '下右
If CheckCloseNode(AendP) = True Then '如果终点在关闭列表中，就说明找到了通路，用回溯的方法记录路径
AStar = 1
'寻找回路
p = AendP.pos
Do
AStarPath(PathLength) = p
PathLength = PathLength 1
p = AStarMap(p.x, p.y).father '指针移动
If p.x = startP.x And p.y = startP.y Then Exit Do
Loop
Exit Function
End If
Loop
AStar = 0
'Debug.Print AStarMap(0, 0).H: Debug.Print AStarMap(1, 1).H
End Function
'根据游戏地图创建AStar的寻路地图
Private Sub CreateAStarMap(map() As Integer, startP As AStarNode, endP As AStarNode)
Dim x As Integer
Dim y As Integer
ReDim AStarMap(maxX - minX, maxY - minY) '根据游戏地图确定寻路地图尺寸
'生成寻路地图
For x = minX To maxX
For y = minY To maxY
If map(x, y) = 1 Then
AStarMap(x, y).style = 障碍
AStarMap(x, y).G = 0 '初始化成0，到需要的时候再重新计算
AStarMap(x, y).H = (Abs(x - endP.pos.x) Abs(y - endP.pos.y)) * 10 '对于相同的起点和终点，H为定值，我们需要在这里一次性计算好(曼哈顿距离)
AStarMap(x, y).pos.x = x
AStarMap(x, y).pos.y = y
ElseIf map(x, y) = 0 Then
AStarMap(x, y).style = 通道
AStarMap(x, y).G = 0
AStarMap(x, y).H = (Abs(x - endP.pos.x) Abs(y - endP.pos.y)) * 10
AStarMap(x, y).pos.x = x
AStarMap(x, y).pos.y = y
End If
Next y
Next x
End Sub
'参数：需要添加进来的节点（添加在线性表的尾部）
Private Function AddOpenList(pos As AStarNode) As Integer
OpenNum = OpenNum 1 '总节点数 1
OpenList(OpenNum) = pos '添加节点
End Function
'参数：需要删除的节点（删除后，将线性表尾部节点补充到删除后的空缺位置，为了减小时间复杂度）
Private Function DelOpenList(pos As AStarNode) As Integer
Dim t As AStarNode '临时节点，用于做变量交换
Dim c As AStarNode '临时节点，用于清空对象
Dim i As Integer
For i = 0 To OpenNum
If OpenList(i).pos.x = pos.pos.x And OpenList(i).pos.y = pos.pos.y Then '找到要删除的节点（目标节点）
t = OpenList(OpenNum) 't指向开启表中最后一个节点
OpenList(OpenNum) = c '删除最后一个节点
OpenList(i) = t '把最后一个节点覆盖到目标节点
OpenNum = OpenNum - 1 '开启表长度-1
Exit For '结束不必要的循环
End If
Next i
End Function
'参数：需要添加进来的节点（添加在线性表的尾部）
Private Function AddCloseList(pos As AStarNode) As Integer
CloseNum = CloseNum 1 '总节点数 1
CloseList(CloseNum) = pos '添加节点
End Function
'确认传入节点是否存在于开启表中
Private Function CheckNode(node As AStarNode) As Boolean
Dim i As Integer
For i = 0 To OpenNum
If OpenList(i).pos.x = node.pos.x And OpenList(i).pos.y = node.pos.y Then '找到了
CheckNode = True
Exit Function
End If
Next i
CheckNode = False
End Function
'确认是否在关闭表里
Private Function CheckCloseNode(node As AStarNode) As Boolean
Dim i As Long
For i = 0 To CloseNum
If CloseList(i).pos.x = node.pos.x And CloseList(i).pos.y = node.pos.y Then '找到了
CheckCloseNode = True
Exit Function
End If
Next i
CheckCloseNode = False
End Function
'功能：
'更新开启表中的G值
Private Sub UpdataG()
Dim i As Integer
For i = 0 To OpenNum
If OpenList(i).G <> AStarMap(OpenList(i).pos.x, OpenList(i).pos.y).G Then
OpenList(i).G = AStarMap(OpenList(i).pos.x, OpenList(i).pos.y).G
End If
Next i
End Sub
Private Sub Neighbor_Search(minFP As AStarNode, offsetX As Integer, offsetY As Integer)
Dim AStep As Integer
'越界检测
If minFP.pos.x offsetX > maxX Or minFP.pos.x offsetX < 0 Or minFP.pos.y offsetY > maxY Or minFP.pos.y offsetY < 0 Then Exit Sub
If offsetX = 0 Or offsetY = 0 Then ' 设置单位花费
AStep = 10
Else
AStep = 14
End If
'如果该邻居不是障碍并且不在关闭表中
If AStarMap(minFP.pos.x offsetX, minFP.pos.y offsetY).style <> 障碍 And CheckCloseNode(AStarMap(minFP.pos.x offsetX, minFP.pos.y offsetY)) = False Then
'AStarMap(minFP.pos.x offsetX, minFP.pos.y offsetY).G = minFP.G AStep '给G赋值
If CheckNode(AStarMap(minFP.pos.x offsetX, minFP.pos.y offsetY)) = True Then '存在于开启表中
If minFP.G AStep < AStarMap(minFP.pos.x offsetX, minFP.pos.y offsetY).G Then '如果走新路径更短就更换父节点
AStarMap(minFP.pos.x offsetX, minFP.pos.y offsetY).G = minFP.G AStep
AStarMap(minFP.pos.x offsetX, minFP.pos.y offsetY).father = minFP.pos
Call UpdataG '更新Openlist中的G值
End If
Else '不存在于开启表中
'设置该邻居的父节点为我们上面找到的最小节点（minFP）
AStarMap(minFP.pos.x offsetX, minFP.pos.y offsetY).father = minFP.pos
'计算该点（邻居）的G值
AStarMap(minFP.pos.x offsetX, minFP.pos.y offsetY).G = minFP.G AStep
'把该点加入开启表中
AddOpenList AStarMap(minFP.pos.x offsetX, minFP.pos.y offsetY)
End If
End If
End Sub
好例子网口号：伸出你的我的手 — 分享！
小贴士
感谢您为本站写下的评论，您的评论对其它用户来说具有重要的参考价值，所以请认真填写。
- 类似“顶”、“沙发”之类没有营养的文字，对勤劳贡献的楼主来说是令人沮丧的反馈信息。
- 相信您也不想看到一排文字/表情墙，所以请不要反馈意义不大的重复字符，也请尽量不要纯表情的回复。
- 提问之前请再仔细看一遍楼主的说明，或许是您遗漏了。
- 请勿到处挖坑绊人、招贴广告。既占空间让人厌烦，又没人会搭理，于人于己都无利。
关于好例子网
本站旨在为广大IT学习爱好者提供一个非营利性互相学习交流分享平台。本站所有资源都可以被免费获取学习研究。本站资源来自网友分享，对搜索内容的合法性不具有预见性、识别性、控制性，仅供学习研究，请务必在下载后24小时内给予删除，不得用于其他任何用途，否则后果自负。基于互联网的特殊性，平台无法对用户传输的作品、信息、内容的权属或合法性、安全性、合规性、真实性、科学性、完整权、有效性等进行实质审查；无论平台是否已进行审查，用户均应自行承担因其传输的作品、信息、内容而可能或已经产生的侵权或权属纠纷等法律责任。本站所有资源不代表本站的观点或立场，基于网友分享，根据中国法律《信息网络传播权保护条例》第二十二与二十三条之规定，若资源存在侵权或相关问题请联系本站客服人员，点此联系我们。关于更多版权及免责申明参见 版权及免责申明
网友评论
我要评论