A-Star 寻路算法演示(PureBasic)
;A-Star panth find
;2003.2.5 from vb6
EnableExplicit
#wd=15 ;width
#Xc=20
#Yc=20
#obstruct = 0
#channel = 1
Structure AStarNode
pos.Point ;该节点的坐标
father.Point
G.i
H.i
style.i ;类型，是否可行走
EndStructure
Declare.i AStar()
Declare AddOpenList(*pos.AStarNode)
Declare DelOpenList(*pos.AStarNode)
Declare AddCloseList(*pos.AStarNode)
Declare Neighbor_Search(*minFP.AStarNode,offsetX.i, offsetY.i)
Declare.i CheckCloseNode(*node.AStarNode)
Declare.i CheckNode(*node.AStarNode)
Declare CreateAStarMap(Array maps.i(2),*startP.AStarNode, *endP.AStarNode)
Declare OnLeftClick()
Declare OnBtLeftClick()
Declare OnBtCPLeftClick()
Declare OnBtCMLeftClick()
Declare OnChkBLeftClick()
Declare ISstartOrEndPoint(px.i,py.i)
Declare DrawMap()
Global OpenNum.i ;开启列表中的总结点数-1
Global CloseNum.i ;关闭列表中的总结点数-1
Define ArrLength.l ;数组长度
Global minX.i,minY.i,maxX.i,maxY.i
;计算出来的地图尺寸
minX=0
minY=0
maxX=#Xc
maxY=#Yc
Global Dim MColor(4),PenColor,Choise.i,starts.i=0,ends.i=0
MColor(1)=$00A000 ;green
MColor(2)=$F00000 ;blue
MColor(3)=$0000F0 ;red
MColor(4)=$00CCFF ;yellow
PenColor=MColor(1)
Choise=1
ArrLength = (maxX - minX) * (maxY - minY) - 1
Global Dim OpenList.AStarNode(ArrLength) ;开启表
Global Dim CloseList.AStarNode(ArrLength) ;关闭表
Global Dim AStarMap.AStarNode(maxX,maxY) ;地图
Global Dim maps.i(maxX,maxY), HavePath.i=#False
Global AstartP.AStarNode ;起点
Global AendP.AStarNode ;终点
;参数：要寻路的二维地图,寻路起点,寻路终点
;返回值：1找到路径，路径存在AStarPath中 0未找到路径
Global Dim AStarPath.Point(ArrLength) ;路径
Global PathLength.i ;路径长度
Global Slant.i ;斜向 0 false ,1 true
Define k.i,Event
Define X.i,Y.i,XN.i,YN.i,oldSX,oldSY,oldEX,oldEY
If OpenWindow(0, 100, 100, 460, 400, "PureBasic - A-Star Path", #PB_Window_SystemMenu|#PB_Window_ScreenCentered)
FrameGadget(11, 335, 15,95, 150, "选项")
OptionGadget(12, 350, 40, 40, 20, "平地")
OptionGadget(13, 350, 65, 40, 20, "障碍")
OptionGadget(14, 350, 90, 40, 20, "开始")
OptionGadget(15, 350, 115,40, 20, "结束")
CheckBoxGadget(16,350,140,40,20,"斜线")
SetGadgetState(12, 1) ; set second option as active one
BindGadgetEvent(12, @OnLeftClick(),#PB_EventType_LeftClick) ; Bind left click
BindGadgetEvent(13, @OnLeftClick(),#PB_EventType_LeftClick) ; Bind left click
BindGadgetEvent(14, @OnLeftClick(),#PB_EventType_LeftClick) ; Bind left click
BindGadgetEvent(15, @OnLeftClick(),#PB_EventType_LeftClick) ; Bind left click
ButtonGadget(17,340,185,80,30,"Find Path")
ButtonGadget(18,340,235,80,30,"Clear Path")
ButtonGadget(19,340,285,80,30,"Clear Map")
BindGadgetEvent(17, @OnBtLeftClick(),#PB_EventType_LeftClick) ; Bind left click
BindGadgetEvent(18, @OnBtCPLeftClick(),#PB_EventType_LeftClick)
BindGadgetEvent(19, @OnBtCMLeftClick(),#PB_EventType_LeftClick)
CanvasGadget(1,400,40,15,115)
If StartDrawing(CanvasOutput(1))
Box(0,0,75,115,$EEEEEE);RGB(196,196,196))
Box(0, 0,15,15,MColor(1))
Box(0,25,15,15,MColor(2))
Box(0,50,15,15,MColor(3))
Box(0,75,15,15,MColor(4))
LineXY(0,105,15,115,$000000)
StopDrawing()
EndIf
CanvasGadget(0, 10, 10, 301, 301)
OnBtCMLeftClick()
Repeat
Event = WaitWindowEvent()
If Event = #PB_Event_Gadget And EventGadget() = 0
If EventType() = #PB_EventType_LeftButtonDown Or (EventType() = #PB_EventType_MouseMove And GetGadgetAttribute(0, #PB_Canvas_Buttons) & #PB_Canvas_LeftButton)
x = GetGadgetAttribute(0, #PB_Canvas_MouseX)
y = GetGadgetAttribute(0, #PB_Canvas_MouseY)
If (x<300 And x>0) And (y<300 And y>0)
If StartDrawing(CanvasOutput(0))
XN=Int(x/#wd)
YN=Int(y/#wd)
Select Choise
Case 1 ;#Tongdao
ISstartOrEndPoint(XN,YN)
maps(XN,YN)=#channel
Case 2 ;#zhangai
ISstartOrEndPoint(XN,YN)
maps(XN,YN)=#obstruct
Case 3
ISstartOrEndPoint(XN,YN)
maps(XN,YN)=2
Box(oldSX*#wd+1,oldSY*#wd+1,13,13,MColor(1))
maps(oldSX,oldSY)=#channel
oldSX=XN
oldSY=YN
starts=1
AstartP\pos\x=XN
AstartP\pos\y=YN
Case 4
ISstartOrEndPoint(XN,YN)
maps(XN,YN)=3
Box(oldEX*#wd+1,oldEY*#wd+1,13,13,MColor(1))
maps(oldEX,oldEY)=#channel
oldEX=XN
oldEY=YN
ends=1
AendP\pos\x=XN
AendP\pos\y=YN
EndSelect
Box(Int(x/#wd)*#wd+1,Int(y/#wd)*#wd+1,13,13,PenColor)
StopDrawing()
EndIf
EndIf
EndIf
EndIf
Until Event = #PB_Event_CloseWindow ; If the user has pressed on the close button
EndIf
End
Procedure.i AStar()
Protected p.Point ;指针
Protected minFP.AStarNode ;最小F值的节点
Protected i.i ;找最小F值For循环的循环变量
Protected Result=0
;初始化
OpenNum = -1: CloseNum = -1
PathLength = 0
Protected t.i=1
CreateAStarMap(maps(),@AstartP,@AendP) ;根据游戏地图创建本次寻路的A星地图
AddOpenList(@AstartP) ;将起点加入开启表
Repeat
If OpenNum = -1
Result = 0
Break ;当开启列表为空时，退出循环（没有找到路径）
EndIf
;把开启列表中G H值最小的点找出来（有多个相同最小值的话，找出靠前的那个）
minFP = OpenList(0)
For i = 0 To OpenNum
If minFP\G + minFP\H > OpenList(i)\G + OpenList(i)\H ;找数组中最小数
minFP = OpenList(i)
EndIf
Next i
;把这个点从开启列表中删除，加入到关闭列表
DelOpenList(@minFP)
AddCloseList(@minFP)
;搜索该点的邻居
Neighbor_Search(@minFP,0,-1) ;上
Neighbor_Search(@minFP, 0, 1) ;下
Neighbor_Search(@minFP,-1, 0) ;左
Neighbor_Search(@minFP, 1, 0) ;右
;这里是八方寻路，用不上可以直接注释掉
If Slant = 1
Neighbor_Search(@minFP, -1, -1) ;上左
Neighbor_Search(@minFP, 1, -1) ;上右
Neighbor_Search(@minFP, -1, 1) ;下左
Neighbor_Search(@minFP, 1, 1) ;下右
EndIf
If CheckCloseNode(@AendP) = #True ;如果终点在关闭列表中，就说明找到了通路，用回溯的方法记录路径
Result = 1
;寻找回路
p = AendP\pos
Repeat
AStarPath(PathLength) = p
PathLength = PathLength + 1
p = AStarMap(p\x,p\y)\father ;指针移动
If p\X = AstartP\pos\x And p\Y = AstartP\pos\y
Break
EndIf
Until t=0
Break
EndIf
Until OpenNum=-1
ProcedureReturn Result
;Debug.Print AStarMap(0, 0).H: Debug.Print AStarMap(1, 1).H
EndProcedure
;根据游戏地图创建AStar的寻路地图
Procedure CreateAStarMap(Array maps.i(2),*startP.AStarNode, *endP.AStarNode)
Protected x.i, y.i
;ReDim AStarMap(maxX - minX, maxY - minY) '根据游戏地图确定寻路地图尺寸
;生成寻路地图
For X = minX To maxX
For Y = minY To maxY
If Maps(X, Y) = 0
AStarMap(X, Y)\style = #obstruct
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 Maps(X, Y) >= 1
AStarMap(X, Y)\style = #channel
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
EndIf
Next Y
Next X
EndProcedure
;参数：需要添加进来的节点（添加在线性表的尾部）
Procedure AddOpenList(*pos.AStarNode)
;Debug OpenNum
OpenNum = OpenNum + 1 ;总节点数 1
;OpenList(OpenNum)=*pos;添加节点
OpenList(OpenNum)\father=*pos\father
OpenList(OpenNum)\G=*pos\G
OpenList(OpenNum)\H=*pos\H
OpenList(OpenNum)\pos=*pos\pos
OpenList(OpenNum)\style=*pos\style
EndProcedure
;参数：需要删除的节点（删除后，将线性表尾部节点补充到删除后的空缺位置，为了减小时间复杂度）
Procedure DelOpenList(*pos.AStarNode)
Protected t.AStarNode ;临时节点，用于做变量交换
Protected c.AStarNode ;临时节点，用于清空对象
Protected i.i
For i = 0 To OpenNum
If OpenList(i)\pos\X =*pos\pos\X And OpenList(i)\pos\Y =*pos\pos\Y ;找到要删除的节点（目标节点）
t = OpenList(OpenNum) ;t指向开启表中最后一个节点
OpenList(OpenNum) = c ;删除最后一个节点
OpenList(i) = t ;把最后一个节点覆盖到目标节点
OpenNum = OpenNum - 1 ;开启表长度-1
Break ;结束不必要的循环
EndIf
Next i
EndProcedure
;参数：需要添加进来的节点（添加在线性表的尾部）
Procedure.i AddCloseList(*pos.AStarNode)
CloseNum = CloseNum + 1 ;总节点数 1
;CloseList(CloseNum) =*pos ;添加节点
CloseList(CloseNum)\father=*pos\father
CloseList(CloseNum)\G=*pos\G
CloseList(CloseNum)\H=*pos\H
CloseList(CloseNum)\pos=*pos\pos
CloseList(CloseNum)\style=*pos\style
EndProcedure
;确认传入节点是否存在于开启表中
Procedure.i CheckNode(*node.AStarNode)
Protected i.i
Protected Result=#False
For i = 0 To OpenNum
If OpenList(i)\pos\X =*node\pos\X And OpenList(i)\pos\Y =*node\pos\Y ;找到了
Result = #True
Break
EndIf
Next i
If i>OpenNum
Result = #False
EndIf
ProcedureReturn Result
EndProcedure
;确认是否在关闭表里
Procedure CheckCloseNode(*node.AStarNode)
Protected i.i
Protected Result=#False
For i = 0 To CloseNum
If CloseList(i)\pos\X =*node\pos\X And CloseList(i)\pos\Y =*node\pos\Y ;找到了
Result =#True
Break
EndIf
Next i
If i>CloseNum
Result = #False
EndIf
ProcedureReturn Result
EndProcedure
;功能：
;更新开启表中的G值
Procedure UpdataG()
Protected i.i
For i = 0 To OpenNum
If OpenList(i)\G <> AStarMap(OpenList(i)\pos\X, OpenList(i)\pos\Y)\G
OpenList(i)\G = AStarMap(OpenList(i)\pos\X, OpenList(i)\pos\Y)\G
EndIf
Next i
EndProcedure
Procedure Neighbor_Search(*minFP.AStarNode,offsetX.i, offsetY.i)
Protected AStep.i
;越界检测
If *minFP\pos\X + offsetX >=maxX Or *minFP\pos\X + offsetX < 0 Or *minFP\pos\Y + offsetY >=maxY Or *minFP\pos\Y + offsetY < 0
Goto exit1
EndIf
If offsetX = 0 Or offsetY = 0 ;设置单位花费
AStep = 10
Else
AStep = 14
EndIf
;如果该邻居不是障碍并且不在关闭表中
If AStarMap(*minFP\pos\X + offsetX, *minFP\pos\Y + offsetY)\style <>#obstruct And CheckCloseNode(AStarMap(*minFP\pos\X + offsetX,*minFP\pos\Y + offsetY)) =#False
;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 ;存在于开启表中
If *minFP\G + AStep < AStarMap(*minFP\pos\X + offsetX,*minFP\pos\Y + offsetY)\G ;如果走新路径更短就更换父节点
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
UpdataG() ;更新Openlist中的G值
EndIf
Else ;不存在于开启表中
AStarMap(*minFP\pos\X + offsetX,*minFP\pos\Y + offsetY)\father =*minFP\pos ;设置该邻居的父节点为我们上面找到的最小节点（minFP）
AStarMap(*minFP\pos\X + offsetX,*minFP\pos\Y + offsetY)\G =*minFP\G + AStep ;计算该点（邻居）的G值
AddOpenList(@AStarMap(*minFP\pos\X + offsetX,*minFP\pos\Y + offsetY)) ;把该点加入开启表中
EndIf
EndIf
exit1:
EndProcedure
Procedure OnLeftClick()
If GetGadgetState(12)
Choise=1
PenColor=MColor(1)
EndIf
If GetGadgetState(13)
Choise=2
PenColor=MColor(2)
EndIf
If GetGadgetState(14)
Choise=3
PenColor=MColor(3)
EndIf
If GetGadgetState(15)
Choise=4
PenColor=MColor(4)
EndIf
EndProcedure
Procedure ISstartOrEndPoint(px.i,py.i)
If maps(px,py)=2
starts=0
EndIf
If maps(px,py)=3
ends=0
EndIf
EndProcedure
Procedure OnBtLeftClick()
Define i.i
If starts=0 Or ends=0
MessageRequester("Warnning","No Start or Ending point!",#PB_MessageRequester_Ok|#PB_MessageRequester_Warning)
Else
If GetGadgetState(16)=#PB_Checkbox_Checked
Slant=1
Else
Slant=0
EndIf
If AStar()=0
MessageRequester("Info","No Path find !",#PB_MessageRequester_Ok|#PB_MessageRequester_Info)
Else
If StartDrawing(CanvasOutput(0))
For i = 1 To PathLength - 1
Circle(AStarPath(i)\x*#wd+7, AStarPath(i)\y*#wd+7,5, $F000F0)
Next i
EndIf
StopDrawing()
HavePath=#True
EndIf
EndIf
EndProcedure
Procedure OnBtCPLeftClick()
Define i.i
If HavePath
If StartDrawing(CanvasOutput(0))
For i = 1 To PathLength - 1
Circle(AStarPath(i)\x*#wd+7, AStarPath(i)\y*#wd+7,5, MColor(1))
Next i
EndIf
StopDrawing()
HavePath=#False
EndIf
EndProcedure
Procedure OnBtCMLeftClick()
Define i.i,j.i
For i=0 To maxX
For j=0 To maxY
maps(i,j)=#channel
Next j
Next i
HavePath=#False
starts=0
ends=0
DrawMap()
EndProcedure
Procedure DrawMap()
Define k.i,Font1.i
LoadFont(0, "Arial" , 28, #PB_Font_Bold)
If StartDrawing(CanvasOutput(0))
Box(0,0,300,300,MColor(1))
For k=0 To 300 Step #wd
Line(0, k, 300, 1,RGB(0,0,0))
Line(k,0,1,300,RGB(0,0,0))
Next k
DrawingMode(#PB_2DDrawing_Transparent)
FrontColor(RGB(200,200,255)) ; print the text to white !
DrawingFont(FontID(0))
DrawText(70, 80, "A graphic")
DrawText(15,160,"of A-Star path !",RGB(220,120,160))
StopDrawing() ; This is absolutely needed when the drawing operations are finished !!! Never forget it !
EndIf
EndProcedure
正月十五闲来无事，改编自VB6版本的。
