DirextX编程

开发平台：
Visual Basic

自动寻路.BAS：源码内容
							Attribute VB_Name = "自动寻路"
'**********************************************************************************
'***---------------------------------- A** 自动寻路模块--------------------------**
'***你可以任意使用，复制和传播该模块，但请不要更改下面的内容,                    **
'***-------------------------工作原理--------------------------------------------**
'**  首先生成8个方向的节点，tmp(tmpe)用于记录生成的节点对应的节点号              **
'**   新生成的节点的指针（d1 -表示离开起始点的 距离)指向生成他的父节点           **
'**,  按该点到目的地的大小nude(i).d2 排序后加入opened列表，                      **
'** (opened 总是指向离 目的地最近的点)然后再从opened表中取出一个节点,生成新的节点**
'** 按8个方向生成新的节点，如果要生成的节点 已经存在（在tmp(tmpe) 中)就比较以下  **
'** 改节点的 d1值 重新修改 父节点指针                                            **
'**  如果达到目的地就返回 节点的序号值，如果目的地不能到达就选出                 **
'**一个距离目的地最近的点做为目的地,如果起始点8个方向都不能动，就返回一个false 值**
'***                                                版权所有: zfc                **
'**                                                     姓名  张林               **
'**                                                     邮箱  zfczl@163.tom.com  **
'**                                                       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)
'
'更新内容 改了寻路程序走斜线和对角能穿过的问题    *b     '2004.8.17
' Download by http://www.codefans.net                                                a*
Option Explicit
Private Type nude_type
    X As Long
    Y As Long
    Father As Long
    D1 As Long
    'D2 As long
    '**********
    d2 As Single
    '**********
    
    Next As Long
    Id As Long
End Type
Public Type P_xy
    X As Long
    Y As Long
End Type
Type Closed_map
    NuDenum As Long
    Mapval As Long
End Type
Private Opened As Long
Public Function FindPath(X As Long, Y As Long, Dx As Long, Dy As Long, ByRef M As Long, ByRef TT() As P_xy, ByRef Desc_Passed_Enable As Boolean) As Boolean
    Dim Nude(6000) As nude_type
    Dim Tmpe(-1 To 500, -1 To 500) As Closed_map
    Dim ISt As Long
    Dim X1 As Long, Y1 As Long
    Dim QQ As Long
    Dim i As Long, j As Long
    
    
    '***************
    '目的地和出发地重合
    If X = Dx And Y = Dy Then
        M = 0
        TT(0).X = Dx
        TT(0).Y = Dy
        FindPath = True: Exit Function
    End If
    '****************
    
    
    X1 = X: Y1 = Y
    Nude(0).X = X: Nude(0).Y = Y: Nude(0).Father = -1: Nude(0).D1 = 0
        
 
'***************************
 'Dim tmpx As long, tmpy As long
 'tmpx = Abs(x1 - dx): tmpy = Abs(y1 - dy)
 'Nude(0).D2 = IIf(tmpx > tmpy, tmpx, tmpy)
     Nude(0).d2 = Sqr((X1 - Dx) ^ 2 + (Y1 - Dy) ^ 2)
'***********************
    Nude(0).Next = -1
    Nude(0).Id = 0: Opened = 0
    Tmpe(X1, Y1).NuDenum = 0
    Tmpe(X1, Y1).Mapval = 1
    Dim Maxnum As Long: Maxnum = 0 '这个数可不能改
    Dim MaxCounts As Long '限制最大搜索范围,加快搜索速度
    MaxCounts = 0
    '*************
    
    '如果 目标正在被包围中（不能到达)就缩小搜索范围节约速度
'    For i = -1 To 1
'        For j = -1 To 1
'            If i = 0 And j = 0 Then
'            Else
'                If Dx + i >= 0 And Dx + i <= Map_Width And Dy + j >= 0 And Dy + j <= Map_Width Then
'                    If Map5(Dx + i, Dy + j) = 0 Then GoTo Begin
'                End If
'            End If
'        Next
'    Next
'    MaxCounts = (Abs(X - Dx) + Abs(Y - Dy)) * 4
    '*******************
