VB.NET-Tipp 0143: Kleinsten umschließenden Kreis (Minimum Bounding Ball) finden
von Dario
Beschreibung
In diesem Tipp wird gezeigt, wie man effizient den kleinsten umgebenden Kreis für eine Punktemenge findet. Der "direkte" Algorithmus hat die astronomische Komplexität von . Das hier vorgestellte Fahren ist ein zufallsbasierter Algorithmus, der in linearer Laufzeit zur Lösung kommt. Eine ausführlichere Abhandlung zum Algorithmus findet sich hier: http://www-i1.informatik.rwth-aachen.de/~algorithmus/algo42.php
Als weitere Optimierung könnte man nur den umschließenden Kreis für die konvexe Hülle suchen: Graham-Scan: Konvexe Hülle eines Polygons berechnen [Tipp 113]
Schwierigkeitsgrad: | Framework-Version(en): .NET Framework 3.0, .NET Framework 3.5, .NET Framework 4 | .NET-Version(en): Visual Basic 2008, Visual Basic 2010 | Download: |
' 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: An ' 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 ' ' ############################################################################## ' ################################# Circle.vb ################################## ' ############################################################################## Option Strict On Structure Circle Public ReadOnly Radius As Double Public ReadOnly Center As Point Public Sub New(ByVal Center As Point, ByVal Radius As Double) Me.Radius = Radius Me.Center = Center End Sub Public Sub New(ByVal A As Point, ByVal B As Point, ByVal C As Point) B = New Point(B.X - A.X, B.Y - A.Y) C = New Point(C.X - A.X, C.Y - A.Y) Dim D = 2 * (B.X * C.Y - B.Y * C.X) D = If(D = 0, 1, D) Dim X = (C.Y * (B.X ^ 2 + B.Y ^ 2) - B.Y * (C.X ^ 2 + C.Y ^ 2)) / D Dim Y = (B.X * (C.X ^ 2 + C.Y ^ 2) - C.X * (B.X ^ 2 + B.Y ^ 2)) / D Dim O = New Point(0, 0) Dim sa = Math.Sqrt(DistanceSq(O, B)) Dim sb = Math.Sqrt(DistanceSq(O, C)) Dim sc = Math.Sqrt(DistanceSq(B, C)) Dim di = (2 * sa * sb * sc) / Math.Sqrt((sa + sb + sc) * _ (-sa + sb + sc) * (sa - sb + sc) * (sa + sb - sc)) Me.Radius = di / 1.9 Me.Center = New Point(CInt(A.X + X), CInt(A.Y + Y)) End Sub Public Function Contains(ByVal p As Point) As Boolean Return DistanceSq(p, Center) <= Radius ^ 2 End Function Public Sub Draw(ByVal g As Graphics) Using Pen = New Pen(Color.FromArgb(42, Color.Blue)) Try Call g.DrawEllipse(Pen, New Rectangle(CInt(Center.X - Radius), _ CInt(Center.Y - Radius), _ CInt(2 * Radius), _ CInt(2 * Radius))) Catch ex As ArithmeticException End Try End Using End Sub End Structure ' ############################################################################## ' ################################# Form1.vb ################################### ' ############################################################################## Option Strict On Imports System.Collections.Generic Public Class Form1 Private m_Backbuffer As Image Private m_Points As New List(Of Point) Private m_Times As New List(Of ULong) Private m_Generation As Integer = 0 Private Const r As Integer = 1 Private Sub Form1_Load(ByVal sender As Object, _ ByVal e As System.EventArgs) Handles Me.Load m_Backbuffer = New Bitmap(picOut.Width, picOut.Height) Dim Rand As New Random Do Until m_Points.Count >= 500 Dim P = New Point(Rand.Next(80, picOut.Width - 80), _ Rand.Next(50, picOut.Height - 80)) If ((P.X - Width / 2) ^ 2 + (P.Y - Height / 2) ^ 2) < 180 ^ 2 _ OrElse Rand.NextDouble() < 0.1 Then Call m_Points.Add(P) Loop Call DrawPoints(m_Points, Color.Orange) 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 DrawPoints(m_Points, Color.Orange, True) m_Generation = 0 lblGeneration.Text = "Eingabe" End Sub Private Sub picOut_Paint(ByVal sender As System.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 LöschenToolStripMenuItem_Click(ByVal sender As System.Object, _ ByVal e As System.EventArgs) Handles LöschenToolStripMenuItem.Click Call m_Points.Clear() Call DrawPoints(m_Points, Color.Orange, True) m_Generation = 0 lblGeneration.Text = "Eingabe" End Sub Private Sub DrawPoints(ByVal Points As IEnumerable(Of Point), _ ByVal Color As Color, _ Optional ByVal Clear As Boolean = False) Using g = Graphics.FromImage(m_Backbuffer) g.SmoothingMode = Drawing2D.SmoothingMode.HighQuality If Clear Then g.Clear(Color.White) For Each Point In Points Using Br = New SolidBrush(Color) Call g.FillEllipse(Br, _ New Rectangle(Point.X - r, Point.Y - r, 2 * r, 2 * r)) End Using Next End Using Call picOut.Invalidate() End Sub Private Sub BerechnenToolStripMenuItem_Click( _ ByVal sender As System.Object, _ ByVal e As System.EventArgs) _ Handles BerechnenToolStripMenuItem.Click Dim Rand As New Random If m_Points.Count < 3 Then Exit Sub Dim Ball As Circle If m_Points.Count > 20 Then ' Stimmen initialisieren If m_Generation = 0 Then Call m_Times.Clear() For i = 0 To m_Points.Count - 1 Call m_Times.Add(1) Next End If ' Nächste Generation m_Generation += 1 ' Indizes und ausgewählte Punkte speichern Dim Indices As New HashSet(Of Integer) Dim RandomPoints As New List(Of Point) ' Gesamtzahl der Stimmen Dim Length = m_Times.Aggregate(Function(s, i) s + i) ' 20 zufällige, per Stimmzahl gewichtete Punkte wählen Do Until RandomPoints.Count >= 20 Dim Index = Rand.Next(0, CInt(Length)) If Not Indices.Contains(Index) Then Dim n = 0UL Dim PointIndex = 0 While n <= Index n += m_Times(PointIndex) PointIndex += 1 End While Call RandomPoints.Add(m_Points(PointIndex - 1)) Call Indices.Add(Index) End If Loop ' Fehler zählen und Stimmen angleichen Dim NumMistakes = 0 Ball = CreateBallNaive(RandomPoints) For i = 0 To m_Points.Count - 1 If Not Ball.Contains(m_Points(i)) Then m_Times(i) *= 2UL NumMistakes += 1 End If Next ' Ab hier ist nur noch Ausgabe lblMistakes.Text = String.Format("Noch {0} Fehler", NumMistakes) lblGeneration.Text = String.Format("{0}. Generation", m_Generation) lblRad.Text = String.Format("Radius: {0} ", _ Math.Round(Ball.Radius, 0)) Else Ball = CreateBallNaive(m_Points) Call MessageBox.Show("Zu wenig Punkte - Löse direkt", "", _ MessageBoxButtons.OK, _ MessageBoxIcon.Information) End If Using g = Graphics.FromImage(m_Backbuffer) g.SmoothingMode = Drawing2D.SmoothingMode.HighQuality Call g.Clear(Color.White) For Each Point In m_Points Call g.FillEllipse( _ If(Ball.Contains(Point), Brushes.Green, Brushes.Red), _ New Rectangle(Point.X - r, Point.Y - r, 2 * r, 2 * r)) Next Call Ball.Draw(g) End Using Call picOut.Invalidate() End Sub ' Naiver Brute Force-Algorithmus zum Finden des Bounding Balls - O(n^4) Private Function CreateBallNaive(ByVal Points As IList(Of Point)) As Circle Dim Changed As Boolean Dim Best As New Circle(Points(0), Points(1), Points(2)) ' Alle sinnvollen 3-Punkte-Kombinationen finden, Kreis errechnen und ' schauen, welche die Beste ist For i = 0 To Points.Count - 1 For j = i + 1 To Points.Count - 1 For k = j + 1 To Points.Count - 1 Dim ContainsAll As Boolean = True Dim Current = New Circle(Points(i), Points(j), Points(k)) For l = 0 To Points.Count - 1 Dim Pnt = Points(l) If (Pnt <> Points(i)) AndAlso _ (Pnt <> Points(j)) AndAlso _ (Pnt <> Points(k)) AndAlso _ (Not Current.Contains(Pnt)) Then ContainsAll = False Exit For End If Next If ContainsAll And _ ((Current.Radius < Best.Radius) Or Not Changed) Then Changed = True Best = Current End If Next Next Next Return Best End Function End Class ' ############################################################################## ' ################################# Helper.vb ################################## ' ############################################################################## Public Module Helper Public Function DistanceSq(ByVal a As Point, ByVal b As Point) As Double Return (a.X - b.X) ^ 2 + (a.Y - b.Y) ^ 2 End Function End Module
Ihre Meinung
Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.
Archivierte Nutzerkommentare
Klicken Sie diesen Text an, wenn Sie die 1 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.
Kommentar von DerTester am 16.10.2011 um 17:47
Super cooler Tipp Darion. Geht das auch mit VBC?