Class MainWindow
'Stores all the points that you can use to create a Voronoi diagram
Private points As New PointCollection
'Stores the boundary were we are interested in showing the Voronoi diagram
Private box As New Boundary
'Stores the points that is visible in the beach line
Dim BeachLinePoints As New PointCollection
'Circle events are stored here
Dim CircleEv As New List(Of Circle)
'
Dim AllCreatedLines As New List(Of VoronoiLine)
Dim AllActiveLines As New List(Of VoronoiLine)
Private Sub Canvas1_MouseDown(sender As System.Object, e As System.Windows.Input.MouseButtonEventArgs)
'Get the location of the mouse and store it
Dim LocationOfNewPoint As New Point
LocationOfNewPoint = e.GetPosition(Canvas1)
'Stor the point for future use
points.Add(LocationOfNewPoint)
'Creat a reprensentation of the point
Dim NewPoint As New Ellipse
NewPoint.Fill = Brushes.Black
NewPoint.StrokeThickness = 2
NewPoint.Stroke = Brushes.Black
' Set the width and height of the Ellipse.
NewPoint.Width = 5
NewPoint.Height = 5
'Add the ellipse to the canvas
Canvas1.Children.Add(NewPoint)
'Set the x and y coordinates to get the ellipse centered around the point
'If you dont substract Radius/2 (with is 2.5 in this case) your center point would be wrong
Canvas.SetLeft(NewPoint, LocationOfNewPoint.X - 2.5)
Canvas.SetTop(NewPoint, LocationOfNewPoint.Y - 2.5)
End Sub
#Region "Bondary class for Voronoi diagram"
Public Class Boundary
'You cant set these variables outside the function
Private _TopLeft As New Point
Private _BottomRight As New Point
'In case you change the increase the values are stored
Private pSortedByXdirection, pSortedByYdirection As New PointCollection
Public ReadOnly Property TopLeft() As Point
Get
Return _TopLeft
End Get
End Property
Public ReadOnly Property BottomRight() As Point
Get
Return _BottomRight
End Get
End Property
#Region "Constructors"
Sub New(ByVal pTopLeft As Point, pBottomRight As Point)
_TopLeft = pTopLeft
_BottomRight = pBottomRight
End Sub
Sub New(ByVal SortedByX_directioon As PointCollection, ByVal SortedByYdirection As PointCollection)
CalculateBondariesFromPointCollection(SortedByX_directioon, SortedByYdirection)
pSortedByXdirection = SortedByX_directioon
pSortedByYdirection = SortedByYdirection
End Sub
Sub New(ByVal OriginalPointcollection As PointCollection)
pSortedByXdirection = SortPoints(OriginalPointcollection, True)
pSortedByYdirection = SortPoints(OriginalPointcollection, False)
CalculateBondariesFromPointCollection(pSortedByXdirection, pSortedByYdirection)
End Sub
Sub New()
End Sub
#End Region
''' <summary>
''' Returns a sorted pointcollection based on Lexografically sorting
''' </summary>
''' <param name="samplepoints"></param>
''' <param name="SortByXdirection"></param>
''' <returns></returns>
''' <remarks></remarks>
Private Function SortPoints(ByVal samplepoints As PointCollection, ByVal SortByXdirection As Boolean) As PointCollection
'Create another array so we can keep the original array out of order
Dim copySamplePoints As Point() = New Point(samplepoints.Count - 1) {}
samplepoints.CopyTo(copySamplePoints, 0)
If SortByXdirection Then
Array.Sort(copySamplePoints, New PointSort(PointSort.Mode.X))
Else
Array.Sort(copySamplePoints, New PointSort(PointSort.Mode.Y))
End If
Dim result As New PointCollection
For Each p As Point In copySamplePoints
result.Add(p)
Next
Return result
End Function
Private Class PointSort
Implements IComparer
Public Enum Mode
X
Y
End Enum
Private currentMode As Mode = Mode.X
Public Sub New(ByVal mode As Mode)
currentMode = mode
End Sub
'Comparing function
'Returns one of three values - 0 (equal), 1 (greater than), -1 (less than)
Private Function IComparer_Compare(ByVal a As Object, ByVal b As Object) As Integer Implements IComparer.Compare
Dim point1 As Point = CType(a, Point)
Dim point2 As Point = CType(b, Point)
If currentMode = Mode.X Then
'Compare X values
If point1.X > point2.X Then
Return 1
ElseIf point1.X < point2.X Then
Return -1
Else
If point1.Y > point2.Y Then
Return 1
ElseIf point1.Y < point2.Y Then
Return -1
Else 'Identical points
Return 0
End If
End If
Else
If point1.Y > point2.Y Then
'Compare Y Values
Return 1
ElseIf point1.Y < point2.Y Then
Return -1
Else 'Y1 = Y2
If point1.X > point2.X Then
'Compare Y Values
Return 1
ElseIf point1.X < point2.X Then
Return -1
Else 'Identical points
Return 0
End If
End If
End If
End Function
End Class
Private Sub CalculateBondariesFromPointCollection(ByVal SortedByX_directioon As PointCollection, ByVal SortedByYdirection As PointCollection)
Dim p1, p2, p3, p4 As New Point
p1 = SortedByX_directioon(0)
p2 = SortedByYdirection(0)
'Temporary storage of min and max values in the pointcollection
Dim Xmin, Ymin, Xmax, Ymax As Double
If p1.X < p2.X Then
Xmin = p1.X
Else
Xmin = p2.X
End If
If p1.Y < p2.Y Then
Ymin = p1.Y
Else
Ymin = p2.Y
End If
p3 = SortedByX_directioon(SortedByX_directioon.Count - 1)
p4 = SortedByYdirection(SortedByYdirection.Count - 1)
If p3.X < p4.X Then
Xmax = p4.X
Else
Xmax = p3.X
End If
If p3.Y < p4.Y Then
Ymax = p4.Y
Else
Ymax = p3.Y
End If
'We are going to base the increase at the Width and Height of the rectangle
'so we are going to performe some calculations in order to make these adjustments
Dim height As Double = Math.Abs(Ymax - Ymin)
Dim width As Double = Math.Abs(Xmax - Xmin)
'Scale the with and height in order to add and substract the values to Y and X
Dim _height As Double = height * (ProcentIncrease) / 100
Dim _width As Double = width * (ProcentIncrease) / 100
'Store the final values
_TopLeft = New Point(Xmin - _width, Ymin - _height)
_BottomRight = New Point(Xmax + _width, Ymax + _height)
End Sub
Public Sub ReturnRectangle(ByVal can As Canvas)
Dim p As New Rectangle
p.Fill = Nothing
p.StrokeThickness = 2
p.Stroke = Brushes.Blue
' Set the width and height of the Rectangle.
' The values can be negative therefore the Math.Abs
p.Width = Math.Abs(_BottomRight.X - _TopLeft.X)
p.Height = Math.Abs(_BottomRight.Y - _TopLeft.Y)
can.Children.Add(p)
Canvas.SetLeft(p, _TopLeft.X)
Canvas.SetTop(p, _TopLeft.Y)
End Sub
Public Function CutLinesToBoundaries() As Object
Return Nothing
End Function
'In reality the value of 50 (width is incresed by the factor 1.5) that would increase the bondaries with 25% on all sides
' To use it you simply write in the increase at for instance 40 (percent)
Private _ProcentIncrease As Double = 50
Public Property ProcentIncrease() As Double
Get
Return _ProcentIncrease
End Get
Set(ByVal value As Double)
_ProcentIncrease = (value)
'Value is changed we need to update the topmost and bottommost points
CalculateBondariesFromPointCollection(pSortedByXdirection, pSortedByYdirection)
End Set
End Property
End Class
#End Region
Private Sub Button1_Click(sender As System.Object, e As System.Windows.RoutedEventArgs) Handles btn_Voronoi.Click
'We need to sort the points according to the Y direction
If points.Count = 0 Then
Exit Sub
ElseIf points.Count = 1 Then
'Return the box
End If
Dim SortedPointCollection_Y As New PointCollection
SortedPointCollection_Y = SortPoints(points, False)
Dim tempbox As New Boundary(New Point(0, 0), New Point(Canvas1.Width, Canvas1.Height))
box = tempbox
Dim NoOfCirclesEvents As Integer = 0
AllCreatedLines.Add(New VoronoiLine)
For i As Integer = 1 To SortedPointCollection_Y.Count - 1
If i = 1 Then
'The first two points cant form a circle event by themselves so we ignore the circle check to save time
Dim first As New VoronoiLine
first.ParabolicCut(SortedPointCollection_Y(i - 1), SortedPointCollection_Y(i), SortedPointCollection_Y(i - 1).Y)
' Canvas1.Children.Add(first.CutLinesByBoundaries(box))
first.VoronoiParent = AllCreatedLines(0)
AllCreatedLines.Add(first)
'The first two point will be a part of our points that will, through the arcs,
'form our beach line. We only need to store its generation points here tough.
BeachLinePoints.Add(SortedPointCollection_Y(i - 1))
BeachLinePoints.Add(SortedPointCollection_Y(i))
Else
'We only check if the new point forms any circles ABOVE the sweep line
' Problem one point can form several valid circles
Dim TempCircle As New Circle
TempCircle = CircleEvent(SortedPointCollection_Y(i))
If Not TempCircle.IsEmpty Then
NoOfCirclesEvents += 1
TempCircle.AddVoronoiLines(AllCreatedLines)
CircleEv.Add(TempCircle)
BeachLinePoints.Add(SortedPointCollection_Y(i))
Else
' No circles found, the question now is were sould our new point be placed?
' It would have to be one of the lines that is a parent of the empty first line for now...
Dim index As Integer = Nothing
Dim min As Double = Nothing
For k As Integer = 0 To BeachLinePoints.Count - 1
If Not LinesExist(SortedPointCollection_Y(i), BeachLinePoints(k)) And Not SortedPointCollection_Y(i) = BeachLinePoints(k) Then
Dim temp As Double = SortedPointCollection_Y(i).Y - Intersection2(SortedPointCollection_Y(i), BeachLinePoints(k), SortedPointCollection_Y(i).Y)
If min = Nothing Then
index = k
min = temp
Else
If min > temp Then
index = k
min = temp
End If
End If
End If
Next
Dim first As New VoronoiLine
first.ParabolicCut(SortedPointCollection_Y(i), BeachLinePoints(index), SortedPointCollection_Y(i).Y)
first.VoronoiParent = AllCreatedLines(0)
AllCreatedLines.Add(first)
BeachLinePoints.Add(SortedPointCollection_Y(i))
End If
End If
Next
For i As Integer = 1 To AllCreatedLines.Count - 1
AllCreatedLines(i).CutLinesByBoundaries(box)
Canvas1.Children.Add(AllCreatedLines(i).GetLine)
Next
stLines.Content = "Number of lines added: " & AllCreatedLines.Count - 1 & " : Nomber of circles: " & NoOfCirclesEvents.ToString
End Sub
''' <summary>
''' Finds the index of a line that contains one point in the circle
''' </summary>
''' <param name="cir"></param>
''' <returns></returns>
''' <remarks></remarks>
Private Function FindDiagram(ByVal cir As Circle) As Integer
For i As Integer = 1 To AllCreatedLines.Count - 1
If cir.Contains(AllCreatedLines(i)) Then
Return i
End If
Next
Return -1
End Function
Private Function GetVoroNoiGraph() As List(Of VoronoiGraphPoint)
Dim result As New List(Of VoronoiGraphPoint)
For i As Integer = 0 To points.Count - 1
Dim Center As New Point
Dim Lines As New Polygon
Center = points(i)
Dim Enclosed As Boolean = False
For j As Integer = 1 To AllCreatedLines.Count - 1
If AllCreatedLines(j).Contains(Center) Then
'Important to check this befor the lines are added, else the first added point will ensure that it is enclosed
If Lines.Points.Contains(AllCreatedLines(j).StartPoint) And Lines.Points.Contains(AllCreatedLines(j).EndPoint) Then
Enclosed = True
End If
If Not Lines.Points.Contains(AllCreatedLines(j).StartPoint) Then
Lines.Points.Add(AllCreatedLines(j).StartPoint)
End If
If Not Lines.Points.Contains(AllCreatedLines(j).EndPoint) Then
Lines.Points.Add(AllCreatedLines(j).EndPoint)
End If
End If
Next
result.Add(New VoronoiGraphPoint(Center, Lines, Enclosed))
Canvas1.Children.Add(result(i).VoronoiPolygon)
Next
For Each p As VoronoiGraphPoint In result
If Not p.Enclosed Then
' The have the same bondary line
'They have opposite bonday lines
'The have the same corner bondary
'They have just two separate lines, it is possible that you would need ot rearrange the poitns
Debug.WriteLine("Polygon not enclosed")
End If
Next
Return result
End Function
Public Class VoronoiGraphPoint
Sub New()
End Sub
Sub New(ByVal p As Point, ByVal pp As Polygon)
CenterPoint = p
VoronoiPolygon = pp
VoronoiPolygon.Fill = Brushes.Blue
VoronoiPolygon.Stroke = Brushes.Black
VoronoiPolygon.StrokeThickness = 2
End Sub
Sub New(ByVal p As Point, ByVal pp As Polygon, ByVal pEnclosed As Boolean)
CenterPoint = p
VoronoiPolygon = pp
VoronoiPolygon.Fill = Brushes.Blue
VoronoiPolygon.Stroke = Brushes.Black
VoronoiPolygon.StrokeThickness = 2
Me.Enclosed = pEnclosed
End Sub
Private _Enclosed As Boolean = False
Public Property Enclosed() As Boolean
Get
Return _Enclosed
End Get
Set(ByVal value As Boolean)
_Enclosed = value
End Set
End Property
Private _CenterPoint As Point
Public Property CenterPoint() As Point
Get
Return _CenterPoint
End Get
Set(ByVal value As Point)
_CenterPoint = value
End Set
End Property
Private _VoronoiPolygon As Polygon
Public Property VoronoiPolygon() As Polygon
Get
Return _VoronoiPolygon
End Get
Set(ByVal value As Polygon)
_VoronoiPolygon = value
End Set
End Property
End Class
Private Function LinesExist(ByVal p1 As Point, ByVal p2 As Point) As Boolean
Dim result As Boolean = False
For Each p As VoronoiLine In AllCreatedLines
If p.Contains(p1) And p.Contains(p2) Then
result = True
End If
Next
Return result
End Function
Private Function CircleEvent(ByVal p As Point) As Circle
'We would have to find the circle event in one of the previous created lines
For i As Integer = 1 To AllCreatedLines.Count - 1
Dim G As New Circle
G.CreatCircleFromVoronoiLine(AllCreatedLines(i), p)
'TODO: Need to fix the situation with two voronoi lines
If Not DoesBeachLineHAvePointsInsideThisCircle(G) Then
Return G
End If
Next
Dim G2 As New Circle
G2.IsEmpty = True
Return G2
End Function
Private Function DoesBeachLineHAvePointsInsideThisCircle(ByVal c As Circle) As Boolean
For Each p As Point In points
If Not c.CreationPoints.Contains(p) Then
If c.DoesCircleContainPoint(p) Then
Return True
End If
End If
Next
Return False
End Function
''' <summary>
''' Returns the y value construcked by the event from the newpoint and the contructed arc of the oldpoint
''' </summary>
''' <param name="NewPoint">This is the point on the sweep line</param>
''' <param name="OldPoint">This is one point above the sweep line</param>
''' <param name="SweepLine">Y position of the sweep line</param>
''' <returns>Calculates the distance fromn a point (NewPoint) to the Parabolic arc generated by the OldPoint and the Sweep line</returns>
''' <remarks>The Function only gives you the Y value of the position on the parabolic intersection given the X location</remarks>
Private Function Intersection2(ByVal NewPoint As Point, ByVal OldPoint As Point, ByVal SweepLine As Double) As Double
Dim res As Double
res = (1 / (2 * ((OldPoint.Y) - SweepLine)))
res *= (NewPoint.X ^ 2 - 2 * OldPoint.X * NewPoint.X + OldPoint.X ^ 2 + OldPoint.Y ^ 2 - SweepLine ^ 2)
Return (res)
End Function
'Lines appers at every conjunction between two points,
Public Class VoronoiLine
Sub New()
End Sub
Private _VoronoiParent As VoronoiLine
Public Property VoronoiParent() As VoronoiLine
Get
Return _VoronoiParent
End Get
Set(ByVal value As VoronoiLine)
_VoronoiParent = value
End Set
End Property
Private _VoronoiChildren As New List(Of VoronoiLine)
Public Property VoronoiChildren() As List(Of VoronoiLine)
Get
Return _VoronoiChildren
End Get
Set(ByVal value As List(Of VoronoiLine))
_VoronoiChildren = value
End Set
End Property
'A check to see if one of the points is the same as the creation point
Public Function Contains(ByVal P As Point) As Boolean
If CreationPointLeft = P Or CreationPointRight = P Then
Return True
Else
Return False
End If
End Function
''' <summary>
''' Finds which side of a line the point is
''' </summary>
''' <param name="PointToBeEvaluated">Evaluation point</param>
''' <returns>-1 for a point to the right, 0 for a point on the line, +1 for a point to the left</returns>
''' <remarks></remarks>
Public Function WhichSide(ByVal PointToBeEvaluated As Point) As Integer
Dim ReturnvalueEquation As Double
ReturnvalueEquation = ((PointToBeEvaluated.Y - Me.StartPoint.Y) _
* (Me.EndPoint.X - Me.StartPoint.X)) - ((Me.EndPoint.Y - Me.StartPoint.Y) _
* (PointToBeEvaluated.X - Me.StartPoint.X))
If ReturnvalueEquation > 0 Then
Return -1
ElseIf ReturnvalueEquation = 0 Then
Return 0
Else
Return 1
End If
End Function
Private _CreationPointRight As New Point
Public Property CreationPointRight() As Point
Get
Return _CreationPointRight
End Get
Set(ByVal value As Point)
_CreationPointRight = value
End Set
End Property
Private _StartPointCreatedByCircle As Boolean = False
Public Property StartPointCreatedByCircle() As Boolean
Get
Return _StartPointCreatedByCircle
End Get
Set(ByVal value As Boolean)
_StartPointCreatedByCircle = value
End Set
End Property
Private _EndPointCreatedByCircle As Boolean = False
Public Property EndPointCreatedByCircle() As Boolean
Get
Return _EndPointCreatedByCircle
End Get
Set(ByVal value As Boolean)
_EndPointCreatedByCircle = value
End Set
End Property
Private _CreationPointLeft As New Point
Public Property CreationPointLeft() As Point
Get
Return _CreationPointLeft
End Get
Set(ByVal value As Point)
_CreationPointLeft = value
End Set
End Property
'Use this if you want to cut the lines afterword
Sub New(ByVal p1 As Point, ByVal p2 As Point)
'In this class it is irrelevant witch point is the startpoint
'and witch is the endpoint, as they are only used to calculate
'the line equation coefficients first.
StartPoint = p1
EndPoint = p2
End Sub
'Use this if you want to cut the lines at creation
Sub New(ByVal p1 As Point, ByVal p2 As Point, ByVal b As Boundary)
'In this class it is irrelevant witch point is the startpoint
'and witch is the endpoint, as they are only used to calculate
'the line equation coefficients. However they cant be equal.
StartPoint = p1
EndPoint = p2
CutLinesByBoundaries(b)
End Sub
Private _StartPoint As New Point
Public Property StartPoint() As Point
Get
Return _StartPoint
End Get
Set(ByVal value As Point)
_StartPoint = value
End Set
End Property
Private _EndPoint As New Point
Public Property EndPoint() As Point
Get
Return _EndPoint
End Get
Set(ByVal value As Point)
_EndPoint = value
End Set
End Property
'It is important to notice that another line event would never cut an existing line!
'A line can only be cut if one of these two events below occurs!
'All the calculated lines must in any event be cut by the boundaries
'This is mearly a test function and has to be changed later on.
Public Function CutLinesByBoundaries(ByVal Box As Boundary) As Polyline
' We first calculate the equation coefficients
CalculateLineEquation(StartPoint, EndPoint)
Dim TempTopY, TempTopX, TempBottomY, TempBottomX As Double
TempTopY = Box.TopLeft.X * A + B
TempTopX = (Box.TopLeft.Y - B) / A
TempBottomY = Box.BottomRight.X * A + B
TempBottomX = (Box.BottomRight.Y - B) / A
'Deals with startpoint
If Not StartPointCreatedByCircle Then
If TempTopX > Box.TopLeft.X Then
If TempTopX < Box.BottomRight.X Then
StartPoint = New Point(TempTopX, Box.TopLeft.Y)
Else
StartPoint = New Point(Box.BottomRight.X, TempBottomY)
End If
Else
StartPoint = New Point(Box.TopLeft.X, TempTopY)
End If
End If
'Deals with endpoint
If Not EndPointCreatedByCircle Then
If TempBottomX > Box.TopLeft.X Then
If TempBottomX < Box.BottomRight.X Then
EndPoint = New Point(TempBottomX, Box.BottomRight.Y)
Else
EndPoint = New Point(Box.BottomRight.X, TempBottomY)
End If
Else
TempBottomY = Box.TopLeft.X * A + B
EndPoint = New Point(Box.TopLeft.X, TempBottomY)
End If
End If
Dim d As New Polyline
d.Points.Add(StartPoint)
d.Points.Add(EndPoint)
d.ToolTip = Math.Round(StartPoint.X, 0) & " and " & Math.Round(StartPoint.Y, 0) & "; " & Math.Round(EndPoint.X, 0) & " and " & Math.Round(EndPoint.Y, 0)
d.Stroke = Brushes.Black
d.StrokeThickness = 2
Return d
End Function
'All the lines in the center of the Voronoi map would be cut by at least one or two circle events
Public Function GetLine() As Polyline
Dim d As New Polyline
d.Points.Add(StartPoint)
d.Points.Add(EndPoint)
d.Stroke = Brushes.Black
d.StrokeThickness = 2
Return d
End Function
'We will store up to two points in the private collection
Private CircleEvents As New List(Of Point)
Private LineIsCreatedFromVertexEvent As Boolean = False
Public Sub CircleEventAppear(ByVal CircleCenter As Circle)
CircleEvents.Add(CircleCenter.CenterPoint)
If CreationPointLeft = Nothing Then
LineIsCreatedFromVertexEvent = True
End If
End Sub
Public Sub CutLineOnCircleEvents()
'If we at the end end up with just one circle event we would have to assume that
'the line go's from the one Voronoi vertex (circle point) to one of the boundaries
If CircleEvents.Count = 0 Then
'This could happen if we for instance design a Voronoi diagram with just two points
Exit Sub
End If
If CircleEvents.Count = 1 Then
'The circle cuts the line in half, the question is witch half sould you cut?
If LineIsCreatedFromVertexEvent Then
' The Vertex is below either one or both line creation points meaning that it is
' Remove the line that goes from the higest Y point
_StartPoint = CircleEvents(0)
Else
_EndPoint = CircleEvents(0)
End If
Else
'The maximum circle event for a single line is two
If CircleEvents(0).Y > CircleEvents(1).Y Then
_StartPoint = CircleEvents(0)
_EndPoint = CircleEvents(1)
Else
_StartPoint = CircleEvents(1)
_EndPoint = CircleEvents(0)
End If
End If
'To determine witch of the two boundary points we would have to remove, we can do that by checking the creation point
'and the circle point. If the circle point is below the CreationPoint, The line below have to go, and if the circle
'point is above the CreationPoint the line above have to be cut. Remember that this is only valid if just one circle
'event is present when the diagram is completed!
End Sub
'Line equation coefficients, only used internally in this class
' y = Ax + B
Dim A, B As Double
Private Sub CalculateLineEquation(ByVal p1 As Point, ByVal p2 As Point)
'Calculate and store the A and B coefficients from the equation here
'http://en.wikipedia.org/wiki/Line_equation#Two-point_form
Dim slope As Double
slope = (p2.Y - p1.Y) / (p2.X - p1.X)
A = (slope)
B = (-slope * p1.X + p1.Y)
End Sub
''' <summary>
''' Calculates the line between two Parabolic intersections
''' </summary>
''' <param name="Point1">A point in the Voronoi diagram</param>
''' <param name="point2">A Point in the Voronoi diagram (different from point 1)</param>
''' <param name="ys">The position of the sweep line</param>
''' <remarks>It would give wrong values if the two points have the same or close to the same Y coordinate, as the double has limited significant storage</remarks>
Public Sub ParabolicCut(ByVal Point1 As Point, ByVal point2 As Point, ys As Double) 'As VoronoiLine
'Stores the values in double format, as I didnt bother to rewrite Benjamin Dittes quadratic equation.
Dim x1, y1, x2, y2 As Double
'Inizialize Point 1
x1 = Point1.X
y1 = Point1.Y
'Inizialize Point 2
x2 = point2.X
y2 = point2.Y
'Sweep line, added 500 to make sure the two calculated points are well of the boundaries
ys = ys + 500
'Setting ut calculation of the quadratic equation
Dim a1 As Double = 1 / (2 * (y1 - ys))
Dim a2 As Double = 1 / (2 * (y2 - ys))
'The two resulting values of x from the quadratic equation
Dim xs1 As Double = 0.5 / (2 * a1 - 2 * a2) * (4 * a1 * x1 - 4 * a2 * x2 + 2 * Math.Sqrt(-8 * a1 * x1 * a2 * x2 - 2 * a1 * y1 + 2 * a1 * y2 + 4 * a1 * a2 * x2 * x2 + 2 * a2 * y1 + 4 * a2 * a1 * x1 * x1 - 2 * a2 * y2))
Dim xs2 As Double = 0.5 / (2 * a1 - 2 * a2) * (4 * a1 * x1 - 4 * a2 * x2 - 2 * Math.Sqrt(-8 * a1 * x1 * a2 * x2 - 2 * a1 * y1 + 2 * a1 * y2 + 4 * a1 * a2 * x2 * x2 + 2 * a2 * y1 + 4 * a2 * a1 * x1 * x1 - 2 * a2 * y2))
'Generate two points to store the two intersection points
Dim p1, p2 As New Point
p1.X = xs1
p2.X = xs2
p1.Y = 0
p2.Y = 0
'Find the resulting Y values calculated from the quadratic equation
' (It dosent matter that the Y is 0 as the function Intersection2 only uses the X value for computation)
p1.Y = Intersection2(p1, Point1, ys)
p2.Y = Intersection2(p2, Point1, ys)
'Sort first and then add the two calculated poitns
If p1.Y > p2.Y Then
Me.StartPoint = (p1)
Me.EndPoint = (p2)
ElseIf p1.Y = p2.Y Then
' if they are the same save them in the order of the X values
If p1.X < p2.X Then
Me.StartPoint = (p1)
Me.EndPoint = (p2)
Else
Me.StartPoint = (p2)
Me.EndPoint = (p1)
End If
Else
Me.StartPoint = (p2)
Me.EndPoint = (p1)
End If
If WhichSide(Point1) >= 0 Then
CreationPointRight = Point1
CreationPointLeft = point2
Else
CreationPointRight = point2
CreationPointLeft = Point1
End If
End Sub
''' <summary>
''' Returns the y value construcked by the event from the newpoint and the contructed arc of the oldpoint
''' </summary>
''' <param name="NewPoint">This is the point on the sweep line</param>
''' <param name="OldPoint">This is one point above the sweep line</param>
''' <param name="SweepLine">Y position of the sweep line</param>
''' <returns>Calculates the distance fromn a point (NewPoint) to the Parabolic arc generated by the OldPoint and the Sweep line</returns>
''' <remarks>The Function only gives you the Y value of the position on the parabolic intersection given the X location</remarks>
Private Function Intersection2(ByVal NewPoint As Point, ByVal OldPoint As Point, ByVal SweepLine As Double) As Double
Dim res As Double
res = (1 / (2 * ((OldPoint.Y) - SweepLine)))
res *= (NewPoint.X ^ 2 - 2 * OldPoint.X * NewPoint.X + OldPoint.X ^ 2 + OldPoint.Y ^ 2 - SweepLine ^ 2)
Return (res)
End Function
'We also generate a function that returns the distance
End Class
#Region "Sorting algorithm"
''' <summary>
''' Returns a sorted pointcollection based on Lexografically sorting
''' </summary>
''' <param name="samplepoints"></param>
''' <param name="SortByXdirection"></param>
''' <returns></returns>
''' <remarks></remarks>
Public Function SortPoints(ByVal samplepoints As PointCollection, ByVal SortByXdirection As Boolean) As PointCollection
'Create another array so we can keep the original array out of order
Dim copySamplePoints As Point() = New Point(samplepoints.Count - 1) {}
samplepoints.CopyTo(copySamplePoints, 0)
If SortByXdirection Then
Array.Sort(copySamplePoints, New PointSort(PointSort.Mode.X))
Else
Array.Sort(copySamplePoints, New PointSort(PointSort.Mode.Y))
End If
Dim result As New PointCollection
For Each p As Point In copySamplePoints
result.Add(p)
Next
Return result
End Function
Private Class PointSort
Implements IComparer
Public Enum Mode
X
Y
End Enum
Private currentMode As Mode = Mode.X
Public Sub New(ByVal mode As Mode)
currentMode = mode
End Sub
'Comparing function
'Returns one of three values - 0 (equal), 1 (greater than), -1 (less than)
Private Function IComparer_Compare(ByVal a As Object, ByVal b As Object) As Integer Implements IComparer.Compare
Dim point1 As Point = CType(a, Point)
Dim point2 As Point = CType(b, Point)
If currentMode = Mode.X Then
'Compare X values
If point1.X < point2.X Then
Return -1
ElseIf point1.X > point2.X Then
Return 1
Else
If point1.Y < point2.Y Then
Return -1
ElseIf point1.Y > point2.Y Then
Return 1
Else 'Identical points
Return 0
End If
End If
Else
If point1.Y < point2.Y Then
'Compare Y Values
Return -1
ElseIf point1.Y > point2.Y Then
Return 1
Else 'Y1 = Y2
If point1.X < point2.X Then
'Compare Y Values
Return -1
ElseIf point1.X > point2.X Then
Return 1
Else 'Identical points
Return 0
End If
End If
End If
End Function
End Class
#End Region
Private Sub btn_Retangle_Click(sender As System.Object, e As System.Windows.RoutedEventArgs) Handles btn_Retangle.Click
Dim b As New Boundary(points)
b.ReturnRectangle(Canvas1)
End Sub
Private Sub btnClear_Click(sender As System.Object, e As System.Windows.RoutedEventArgs) Handles btnClear.Click
points.Clear()
AllCreatedLines.Clear()
BeachLinePoints.Clear()
Canvas1.Children.Clear()
stLines.Content = "Number of lines added: 0"
End Sub
Private Sub Canvas1_MouseMove(sender As System.Object, e As System.Windows.Input.MouseEventArgs)
Dim tempPoint As New Point
tempPoint = e.GetPosition(Canvas1)
stPosition.Content = "(" & Math.Abs(tempPoint.X).ToString & "; " & Math.Abs(tempPoint.Y).ToString & ")"
End Sub
''' <summary>
''' A class for preforming circle tests
''' </summary>
''' <remarks></remarks>
Public Class Circle
Public Function Contains(ByVal dia As VoronoiLine) As Boolean
Dim pleft As Boolean = False
Dim pright As Boolean = False
For Each p As Point In CreationPoints
If dia.CreationPointLeft = p Then
pleft = True
End If
If dia.CreationPointLeft = p Then
pright = True
End If
Next
If pleft And pright Then
Return True
Else
Return False
End If
End Function
Private _IsEmpty As Boolean = False
Public Property IsEmpty() As Boolean
Get
Return _IsEmpty
End Get
Set(ByVal value As Boolean)
_IsEmpty = value
End Set
End Property
Private _CreationPoints As New List(Of Point)
Public Property CreationPoints() As List(Of Point)
Get
Return _CreationPoints
End Get
Set(ByVal value As List(Of Point))
_CreationPoints = value
End Set
End Property
Private _CenterPoint As Point
Public Property CenterPoint() As Point
Get
Return _CenterPoint
End Get
Set(ByVal value As Point)
_CenterPoint = value
End Set
End Property
Private _radius As Double
Public Property Radius() As Double
Get
Return _radius
End Get
Set(ByVal value As Double)
_radius = value
End Set
End Property
Public Function OutsideBoundary(ByVal box As Boundary) As Boolean
If CenterPoint.Y < box.TopLeft.Y Then
Return True
ElseIf CenterPoint.Y > box.BottomRight.Y Then
Return True
ElseIf CenterPoint.X < box.TopLeft.X Then
Return True
ElseIf CenterPoint.X > box.BottomRight.X Then
Return True
Else
Return False
End If
End Function
Private Function Distance(ByVal p1 As Point, ByVal p2 As Point) As Double
Return Math.Sqrt((p1.X - p2.X) ^ 2 + (p1.Y - p2.Y) ^ 2)
End Function
Public Function DoesCircleContainPoint(ByVal p1 As Point) As Boolean
Dim d As Double
d = Distance(p1, CenterPoint)
'Determine if the point is within the Circle
If d < Radius Then
Return True
Else
'We will detect more creationpoints of the circle here and
'add them to the Circle creation point list for later usage
If d = Radius Then
CreationPoints.Add(p1)
End If
Return False
End If
End Function
Public Sub ReturnCenterPoint(ByVal can As Canvas)
Dim p As New Ellipse
p.Fill = Brushes.Blue
p.StrokeThickness = 2
p.Stroke = Brushes.Blue
' Set the width and height of the Ellipse.
p.Width = 5
p.Height = 5
can.Children.Add(p)
Canvas.SetLeft(p, CenterPoint.X - 2.5)
Canvas.SetTop(p, CenterPoint.Y - 2.5)
End Sub
Public Sub ReturnEllipse(ByVal can As Canvas)
Dim p As New Ellipse
Dim mySolidColorBrush As New SolidColorBrush()
' Describes the brush's color using RGB values.
' Each value has a range of 0-255. (The resulting color is black)
mySolidColorBrush.Color = Color.FromArgb(255, 255, 255, 0)
p.Fill = mySolidColorBrush
p.StrokeThickness = 2
p.Stroke = Brushes.Black
' Set the width and height of the Ellipse.
p.Width = Radius * 2
p.Height = Radius * 2
can.Children.Add(p)
Canvas.SetLeft(p, CenterPoint.X - Radius)
Canvas.SetTop(p, CenterPoint.Y - Radius)
End Sub
Public Sub CreatCircleFromThreePoints(ByVal Point1 As Point, ByVal Point2 As Point, ByVal Point3 As Point)
Dim Pt(3) As Point
Pt(0) = Point1
Pt(1) = Point2
Pt(2) = Point3
CreationPoints.Add(New Point(Pt(0).X, Pt(0).Y))
CreationPoints.Add(New Point(Pt(1).X, Pt(1).Y))
CreationPoints.Add(New Point(Pt(2).X, Pt(2).Y))
GetCircleRectFromPoints(Pt)
End Sub
Private OldLine As VoronoiLine
Public Sub CreatCircleFromVoronoiLine(ByVal VoronoiLine As VoronoiLine, ByVal Point3 As Point)
OldLine = VoronoiLine
Dim Pt(3) As Point
Pt(0) = VoronoiLine.CreationPointRight
Pt(1) = VoronoiLine.CreationPointLeft
Pt(2) = Point3
CreationPoints.Add(New Point(Pt(0).X, Pt(0).Y))
CreationPoints.Add(New Point(Pt(1).X, Pt(1).Y))
CreationPoints.Add(New Point(Pt(2).X, Pt(2).Y))
GetCircleRectFromPoints(Pt)
End Sub
Public Sub AddVoronoiLines(ByVal diagram As List(Of VoronoiLine))
OldLine.EndPointCreatedByCircle = True
OldLine.EndPoint = CenterPoint
Dim Right As New VoronoiLine
Right.ParabolicCut(OldLine.CreationPointRight, CreationPoints(2), CreationPoints(2).Y)
Right.VoronoiParent = OldLine
Dim Left As New VoronoiLine
Left.ParabolicCut(OldLine.CreationPointLeft, CreationPoints(2), CreationPoints(2).Y)
Left.VoronoiParent = OldLine
If OldLine.WhichSide(Right.StartPoint) = OldLine.WhichSide(OldLine.CreationPointRight) Then
Right.StartPoint = CenterPoint
Right.StartPointCreatedByCircle = True
Else
Right.EndPoint = CenterPoint
Right.EndPointCreatedByCircle = True
End If
diagram.Add(Right)
If OldLine.WhichSide(Left.StartPoint) = OldLine.WhichSide(OldLine.CreationPointLeft) Then
Left.StartPoint = CenterPoint
Left.StartPointCreatedByCircle = True
Else
Left.EndPoint = CenterPoint
Left.EndPointCreatedByCircle = True
End If
diagram.Add(Left)
End Sub
Private Function PointsAboveCenterPointInCircle() As Integer
Dim result As Integer = 0
For Each p As Point In CreationPoints
If p.Y >= CenterPoint.Y Then
result += 1
End If
Next
Return result
End Function
Private Sub GetCircleRectFromPoints(ByVal Pts() As Point) 'As RectangleF
'(X - Cx)^2 + (Y - Cy)^2 = R^2
'(R^2 - Cx^2 - Cy^2) + 2X*Cx + 2Y*Cy = X^2 + Y^2
'Cr + A*X + B*Y = X^2 + Y^2
'Solve matrix using gaussian elimination.
Dim N As Integer = Pts.Length - 1
Dim X(N, N) As Double, Y(N) As Double
For I As Integer = 0 To N
X(I, 0) = 1 : X(I, 1) = Pts(I).X : X(I, 2) = Pts(I).Y
Y(I) = X(I, 1) * X(I, 1) + X(I, 2) * X(I, 2)
Next
Dim MatInv As New Elimination
MatInv.ComputeCoefficents(X, Y)
Dim A As Single = CSng(Y(1) / 2)
Dim B As Single = CSng(Y(2) / 2)
Dim R As Single = CSng(Math.Sqrt(Y(0) + A * A + B * B))
CenterPoint = New Point(A, B)
Radius = R
' Return New RectangleF(A - R, B - R, 2 * R, 2 * R)
End Sub
Private Class Elimination
Sub ComputeCoefficents(ByVal X(,) As Double, ByVal Y() As Double)
Dim I, J, K, K1, N As Integer
N = Y.Length
For K = 0 To N - 1
K1 = K + 1
For I = K To N - 1
If X(I, K) <> 0 Then
For J = K1 To N - 1
X(I, J) /= X(I, K)
Next J
Y(I) /= X(I, K)
End If
Next I
For I = K1 To N - 1
If X(I, K) <> 0 Then
For J = K1 To N - 1
X(I, J) -= X(K, J)
Next J
Y(I) -= Y(K)
End If
Next I
Next K
For I = N - 2 To 0 Step -1
For J = N - 1 To I + 1 Step -1
Y(I) -= X(I, J) * Y(J)
Next J
Next I
End Sub
End Class
End Class
End Class
Submit an article or tip