vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Blitzschnelles Erstellen von grafischen Diagrammen!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2019
 
zurück
Rubrik: Grafik und Font   |   VB-Versionen: VB.NET13.08.07
Wegberechnung (Pathfinding, Pfadfindung) (.NET)

Berechnung des möglichst kürzesten Weges von A nach B

Autor:   mikeb69Bewertung:     [ Jetzt bewerten ]Views:  10.756 
www.powerdesktop-online.deSystem:  WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 Beispielprojekt auf CD 

Die berechnung des möglichst kürzesten Weges von A nach B, evtl. um Hindernisse herum, ist gar nicht so schwer:
 www.policyalmanac.org/games/aStarTutorial_de.html

In Anlehnung an diesen Artikel habe ich eine kleine Klasse programmiert, die die Funktionsweise des Pathfinding erklären soll.

Hier der Quellcode der Klasse:

Public Class ClassPathFinder
  Private startPoint As Point
  Private destPoint As Point
  Private sizeOfField As Size
  Private calcfinished As Boolean
  Private path As New List(Of Point) ' errechneter Weg
  Private calctime As Long           ' benötigte Zeit
 
  Private openList As New List(Of pointValue)   ' Liste aller möglchen Wegepunkte
  Private closedList As New List(Of pointValue) ' Liste aller Wegepunkte
 
  Private field(,) As Integer
 
  Public Const F_START As Integer = 1  ' Startpunkt
  Public Const F_DEST As Integer = 2   ' Zielpunkt
  Public Const F_BORDER As Integer = 3 ' Hindernis
  Public Const F_WAY As Integer = 4    ' errechneter Weg
 
  Private Structure pointValue
    Public Location As Point    ' Punkt im Gitter
    Public WayCosts As Integer  ' Wegekosten
    Public distance As Integer  ' Entfernung zum Ziel
    Public TotalCost As Integer ' Gesamtkosten = waycosts + distance
    Public Parent As Point      ' Ausgangspunkt dieses Punktes
  End Structure
  ''' <summary>New</summary>
  ''' <param name="start">Ausgangspunkt</param>
  ''' <param name="dest">Zielpunkt</param>
  ''' <param name="size">Größe des 'Spielfeldes'</param>
  ''' <param name="border">Height = 1 - wagerecht, Width = 1 - senkrecht</param>
  Public Sub New(ByVal start As Point, ByVal dest As Point, _
    ByVal size As Size, ByVal border As Rectangle)
 
    startPoint = start
    destPoint = dest
    sizeOfField = size
    calcfinished = False
    ReDim field(size.Width, size.Height)
 
    ' Hindernisse ins Gitter setzen
    If border.Height = 1 Then
      ' Hindernis in x Ausdehnung einzeichnen 
      For i As Integer = border.X To border.Width
        field(i, border.Y) = F_BORDER
      Next 
    Else
      ' Hindernis in y Ausdehnung einzeichnen
      For i As Integer = border.Y To border.Height
        field(border.X, i) = F_BORDER
      Next 
    End If
 
    ' Ziel- und Startpunkte ins Gitter setzen
    field(startPoint.X, startPoint.Y) = F_START
    field(destPoint.X, destPoint.Y) = F_DEST
  End Sub
  ''' <summary>Berechnet den Weg zwischen A und B.</summary>
  Public Sub Calculate()
    Dim t As New Stopwatch
    t.Start()
 
    ' mit dem Startpunkt beginnen
    Dim level As Integer = 0
    Dim turn As Integer = 0
    Dim actualPoint As pointValue
    actualPoint.Location = startPoint
    Do
      ' actual point aus der Openlist in die Closedlist verschieben
      gridarg = actualPoint
      Dim pos As Integer = openList.FindIndex(AddressOf Find_Grid_Location)
      Try
        openList.RemoveAt(pos)
      Catch ex As Exception
      End Try
      closedList.Add(actualPoint)
 
     ' alle Punkte links und rechts vom Standpunkt berechnen
     For x As Integer = 0 To 2
       For y As Integer = 0 To 2
         Dim pv As New pointValue
         pv.Location = AddPoint(actualPoint.Location, New Point(1 - x, 1 - y))
         ' nur berechnen wenn noch nicht in der Openlist oder Closedlist ist
         gridarg = New pointValue
         gridarg.Location = pv.Location
         If openList.FindIndex(AddressOf Find_Grid_Location) = -1 And _
           closedList.FindIndex(AddressOf Find_Grid_Location) = -1 Then
           ' nur berechnen, wenn nicht der aktuelle Standort und der Punkt 
           ' innerhalb des Gitters liegt und keine Hinderniss da ist
           If pv.Location <> actualPoint.Location And _
             pv.Location.X >= 0 And pv.Location.Y >= 0 And _
             pv.Location.X <= sizeOfField.Width And _
             pv.Location.Y <= sizeOfField.Height Then
             If field(pv.Location.X, pv.Location.Y) <> F_BORDER Then
               ' Entfernung berechnen
               Dim tempDist As Point = SubstractPoint(pv.Location, destPoint)
               pv.distance = (tempDist.X + tempDist.Y) * 10
               ' Wegekosten berechnen
               If pv.Location.X <> actualPoint.Location.X And _
                 pv.Location.Y <> actualPoint.Location.Y Then
                 ' Diagonal
                 pv.WayCosts = 14
               Else
                 ' senkrecht oder wagerecht 
                 pv.WayCosts = 10
               End If
               ' Gesamtkosten
               pv.TotalCost = pv.WayCosts + pv.distance
               ' Ausgangspunkt eintragen
               pv.Parent = actualPoint.Location
               ' Punkt in die offene Liste eintragen
               openList.Add(pv)
             End If
             pv = Nothing
           End If
         End If
       Next 
     Next 
     ' alle Grid-Elemente mit dem selben Eltern Grid-Element finden
     parentarg = actualPoint.Location
     Dim parents As List(Of pointValue) = openList.FindAll(AddressOf Find_All_Parents)
     ' nach totalcosts sortieren
     parents.Sort(AddressOf Sort_By_TotalCosts)
     ' erstes Parents-Element nehmen, da dieses die wenigsten Wegekosten hat
     Try
       actualPoint = parents(level)
       level = 0
     Catch ex As Exception
       ' kein reguläres Parent-Grid-Element gefunden
       ' dieser Pfad führt nicht zum Ziel
       ' Berechnung neu starten, aber jetzt einen anderen Pfad nehmen
       actualPoint.Location = startPoint
       turn += 1
       level = turn
       closedList.Clear()
       openList.Clear()
       ' nach drei vergeblichen Versuchen den Weg zu finden, Suche abbrechen
       If turn = 3 Then Exit Do
     End Try
  Loop Until actualPoint.Location = destPoint
  ' Anzeigen, dass die Berechnung beendet wurde
  calcfinished = True
  t.Stop()
  calctime = t.ElapsedMilliseconds
  t = Nothing
  ' einzelne Properties aktualisieren
  For i As Integer = 1 To closedList.Count - 1
    ' Array aktualisieren
    Dim x As Integer = closedList(i).Location.X
    Dim y As Integer = closedList(i).Location.Y
    field(x, y) = F_WAY
    ' list(of point) aktualisieren
    path.Add(closedList(i).Location)
  Next 
