Tipp-Upload: VB.NET 0364: Graphen - Färbungsproblem

Über den Tipp  

Dieser Tippvorschlag ist noch unbewertet.

Der Vorschlag ist in den folgenden Kategorien zu finden:

• Algorithmen
• Grafik
• Mathematik
• Sonstiges

Dem Tippvorschlag wurden folgende Schlüsselwörter zugeordnet:
graph, karte, graph-coloring, färbung, färbungsproblem, greedy, 4-farben, vierfarben

Der Vorschlag wurde erstellt am: 26.04.2009 19:30.
Die letzte Aktualisierung erfolgte am 26.04.2009 19:30.

Zurück zur Übersicht

Beschreibung  

Ein sog. Graph ist eine häufig benötigte Datenstruktur. Er besteht aus einer Menge von Knoten (Punkten), die durch Kanten untereinander verbunden sind. Dieser Tipp zeigt den Umgang mit (ungerichteten) Graphen anhand des sog. Färbungsproblems, das z.B. in der Kartographie auftritt. Es geht hierbei darum, jedem Land auf einer Karte so eine Farbe zuzuordnen, dass kein Nachbarland die selbe Farbe besitzt. Dies lässt sich durch Graphen nachbilden. Zum Färben der Karte sind dabei nie mehr als vier Farben nötig.

Schwierigkeitsgrad

Verwendete API-Aufrufe:

Download: Download des Beispielprojektes [14,48 KB]

' Dieser Source 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!
'
' Beachten Sie, das vom Designer generierter Code hier ausgeblendet wird.
' In den Zip-Dateien ist er jedoch zu finden.

' --------- Anfang Projektgruppe Graph coloring.sln  ---------
' -------- Anfang Projektdatei Graph coloring.vbproj  --------
' ----------------- Anfang Datei frmMain.vb  -----------------
Option Strict On

Public Class frmMain

    Private ReadOnly m_Graph As New Graph(Of Node)
    Private ReadOnly m_Colors As Color() = {Color.Green, Color.Red, Color.Blue, Color.Yellow}

    ' Graphen löschen
    Private Sub LöschenToolStripMenuItem_Click(ByVal sender As System.Object, ByVal e As _
        System.EventArgs) Handles LöschenToolStripMenuItem.Click

        m_Graph.Clear()
        UpdateGraph()

    End Sub

    ' Graph neuzeichnen
    Private Sub UpdateGraph()

        Me.lblNodes.Text = m_Graph.Nodes.Count.ToString()
        Me.lblEdges.Text = m_Graph.NumEdges.ToString()
        Me.Invalidate()

    End Sub

    ' Färbung durchführen
    Private Sub FärbungBerechnenToolStripMenuItem_Click(ByVal sender As System.Object, ByVal _
        e As System.EventArgs) Handles FärbungBerechnenToolStripMenuItem.Click

        Dim Visited As New HashSet(Of Node)

        For Each Node In m_Graph.Nodes
            Node.Color = -1
        Next

        For Each Node In m_Graph.Nodes
            ColorRec(Node, Visited)
        Next

        UpdateGraph()

    End Sub

    ' Graph rekursiv färben
    Private Function ColorRec(ByVal Node As Node, ByVal Visited As HashSet(Of Node)) As Boolean

        If Visited.Contains(Node) Then Return True

        Dim Adjacents = m_Graph.Adjacents(Node)
        Dim AdjColors = Adjacents.Select(Function(a) a.Color)

        Visited.Add(Node)

        ' Alle möglichen Farben durchprobieren
        For ColorIndex = 0 To m_Colors.Count - 1

            ' Nachbarn dürfen keine gleichen Farben haben
            If Not AdjColors.Contains(ColorIndex) Then

                ' Einfärben
                Node.Color = ColorIndex

                ' Nachbarn rekursiv einfärben
                Dim Res As Boolean = True

                For Each Adj In Adjacents
                    Res = Res And ColorRec(Adj, Visited)
                Next

                ' Wenn es bis hierher geklappt hat, sind wir fertig
                If Res = True Then Return True
            End If

        Next

        ' Hier lief etwas schief
        Return False

    End Function

End Class

' ------------------ Ende Datei frmMain.vb  ------------------
' ------------------ Anfang Datei Graph.vb  ------------------
Option Strict On

Imports System.Collections.Generic

