Die Community zu .NET und Classic VB.
Menü

VB.NET-Tipp 0143: Kleinsten umschließenden Kreis (Minimum Bounding Ball) finden

 von 

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 Latex: \mathcal{O}(n^4). 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:

Schwierigkeitsgrad 3

Framework-Version(en):

.NET Framework 3.0, .NET Framework 3.5, .NET Framework 4

.NET-Version(en):

Visual Basic 2008, Visual Basic 2010

Download:

Download des Beispielprojektes [13,15 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:    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?