form1.frm

初学A*算法的很好源码

            mapList(X, Y).RUN = True            '设置路径能通过
        Else
            lb(Index).BackColor = nwColor
            mapList(X, Y).RUN = False           '设置不能通过
        End If
    End If
End Sub

'--------------------------------------------------------------------
' 找出ix,iy中的相应的lable控件
'--------------------------------------------------------------------
Public Function findIndex(ix As Integer, iy As Integer)
    For i = 1 To mapW * mapH + 1
        If ix = lbList(i).X And iy = lbList(i).Y Then
            findIndex = i
            Exit For
        End If
    Next
End Function

'--------------------------------------------------------------------
' 用Astar算法开始查找路径
'--------------------------------------------------------------------
Private Function findPath()
'--------------------------------------------------------------------
' 设置地图属性
'--------------------------------------------------------------------
    i = 1
    For Y = 1 To mapH
    For X = 1 To mapW
        If lb(i).BackColor = phColor _
        Or lb(i).BackColor = opColor _
        Or lb(i).BackColor = clColor Then lb(i).BackColor = blColor '把路径换回背景色
        mapList(X, Y).OCW = 0       '设置路径为开启
        i = i + 1
    Next
    Next
    
'--------------------------------------------------------------------
' 设置路径为没找到
'--------------------------------------------------------------------
    blnPath = False
    
'--------------------------------------------------------------------
' 判断开始点和目标是否在同一位置
'--------------------------------------------------------------------
    If start.X = target.X And start.Y = target.Y Then
        findPath = 0
        Exit Function
    End If
    
'--------------------------------------------------------------------
' 把开始点加入打表队列
'--------------------------------------------------------------------
    openList(1).X = start.X
    openList(1).Y = start.Y
    onOpenList = 1
    
    mapList(openList(1).X, openList(1).Y).G = 0
'--------------------------------------------------------------------
' 当开启列表不为空就循环
'--------------------------------------------------------------------
        Do While onOpenList > 0 And Not blnPath
        'For i = 1 To onOpenList Step 1
'        For i = onOpenList To 1 Step -1
'            If mapList(openList(onOpenList).X, openList(onOpenList).Y).F > mapList( (i).X, openList(i).Y).F Then
'                parent.X = openList(i).X    '取出F值最少的位置
'                parent.Y = openList(i).Y
'
'                For j = i To onOpenList - 1 '抽出第i个元素后,把后面的元素接上
'                    openList(j).X = openList(j + 1).X
'                    openList(j).Y = openList(j + 1).Y
'                Next
'                openList(onOpenList).X = parent.X
'                openList(onOpenList).Y = parent.Y
'            End If
'        Next
        
        '对开启列表操作(下面代码以链表形式操作)
        t = onOpenList
        For i = onOpenList To 1 Step -1
            If mapList(openList(onOpenList).X, openList(onOpenList).Y).F > mapList(openList(i).X, openList(i).Y).F Then
                parent.X = openList(i).X    '取出F值最少的位置
                parent.Y = openList(i).Y
                t = i
            End If
        Next
        If t <> onOpenList Then
            For j = t To onOpenList - 1 '抽出第i个元素后,把后面的元素接上
                openList(j).X = openList(j + 1).X
                openList(j).Y = openList(j + 1).Y
            Next
            openList(onOpenList).X = parent.X
            openList(onOpenList).Y = parent.Y
        End If
        
        '取F值最少的做父节点
        parent.X = openList(onOpenList).X
        parent.Y = openList(onOpenList).Y
        
        X = parent.X
        Y = parent.Y
        For t = 1 To mapW * mapH + 1
        If X = lbList(t).X And Y = lbList(t).Y And Not (X = start.X And Y = start.Y) Then
            lb(t).BackColor = clColor
            Exit For
        End If
        Next
        
        '删除取出的节点
        'openList(1).X = openList(onOpenList).X
        'openList(1).Y = openList(onOpenList).Y
        onOpenList = onOpenList - 1
        mapList(parent.X, parent.Y).OCW = 10    '关闭
        
        For b = parent.Y - 1 To parent.Y + 1
        For a = parent.X - 1 To parent.X + 1

        If a <> -1 And b <> -1 And a <= mapW And b <= mapH Then '判断有没有超出范围
            If mapList(a, b).RUN Then   '判断是否可行
'--------------------------------------------------------------------
' 判断父节点上下左右四个方向有墙
'--------------------------------------------------------------------
'  1  2  3      5为父节点
'  4  5  6      分别对 1,7,3,9 四个位置的 (上,下,左,右)其中2个方向进行判断
'  7  8  9      如果是有障碍物就不设置从该父节点到这该点的路径
'--------------------------------------------------------------------
                Obstacle = False '设置没有墙
                If a = parent.X - 1 Then
                    If b = parent.Y - 1 Then        '左上角(1)
                        If Not mapList(parent.X, parent.Y - 1).RUN Or Not mapList(parent.X - 1, parent.Y).RUN Then '判断2,4是否有墙
                            Obstacle = True
                        End If
                    ElseIf b = parent.Y + 1 Then    '左下角(7)
                        If Not mapList(parent.X, parent.Y + 1).RUN Or Not mapList(parent.X - 1, parent.Y).RUN Then '判断8,4是否有墙
                            Obstacle = True
                        End If
                    End If
                ElseIf a = parent.X + 1 Then
                    If b = parent.Y - 1 Then        '右上角(3)
                        If Not mapList(parent.X, parent.Y - 1).RUN Or Not mapList(parent.X + 1, parent.Y).RUN Then '判断2,6是否有墙
                            Obstacle = True
                        End If
                    ElseIf b = parent.Y + 1 Then    '右下角(9)
                        If Not mapList(parent.X, parent.Y + 1).RUN Or Not mapList(parent.X + 1, parent.Y).RUN Then '判断8,6是否有墙
                            Obstacle = True
                        End If
                    End If
                End If
                
                If Not Obstacle Then    '判断是否发现墙
                If mapList(a, b).OCW = 1 Then '判断是否存在开启列表中
                    If Abs(parent.X - a) = 1 And Abs(parent.Y - b) = 1 Then
                        t = 14
                    Else
                        t = 10
                    End If
                    tg = mapList(parent.X, parent.Y).G + t
                    
                    If tg < mapList(a, b).G Then    ' 如果把现在的节点当父节点的话.距离近了就设这为新的父节点
                        parentList(a, b).X = parent.X
                        parentList(a, b).Y = parent.Y
                    End If
                    
                ElseIf mapList(a, b).OCW = 0 Then '判断是否为默认状态
                    If Abs(parent.X - a) = 1 And Abs(parent.Y - b) = 1 Then
                        t = 14
                    Else
                        t = 10
                    End If
                    
                    '估计函数
                    mapList(a, b).G = mapList(parent.X, parent.Y).G + t '设置G的值
                    mapList(a, b).H = 10 * (Abs(a - target.X) + Abs(b - target.Y))  '设置H值
                    mapList(a, b).F = mapList(a, b).G + mapList(a, b).H             '设置F值
                    
                    parentList(a, b).X = parent.X       '记录父节点
                    parentList(a, b).Y = parent.Y
                    
                    onOpenList = onOpenList + 1         '增加到开启列表
                    openList(onOpenList).X = a
                    openList(onOpenList).Y = b
                    mapList(a, b).OCW = 1               '设置路径为开启

                    X = a
                    Y = b
                    For t = 1 To mapW * mapH + 1
                    If X = lbList(t).X And Y = lbList(t).Y Then
                        If Not (X = target.X And Y = target.Y) Then
                        If Not (X = start.X And Y = start.Y) Then
                            lb(t).BackColor = opColor
                        End If
                        End If
                        Exit For
                    End If
                    Next
                End If 'If mapList(a, b).OCW = 1 Then 判断是否存在开启列表中
                
                If a = target.X And b = target.Y Then '判断是否找到目标
                    tgBf.X = a  '记录找到目标的父节点
                    tgBf.Y = b
                    blnPath = True
                End If 'If a = target.x And b = target.y Then 判断是否找到目标
                End If 'If Not Obstacle Then    判断是否发现墙
            End If 'If mapList(a, b).RUN Then 判断是否可行
        End If
        Next
        Next
        
'--------------------------------------------------------------------
' 判断是否为单步演示
'--------------------------------------------------------------------
    If blnStep Then t = MsgBox("在开启列表中的元素的个数:" & onOpenList & vbCr & "点(是)继续单步演示", vbYesNo, "逐步测试", 100, 100)
    If t = vbNo Then blnStep = False

    Loop 'Do While onOpenList > 0
'--------------------------------------------------------------------
' 输出路径
'--------------------------------------------------------------------
OutPath:
    If blnPath Then '判断有没有找到路径
        X = target.X
        Y = target.Y
    
        pathLcNumber = 1
        Do While Not (parentList(X, Y).X = start.X And parentList(X, Y).Y = start.Y)
            t = parentList(X, Y).X  '设置上一下的父点
            Y = parentList(X, Y).Y
            X = t
            
            pathLcNumber = pathLcNumber + 1     '保存位置
            pathLc(pathLcNumber).X = X
            pathLc(pathLcNumber).Y = Y
        Loop
        For i = 1 To pathLcNumber '显示路径
            X = pathLc(i).X
            Y = pathLc(i).Y
            For j = 1 To mapW * mapH
                If X = lbList(j).X And Y = lbList(j).Y Then
                    lb(j).BackColor = phColor
                    Exit For
                End If
            Next
        Next
    Else
        MsgBox "无法找出路径", vbCritical, "寻路错误"
    End If
    
    blnStep = False
    reSetColor = True
End Function

Private Sub Timer1_Timer()
'    If Form1.Caption = "A* 算法VB版演示" Then
'        Form1.Caption = "作者:merting"
'        Timer1.Interval = 2000
'    ElseIf Form1.Caption = "作者:merting" Then
'        Form1.Caption = "博客:http://fdlove.139.com"
'        Timer1.Interval = 2000
'    Else
'        Form1.Caption = "A* 算法VB版演示"
'        Timer1.Interval = 5000
'    End If
End Sub