'////////////////////////////////////////////////////////////
'////////// DO NOT DISTRIBUTE WITHOUT PERMISSION
'////////// Wit C. Bushko 8*833 5674
'////////////////////////////////////////////////////////////
Option Explicit
'
Private Const MIN_DISTX = 0.0001
Private Const MIN_DISTY = 0.0001
'
Private Type LineFit
A As Double
b As Double
x1 As Double
x2 As Double
q As Double
End Type
'--------------------------------------------------------------------------------
Public Sub CompressData(RawData() As Double, CompData() As Double, _
ByVal DistX As Double, ByVal DistY As Double)
'------
' CompressData finds a multilinear fit to a series of points.
' Input:
' RawData(i,j) - coordinate x (i=0), and coordinate y,(i=1) of the jth point (j=0,1,2,...,n)
' of raw data.
' DistX - parameter defining the accuracy of x coordinate fit.
' DistY - parameter defining the accuracy of y coordinate fit.
' Output:
' CompData(i,j) - coordinate x (i=0), and coordinate y,(i=1) of jth point (j=0,1,2,...,n)
' of compressed data.
'
'------
Dim n1 As Long
Dim n2 As Long
Dim n, Mx As Long
Dim A As Double
Dim b As Double
Dim Seg() As LineFit
Dim i As Integer
Dim y1, y2, ymax, ymin As Double
Dim NorD As Double
'---
If DistX < MIN_DISTX Then DistX = MIN_DISTX
If DistY < MIN_DISTY Then DistX = MIN_DISTY
'
Mx = UBound(RawData, 2)
'
n = -1
n1 = 0
Do
LinearFit RawData(), n1, n2, DistX, DistY, A, b, NorD
'
n = n + 1: ReDim Preserve Seg(n)
Seg(n).A = A
Seg(n).b = b
Seg(n).x1 = RawData(0, n1)
Seg(n).x2 = RawData(0, n2)
Seg(n).q = NorD
If n2 = Mx Then Exit Do
n1 = n2
Loop
'-------
ReDim CompData(1, n + 1)
CompData(0, 0) = Seg(0).x1
CompData(1, 0) = Seg(0).A * Seg(0).x1 + Seg(0).b
For i = 1 To n
CompData(0, i) = Seg(i).x1
y1 = Seg(i - 1).A * CompData(0, i) + Seg(i - 1).b + Seg(i - 1).q
y2 = Seg(i).A * CompData(0, i) + Seg(i).b + Seg(i).q
If y1 < y2 Then ymax = y1 Else ymax = y2
y1 = Seg(i - 1).A * CompData(0, i) + Seg(i - 1).b - Seg(i - 1).q
y2 = Seg(i).A * CompData(0, i) + Seg(i).b - Seg(i).q
If y1 > y2 Then ymin = y1 Else ymin = y2
CompData(1, i) = (ymin + ymax) / 2#
Next
CompData(0, n + 1) = Seg(n).x2
CompData(1, n + 1) = Seg(n).A * Seg(n).x2 + Seg(n).b
'---
End Sub
'--------------------------------------------------------------------------------
Private Sub LinearFit(y() As Double, nmin As Long, nmax As Long, _
ByVal DistX As Double, ByVal DistY As Double, _
A As Double, b As Double, NorD As Double)
'---
Dim Flg As Boolean
Dim i, n1, n2, Mx, m, Dn, q As Long
Dim Sx, Sxx, Sy, Sxy As Double
Dim MaxD As Double
'---
Mx = UBound(y, 2)
'
Sx = y(0, nmin): Sxx = y(0, nmin) * y(0, nmin)
Sy = y(1, nmin)
Sxy = y(0, nmin) * y(1, nmin)
'
nmax = nmin
Dn = 1
n1 = nmax + 1
nmax = nmax + Dn
n2 = nmax
q = 1
'-------
Do
For i = n1 To n2
Sx = Sx + q * y(0, i): Sxx = Sxx + q * y(0, i) * y(0, i)
Sy = Sy + q * y(1, i)
Sxy = Sxy + q * y(0, i) * y(1, i)
Next
m = nmax - nmin + 1
A = (m * Sxy - Sx * Sy) / (m * Sxx - Sx * Sx)
b = (Sxx * Sy - Sx * Sxy) / (m * Sxx - Sx * Sx)
'-------
NorD = Sqr(DistX * DistX * A * A + DistY * DistY)
MaxD = MaxDistance(y(), nmin, nmax, A, b)
'-------
If NorD > MaxD Then
If Flg Then
If Dn = 1 Then Exit Sub
Dn = Dn / 2
Else
Dn = 2 * Dn
Do While nmax + Dn > Mx
If Dn = 1 Then Exit Sub
Dn = Dn / 2
Loop
End If
n1 = nmax + 1
nmax = nmax + Dn
n2 = nmax
q = 1
Else
Flg = True
If Dn > 1 Then Dn = Dn / 2
n2 = nmax
nmax = nmax - Dn
n1 = nmax + 1
q = -1
End If
Loop
'---
End Sub
'--------------------------------------------------------------------------------
Private Function MaxDistance(f() As Double, _
n1 As Long, n2 As Long, _
A As Double, b As Double) As Double
'---
Dim i As Integer
Dim d As Double
'---
MaxDistance = 0#
For i = n1 To n2
d = Abs(A * f(0, i) + b - f(1, i))
If d > MaxDistance Then MaxDistance = d
Next
'---
End Function
'--------------------------------------------------------------------------------
Reply With Quote