自动寻路.bas

智能搜索-寻路演示

Attribute VB_Name = "自动寻路"
'**********************************************************************************
'***---------------------------------- A** 自动寻路模块--------------------------**
'***你可以任意使用，复制和传播该模块，但请不要更改下面的内容,                    **
'***-------------------------工作原理--------------------------------------------**
'**  首先生成8个方向的节点，tmp(tmpe)用于记录生成的节点对应的节点号              **
'**   新生成的节点的指针（d1 -表示离开起始点的 距离)指向生成他的父节点           **
'**,  按该点到目的地的大小nude(i).d2 排序后加入opened列表，                      **
'** (opened 总是指向离 目的地最近的点)然后再从opened表中取出一个节点,生成新的节点**            **
'** 按8个方向生成新的节点，如果要生成的节点 已经存在（在tmp(tmpe) 中)就比较以下  **
'** 改节点的 d1值 重新修改 父节点指针                                            **
'**  如果达到目的地就返回 节点的序号值，如果目的地不能到达就选出                 **
'**一个距离目的地最近的点做为目的地,如果起始点8个方向都不能动，就返回一个false 值**
'***                                                版权所有: zfc                **
'**                                                     姓名  张林               **
'**                                                     邮箱  [e-mail]  **
'**                                                       QQ  21338963           **
'**                                                               2004.5.10      **
'**********************************************************************************
' 解释:在8个方向的地图上
'   在地图上两点(x1,y1),(x2,y2) 的距离的最短值是 是 abs(x1-x2) 与 abs(y1-y2)
'  中的较大的一个,而不是 SQR((x1-x2)^2 +(y1-y2)^2) 如下图
'           *  a(1,1)
'           **
'           *** b(3,3)             a 到 b 的距离 是 3-1 =2 而不是 SQR((3-1)^2+(3-1)^2)= SQR(8)
'
Option Explicit
Type nude_type
X As Integer
Y As Integer
Father As Integer
D1 As Integer
D2 As Integer
Next As Integer
Id As Integer
End Type
Type Closed_map
NuDenum As Integer
Mapval As Integer
End Type
Dim Opened As Integer
Public SleepTimes As Integer
Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long)

Function FindPath(X As Integer, Y As Integer, dx As Integer, dy As Integer, ByRef m As Integer, ByRef TT() As P_xy) As Boolean
'寻路 主程序
'该程序 默认的 地图名叫 map ,所以 你 的游戏 调用该 模块时 也要叫地图 命名成 map() 二维 数组
' x,y 表示 起点坐标，dx,dy 表示 目标坐标 ,TT()是 要走的路的坐标 m 是指向  数组TT()存放 下一不要走的路的 的指针
'm 和 tt 的数据由本函数 自动生成
Dim Nude(5000) As nude_type
Dim Tmpe(-1 To 500, -1 To 500) As Closed_map
Dim ISt As Integer
Dim x1 As Integer, y1 As Integer
Dim QQ As Integer

Dim LengTh As Integer
x1 = X: y1 = Y
'设 nude(0)为起始点
Nude(0).X = X: Nude(0).Y = Y: Nude(0).Father = -1: Nude(0).D1 = 0
 Dim tmpx As Integer, tmpy As Integer
         tmpx = Abs(x1 - dx): tmpy = Abs(y1 - dy)
        ' If tmpx >= tmpy Then
        ' Nude(0).D2 = tmpx
        ' Else
         'Nude(0).D2 = tmpy
        ' End If
 Nude(0).D2 = IIf(tmpx > tmpy, tmpx, tmpy)

