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

Text File | 1996-05-04 | 16.9 KB | 608 lines

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

Private Xmin As Single      ' Min X and Y values.
Private Zmin As Single
Private Dx As Single        ' Spacing between rows of data.
Private Dz As Single
Private NumX As Integer     ' Number of X and Y entries.
Private NumZ As Integer
Private Points() As Point3D ' Data values.

Private RemoveHidden As Boolean ' Remove hidden surfaces?

' ************************************************
' Generate the fractal surface.
' ************************************************
Public Sub GenerateSurface(divisions As Integer, Dy As Single)
Dim oldpoints() As Point3D
Dim oldx As Integer
Dim oldz As Integer
Dim factor As Integer
Dim newx As Integer
Dim newz As Integer
Dim i As Integer
Dim j As Integer
Dim newi As Integer
Dim newj As Integer

    ' Make room for the new data.
    factor = 2 ^ divisions
    newx = (NumX - 1) * factor + 1
    newz = (NumZ - 1) * factor + 1

    ' Copy the original data.
    ReDim oldpoints(1 To NumX, 1 To NumZ)
    For i = 1 To NumX
        For j = 1 To NumZ
            oldpoints(i, j) = Points(i, j)
        Next j
    Next i

    ' Resize and initialize the Points array.
    oldx = NumX
    oldz = NumZ
    SetBounds Xmin, Dx / factor, newx, _
              Zmin, Dz / factor, newz

    ' Move the data to new positions.
    newi = 1
    For i = 1 To oldx
        newj = 1
        For j = 1 To oldz
            Points(newi, newj) = oldpoints(i, j)
            newj = newj + factor
        Next j
        newi = newi + factor
    Next i

    ' Subdivide each area in the data.
    newi = 1
    For i = 2 To oldx
        newj = 1
        For j = 2 To oldz
            Subdivide newi, newi + factor, _
                      newj, newj + factor, Dy
            newj = newj + factor
        Next j
        newi = newi + factor
    Next i
End Sub

' ************************************************
' Let the user decide if we should draw hidden
' surfaces.
' ************************************************
Property Let ShowHidden(value As Boolean)
    RemoveHidden = Not value
End Property
' ************************************************
' Tell the user if we are drawing hidden surfaces.
' ************************************************
Property Get ShowHidden() As Boolean
    ShowHidden = Not RemoveHidden
End Property


' ************************************************
' Draw a line between the points. Set the hi and
' lo values for the line.
' ************************************************
Sub DrawAndSetLine(canvas As Object, ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single, ByVal y2 As Single, hi() As Integer, lo() As Integer)
Dim tmp As Single
Dim ix As Integer
Dim iy As Integer
Dim y As Single
Dim Dy As Single

    ' Deal only with integers.
    x1 = CInt(x1)
    y1 = CInt(y1)
    x2 = CInt(x2)
    y2 = CInt(y2)

    ' Make x1 < x2.
    If x2 < x1 Then
        tmp = x1
        x1 = x2
        x2 = tmp
        tmp = y1
        y1 = y2
        y2 = tmp
    End If

    ' Draw the line.
    canvas.Line (x1, y1)-(x2, y2)

    ' Deal with vertical lines separately.
    If x1 = x2 Then
        If y1 < y2 Then
            lo(x1) = y1
            hi(x1) = y2
        Else
            lo(x1) = y2
            hi(x1) = y1
        End If
        Exit Sub
    End If

    ' Deal with non-vertical lines.
    Dy = (y2 - y1) / CInt(x2 - x1)
    y = y1
    For ix = x1 To x2
        iy = CInt(y)

        lo(ix) = iy
        hi(ix) = iy

        y = y + Dy
    Next ix
End Sub




' ************************************************
' Draw a line between the points using and
' updating the hi and lo arrays.
' ************************************************
Sub DrawLine(canvas As Object, ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single, ByVal y2 As Single, hi() As Integer, lo() As Integer)
Dim tmp As Single
Dim ix As Integer
Dim iy As Integer
Dim y As Single
Dim Dy As Single
Dim firstx As Integer
Dim firsty As Integer
Dim skipping As Boolean
Dim above As Boolean

    ' Deal only with integers.
    x1 = CInt(x1)
    y1 = CInt(y1)
    x2 = CInt(x2)
    y2 = CInt(y2)

    ' Make x1 < x2.
    If x2 < x1 Then
        tmp = x1
        x1 = x2
        x2 = tmp
        tmp = y1
        y1 = y2
        y2 = tmp
    End If

    ' Deal with vertical lines separately.
    If x1 = x2 Then
        ' Make y1 < y2.
        If y2 < y1 Then
            tmp = y1
            y1 = y2
            y2 = tmp
        End If
        If y1 <= lo(x1) Then
            If y2 <= lo(x1) Then
                canvas.Line (x1, y1)-(x2, y2)
            Else
                canvas.Line (x1, y1)-(x2, lo(x2))
            End If
            lo(x1) = y1
        End If
        If y2 >= hi(x2) Then
            If y1 >= hi(x2) Then
                canvas.Line (x1, y1)-(x2, y2)
            Else
                canvas.Line (x1, hi(x1))-(x2, y2)
            End If
            hi(x2) = y2
        End If
        Exit Sub
    End If

    ' Deal with non-vertical lines.
    Dy = (y2 - y1) / CInt(x2 - x1)
    y = y1

    ' Find the first visible point.
    skipping = True
    For ix = x1 To x2
        iy = CInt(y)
        ' See if this point is visible.
        If iy <= lo(ix) Then
            If skipping Then
                ' Start a new line below.
                firstx = ix
                firsty = lo(ix)
                skipping = False
                above = False
            End If
        ElseIf iy >= hi(ix) Then
            If skipping Then
                ' Start a new line above.
                firstx = ix
                firsty = hi(ix)
                skipping = False
                above = True
            End If
        Else
            ' This point is not visible.
            If Not skipping Then
                ' Draw the previous visible line.
                If above Then
                    ' The line is coming from
                    ' above. Connect it to hi(ix).
                    canvas.Line (firstx, firsty)-(ix, hi(ix))
                Else
                    ' The line is coming from
                    ' below. Connect it to lo(ix).
                    canvas.Line (firstx, firsty)-(ix, lo(ix))
                End If

                skipping = True
            End If
        End If

        If iy < lo(ix) Then lo(ix) = iy
        If iy > hi(ix) Then hi(ix) = iy

        y = y + Dy
    Next ix

    ' Draw to the last point if necessary.
    If Not skipping Then _
        canvas.Line (firstx, firsty)-(x2, y2)
End Sub



' ************************************************
' Create the Points array.
' ************************************************
Sub SetBounds(x1 As Single, deltax As Single, xnum As Integer, z1 As Single, deltaz As Single, znum As Integer)
Dim i As Integer
Dim j As Integer
Dim x As Single
Dim z As Single

    Xmin = x1
    Zmin = z1
    Dx = deltax
    Dz = deltaz
    NumX = xnum
    NumZ = znum
    ReDim Points(1 To NumX, 1 To NumZ)

    x = Xmin
    For i = 1 To NumX
        z = Zmin
        For j = 1 To NumZ
            Points(i, j).coord(1) = x
            Points(i, j).coord(2) = 0
            Points(i, j).coord(3) = z
            Points(i, j).coord(4) = 1#
            z = z + Dz
        Next j
        x = x + Dx
    Next i
End Sub

