A* Algorithmus

Megger · 4. November 2009, 15:15

Hiho

Ich habe mal den A* Algorithmus in Excel mit VBA realisiert.

Ich denke es ist noch nicht perfekt, aber ich denke man kann damit arbeiten.

Visual Basic-Quellcode

Option Explicit
Dim StartPoint As KoordPoint
Dim ZielPoint As KoordPoint
Dim openlist As Collection
Dim closedList As Collection
Dim wks As Worksheet
Dim minX As Integer
Dim maxX As Integer
Dim minY As Integer
Dim maxY As Integer
Public Sub calc_click()
Set wks = Application.Worksheets(1)
Set openlist = New Collection
Set closedList = New Collection
minX = 2
maxX = 51
minY = 2
maxY = 51
Set StartPoint = New KoordPoint
If wks.Cells(1, 1) < minY Then
StartPoint.setY (minY)
ElseIf wks.Cells(1, 1) > maxY Then
StartPoint.setY (maxY)
Else
StartPoint.setY (wks.Cells(1, 1))
End If
If wks.Cells(1, 2) < minX Then
StartPoint.setX (minX)
ElseIf wks.Cells(1, 2) > maxX Then
StartPoint.setX (maxX)
Else
StartPoint.setX (wks.Cells(1, 2))
End If
StartPoint.setG (0)
openlist.Add StartPoint
Set ZielPoint = New KoordPoint
If wks.Cells(1, 3) < minY Then
ZielPoint.setY (minY)
ElseIf wks.Cells(1, 3) > maxY Then
ZielPoint.setY (maxY)
Else
ZielPoint.setY (wks.Cells(1, 3))
End If
If wks.Cells(1, 4) < minX Then
ZielPoint.setX (minX)
ElseIf wks.Cells(1, 4) > maxX Then
ZielPoint.setX (maxX)
Else
ZielPoint.setX (wks.Cells(1, 4))
End If
Call prepare
If FindPath Then
Call PaintPath
End If
End Sub
Private Function FindPath() As Boolean
Dim AktPoint As KoordPoint
Dim i As Integer
Dim j As Integer
Dim x As Integer
Dim y As Integer
Dim index As Integer
Dim runner As Integer
Dim found As Boolean
found = False
Set AktPoint = openlist.Item(1)
index = 1
runner = 0
Do
j = openlist.Count
For i = 1 To j
If AktPoint Is Nothing = True Then
Set AktPoint = openlist.Item(i)
index = i
ElseIf AktPoint.getF > openlist.Item(i).getF Then
Set AktPoint = openlist.Item(i)
index = i
End If
Next i
openlist.Remove (index)
closedList.Add AktPoint
Call getNeighborPoints(AktPoint)
Set AktPoint = Nothing
If isZielInOpenList Then
found = True
Exit Do
End If
runner = runner + 1
Loop While Not openlist.Count = 0 And runner < 1000
FindPath = found
End Function
Private Function rateCosts(inX As Integer, inY As Integer) As Integer
Dim costs As Integer
Dim x As Integer
Dim y As Integer
x = inX
y = inY
costs = 0
Do While (x > ZielPoint.getX())
costs = costs + 10
x = x - 1
Loop
Do While (x < ZielPoint.getX())
costs = costs + 10
x = x + 1
Loop
Do While (y > ZielPoint.getY())
costs = costs + 10
y = y - 1
Loop
Do While (y < ZielPoint.getY())
costs = costs + 10
y = y + 1
Loop
rateCosts = costs
End Function
Private Function calcCosts(PointA As KoordPoint, PointB As KoordPoint) As Double
Dim costs As Double
Dim ax As Integer
Dim ay As Integer
Dim bx As Integer
Dim by As Integer
costs = 0
ax = PointA.getX()
ay = PointA.getY()
bx = PointB.getX()
by = PointB.getY()
Do While ax < bx And ay < by
costs = costs + Sqr(20)
ax = ax + 1
ay = ay + 1
Loop
Do While ax > bx And ay > by
costs = costs + Sqr(20)
ax = ax - 1
ay = ay - 1
Loop
Do While ax < bx And ay > by
costs = costs + Sqr(20)
ax = ax + 1
ay = ay - 1
Loop
Do While ax > bx And ay < by
costs = costs + Sqr(20)
ax = ax - 1
ay = ay + 1
Loop
Do While ax < bx
costs = costs + 10
ax = ax + 1
Loop
Do While ax > bx
costs = costs + 10
ax = ax - 1
Loop
Do While ay < by
costs = costs + 10
ay = ay + 1
Loop
Do While ay > by
costs = costs + 10
ay = ay - 1
Loop
calcCosts = costs
End Function
Private Function getNeighborPoints(AktPoint As KoordPoint)
Dim startx As Integer
Dim endx As Integer
Dim starty As Integer
Dim endy As Integer
Dim x As Integer
Dim y As Integer
Dim NeighborPoint As KoordPoint
startx = AktPoint.getX() - 1
endx = AktPoint.getX() + 1
starty = AktPoint.getY() - 1
endy = AktPoint.getY() + 1
If startx < minX Then
startx = minX
End If
If starty < minY Then
starty = minY
End If
If endx > maxX Then
endx = maxX
End If
If endy > maxY Then
endy = maxY
End If
For x = startx To endx
For y = starty To endy
'If AktPoint.getX = 4 And AktPoint.getY = 3 Then
' Call canMoveDiagonal(AktPoint, x, y)
'End If
If canMoveDiagonal(AktPoint, x, y) And Not isInClosedList(x, y) And Not wks.Cells(y, x).Value = "x" And (Not x = AktPoint.getX Or Not y = AktPoint.getY) Then
Call paint(x, y, 6)
Set NeighborPoint = New KoordPoint
NeighborPoint.setX (x)
NeighborPoint.setY (y)
NeighborPoint.setParent AktPoint
NeighborPoint.setH (rateCosts(x, y))
NeighborPoint.setG (calcCosts(NeighborPoint, AktPoint) + AktPoint.getG())
Call addToOpenList(NeighborPoint, AktPoint)
Set NeighborPoint = Nothing
Call paint(x, y, 5)
End If
Next y
Next x
End Function
Private Function addToOpenList(checkPoint As KoordPoint, AktPoint As KoordPoint)
Dim tmpPoint As KoordPoint
Dim found As Boolean
Dim index As Integer
index = 0
found = False
For Each tmpPoint In openlist
index = index + 1
If tmpPoint.getX = checkPoint.getX And tmpPoint.getY = checkPoint.getY Then
found = True
If tmpPoint.getG > checkPoint.getG Then
Call openlist.Add(checkPoint, , index)
openlist.Remove (index + 1)
End If
End If
Next
If Not found Then
index = 0
For Each tmpPoint In closedList
index = index + 1
If tmpPoint.getX = checkPoint.getX And tmpPoint.getY = checkPoint.getY Then
found = True
If tmpPoint.getG > checkPoint.getG Then
closedList.Add checkPoint, index, index, index - 1
closedList.Remove index + 1
End If
End If
Next
End If
If Not found Then
openlist.Add checkPoint
End If
End Function
Private Function paint(x As Integer, y As Integer, color As Integer)
wks.Cells(y, x).Interior.ColorIndex = color
End Function
Private Function isInClosedList(x As Integer, y As Integer) As Boolean
Dim tmpPoint As KoordPoint
Dim found As Boolean
found = False
For Each tmpPoint In closedList
If tmpPoint.getX = x And tmpPoint.getY = y Then
found = True
Exit For
End If
Next
isInClosedList = found
End Function
Private Function isZielInOpenList() As Boolean
Dim tmpPoint As KoordPoint
Dim found As Boolean
found = False
For Each tmpPoint In openlist
If tmpPoint.getX = ZielPoint.getX And tmpPoint.getY = ZielPoint.getY Then
found = True
Exit For
End If
Next
isZielInOpenList = found
End Function
Private Function PaintPath()
Dim tmpPoint As KoordPoint
For Each tmpPoint In openlist
If tmpPoint.getX = ZielPoint.getX And tmpPoint.getY = ZielPoint.getY Then
Exit For
End If
Next
Do While tmpPoint.getParent Is Nothing = False
If tmpPoint.getX = ZielPoint.getX And tmpPoint.getY = ZielPoint.getY Then
Call paint(tmpPoint.getX, tmpPoint.getY, 3)
Else
Call paint(tmpPoint.getX, tmpPoint.getY, 7)
End If
Set tmpPoint = tmpPoint.getParent
Loop
End Function
Private Function canMoveDiagonal(inAktPoint As KoordPoint, inX As Integer, inY As Integer) As Boolean
Dim ax As Integer
Dim ay As Integer
Dim bx As Integer
Dim by As Integer
Dim AktPoint As KoordPoint
Dim tmp1 As Variant
Dim tmp2 As Variant
Dim erg As Boolean
erg = True
Set AktPoint = inAktPoint
ax = AktPoint.getX
ay = AktPoint.getY
bx = inX
by = inY
tmp1 = wks.Cells(ay - 1, ax)
tmp2 = wks.Cells(ay, ax - 1)
If ax - 1 = bx And ay - 1 = by And (tmp1 = "x" Or tmp2 = "x") Then
erg = False
End If
tmp1 = wks.Cells(ay + 1, ax)
tmp2 = wks.Cells(ay, ax - 1)
If ax - 1 = bx And ay + 1 = by And (tmp1 = "x" Or tmp2 = "x") Then
erg = False
End If
tmp1 = wks.Cells(ay + 1, ax)
tmp2 = wks.Cells(ay, ax + 1)
If ax + 1 = bx And ay + 1 = by And (tmp1 = "x" Or tmp2 = "x") Then
erg = False
End If
tmp1 = wks.Cells(ay - 1, ax)
tmp2 = wks.Cells(ay, ax + 1)
If ax + 1 = bx And ay - 1 = by And (tmp1 = "x" Or tmp2 = "x") Then
erg = False
End If
canMoveDiagonal = erg
End Function
Private Function prepare()
Dim x As Integer
Dim y As Integer
Dim tmp As String
For x = minX To maxX
For y = minY To maxY
tmp = wks.Cells(y, x)
If tmp = "x" Then
wks.Cells(y, x).Interior.ColorIndex = 1
ElseIf x = StartPoint.getX And y = StartPoint.getY Then
wks.Cells(y, x).Interior.ColorIndex = 4
ElseIf x = ZielPoint.getX And y = ZielPoint.getY Then
wks.Cells(y, x).Interior.ColorIndex = 3
Else
wks.Cells(y, x).Interior.ColorIndex = 0
End If
Next y
Next x
End Function

