AndVGri
Advanced Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
'=== Необходимо создать класс PointClass ===
Public X As Double
Public Y As Double
Public NextItem As PointClass
'=== End Class ===
'==== Код для вычисления радиуса (основная процедура CalcRadius) ===
'процедура чтения файла координат точек многоугольника
Private Sub ReadPoints(ByVal FileName As String, ByRef toRoot As PointClass)
Dim vX As Double, vY As Double, Item As PointClass
Dim fNum As Integer
fNum = FreeFile()
Open FileName For Input As #fNum
Do Until EOF(fNum)
Set Item = New PointClass
Input #fNum, vX, vY
Item.X = vX: Item.Y = vY
Set Item.NextItem = toRoot
Set toRoot = Item
Loop
Close #fNum
End Sub
'Функция нахождения минимального радиуса круга для многоугольника
Private Function GetRadius(ByVal Point1 As PointClass, ByVal Point2 As PointClass, _
ByVal inRoot As PointClass, ByVal startRadius As Double) As Double
Dim Item As PointClass, Dist As Double, Xc As Double, Yc As Double
Dim A As Double, B As Double, C As Double, D As Double
Dim r1 As Double, r2 As Double, P As Double
'координаты центра окружности через 2 точки
Xc = 0.5 * (Point1.X + Point2.X): Yc = 0.5 * (Point1.Y + Point2.Y)
'по списку координат точек
Set Item = inRoot
Do Until Item Is Nothing
'если точка в списке не пара исходных
If Not ((Point1 Is Item) Or (Point2 Is Item)) Then
'выислить расстояние от центра окружности до точки
'и проверить на превышение радиуса окружности
Dist = Math.Sqr((Xc - Item.X) ^ 2 + (Yc - Item.Y) ^ 2)
If Dist > startRadius Then
'вычислить радиус и координаты центра окружности по 3 точкам
A = Point1.X - Item.X: B = Point1.Y - Item.Y
C = Point2.X - Item.X: D = Point2.Y - Item.Y
r1 = 0.5 * (A ^ 2 + B ^ 2): r2 = 0.5 * (C ^ 2 + D ^ 2)
P = 1# / (A * D - B * C)
Xc = (D * r1 - B * r2) * P: Yc = (A * r2 - C * r1) * P
startRadius = Math.Sqr(Xc * Xc + Yc * Yc)
Xc = Xc + Item.X: Yc = Yc + Item.Y
End If
End If
Set Item = Item.NextItem
Loop
GetRadius = startRadius
End Function
'Основная процедура нахождения минимального радиуса круга для многоугольника
Private Sub CalcRadius(ByVal InputFile As String)
Dim pRoot As PointClass, vMax As Double, Dist As Double
Dim pCurrentPoint As PointClass, pNextPoint As PointClass
Dim pMaxPoint1 As PointClass, pMaxPoint2 As PointClass
'Читаем координаты точек многоугольника
Call ReadPoints(InputFile, pRoot)
'Для каждой точки многоугольника
Set pCurrentPoint = pRoot
Do Until pCurrentPoint Is Nothing
'Ищем расстояние до последующих в списке
'и определяем максимальное расстояние между 2 точками
Set pNextPoint = pCurrentPoint.NextItem
Do Until pNextPoint Is Nothing
Dist = Math.Sqr((pNextPoint.X - pCurrentPoint.X) ^ 2 + (pCurrentPoint.Y - pNextPoint.Y) ^ 2)
If vMax < Dist Then
vMax = Dist
'сохраняем ссылки на точки, расстояние между которыми максимально
'через них окружность пройдёт всегда
Set pMaxPoint1 = pCurrentPoint
Set pMaxPoint2 = pNextPoint
End If
Set pNextPoint = pNextPoint.NextItem
Loop
Set pCurrentPoint = pCurrentPoint.NextItem
Loop
'вычисляем минимальный радиус
vMax = GetRadius(pMaxPoint1, pMaxPoint2, pRoot, 0.5 * vMax)
MsgBox "Минимальный радиус описанной окружности: " & CStr(vMax), vbInformation, "Ответ"
End Sub
|