Nude(0).Next = -1
Nude(0).Id = 0: Opened = 0
Tmpe(x1, y1).NuDenum = 0
Tmpe(x1, y1).Mapval = 1
Dim Maxnum As Integer: Maxnum = 0 '这个数可不能改
Dim MaxCounts As Integer '限制最大搜索范围,加快搜索速度
Select Case Nude(0).D2
Case 0 To 5
MaxCounts = 50
Case 6 To 10
MaxCounts = 100
Case 11 To 20
MaxCounts = 400
Case 21 To 30
MaxCounts = 1000
Case 31 To 40
MaxCounts = 2000
Case Is > 40
MaxCounts = 5000
End Select
'白色表示活动(opened 列表中的)的接点，黄色表示关闭的(已经从opened列表中取出)接点
Do
QQ = Getopenednude(Nude()) '从opened 表中取出一个离目标最近的点做为 种子
ISt = Sub1(Nude(QQ).X, Nude(QQ).Y, dx, dy, Tmpe(), Nude(), Maxnum) '生成8个方向的接点
'****************** '画所有扫瞄过的地图
Dim l As Integer, aa As Integer
l = 0
aa = Maxnum
For l = 1 To aa
Dim Openedmap As Integer
Openedmap = Opened
    While (Openedmap <> -1)
     If Nude(Openedmap).Id = l Then
     TT(l).X = Nude(l).X
     TT(l).Y = Nude(l).Y
     Form1.Line (30 + TT(l).X * a + 2, 30 + TT(l).Y * a + 2)-Step(a - 4, a - 4), vbWhite, BF
     GoTo g1
    Else
    Openedmap = Nude(Openedmap).Next
    End If
Wend
     TT(l).X = Nude(l).X
     TT(l).Y = Nude(l).Y
     Form1.Line (30 + TT(l).X * a + 2, 30 + TT(l).Y * a + 2)-Step(a - 4, a - 4), vbYellow, BF
g1:


Next l
'***************************
'***************** 下面画最近临时路线 (兰色)
l = 0
If ISt > 0 Then aa = Opened
Do
TT(l).X = Nude(aa).X
TT(l).Y = Nude(aa).Y
Form1.Line (30 + TT(l).X * a + 3, 30 + TT(l).Y * a + 3)-Step(a - 5, a - 5), vbBlue, BF

aa = Nude(aa).Father
l = l + 1
Loop Until aa = -1
'******************************

If ISt > 0 Then GoTo FINDs '找到目标
Sleep SleepTimes
DoEvents
If Maxnum >= MaxCounts Then Exit Do
Loop Until Opened = -1




If Maxnum = 0 Then '8个方向都不能移动，就返回 false
FindPath = False: Exit Function
End If

   '************目标不能到达就选择一个离目标最近的点做为一个新目标
   Dim nn As Integer, mm As Integer
   Dim iii As Integer
     Dim i As Integer
      aa = Maxnum
      LengTh = Nude(1).D2
      iii = 1
      nn = Nude(1).X: mm = Nude(1).Y
      
      For i = 1 To aa
   If LengTh > Nude(i).D2 Then
      LengTh = Nude(i).D2
      nn = Nude(i).X: mm = Nude(i).Y
      iii = i
   End If
 
      Next
        dx = nn: dy = mm
FINDs:  '最终处理  把生成的路线 返回到调用着的路线数祖

aa = iii
l = 0
If ISt > 0 Then aa = ISt
Do
TT(l).X = Nude(aa).X
TT(l).Y = Nude(aa).Y
'**********'下面这一行是画最终路线 黑色
Form1.Line (30 + TT(l).X * a + 3, 30 + TT(l).Y * a + 3)-Step(a - 5, a - 5), vbBlack, BF
'************
aa = Nude(aa).Father
l = l + 1
Loop Until aa = -1
m = l - 2
FindPath = True

End Function


Function Sub1(ByRef X As Integer, ByRef Y As Integer, ByRef dx As Integer, ByRef dy As Integer, ByRef tmp() As Closed_map, ByRef Nude() As nude_type, ByRef n As Integer) As Integer
'寻路 子模块 根据母接点 生成 8个方向的 子接点,插入opened表
Dim i As Integer, j As Integer, Fatnum As Integer, Mme As Integer, m As Integer
Dim aaa As Integer, x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer
Dim t As Integer
 t = 0