Und die Klasse "KoordPoint"

Visual Basic-Quellcode

Option Explicit
Private parent As KoordPoint
Private x As Integer
Private y As Integer
Private g As Double
Private h As Double
Public Function setParent(inParent As KoordPoint)
Set parent = inParent
End Function
Public Function getParent() As KoordPoint
Set getParent = parent
End Function
Public Function setX(inX As Integer)
x = inX
End Function
Public Function getX() As Integer
getX = x
End Function
Public Function setY(inY As Integer)
y = inY
End Function
Public Function getY() As Integer
getY = y
End Function
Public Function setG(inG As Double)
g = inG
End Function
Public Function getG() As Double
getG = g
End Function
Public Function setH(inH As Double)
h = inH
End Function
Public Function getH() As Double
getH = h
End Function
Public Function getF() As Double
getF = g + h
End Function

In A1 muss der Y-Wert des Startpunkts angegeben werden

In B1 muss der X-Wert des Startpunkts angegeben werden

In C1 muss der Y-Wert des Zielpunkts angegeben werden

In D1 muss der X-Wert des Zielpunkts angegeben werden

Außerdem muss man am Anfang des Scripts die Grenzen des Feldes angeben (hier beginnt das Feld bei B2 und ist 50x50 Felder groß)

Ich denke das Script lässt sich noch optimieren, oder?

A* Algorithmus

A* Algorithmus

Visual Basic-Quellcode

Visual Basic-Quellcode

Ähnliche Themen

1 Benutzer hat hier geschrieben