' Implementierung eines generischen Graphen
Public Class Graph(Of TNode)

    Implements IGraph(Of TNode)

    Private ReadOnly m_Nodes As New List(Of TNode)
    Private ReadOnly m_Edges As New Dictionary(Of TNode, HashSet(Of TNode))

    Public Sub AddNode(ByVal Node As TNode)

        m_Nodes.Add(Node)
        m_Edges(Node) = New HashSet(Of TNode)

    End Sub

    Public Sub AddEdge(ByVal Start As TNode, ByVal [End] As TNode)

        m_Edges(Start).Add([End])
        m_Edges([End]).Add(Start)

    End Sub

    Public Sub Clear()

        m_Nodes.Clear()
        m_Edges.Clear()

    End Sub

    Public Sub RemoveNode(ByVal Node As TNode)

        m_Nodes.Remove(Node)
        m_Edges.Remove(Node)

        For Each TempNode In Nodes
            m_Edges(TempNode).Remove(TempNode)
        Next

    End Sub

    Public Function Adjacents(ByVal Node As TNode) As System.Collections.Generic.IEnumerable( _
        Of TNode) Implements IGraph(Of TNode).Adjacents

        Return m_Edges(Node)

    End Function

    Public Function LinkedWith(ByVal A As TNode, ByVal B As TNode) As Boolean

        Return Adjacents(A).Contains(B)

    End Function

    Public ReadOnly Property Nodes() As System.Collections.Generic.IList(Of TNode) Implements _
        IGraph(Of TNode).Nodes

        Get
            Return m_Nodes

        End Get

    End Property

    Public ReadOnly Property NumEdges() As Long
        Get
            Return CLng(0.5 * Aggregate Edge In m_Edges Into Sum(Edge.Value.Count))

        End Get

    End Property

End Class

' ------------------- Ende Datei Graph.vb  -------------------
' ------------------- Anfang Datei GUI.vb  -------------------
Option Strict On

' GUI-Teil der Anwendung - Hier in Extra-Datei
Partial Class frmMain

    Private Const InnerRad As Integer = 4
    Private Const NodeRad As Integer = 6

    Private m_EdgeStart As Node = Nothing
    Private m_EdgeEnd As Node = Nothing
    Private m_CreatingEdge As Boolean = False

    Private m_Background As Image
    Private m_CurrentMouseLocation As Point

    ' Knoten über Mauskoordinaten suchen
    Private Function HoveredNode(ByVal Pos As Point, Optional ByVal f As Double = 1) As Node

        Return m_Graph.Nodes.FirstOrDefault(Function(Node) ((Node.Position.X - Pos.X) ^ 2 + ( _
            Node.Position.Y - Pos.Y) ^ 2) <= f * NodeRad ^ 2)

    End Function

    ' Neuen Knoten oder neue Kante erstellen
    Private Sub Form1_MouseDown(ByVal sender As Object, ByVal e As _
        System.Windows.Forms.MouseEventArgs) Handles Me.MouseDown

        If e.Button = Windows.Forms.MouseButtons.Left Then

            Dim HitNode = HoveredNode(e.Location)

            If HitNode Is Nothing AndAlso HoveredNode(e.Location, 4) Is Nothing Then
                m_Graph.AddNode(New Node(e.X, e.Y))

            ElseIf HitNode IsNot Nothing Then

                m_EdgeStart = HitNode
                m_CreatingEdge = True
            End If

        ElseIf e.Button = Windows.Forms.MouseButtons.Right Then

            Dim HitNode = HoveredNode(e.Location)

            If HitNode IsNot Nothing Then m_Graph.RemoveNode(HitNode)
        End If

        UpdateGraph()

    End Sub

    ' Eventuell Auswahllinie anzeigen
    Private Sub Form1_MouseMove(ByVal sender As Object, ByVal e As _
        System.Windows.Forms.MouseEventArgs) Handles Me.MouseMove

        m_CurrentMouseLocation = e.Location

        If m_CreatingEdge Then

            Dim HitNode = HoveredNode(e.Location)

            If HitNode IsNot Nothing AndAlso HitNode IsNot m_EdgeStart AndAlso Not _
                m_Graph.LinkedWith(m_EdgeStart, HitNode) Then

                m_EdgeEnd = HitNode

            Else

                m_EdgeEnd = Nothing
            End If

            UpdateGraph()
        End If

    End Sub

    ' Eventuell neue Kante erzeugen
    Private Sub Form1_MouseUp(ByVal sender As Object, ByVal e As _
        System.Windows.Forms.MouseEventArgs) Handles Me.MouseUp

        If m_CreatingEdge Then
            If m_EdgeEnd IsNot Nothing Then m_Graph.AddEdge(m_EdgeStart, m_EdgeEnd)

            m_EdgeEnd = Nothing
            m_EdgeStart = Nothing
            m_CreatingEdge = False
            UpdateGraph()
        End If

    End Sub

    ' Graphen zeichnen
    Private Sub Form1_Paint(ByVal sender As Object, ByVal e As _
        System.Windows.Forms.PaintEventArgs) Handles Me.Paint

        Dim g = e.Graphics

        g.Clear(Color.White)
        g.SmoothingMode = Drawing2D.SmoothingMode.HighQuality

        If m_Background IsNot Nothing Then g.DrawImage(m_Background, New Rectangle(0, 0, _
            Me.Width, Me.Height))

        Using BorderPen = New Pen(Color.Black, 1), LinePen = New Pen(Color.Blue, 1), _
            HighlightLinePen = New Pen(Color.Red, 1)

            If m_CreatingEdge Then g.DrawLine(HighlightLinePen, m_EdgeStart.Position, _
                m_CurrentMouseLocation)

            For Each Node In m_Graph.Nodes
                For Each Adj In m_Graph.Adjacents(Node)
                    g.DrawLine(LinePen, Node.Position, Adj.Position)
                Next
            Next

            For Each Node In m_Graph.Nodes

                Dim BorderColor = If(Node Is m_EdgeStart Or Node Is m_EdgeEnd, Color.Orange, _
                    Color.White)

                Dim FillColor = m_Colors(If(Node.Color >= 0, Node.Color, 0))

                Using FillBrush = New SolidBrush(FillColor), BorderBrush = New SolidBrush( _
                    BorderColor)

                    g.FillEllipse(BorderBrush, New Rectangle(Node.Position.X - NodeRad, _
                        Node.Position.Y - NodeRad, 2 * NodeRad, 2 * NodeRad))

                    g.DrawEllipse(BorderPen, New Rectangle(Node.Position.X - NodeRad, _
                        Node.Position.Y - NodeRad, 2 * NodeRad, 2 * NodeRad))

                    g.FillEllipse(FillBrush, New Rectangle(Node.Position.X - InnerRad, _
                        Node.Position.Y - InnerRad, 2 * InnerRad, 2 * InnerRad))

                    g.DrawEllipse(BorderPen, New Rectangle(Node.Position.X - InnerRad, _
                        Node.Position.Y - InnerRad, 2 * InnerRad, 2 * InnerRad))

                End Using

            Next

        End Using

    End Sub

    ' Hintergrundbild laden
    Private Sub HintergrundbildLadenToolStripMenuItem_Click(ByVal sender As System.Object, _
        ByVal e As System.EventArgs) Handles HintergrundbildLadenToolStripMenuItem.Click

        OpenFileDialog1.ShowDialog()

        If OpenFileDialog1.FileName <> "" Then
            m_Background = New Bitmap(OpenFileDialog1.FileName)
            UpdateGraph()
        End If

    End Sub

