TNN RUS

ТЕрритория бЕз имЕни

    Ресурс разрабатывался с целью преодоления граничащего с преступлением недостатка информации и тех. средств в области геомеханики и комплексной обработки массивов цифровой информации (ни один пакет: Maple, Mathematica, и даже MathCad и MatLab - не показали должного уровня обработки именно такого типа информации. Delphi даже в расчёт не берётся).

    Уже в сентябре 2004 года текущие наработки и собранная литература не позволили автору игнорировать подобное положение вещей.

mykaralw@yandex.ru


Триангуляция в Microsoft Excel.



В данном проекте уделено особое внимание построению поверхностей и работа с ними средствами 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.

Сайт управляется системой uCoz