End Sub
#Region "Suchen/Sortieren"
  ''' <summary>Liste nach den TotalCosts sortieren.</summary>
  Private Function Sort_By_TotalCosts(ByVal first As pointValue, _
    ByVal second As pointValue) As Integer
 
    If first.TotalCost < second.TotalCost Then
      Return True
    Else
      Return False
    End If
  End Function
  ''' <summary>Findet gleiche Koordinaten im Spielfeld.</summary>
  Private gridarg As pointValue
  Private Function Find_Grid_Location(ByVal p As pointValue) As Boolean
    If p.Location = gridarg.Location Then
      Return True
    Else
      Return False
    End If
  End Function
  ''' <summary>Findet alle Koordinaten eines Elternfeldes.</summary>
  Private parentarg As Point
  Private Function Find_All_Parents(ByVal p As pointValue) As Boolean
    If p.Parent = parentarg Then
      Return True
    Else
      Return False
    End If
  End Function
#End Region
#Region "Properties"
  ''' <summary>Gibt den Startpunkt an.</summary>
  Public ReadOnly Property LocationStart() As Point
    Get
      Return startPoint
    End Get
  End Property
 
  ''' <summary>Gibt den Zielpunkt an.</summary>
  Public ReadOnly Property LocationDest() As Point
    Get
      Return destPoint
    End Get
  End Property
 
  ''' <summary>Gibt den errechneten Weg zurück.</summary>
  Public ReadOnly Property CalculatedPath() As List(Of Point)
    Get
      Return path
    End Get
  End Property
 
  ''' <summary>Gibt das Array mit allen Informationen über die 
  ''' Pfadfindung zurück.</summary>
  Public ReadOnly Property GridAsArray() As Integer(,)
    Get
      Return field
    End Get
  End Property
 
  ''' <summary>Gibt an, ob die Pfadfindung beendet wurde.</summary>
  Public ReadOnly Property CalculationFinished() As Boolean
    Get
      Return calcfinished
    End Get
  End Property
 
  ''' <summary>Gibt die Zeit (in ms) zurück, die zum Finden 
  ''' des Weges gebraucht wurde.</summary>
  Public ReadOnly Property CalculationTime() As Long
    Get
      Return calctime
    End Get
  End Property
#End Region
#Region "Math-Operation"
  ''' <summary>Subtrahiert zwei Point-Variablen - z.b. um die Distanz zwischen 
  ''' zwei Punkten zu berechnen.</summary>
  Private Function SubstractPoint(ByVal point1 As Point, ByVal point2 As Point)
    Return New Point(Math.Abs(point1.X - point2.X), Math.Abs(point1.Y - point2.Y))
  End Function
 
  ''' <summary>Addiert zwei Point-Variablen.</summary>
  Private Function AddPoint(ByVal point1 As Point, ByVal point2 As Point)
    Return New Point(point1.X + point2.X, point1.Y + point2.Y)
  End Function