End Class

' -------------------- Ende Datei GUI.vb  --------------------
' ------------------ Anfang Datei IGraph.vb ------------------
Option Strict On

Imports System.Collections.Generic

' Schnittstelle für Graphen
Public Interface IGraph(Of TNode)

    ReadOnly Property Nodes() As IList(Of TNode)

    Function Adjacents(ByVal Node As TNode) As IEnumerable(Of TNode)

End Interface

' ------------------- Ende Datei IGraph.vb -------------------
' ------------------- Anfang Datei Node.vb -------------------
Option Strict On

Friend Class Node

    Private ReadOnly m_Pos As Point
    Private m_Color As Integer = -1

    Public ReadOnly Property Position() As Point
        Get
            Return m_Pos

        End Get

    End Property

    Public Sub New(ByVal x As Integer, ByVal y As Integer)

        m_Pos = New Point(x, y)

    End Sub

    Public Property Color() As Integer
        Get
            Return m_Color

        End Get

        Set(ByVal value As Integer)
            m_Color = value

        End Set

    End Property

End Class

' -------------------- Ende Datei Node.vb --------------------
' --------- Ende Projektdatei Graph coloring.vbproj  ---------
' ---------- Ende Projektgruppe Graph coloring.sln  ----------

	

Diskussion  

Diese Funktion ermöglicht es, Fragen, die die Veröffentlichung des Tipps betreffen, zu klären, oder Anregungen und Verbesserungsvorschläge einzubringen. Nach der Veröffentlichung des Tipps werden diese Beiträge nicht weiter verlinkt. Allgemeine Fragen zum Inhalt sollten daher hier nicht geklärt werden.
Folgende Diskussionen existieren bereits

Um eine Diskussion eröffnen zu können, müssen sie angemeldet sein.