Die Community zu .NET und Classic VB.

Startseite / Tipps / VB.NET-Tipp 0113: Graham-Scan: Konvexe Hülle eines Polygons berechnen

VB.NET-Tipp 0113: Graham-Scan: Konvexe Hülle eines Polygons berechnen

 von Dario

Schwierigkeitsgrad:

Framework-Version(en): .NET Framework 3.5

.NET-Version(en): Visual Basic 2008

Download: Download des Beispielprojektes [13,13 KB]

' Dieser Quellcode stammt von http://www.activevb.de
' und kann frei verwendet werden. Für eventuelle Schäden
' wird nicht gehaftet.

' Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
' Ansonsten viel Spaß und Erfolg mit diesem Source!

' Projektversion:   Visual Studio 2008
' Option Strict:    Aus
' Option Explicit:  An
' Option Infer:     An
'
' Referenzen: 
'  - System
'  - System.Data
'  - System.Deployment
'  - System.Drawing
'  - System.Windows.Forms
'  - System.Xml
'  - System.Core
'  - System.Xml.Linq
'  - System.Data.DataSetExtensions
'
' Imports: 
'  - Microsoft.VisualBasic
'  - System
'  - System.Collections
'  - System.Collections.Generic
'  - System.Data
'  - System.Drawing
'  - System.Diagnostics
'  - System.Windows.Forms
'  - System.Linq
'  - System.Xml.Linq
'

' ##############################################################################
' ################################ frmMain.vb ##################################
' ##############################################################################
Option Strict On
Option Explicit On

' Graham-Scan Algorithmus - Siehe:
'  http://en.wikipedia.org/wiki/Graham_Scan
'  http://www.iti.fh-flensburg.de/lang/algorithmen/geo/graham.htm
'  http://www.cs.princeton.edu/~ah/alg_anim/version1/GrahamScan.html

Public Class frmMain
    Private m_Backbuffer As Bitmap

    Private m_Points As New List(Of Point)

    Private Sub Form1_Load(ByVal sender As Object, _
        ByVal e As System.EventArgs) Handles Me.Load

        m_Backbuffer = New Bitmap(picOut.Width, picOut.Height)
    End Sub

    Private Sub picOut_Paint(ByVal sender As Object, _
        ByVal e As System.Windows.Forms.PaintEventArgs) Handles picOut.Paint

        Call e.Graphics.DrawImage(m_Backbuffer, New Point(0, 0))
    End Sub

    Private Sub DrawPolygon(ByVal Polygon As Point(), _
        ByVal Color As Color, _
        ByVal Clear As Boolean, _
        Optional ByVal Size As Integer = 1)

        Using g = Graphics.FromImage(m_Backbuffer), Pen = New Pen(Color, Size)
            g.SmoothingMode = Drawing2D.SmoothingMode.HighQuality
            If Clear Then Call g.Clear(Color.White)
            If Polygon.Length >= 2 Then Call g.DrawPolygon(Pen, Polygon)
        End Using

        Call picOut.Invalidate()
    End Sub

    Private Sub picOut_MouseDown(ByVal sender As System.Object, _
        ByVal e As System.Windows.Forms.MouseEventArgs) Handles picOut.MouseDown

        Call m_Points.Add(e.Location)

        Call DrawPolygon(m_Points.ToArray(), _
            Color.FromArgb(75, Color.Blue), True)
        lblNumPoints.Text = String.Format("Polygon: {0} Punkt(e)", _
            m_Points.Count)
    End Sub

    Private Sub ScanToolStripMenuItem_Click(ByVal sender As System.Object, _
        ByVal e As System.EventArgs) Handles ScanToolStripMenuItem.Click

        Dim Ret = GrahamScan.ConvexHull(m_Points)

        Call DrawPolygon(Ret.ToArray(), Color.Green, False, 2)
        lblNumPoints.Text = String.Format("Hülle: {0} Punkt(e)", Ret.Count)
    End Sub

    Private Sub ClearToolStripMenuItem_Click(ByVal sender As System.Object, _
        ByVal e As System.EventArgs) Handles ClearToolStripMenuItem.Click

        m_Points = New List(Of Point)

        Call DrawPolygon(m_Points.ToArray(), Nothing, True)
        lblNumPoints.Text = String.Format("Polygon: 0 Punkt(e)", m_Points.Count)
    End Sub
End Class

' ##############################################################################
' ############################### GrahamScan.vb ################################
' ##############################################################################
Imports System.Drawing.Point

Module GrahamScan

    ' Liegt Punkt C links, rechts oder auf dem Vektor AB?
    Private Function Orientation(ByVal A As Point, _
        ByVal B As Point, ByVal C As Point) As Integer

        Return (B.X - A.X) * (C.Y - A.Y) - (C.X - A.X) * (B.Y - A.Y)
    End Function

    ' Minimalen Punkt (kleinste y-Koordinate) suchen
    Private Function Less(ByVal A As Point, ByVal B As Point) As Boolean
        Return (A.Y < B.Y) OrElse ((A.Y = B.Y) And (A.X < B.X))
    End Function

    Public Function ConvexHull( _
        ByVal RawPoints As IEnumerable(Of Point)) As IEnumerable(Of Point)

        If RawPoints.Count <= 3 Then Return RawPoints

        Dim Points = New List(Of Point)(RawPoints)

        ' "Kleinsten" Punkt suchen
        Dim MinIndex = Enumerable.Range(0, Points.Count).Aggregate( _
            Function(Min, idx) If(Less(Points(idx), Points(Min)), idx, Min))
        Dim MinPoint = Points(MinIndex)

        ' Minimum an Position 0 bringen
        Call Swap(Points(0), Points(MinIndex))

        ' Restliche Punkte von links nach rechts ihrem Winkel zum minimalen 
        '  Punkt nach sortieren
        Call Points.Sort(1, Points.Count - 1, _
            New FunctionComparer(Of Point)( _
                Function(a, b) Orientation(MinPoint, a, b)))

        ' Stapel für die Elemente
        Dim Stack As New List(Of Point)

        ' Erster und zweiter Punkt bilden die Ausgangssituation
        Call Stack.Add(Points(0))
        Call Stack.Add(Points(1))

        ' Alle weiteren Punkte durchgehen 
        For i = 2 To Points.Count - 1

            ' Vorhergehende Drehungen im Uhrzeigersinn, die nicht zur Hülle 
            '  gehören, löschen
            Do Until (Stack.Count < 2) OrElse _
                (Orientation(Stack(Stack.Count - 1), _
                    Stack(Stack.Count - 2), Points(i)) > 0)

                Call Stack.RemoveAt(Stack.Count - 1)
            Loop

            ' Punkt hinzufügen
            Call Stack.Add(Points(i))
        Next

        ' Stapel ausgeben
        Return Stack
    End Function

End Module
' ##############################################################################
' ################################# Helper.vb ##################################
' ##############################################################################
Option Strict On

' Hilfsfunktionen

' IComparer aus Delegaten/Lambda erstellen - .NET will's so
Class FunctionComparer(Of T) : Implements IComparer(Of T)
    Private ReadOnly m_Func As Comparison(Of T)

    Public Sub New(ByVal Func As Comparison(Of T))
        m_Func = Func
    End Sub

    Public Function Compare(ByVal x As T, _
        ByVal y As T) As Integer _
        Implements System.Collections.Generic.IComparer(Of T).Compare

        Return m_Func(x, y)
    End Function
End Class

Module Helper
    ' Tauschen von zwei Werten
    Public Sub Swap(Of T)(ByRef a As T, ByRef b As T)
        Dim tmp = a
        a = b
        b = tmp
    End Sub
End Module