' ************************************************
' Recursively subdivide the indicated area.
' ************************************************
Private Sub Subdivide(i1 As Integer, i2 As Integer, j1 As Integer, j2 As Integer, Dy As Single)
Dim y11 As Single
Dim y12 As Single
Dim y21 As Single
Dim y22 As Single
Dim imid As Integer
Dim jmid As Integer

    If i2 - i1 <= 1 Or j2 - j1 <= 1 Then Exit Sub

    ' Compute the midpoint locations.
    y11 = Points(i1, j1).coord(2)
    y12 = Points(i1, j2).coord(2)
    y21 = Points(i2, j1).coord(2)
    y22 = Points(i2, j2).coord(2)

    imid = (i1 + i2) \ 2
    jmid = (j1 + j2) \ 2
    Points(i1, jmid).coord(2) = (y11 + y12) / 2 + 2 * Dy * Rnd - Dy
    Points(i2, jmid).coord(2) = (y21 + y22) / 2 + 2 * Dy * Rnd - Dy
    Points(imid, j1).coord(2) = (y11 + y21) / 2 + 2 * Dy * Rnd - Dy
    Points(imid, j2).coord(2) = (y12 + y22) / 2 + 2 * Dy * Rnd - Dy
    Points(imid, jmid).coord(2) = (y11 + y12 + y21 + y22) / 4 + 2 * Dy * Rnd - Dy

    ' Recursively subdivide the four new areas.
    Subdivide i1, imid, j1, jmid, Dy / 2
    Subdivide imid, i2, j1, jmid, Dy / 2
    Subdivide i1, imid, jmid, j2, Dy / 2
    Subdivide imid, i2, jmid, j2, Dy / 2
End Sub


' ************************************************
' Save the indicated data value.
' ************************************************
Sub SetValue(x As Single, y As Single, z As Single)
Dim i As Integer
Dim j As Integer

    i = (x - Xmin) / Dx + 1
    j = (z - Zmin) / Dz + 1
    Points(i, j).coord(2) = y
End Sub

' ***********************************************
' Return a string indicating the object type.
' ***********************************************
Property Get ObjectType() As String
    ObjectType = "FRACTALGRID"
End Property



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

    For i = 1 To NumX
        For j = 1 To NumZ
            For k = 1 To 3
                Points(i, j).coord(k) = Points(i, j).trans(k)
            Next k
        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
Dim j As Integer

    For i = 1 To NumX
        For j = 1 To NumZ
            m3ApplyFull Points(i, j).coord, M, Points(i, j).trans
        Next j
    Next i
End Sub

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

    For i = 1 To NumX
        For j = 1 To NumZ
            m3Apply Points(i, j).coord, M, Points(i, j).trans
        Next j
    Next i
End Sub


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

    For i = 1 To NumX
        For j = 1 To NumZ
            D.Distort Points(i, j).coord(1), Points(i, j).coord(2), Points(i, j).coord(3)
        Next j
    Next i
End Sub


' ************************************************
' Draw the grid without hidden surfaces using the
' hi-lo algorithm.
' ************************************************
Public Sub DrawWithoutHidden(canvas As Object, Optional R As Variant)
Dim Xmin As Integer
Dim Xmax As Integer
Dim lo() As Integer
Dim hi() As Integer
Dim ix As Integer
Dim i As Integer
Dim j As Integer

    ' Bound the X values.
    Xmin = Points(1, 1).trans(1)
    Xmax = Xmin
    For i = 1 To NumX
        For j = 1 To NumZ
            ix = CInt(Points(i, j).trans(1))
            If Xmin > ix Then Xmin = ix
            If Xmax < ix Then Xmax = ix
        Next j
    Next i

    ' Create the hi and lo arrays.
    ReDim lo(Xmin To Xmax)
    ReDim hi(Xmin To Xmax)

    ' Draw the X and Z front edges.
    For i = 2 To NumX
        ' Draw the edge between
        ' Points(i - 1, NumZ) and Points(i, NumZ)
        ' and set hi and lo for its values.
        DrawAndSetLine canvas, _
            Points(i - 1, NumZ).trans(1), _
            Points(i - 1, NumZ).trans(2), _
            Points(i, NumZ).trans(1), _
            Points(i, NumZ).trans(2), _
            hi, lo
    Next i
    For i = 2 To NumZ
        ' Draw the edge between
        ' Points(NumX, i - 1) and Points(NumX, i)
        ' and set hi and lo for its values.
        DrawAndSetLine canvas, _
            Points(NumX, i - 1).trans(1), _
            Points(NumX, i - 1).trans(2), _
            Points(NumX, i).trans(1), _
            Points(NumX, i).trans(2), _
            hi, lo
    Next i

    ' Draw the "rectangles."
    For i = NumX - 1 To 1 Step -1
        For j = NumZ - 1 To 1 Step -1
            ' Draw the edges between:
            '   Points(i, j) and Points(i + 1, j)
            '   Points(i, j) and Points(i, j + 1)

            ' If the right side of the "rectangle"
            ' leans over the top like this:
            '    +_
            '    | \_
            '    |   \_
            '    +     \_
            '     \      \
            '      +------+
            ' draw the top first so the right side
            ' doesn't make hi() too bit and stop
            ' the top from being drawn.
            '
            ' This only happens with perspective
            ' projection.
            If Points(i + 1, j).trans(1) >= Points(i, j).trans(1) Then
                DrawLine canvas, _
                    Points(i, j).trans(1), _
                    Points(i, j).trans(2), _
                    Points(i, j + 1).trans(1), _
                    Points(i, j + 1).trans(2), _
                    hi, lo
                DrawLine canvas, _
                    Points(i, j).trans(1), _
                    Points(i, j).trans(2), _
                    Points(i + 1, j).trans(1), _
                    Points(i + 1, j).trans(2), _
                    hi, lo
            Else
                DrawLine canvas, _
                    Points(i, j).trans(1), _
                    Points(i, j).trans(2), _
                    Points(i + 1, j).trans(1), _
                    Points(i + 1, j).trans(2), _
                    hi, lo
                DrawLine canvas, _
                    Points(i, j).trans(1), _
                    Points(i, j).trans(2), _
                    Points(i, j + 1).trans(1), _
                    Points(i, j + 1).trans(2), _
                    hi, lo
            End If
        Next j
    Next i
End Sub

' ************************************************
' Draw the grid including hidden surfaces.
' ************************************************
Public Sub DrawWithHidden(canvas As Object, Optional R As Variant)
Dim i As Integer
Dim j As Integer

    On Error Resume Next

    ' Draw lines parallel to the X axis.
    For i = 1 To NumX
        canvas.CurrentX = Points(i, 1).trans(1)
        canvas.CurrentY = Points(i, 1).trans(2)
        For j = 2 To NumZ
            canvas.Line -(Points(i, j).trans(1), _
                          Points(i, j).trans(2))
        Next j
    Next i

    ' Draw lines parallel to the Y axis.
    For j = 1 To NumZ
        canvas.CurrentX = Points(1, j).trans(1)
        canvas.CurrentY = Points(1, j).trans(2)
        For i = 2 To NumX
            canvas.Line -(Points(i, j).trans(1), _
                          Points(i, j).trans(2))
        Next i
    Next j
End Sub

' ************************************************
' Draw the transformed points on a Form, Printer,
' or PictureBox.
' ************************************************
Public Sub Draw(canvas As Object, Optional R As Variant)
    If RemoveHidden Then
        DrawWithoutHidden canvas, R
    Else
        DrawWithHidden canvas, R
    End If
End Sub
' ************************************************
' Write a grid to a file using Write.
' Begin with "FRACTALGRID" to identify this object.
' ************************************************
Public Sub FileWrite(filenum As Integer)
Dim i As Integer
Dim j As Integer

    ' Write basic information.
    Write #filenum, _
        "FRACTALGRID", Xmin, Zmin, Dx, Dz, NumX, NumZ

    ' Write the Z values.
    For i = 1 To NumX
        For j = 1 To NumZ
            Write #filenum, Points(i, j).coord(2)
        Next j
    Next i
End Sub

' ************************************************
' Read a grid from a file using Input.
' Assume the "FRACTALGRID" label has alreaDz been
' read.
' ************************************************
Public Sub FileInput(filenum As Integer)
Dim i As Integer
Dim j As Integer

    ' Get the basic information.
    Input #filenum, Xmin, Zmin, Dx, Dz, NumX, NumZ

    ' Allocate the Points array and set the X and
    ' Y values.
    SetBounds Xmin, Dx, NumX, Zmin, Dz, NumZ

    ' Read the Z values.
    For i = 1 To NumX
        For j = 1 To NumZ
            Input #filenum, Points(i, j).coord(2)
        Next j
    Next i
End Sub