module1.bas

A星算法 A星算法MSSCCPRJ.SCC A星算法Form1.frm A星算法工程1.vbp A星算法Module1.bas A星算法工程1.vbw A星算法工程1.exe # #

Attribute VB_Name = "Module1"
Private Declare Function GetTickCount Lib "kernel32" () As Long
Type point
x As Integer
y As Integer
End Type
Public star As point
Public endd As point
Public cur As point
Public temp(3) As point

Public ball(600) As point  '路径数据
Public ballgood(600) As point

Public Coun As Long
Public i As Integer, j As Integer, k As Integer
Public ii As Integer, jj As Integer, kk As Integer
Public lg(3) As Single
Public li As Integer
Public lmax As Single
Public ma(-2 To 32, -2 To 22) As Byte  '地图
Public maai(-2 To 32, -2 To 22) As Byte

Public endst As Boolean

Dim FPS_Count As Long

Public Function aithinkk()

endst = True
Coun = 0
cur.x = star.x
cur.y = star.y

For i = 0 To 30
For j = 0 To 20
 maai(i, j) = 0
Next
Next

Do
If GetTickCount - FPS_Count > 15 Then
ball(Coun).x = cur.x
ball(Coun).y = cur.y
Coun = Coun + 1
ert
FPS_Count = GetTickCount
End If
DoEvents
Loop While endst


huiend  '绘制最后的优化结果

End Function

Public Sub ert()
lmax = 20000
temp(0).x = cur.x - 1: temp(0).y = cur.y
temp(1).x = cur.x + 1: temp(1).y = cur.y
temp(2).x = cur.x: temp(2).y = cur.y - 1
temp(3).x = cur.x: temp(3).y = cur.y + 1

For k = 0 To 3
If ma(temp(k).x, temp(k).y) = 1 Or maai(temp(k).x, temp(k).y) = 1 Then
lg(k) = 20000
Else
lg(k) = leng(temp(k), endd)
End If
Next

For i = 0 To 3
If lg(i) < lmax Then lmax = lg(i): li = i
Next

If lmax = 20000 Then
lesw   '遇到"死路"须返回寻找新路径
Else

If li = 0 Then
maai(cur.x - 1, cur.y) = 1
cur.x = cur.x - 1
ElseIf li = 1 Then
maai(cur.x + 1, cur.y) = 1
cur.x = cur.x + 1
ElseIf li = 2 Then
maai(cur.x, cur.y - 1) = 1
cur.y = cur.y - 1
ElseIf li = 3 Then
maai(cur.x, cur.y + 1) = 1
cur.y = cur.y + 1
End If

End If
'Form1.Picture1.Cls
Form1.List1.AddItem Str(cur.x) + Str(cur.y)
Form1.Picture1.Circle (cur.x * 20 + 10, cur.y * 20 + 10), 6, QBColor(10)

If cur.x = endd.x And cur.y = endd.y Then endst = False
End Sub

Public Function leng(p1 As point, p2 As point) As Single
leng = (p2.x - p1.x) * (p2.x - p1.x) + (p2.y - p1.y) * (p2.y - p1.y)
End Function



Public Sub lesw()   '遇到"死路"须返回寻找新路径

For ii = Coun - 2 To 0 Step -1
temp(0).x = ball(ii).x - 1: temp(0).y = ball(ii).y
temp(1).x = ball(ii).x + 1: temp(1).y = ball(ii).y
temp(2).x = ball(ii).x: temp(2).y = ball(ii).y - 1
temp(3).x = ball(ii).x: temp(3).y = ball(ii).y + 1

For kk = 0 To 3
If ma(temp(kk).x, temp(kk).y) = 1 Or maai(temp(kk).x, temp(kk).y) = 1 Then
lg(kk) = 20000
Else
lg(kk) = leng(temp(kk), endd)
End If
Next

For jj = 0 To 3
If lg(jj) < lmax Then lmax = lg(jj): li = jj
Next

If lmax < 20000 Then
If li = 0 Then
maai(ball(ii).x - 1, ball(ii).y) = 1
cur.x = ball(ii).x - 1
cur.y = ball(ii).y
ElseIf li = 1 Then
maai(ball(ii).x + 1, ball(ii).y) = 1
cur.x = ball(ii).x + 1
cur.y = ball(ii).y
ElseIf li = 2 Then
maai(ball(ii).x, ball(ii).y - 1) = 1
cur.x = ball(ii).x
cur.y = ball(ii).y - 1
ElseIf li = 3 Then
maai(ball(ii).x, ball(ii).y + 1) = 1
cur.x = ball(ii).x
cur.y = ball(ii).y + 1
End If


For kk = ii + 1 To Coun - 1
Form1.Picture1.Circle (ball(kk).x * 20 + 10, ball(kk).y * 20 + 10), 6, QBColor(1)
Next

Coun = ii + 1
Exit For
End If


Next

'1:
End Sub


Public Sub huiend() '绘制最后的优化结果
Dim congood As Long

For i = 0 To Coun - 1

FPS_Count = GetTickCount '延时
Do
If GetTickCount - FPS_Count > 6 Then Exit Do
DoEvents
Loop

ballgood(congood).x = ball(i).x
ballgood(congood).y = ball(i).y
congood = congood + 1
Form1.Picture1.Circle (ball(i).x * 20 + 10, ball(i).y * 20 + 10), 6, QBColor(12)

For j = i + 2 To Coun - 1
If leng(ball(i), ball(j)) = 1 Then
congood = congood + 1
Form1.Picture1.Circle (ball(j).x * 20 + 10, ball(j).y * 20 + 10), 6, QBColor(12)
ballgood(congood).x = ball(j).x
ballgood(congood).y = ball(j).y
congood = congood + 1
i = j
Exit For
End If
Next

Next


Form1.List1.Clear
For k = 0 To congood - 1
Form1.List1.AddItem Str(ballgood(k).x) + Str(ballgood(k).y)
Next

End Sub