For i = -1 To 1
For j = -1 To 1
If (i <> 0 Or j <> 0) And Testmap(X + i, Y + j) Then 'testmap() 用于记录 已经生成的地图接点
   ' 如果要生成的接点 已经在 testmap 中 就比较一下他们的父接点的 d1 ,如果要生成的目标的 d1 比母点的父接点的 d1 还小就修改成目标接点
   'd1 表示离开 起始点的距离
   If tmp(X + i, Y + j).Mapval = 1 Then
      Mme = tmp(X + i, Y + j).NuDenum
       aaa = tmp(X, Y).NuDenum
      Fatnum = Nude(aaa).Father
      If Fatnum = -1 Then
      '已经是 起始点
      Else
      If Nude(Fatnum).D1 > Nude(Mme).D1 Then Nude(aaa).Father = Mme
      End If
   End If
   If tmp(X + i, Y + j).Mapval = 0 Then '要生成的接点 没有在 testmap()表中,就生成该接点
      m = tmp(X, Y).NuDenum
      n = n + 1
      x1 = X + i: y1 = Y + j
      tmp(x1, y1).Mapval = 1
      tmp(x1, y1).NuDenum = n
      Nude(n).X = x1: Nude(n).Y = y1
      Nude(n).Father = m
      Nude(n).D1 = Nude(m).D1 + 1
         
         Dim ttmpx As Integer, ttmpy As Integer
         ttmpx = Abs(x1 - dx): ttmpy = Abs(y1 - dy)
         
        ' If ttmpx >= ttmpy Then
        ' Nude(n).D2 = ttmpx
        ' Else
        ' Nude(n).D2 = ttmpy
        ' End If
         Nude(n).D2 = IIf(ttmpx > ttmpy, ttmpx, ttmpy)
         
   Nude(n).Id = n
  ' Form1.Line (30 + x1 * a + 3, 30 + y1 * a + 3)-Step(a - 5, a - 5), vbWhite, BF
   If Nude(n).D2 = 0 Then '找到目标
   Sub1 = n
   Exit Function
   End If
   '插入 opened 表
   Call InstOPened(Nude(n), Nude())
 
  End If
End If
Next
Next
   
End Function

Sub InstOPened(Mnud As nude_type, Nude() As nude_type)
' opened 列表 用于 记录生成的新接点，opened 总是指向离目标就近的接点,opened=-1 时表示 表已空
Dim Temp2 As Integer
Dim f As Integer
Dim dd As Integer
If Opened = -1 Then
Mnud.Next = -1
Opened = Mnud.Id
Exit Sub
End If
f = Mnud.D2
Temp2 = Opened
'排序后插入opened表
Do
If f < Nude(Temp2).D2 Then GoTo K1
dd = Temp2
Temp2 = Nude(Temp2).Next
Loop Until Temp2 = -1
Mnud.Next = -1
Nude(dd).Next = Mnud.Id
Exit Sub
K1:

Mnud.Next = Temp2
If Opened <> Temp2 Then
Nude(dd).Next = Mnud.Id
Else
Opened = Mnud.Id
End If
End Sub
Function Getopenednude(Nude() As nude_type) As Integer
'从opened 表中 取出最近接点
Dim tmp3 As Integer
If Opened = -1 Then
' error
Else
tmp3 = Opened
Opened = Nude(tmp3).Next
Getopenednude = tmp3
End If
End Function
Function Testmap(ByVal X As Integer, ByVal Y As Integer)
'  检测地图能不能走
On Error GoTo Errors '如过超出边界 就不能走
'你可以在这里加如其他的限制 ,比如有走的地图上不能有其他的 蚂蚁
 If Map(X, Y) = 0 Then Testmap = True: Exit Function
Errors:
Testmap = False
End Function