Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH10/SRC/SPARSE2.CLS

Text File | 1996-05-04 | 10.7 KB | 392 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ObjSparseGrid"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Private NumPts As Integer   ' # actual data values.
Private Data() As Point3D   ' Actual data values.

Private ShowData As Boolean ' Draw the actual data?

Private grid As ObjGrid3D
' ************************************************
' Compute a weighted average of the y coordinates
' of the points with indices in best_i().
' ************************************************
Sub WeightedAverage(x As Single, y As Single, z As Single, best_i() As Integer, num As Integer)
Dim i As Integer
Dim j As Integer
Dim diffx As Single
Dim diffz As Single
Dim dist2(1 To 4) As Single
Dim wgt As Single
Dim tot As Single

    ' Compute the distance squared to each point.
    For i = 1 To num
        diffx = x - Data(best_i(i)).coord(1)
        diffz = z - Data(best_i(i)).coord(3)
        dist2(i) = diffx * diffx + diffz * diffz
        If dist2(i) = 0 Then
            y = Data(best_i(i)).coord(2)
            Exit Sub
        End If
    Next i

    ' Compute the contribution due to each point.
    y = 0
    For i = 1 To num
        ' Compute the weight for point i.
        wgt = 1
        For j = 1 To num
            If j <> i Then
                wgt = wgt * dist2(j)
            End If
        Next j
        y = y + wgt * Data(best_i(i)).coord(2)
        tot = tot + wgt
    Next i

    y = y / tot
End Sub




' ************************************************
' Find the data point closest to the desired
' location.
'
' If on_left is true the point must be to the left
' of (x, y).
'
' If on_top is true the point must be above
' (x, y).
' ************************************************
Sub FindNearestPoint(x As Single, z As Single, best_i As Integer, on_left As Boolean, on_top As Boolean)
Dim i As Integer
Dim best_dist2 As Single
Dim diffx As Single
Dim diffz As Single
Dim dist2 As Single

    ' Start with the first data point.
    best_i = 0
    best_dist2 = 1000000

    ' See which points are closer.
    For i = 1 To NumPts
        ' See if the point satisfies on_left/on_top.
        If (x < Data(i).coord(1)) = on_left And _
           (z > Data(i).coord(3)) = on_top Then

            ' See if this point is closer than the
            ' best one so far.
            diffx = x - Data(i).coord(1)
            diffz = z - Data(i).coord(3)
            dist2 = diffx * diffx + diffz * diffz
            If dist2 < best_dist2 Then
                best_i = i
                best_dist2 = dist2
            End If
        End If
    Next i
End Sub





' ************************************************
' Create the grid values for display.
'
' d_x and d_z tell how far apart to make the grid
' lines.
' ************************************************
Public Sub InitializeGrid(Dx As Single, Dz As Single)
Dim Xmin As Single
Dim Xmax As Single
Dim Zmin As Single
Dim Zmax As Single
Dim NumX As Integer
Dim NumZ As Integer
Dim wid As Single
Dim hgt As Single
Dim i As Integer
Dim j As Integer
Dim x As Single
Dim y As Single
Dim z As Single
Dim best_i(1 To 4) As Integer
Dim num_close As Integer

    ' Find the X and Z data bounds.
    Xmin = Data(1).coord(1)
    Xmax = Xmin
    Zmin = Data(1).coord(3)
    Zmax = Zmin
    For i = 2 To NumPts
        If Xmin > Data(i).coord(1) Then Xmin = Data(i).coord(1)
        If Xmax < Data(i).coord(1) Then Xmax = Data(i).coord(1)
        If Zmin > Data(i).coord(3) Then Zmin = Data(i).coord(3)
        If Zmax < Data(i).coord(3) Then Zmax = Data(i).coord(3)
    Next i

    ' Set the data boundaries.
    wid = Xmax - Xmin
    hgt = Zmax - Zmin
    NumX = wid / Dx + 1
    NumZ = hgt / Dz + 1
    x = (wid - NumX * Dx) / 2
    z = (hgt - NumZ * Dz) / 2
    Xmin = Xmin - x
    Xmax = Xmax + x
    Zmin = Zmin - z
    Zmax = Zmax + z

    ' Create the new grid object.
    Set grid = New ObjGrid3D
    grid.SetBounds Xmin, Dx, NumX, Zmin, Dz, NumZ

    ' Fill in data values.
    x = Xmin
    For i = 1 To NumX
        z = Zmin
        For j = 1 To NumZ
            ' Find close points to the upper left,
            ' upper right, lower left, and lower
            ' right. Average them.
            num_close = 1
            FindNearestPoint x, z, best_i(num_close), True, True
            If best_i(num_close) > 0 Then num_close = num_close + 1

            FindNearestPoint x, z, best_i(num_close), True, False
            If best_i(num_close) > 0 Then num_close = num_close + 1

            FindNearestPoint x, z, best_i(num_close), False, True
            If best_i(num_close) > 0 Then num_close = num_close + 1

            FindNearestPoint x, z, best_i(num_close), False, False
            If best_i(num_close) > 0 Then num_close = num_close + 1

            WeightedAverage x, y, z, best_i, num_close - 1

            ' Add the value to the grid.
            grid.SetValue x, y, z
            z = z + Dz
        Next j
        x = x + Dx
    Next i
End Sub





' ************************************************
' Set a data value.
' ************************************************
Sub SetValue(x As Single, y As Single, z As Single)
    NumPts = NumPts + 1
    ReDim Preserve Data(1 To NumPts)
    Data(NumPts).coord(1) = x
    Data(NumPts).coord(2) = y
    Data(NumPts).coord(3) = z
    Data(NumPts).coord(4) = 1#
End Sub
' ***********************************************
' Return a string indicating the object type.
' ***********************************************
Property Get ObjectType() As String
    ObjectType = "SPARSE_GRID"
End Property



' ***********************************************
' Fix the data coordinates at their transformed
' values.
' ***********************************************
Public Sub FixPoints()
Dim i As Integer
Dim j As Integer

    ' Fix the grid points if the grid exists.
    If Not grid Is Nothing Then grid.FixPoints

    ' Fix the original data.
    For i = 1 To NumPts
        For j = 1 To 3
            Data(i).coord(j) = Data(i).trans(j)
        Next j
    Next i
End Sub

' ************************************************
' Apply a transformation matrix which may not
' contain 0, 0, 0, 1 in the last column to the
' object.
' ************************************************
Public Sub ApplyFull(M() As Single)
Dim i As Integer

    ' Apply the matrix to the grid if it exists.
    If Not grid Is Nothing Then grid.ApplyFull M

    ' Apply the matrix to the sparse data.
    For i = 1 To NumPts
        m3ApplyFull Data(i).coord, M, Data(i).trans
    Next i
End Sub

' ************************************************
' Apply a transformation matrix to the object.
' ************************************************
Public Sub Apply(M() As Single)
Dim i As Integer

    ' Apply the matrix to the grid if it exists.
    If Not grid Is Nothing Then grid.Apply M

    ' Apply the matrix to the sparse data.
    For i = 1 To NumPts
        m3Apply Data(i).coord, M, Data(i).trans
    Next i
End Sub


' ************************************************
' Apply a nonlinear transformation.
' ************************************************
Public Sub Distort(D As Object)
Dim i As Integer

    ' Distort the grid if it exists.
    If Not grid Is Nothing Then grid.Distort D

    ' Distort the sparse data.
    For i = 1 To NumPts
        D.Distort Data(i).coord(1), Data(i).coord(2), Data(i).coord(3)
    Next i
End Sub

' ************************************************
' Write the sparse grid's grid object to a file
' using Write. The data can later be loaded into
' an ObjGrid3D object but not an ObjSparseGrid
' object.
' ************************************************
Public Sub FileWriteGrid(filenum As Integer)
    If Not grid Is Nothing Then grid.FileWrite filenum
End Sub
' ************************************************
' Write a sparse grid to a file using Write.
' Begin with "SPARSE_GRID" to identify this object.
' ************************************************
Public Sub FileWrite(filenum As Integer)
Dim i As Integer

    ' Write basic information.
    Write #filenum, "SPARSE_GRID", NumPts

    ' Write the data.
    For i = 1 To NumPts
        Write #filenum, Data(i).coord(1), _
            Data(i).coord(2), Data(i).coord(3)
    Next i

    ' Write grid spacing information.
    If grid Is Nothing Then
        Write #filenum, 0, 0
    Else
        Write #filenum, grid.Dx, grid.Dz
    End If
End Sub





' ************************************************
' Draw the transformed points on a Form, Printer,
' or PictureBox.
' ************************************************
Public Sub Draw(canvas As Object, Optional r As Variant)
Dim i As Integer

    ' Draw the grid if it exists.
    If Not grid Is Nothing Then grid.Draw canvas, r

    ' Draw the original data points if desired.
    If ShowData Then
        On Error Resume Next
        For i = 1 To NumPts
            canvas.Line (Data(i).trans(1) - 2, Data(i).trans(2) - 2)-Step(4, 4), vbRed
            canvas.Line (Data(i).trans(1) + 2, Data(i).trans(2) - 2)-Step(-4, 4), vbRed
        Next i
    End If
End Sub



' ************************************************
' Read a sparse grid from a file using Input.
' Assume the "SPARSE_GRID" label has already been
' read.
' ************************************************
Public Sub FileInput(filenum As Integer)
Dim i As Integer
Dim Dx As Single
Dim Dz As Single

    ' Get the basic information.
    Input #filenum, NumPts

    ' Allocate the Data array.
    ReDim Data(1 To NumPts)

    ' Read the data.
    For i = 1 To NumPts
        Input #filenum, Data(i).coord(1), _
            Data(i).coord(2), Data(i).coord(3)
    Next i

    ' Read grid spacing information.
    Input #filenum, Dx, Dz

    ' Initialize the grid data.
    If Dx = 0 Then
        Set grid = Nothing
    Else
        InitializeGrid Dx, Dz
    End If
End Sub



' ************************************************
' Tell the user whether we're drawing the data.
' ************************************************
Property Get ShowTrueData() As Boolean
    ShowTrueData = ShowData
End Property

' ************************************************
' Let the user decide whether we should draw the
' actual data.
' ************************************************
Property Let ShowTrueData(value As Boolean)
    ShowData = value
End Property


Private Sub Class_Initialize()
    Set grid = Nothing
End Sub