' *** POLYLINE NODE REDUCTION

Option Explicit

'=============================================================================

' *** SUBROUTINE DECLARATIONS ***

Sub RemoveUnmarked (tcv,m)  
  Dim i,n

  ' Starting from end of polyline makes it easier
  n=tcv.Count
  For i=n-1 to 0 step -1
    if not m(i) then tcv.remove(i)
  Next
End sub

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'
' Input:  t   = approximation tolerance, squared
' I/O:    tcv = polyline: collection of vertex coordinates

Sub poly (t, tcv)
  Dim n, i, k, xd, yd, x(), y(), m()

  ' Create dynamic arrays
  n=tcv.Count-1
  Redim x(n), y(n), m(n)

  ' Copy vertex data into arrays (SLOW)
  For i=n to 0 step-1
    x(i)=tcv(i).x: y(i)=tcv(i).y
  Next

  ' STAGE 1. Vertex Reduction within tolerance of prior vertex cluster
  ' Include start and finish nodes

  k=0: m(0)=True
  For i=1 to n-1
    xd=x(i)-x(k): yd=y(i)-y(k)
    If xd*xd+yd*yd>t then k=k+1: x(k)=x(i): y(k)=y(i): m(i)=True
  Next
  k=k+1: x(k)=x(n): y(k)=y(n): m(n)=True

  RemoveUnmarked tcv,m

  ' STAGE 2. Douglas-Peucker polyline simplification
  ' Mark the first and last nodes

  For i=0 to k
    m(i)=False
  Next
  m(0)=True: m(k)=True

  simplifyDP t, x, y, 0, k, m
  
  ' Remove unmarked nodes
  RemoveUnmarked tcv,m

  ' Script interface with TurboCAD is very slow:
  ' Copying vertices to arrays is very slow
  ' Remove unmarked nodes is also slow.

End sub

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' This is the Douglas-Peucker recursive simplification routine
' It just marks vertices that are part of the simplified polyline
' for approximating the polyline subchain j to k.
'
'  Input:  t   = approximation tolerance, squared
'          x,y = polyline: vertex coordinates
'          j,k = indices for the subchain j to k
'  Output: m   = array of markers matching polyline vertices
'
Sub simplifyDP (t, x, y, i, k, m)

  Dim j, mj, cu, cw, d, md, xi, yi, xj, yj, xk, yk

  If k-i<2 then Exit Sub

  xi=x(i): yi=y(i): xk=x(k)-xi: yk=y(k)-yi
  cu=xk*xk+yk*yk

  md=0: mj=j
  For j=i+1 to k-1
    xj=x(j)-xi: yj=y(j)-yi
    cw=xj*xk+yj*yk
    If cw<=0 then
      d=xj*xj+yj*yj
    Elseif cu<=cw then
      d=xj*xj + yj*yj + cu - 2*cw
    Else
      d=xj*yk-xk*yj: d=d*d/cu
    End if
    If d>md Then md=d: mj=j
  Next
  If md>t then
    m(mj)=True
    simplifyDP t, x,y, i, mj, m
    simplifyDP t, x,y, mj, k, m
  End if
End sub

'=============================================================================

' *** MAIN BLOCK ***

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Dim tcApp
Dim tcSel
Dim tcVrts
Dim tcType
Dim nsel
Dim i, j
Dim t
Dim nv
Dim s

'Set tcApp = CreateObject("TurboCAD.Application")
Application.Visible = True

Set tcSel=Application.Selection

nsel=tcSel.Count	'N/o selected objects

If nsel<1 Then 

  MsgBox "Nix Ausgewählt"  

Else

  j=0
  For i=0 to nsel-1
    tcType=tcSel(i).Type
    If tcType="GRAPHIC" then
      if tcSel(i).Vertices.Count>=3 then j=j+1
    End if
  Next

  If j<1 Then

    MsgBox CStr(nsel) & " Objekte ausgewählt, keins davon einfache Polylinie mit with 3 oder mehr Knoten - Fertig"

  Else
    'Get tolerance, use tolerance squared
    t=InputBox("Toleranz in Ausgewählten Objekten", , 0.1)
    t=t*t

    For i=0 to nsel-1
      If tcSel(i).Type="GRAPHIC" then
        Set tcVrts=tcSel(i).Vertices
        nv=tcVrts.Count
        If nv>=3 then poly t,tcVrts
      End if
      tcSel(i).Select
    Next
  End if
End if

Application.ActiveDrawing.ActiveView.Refresh

Set tcVrts = nothing
Set tctype = nothing
Set tcSel = nothing


' *** End ***