#End Region
End Class

Um die Funktion dieser Klasse veranschaulichen zu können, erstellen Sie am besten eine Form1. Auf dieser Plazieren Sie eine Picturebox1 und einen Button1.
Den folgenden Code kopieren Sie nun in Ihr Projekt:

Public Class Form1
  Private c As ClassPathFinder
  Private WithEvents t As Timer
 
  Private Const G_X As Integer = 10
  Private Const G_Y As Integer = 10
  Private Sub Form1_Load(ByVal sender As System.Object, _
    ByVal e As System.EventArgs) Handles MyBase.Load
 
    c = New ClassPathFinder(New Point(3, 2), New Point(7, 7), _
      New Size(G_X, G_Y), New Rectangle(5, 2, 1, 8))
    Me.Text = "Bitte 'Start-Taste' drücken"
    BuildPicture()
  End Sub
  Private Sub BuildPicture()
    Dim b As New Bitmap(Me.PictureBox1.Width, Me.PictureBox1.Height)
    Dim g As Graphics = Graphics.FromImage(b)
    Dim h As Integer = Me.PictureBox1.Height / (G_Y + 1)
    Dim w As Integer = Me.PictureBox1.Width / (G_X + 1)
 
    For x As Integer = 0 To G_X
      For y As Integer = 0 To G_Y
        Dim rect As New Rectangle(x * w, y * h, w, h)
        g.DrawRectangle(Pens.Black, rect)
        Select Case c.GridAsArray(x, y)
          Case ClassPathFinder.F_START
            g.FillRectangle(Brushes.Green, rect)
          Case ClassPathFinder.F_DEST
            g.FillRectangle(Brushes.Red, rect)
          Case ClassPathFinder.F_BORDER
            g.FillRectangle(Brushes.Blue, rect)
          Case ClassPathFinder.F_WAY
            g.FillRectangle(Brushes.Yellow, rect)
        End Select
      Next 
    Next 
    Me.PictureBox1.Image = b
  End Sub
  Private Sub Button1_Click(ByVal sender As Object, _
    ByVal e As System.EventArgs) Handles Button1.Click
 
    c.Calculate()
    t = New Timer
    t.Interval = 500
    t.Start()
  End Sub
  Private Sub t_Tick(ByVal sender As Object, _
    ByVal e As System.EventArgs) Handles t.Tick
 
    If c.CalculationFinished = True Then
      t.Stop()
    End If
    BuildPicture()
    Me.Text = "Elapsed Time = " & c.CalculationTime & "ms"
  End Sub
End Class

Dieser Tipp wurde bereits 10.756 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2019 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel