В данном проекте уделено особое внимание построению поверхностей и работа с ними средствами MS Excel. |
Надстройка XlMatrix for MS Excel. |
В данном разделе не приводится описание вариантов построения триангуляции Делоне, а описывается конкретный алгоритм, реализованный в Visual Basic Application for MS Excel.
Public Function TriangulationDelaunay(point As Variant) As Variant Attribute TriangulationDelaunay.VB_Description = "Построение системы треугольников по набору точек point=mmatrix(XY)." Attribute TriangulationDelaunay.VB_ProcData.VB_Invoke_Func = "\n28" Dim n As Long Dim nt As Long Dim h As Long Dim i As Long Dim j As Long Dim k As Long Dim l As Long Dim m As Long Dim hn As Long Dim hf As Boolean Dim kt As Long Dim kr As Double Dim counta As Long Dim counttr As Long Dim minX As Double Dim maxK As Double Dim minlen As Double Dim x1 As Double Dim x2 As Double Dim x3 As Double Dim y1 As Double Dim y2 As Double Dim y3 As Double Dim ax As Double Dim ay As Double Dim bx As Double Dim by As Double Dim xa As Double Dim ya As Double Dim sa As Double Dim sb As Double Dim sc As Double Dim x As Double Dim y As Double Dim x0 As Double Dim y0 As Double Dim k1 As Double Dim k2 As Double Dim xx As Double Dim yy As Double Dim len1 As Double Dim t1 As Double Dim t2 As Double Dim t3 As Double Dim xc As Double Dim yc As Double Dim r2c As Double Dim r2 As Double Dim alive() As Long Dim tri() As Long Dim res() As Long n = UBound(point) nt = n * 10 counta = 0 ReDim alive(1 To nt, 1 To 4) ReDim tri(1 To nt, 1 To 3) i = 1 minX = point(1, 1) For h = 2 To n If point(h, 1) < minX Then minX = point(h, 1) i = h End If Next h alive(1, 1) = i maxK = 0 For h = 1 To n If h <> i Then If point(h, 1) = point(i, 1) Then j = h h = n Else kr = Abs((point(h, 2) - point(i, 2)) / (point(h, 1) - point(i, 1))) If kr > maxK Then maxK = kr j = h End If End If End If Next h alive(1, 2) = j alive(1, 3) = -1 counta = 1 counttr = 0 h = 1 kt = counta Do While (counta > 0 And kt < nt - 2) m = 0 hf = False hn = 0 For h = 1 To kt If (alive(h, 3) <> 0) And alive(h, 4) = 0 Then m = h h = kt End If Next h If m > 0 Then counta = counta - 1 i = alive(m, 1) j = alive(m, 2) k = alive(m, 3) x1 = point(i, 1) y1 = point(i, 2) x2 = point(j, 1) y2 = point(j, 2) hn = 0 For h = 1 To n hf = False If (h <> i) And (h <> j) And (h <> k) Then x3 = point(h, 1) y3 = point(h, 2) sc = x1 * (y2 - y3) + x2 * (y3 - y1) + x3 * (y1 - y2) If sc <> 0 Then t1 = x1 ^ 2 + y1 ^ 2 t2 = x2 ^ 2 + y2 ^ 2 t3 = x3 ^ 2 + y3 ^ 2 sa = t1 * (y2 - y3) + t2 * (y3 - y1) + t3 * (y1 - y2) sb = t1 * (x2 - x3) + t2 * (x3 - x1) + t3 * (x1 - x2) xc = 0.5 * sa / sc yc = -0.5 * sb / sc r2c = (x1 - xc) ^ 2 + (y1 - yc) ^ 2 For l = 1 To n If (l <> i) And (l <> j) And (l <> h) Then hf = True x = point(l, 1) y = point(l, 2) r2 = (x - xc) ^ 2 + (y - yc) ^ 2 If r2 < r2c Then hf = False hn = 0 l = n Else hf = True End If End If Next l End If End If If hf Then hn = h h = n End If Next h If hf Then alive(m, 4) = hn k = 0 For h = 1 To kt If (alive(h, 1) = i And alive(h, 2) = hn) Or (alive(h, 1) = hn And alive(h, 2) = i) Then If alive(h, 3) <> 0 Then k = h h = kt End If Next h If k = 0 Then kt = kt + 1 alive(kt, 1) = i alive(kt, 2) = hn alive(kt, 3) = j counta = counta + 1 ElseIf k > 0 Then alive(k, 4) = j counta = counta - 1 End If k = 0 For h = 1 To kt If (alive(h, 1) = j And alive(h, 2) = hn) Or (alive(h, 1) = hn And alive(h, 2) = j) Then If alive(h, 3) <> 0 Then k = h h = kt End If Next h If k = 0 Then kt = kt + 1 alive(kt, 1) = j alive(kt, 2) = hn alive(kt, 3) = i counta = counta + 1 ElseIf k > 0 Then alive(k, 4) = i counta = counta - 1 End If counttr = counttr + 1 tri(counttr, 1) = i tri(counttr, 2) = j tri(counttr, 3) = hn Else alive(m, 4) = -1 End If End If Loop ReDim res(1 To counttr, 1 To 3) For h = 1 To counttr For m = 1 To 3 res(h, m) = tri(h, m) Next m Next h TriangulationDelaunay = res End Function
безымянный © copyright 2004 |
Опубликовано 7 апреля 2006г.
Made in Terra No Names.