Begin:
    Do
        QQ = Getopenednude(Nude())
        ISt = Sub1(Nude(QQ).X, Nude(QQ).Y, Dx, Dy, Tmpe(), Nude(), Maxnum, Desc_Passed_Enable)
        If ISt > 0 Then GoTo FINDs '找到目标
        If Maxnum >= MaxCounts Then
            Exit Do
        End If
    Loop Until Opened = -1
    
    If Maxnum = 0 Then
    '************
    ' 要找的目标紧挨着自己
        M = 0
        TT(0).X = X
        TT(0).Y = Y
        FindPath = True: Exit Function
    '***************
    End If
       '********目标没有找到就选泽一个距离目标最近的地方作为目标
    Dim AA As Long, Lengh As Single
    Dim nn As Long, MM As Long
    Dim iii As Long
    AA = Maxnum
    Lengh = Nude(1).d2
    iii = 1
    nn = Nude(1).X: MM = Nude(1).Y
       
    For i = 1 To AA
        If Lengh > Nude(i).d2 Then
            Lengh = Nude(i).d2
            nn = Nude(i).X: MM = Nude(i).Y
            iii = i
        End If
    
    Next
    Dx = nn: Dy = MM
FINDs:
    Dim l As Long
    AA = iii
    l = 0
    If ISt > 0 Then AA = ISt
    Do
        TT(l).X = Nude(AA).X
        TT(l).Y = Nude(AA).Y
        AA = Nude(AA).Father
        l = l + 1
    Loop Until AA = -1
    M = l - 2
    FindPath = True
End Function
Private Function Sub1(ByRef X As Long, ByRef Y As Long, _
ByRef Dx As Long, ByRef Dy As Long, ByRef tmp() As Closed_map, _
ByRef Nude() As nude_type, ByRef N As Long, _
ByRef Desc_Passed_Enable As Boolean) As Long
    Dim i As Long, j As Long, Fatnum As Long, Mme As Long, _
    M As Long
    Dim aaa As Long, X1 As Long, Y1 As Long, X2 As Long, Y2 As Long
    Dim t As Long
    t = 0
    For i = -1 To 1
        For j = -1 To 1
     '*********仅用于怪物寻找玩家
            If Desc_Passed_Enable = False Then
                If i <> 0 Or j <> 0 Then
                    If X + i = Dx And Y + j = Dy Then '找到目标
                        Dx = X:  Dy = Y
                        Sub1 = tmp(X, Y).NuDenum
                        Exit Function
                    End If
                End If
            End If
      '*************
    
            If (i <> 0 Or j <> 0) And Testmap(X, Y, i, j) Then
                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
                    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 tmpx As long, tmpy As long
        'tmpx = Abs(x1 - dx): tmpy = Abs(y1 - dy)
        'Nude(0).D2 = IIf(tmpx > tmpy, tmpx, tmpy)
                    Nude(N).d2 = Sqr((X1 - Dx) ^ 2 + (Y1 - Dy) ^ 2)
    '***********************
    
             
                    Nude(N).Id = N
                    If Nude(N).d2 = 0 Then '找到目标
                        Sub1 = N
                        Exit Function
                    End If
                    Call InstOPened(Nude(N), Nude())
                    
                End If
            End If
        
        Next
    Next
   
End Function
Private Sub InstOPened(Mnud As nude_type, Nude() As nude_type)
    Dim Temp2 As Long
    'Dim f As long
    '************
    Dim f As Single
    '**********
    Dim dd As Long
    If Opened = -1 Then
        Mnud.Next = -1
        Opened = Mnud.Id
        Exit Sub
    End If
    f = Mnud.d2
    Temp2 = 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
Private Function Getopenednude(Nude() As nude_type) As Long
    Dim tmp3 As Long
    If Opened = -1 Then
    ' error
    Else
        tmp3 = Opened
        Opened = Nude(tmp3).Next
        Getopenednude = tmp3
    End If
End Function
Private Function Testmap(ByVal X As Long, ByVal Y As Long, i As Long, j As Long)
'  检测地图能不能走
On Error GoTo Errors '如过超出边界 就不能走
'你可以在这里加如其他的限制 ,比如有走的地图上不能有其他的 蚂蚁
 
    If i * j = 0 Then
        If Map.Map3(X + i, Y + j) = 0 And Map.Map4(X + i, Y + j) = 0 And Map.Map5(X + i, Y + j) = 0 Then Testmap = True: Exit Function
    
        If Map.Map4(X + i, Y + j) > 0 Then
'            If Mon(Map4(X + i, Y + j)).HP_生命值 <= 0 Then Testmap = True: Exit Function
        End If
    End If
    If i * j <> 0 Then
        If Map.Map3(X + i, Y + j) = 0 And Map.Map4(X + i, Y + j) = 0 And Map.Map5(X + i, Y + j) = 0 And Map.Map3(X + i, Y) = 0 And Map.Map4(X + i, Y) = 0 And Map.Map5(X + i, Y) = 0 And Map.Map3(X, Y + j) = 0 And Map.Map4(X, Y + j) = 0 And Map.Map5(X, Y + j) = 0 Then Testmap = True: Exit Function
    End If
Errors:
    Testmap = False
End Function

						