Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH12/SRC/OBJPGONC.CLS

Text File | 1996-05-04 | 23.0 KB | 855 lines

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

' Point3D is defined in module M3OPS.BAS as:
'    Type Point3D
'        coord(1 To 4) As Single
'        trans(1 To 4) As Single
'    End Type

Private NumPts As Integer ' Number of points.
Private Points() As Point3D  ' Data points.

Private IsCulled As Boolean
' ************************************************
' Draw the transformed points on a Form, Printer,
' or PictureBox. Use the API function Polygon so
' the polygon will be properly filled to cover
' polygons behind it.
'
' Assume the point light source is infinitely far
' away so the color is the same for the whole
' polygon.
' ************************************************
Public Sub DrawShaded(canvas As Object, Optional r As Variant)
Dim pts() As POINTAPI
Dim pt As Integer
Dim status As Integer
Dim nx As Single
Dim ny As Single
Dim nz As Single
Dim lx As Single
Dim ly As Single
Dim lz As Single
Dim vx As Single
Dim vy As Single
Dim vz As Single
Dim rx As Single
Dim ry As Single
Dim rz As Single
Dim l_len As Single
Dim v_len As Single
Dim r_len As Single
Dim intensity As Single
Dim clr As Long
Dim NdotL As Single
Dim RdotV As Single
Dim r_dif As Single
Dim g_dif As Single
Dim b_dif As Single
Dim r_amb As Single
Dim g_amb As Single
Dim b_amb As Single
Dim spec As Single
Dim Ir As Single
Dim Ig As Single
Dim Ib As Single

    ' Don't draw if culled.
    If IsCulled Then Exit Sub

    ' Fill in the point array.
    ReDim pts(1 To NumPts)
    For pt = 1 To NumPts
        pts(pt).x = Points(pt).trans(1)
        pts(pt).y = Points(pt).trans(2)
    Next pt

    ' Find the unit vector pointing toward the light.
    lx = LightX - Points(1).coord(1)
    ly = LightY - Points(1).coord(2)
    lz = LightZ - Points(1).coord(3)
    l_len = Sqr(lx * lx + ly * ly + lz * lz)
    lx = lx / l_len
    ly = ly / l_len
    lz = lz / l_len
    ' We will use l_len later as the distance from
    ' the light to the surface.

    ' Find the surface unit normal.
    UnitNormalVector nx, ny, nz

    ' Calculate the part due to diffuse reflection.
    NdotL = nx * lx + ny * ly + nz * lz
    If NdotL < 0 Then
        ' The light does not hit the surface.
        r_dif = 0
        g_dif = 0
        b_dif = 0
        spec = 0
    Else
        r_dif = LightKdr * NdotL
        g_dif = LightKdg * NdotL
        b_dif = LightKdb * NdotL

        ' Find the vector V from the surface to the
        ' viewpoint.
        vx = EyeX - Points(1).coord(1)
        vy = EyeY - Points(1).coord(2)
        vz = EyeZ - Points(1).coord(3)
        v_len = Sqr(vx * vx + vy * vy + vz * vz)
        vx = vx / v_len
        vy = vy / v_len
        vz = vz / v_len

        ' Find vector R in the mirror direction.
        rx = 2 * nx * NdotL - lx
        ry = 2 * ny * NdotL - ly
        rz = 2 * nz * NdotL - lz

        ' Calculate the part due to specular reflection.
        RdotV = rx * vx + ry * vy + rz * vz
        If RdotV < 0 Then
            spec = 0
        Else
            spec = LightKs * RdotV ^ LightN
        End If
    End If

    ' Calculate the part due to ambient light.
    r_amb = LightIar * LightKar
    g_amb = LightIag * LightKag
    b_amb = LightIab * LightKab

    ' See how intense to make the color.
    Ir = r_amb + _
        LightIir / (l_len + LightKdist) * _
            (r_dif + spec)
    Ig = g_amb + _
        LightIig / (l_len + LightKdist) * _
            (g_dif + spec)
    Ib = b_amb + _
        LightIib / (l_len + LightKdist) * _
            (b_dif + spec)

    ' Compute the color.
    clr = &H2000000 + RGB(Ir, Ig, Ib)
    canvas.FillColor = clr

    ' Draw the polygon.
    On Error Resume Next
    status = Polygon(canvas.hdc, pts(1), NumPts)
End Sub

' ************************************************
' Draw the transformed points on a Form, Printer,
' or PictureBox. Use the API function Polygon so
' the polygon will be properly filled to cover
' polygons behind it.
' ************************************************
Public Sub DrawOrdered(canvas As Object, Optional r As Variant)
Dim pts() As POINTAPI
Dim pt As Integer
Dim status As Integer

    ' Don't draw if culled.
    If IsCulled Then Exit Sub

    ' Fill in the point array.
    ReDim pts(1 To NumPts)
    For pt = 1 To NumPts
        pts(pt).x = Points(pt).trans(1)
        pts(pt).y = Points(pt).trans(2)
    Next pt

    ' Draw the polygon.
    On Error Resume Next
    status = Polygon(canvas.hdc, pts(1), NumPts)
End Sub



' ************************************************
' Return the minimum and maximum coordinates.
' ************************************************
Public Sub GetExtent(xmin As Single, xmax As Single, ymin As Single, ymax As Single, zmin As Single, zmax As Single)
Dim i As Integer
Dim x As Single
Dim y As Single
Dim Z As Single

    xmin = Points(1).trans(1)
    xmax = xmin
    ymin = Points(1).trans(2)
    ymax = ymin
    zmin = Points(1).trans(3)
    zmax = zmin
    For i = 2 To NumPts
        x = Points(i).trans(1)
        y = Points(i).trans(2)
        Z = Points(i).trans(3)
        If xmin > x Then xmin = x
        If xmax < x Then xmax = x
        If ymin > y Then ymin = y
        If ymax < y Then ymax = y
        If zmin > Z Then zmin = Z
        If zmax < Z Then zmax = Z
    Next i
End Sub




' ************************************************
' Return the coordinates of a point on the polygon.
' ************************************************
Public Sub GetTransformedPoint(index As Integer, x As Single, y As Single, Z As Single)
    x = Points(index).trans(1)
    y = Points(index).trans(2)
    Z = Points(index).trans(3)
End Sub


' ************************************************
' See where the projections of two segments cross.
' Return true if the segments cross, false
' otherwise.
' ************************************************
Function FindCrossing( _
    ax1 As Single, ay1 As Single, az1 As Single, _
    ax2 As Single, ay2 As Single, az2 As Single, _
    bx1 As Single, by1 As Single, bz1 As Single, _
    bx2 As Single, by2 As Single, bz2 As Single, _
    x As Single, y As Single, z1 As Single, z2 As Single) _
        As Boolean
Dim dxa As Single
Dim dya As Single
Dim dza As Single
Dim dxb As Single
Dim dyb As Single
Dim dzb As Single
Dim t1 As Single
Dim t2 As Single
Dim denom As Single

    dxa = ax2 - ax1
    dya = ay2 - ay1
    dxb = bx2 - bx1
    dyb = by2 - by1

    FindCrossing = False

    denom = dxb * dya - dyb * dxa
    ' If the segments are parallel, stop.
    If denom < 0.01 And denom > -0.01 Then Exit Function

    t2 = (ax1 * dya - ay1 * dxa - bx1 * dya + by1 * dxa) / denom
    If t2 < 0 Or t2 > 1 Then Exit Function

    t1 = (ax1 * dyb - ay1 * dxb - bx1 * dyb + by1 * dxb) / denom
    If t1 < 0 Or t1 > 1 Then Exit Function

    ' Compute the points of overlap.
    x = ax1 + t1 * dxa
    y = ay1 + t1 * dya
    dza = az2 - az1
    dzb = bz2 - bz1
    z1 = az1 + t1 * dza
    z2 = bz1 + t2 * dzb
    FindCrossing = True
End Function

' ************************************************
' Return the number of points.
' ************************************************
Property Get NumPoints() As Integer
    NumPoints = NumPts
End Property

' ************************************************
' Return true if this polygon partially obscures
' (has greater Z value than) polygon obj.
'
' We assume one polygon may obscure the other, but
' they cannot obscure each other.
'
' This check is executed by seeing where the
' projections of the edges of the polygons cross.
' Where they cross, see if one Z value is greater
' than the other.
'
' If no edges cross, see if one polygon contains
' the other. If so, there is an overlap.
' ************************************************
Public Function Obscures(obj As ObjPolygon) As Boolean
Dim num As Integer
Dim i As Integer
Dim j As Integer
Dim xi1 As Single
Dim yi1 As Single
Dim zi1 As Single
Dim xi2 As Single
Dim yi2 As Single
Dim zi2 As Single
Dim xj1 As Single
Dim yj1 As Single
Dim zj1 As Single
Dim xj2 As Single
Dim yj2 As Single
Dim zj2 As Single
Dim x As Single
Dim y As Single
Dim z1 As Single
Dim z2 As Single

    num = obj.NumPoints

    ' Check each edge in this polygon.
    GetTransformedPoint NumPts, xi1, yi1, zi1
    For i = 1 To NumPts
        GetTransformedPoint i, xi2, yi2, zi2

        ' Compare with each edge in the other.
        obj.GetTransformedPoint num, xj1, yj1, zj1
        For j = 1 To num
            obj.GetTransformedPoint j, xj2, yj2, zj2
            ' See if the segments cross.
            If FindCrossing( _
                xi1, yi1, zi1, _
                xi2, yi2, zi2, _
                xj1, yj1, zj1, _
                xj2, yj2, zj2, _
                x, y, z1, z2) _
            Then
                If z1 - z2 > 0.01 Then
                    ' z1 > z2. We obscure it.
                    Obscures = True
                    Exit Function
                End If
                If z2 - z1 > 0.01 Then
                    ' z2 > z1. It obscures us.
                    Obscures = False
                    Exit Function
                End If
            End If

            xj1 = xj2
            yj1 = yj2
            zj1 = zj2
        Next j

        xi1 = xi2
        yi1 = yi2
        zi1 = zi2
    Next i

    ' No edges cross. See if one polygon contains
    ' the other.

    ' If any points of one polygon are inside the
    ' other, then they must all be. Since the
    ' IsAbove tests were inconclusive, some points
    ' in one polygon are on the "bad" side of the
    ' other. In that case there is an overlap.

    ' See if this polygon is inside the other.
    GetTransformedPoint 1, xi1, yi1, zi1
    If obj.PointInside(xi1, yi1) Then
        Obscures = True
        Exit Function
    End If

    ' See if the other polygon is inside this one.
    obj.GetTransformedPoint 1, xi1, yi1, zi1
    If PointInside(xi1, yi1) Then
        Obscures = True
        Exit Function
    End If

    Obscures = False
End Function

' ************************************************
' Return true if the point projection lies within
' this polygon's projection.
' ************************************************
Function PointInside(x As Single, y As Single) As Boolean
Dim i As Integer
Dim theta1 As Double
Dim theta2 As Double
Dim dtheta As Double
Dim dx As Double
Dim dy As Double
Dim angles As Double

    dx = Points(NumPts).trans(1) - x
    dy = Points(NumPts).trans(2) - y
    theta1 = Arctan2(CSng(dx), CSng(dy))
    If theta1 < 0 Then theta1 = theta1 + 2 * PI
    For i = 1 To NumPts
        dx = Points(i).trans(1) - x
        dy = Points(i).trans(2) - y
        theta2 = Arctan2(CSng(dx), CSng(dy))
        If theta2 < 0 Then theta2 = theta2 + 2 * PI
        dtheta = theta2 - theta1
        If dtheta > PI Then dtheta = dtheta - 2 * PI
        If dtheta < -PI Then dtheta = dtheta + 2 * PI
        angles = angles + dtheta
        theta1 = theta2
    Next i

    PointInside = (Abs(angles) > 0.001)
End Function

' ************************************************
' Return true if this polygon is completly below
' the plane containing obj.
' ************************************************
Public Function IsBelow(obj As ObjPolygon) As Boolean
Dim nx As Single
Dim ny As Single
Dim nz As Single
Dim px As Single
Dim py As Single
Dim pz As Single
Dim dx As Single
Dim dy As Single
Dim dz As Single
Dim cx As Single
Dim cy As Single
Dim cz As Single
Dim i As Integer

    ' Compute a downward pointing normal to the plane.
    obj.TransformedNormalVector nx, ny, nz
    If nz > 0 Then
        nx = -nx
        ny = -ny
        nz = -nz
    End If

    ' Get a point on the plane.
    obj.GetTransformedPoint 1, px, py, pz

    ' See if the points in this polygon all lie
    For i = 1 To NumPts
        ' Get the vector from plane to point.
        dx = Points(i).trans(1) - px
        dy = Points(i).trans(2) - py
        dz = Points(i).trans(3) - pz

        ' If the dot product < 0, the point is
        ' below the plane.
        If dx * nx + dy * ny + dz * nz < -0.01 Then
            IsBelow = False
            Exit Function
        End If
    Next i
    IsBelow = True
End Function


' ************************************************
' Return true if this polygon is completly above
' the plane containing obj.
' ************************************************
Public Function IsAbove(obj As ObjPolygon) As Boolean
Dim nx As Single
Dim ny As Single
Dim nz As Single
Dim px As Single
Dim py As Single
Dim pz As Single
Dim dx As Single
Dim dy As Single
Dim dz As Single
Dim cx As Single
Dim cy As Single
Dim cz As Single
Dim i As Integer

    ' Compute an upward pointing normal to the plane.
    obj.TransformedNormalVector nx, ny, nz
    If nz < 0 Then
        nx = -nx
        ny = -ny
        nz = -nz
    End If

    ' Get a point on the plane.
    obj.GetTransformedPoint 1, px, py, pz

    ' See if the points in this polygon all lie
    For i = 1 To NumPts
        ' Get the vector from plane to point.
        dx = Points(i).trans(1) - px
        dy = Points(i).trans(2) - py
        dz = Points(i).trans(3) - pz

        ' If the dot product < 0, the point is
        ' below the plane.
        If dx * nx + dy * ny + dz * nz < -0.01 Then
            IsAbove = False
            Exit Function
        End If
    Next i
    IsAbove = True
End Function


' ***********************************************
' Return the maximum transformed Z value for this
' object.
' ***********************************************
Property Get Distance(x As Single, y As Single, Z As Single) As Single
Dim best As Single
Dim dist As Single
Dim dx As Single
Dim dy As Single
Dim dz As Single
Dim i As Integer

    best = INFINITY
    For i = 1 To NumPts
        dx = Points(i).coord(1) - x
        dy = Points(i).coord(2) - y
        dz = Points(i).coord(3) - Z
        dist = dx * dx + dy * dy + dz * dz
        If best > dist Then best = dist
    Next i
    Distance = Sqr(best)
End Property

' ***********************************************
' Return the maximum transformed Z value for this
' object.
' ***********************************************
Property Get zmax() As Single
Dim best As Single
Dim Z As Single
Dim i As Integer

    best = Points(1).trans(3)
    For i = 2 To NumPts
        Z = Points(i).trans(3)
        If best < Z Then best = Z
    Next i
    zmax = best
End Property






' ***********************************************
' Compute a transformed normal vector.
' ***********************************************
Public Sub TransformedNormalVector(nx As Single, ny As Single, nz As Single)
Dim Ax As Single
Dim Ay As Single
Dim Az As Single
Dim Bx As Single
Dim By As Single
Dim Bz As Single

    Ax = Points(2).trans(1) - Points(1).trans(1)
    Ay = Points(2).trans(2) - Points(1).trans(2)
    Az = Points(2).trans(3) - Points(1).trans(3)
    Bx = Points(3).trans(1) - Points(2).trans(1)
    By = Points(3).trans(2) - Points(2).trans(2)
    Bz = Points(3).trans(3) - Points(2).trans(3)
    m3Cross nx, ny, nz, Ax, Ay, Az, Bx, By, Bz
End Sub



' ***********************************************
' Compute a normal vector for this polygon.
' ***********************************************
Public Sub NormalVector(nx As Single, ny As Single, nz As Single)
Dim Ax As Single
Dim Ay As Single
Dim Az As Single
Dim Bx As Single
Dim By As Single
Dim Bz As Single

    Ax = Points(2).coord(1) - Points(1).coord(1)
    Ay = Points(2).coord(2) - Points(1).coord(2)
    Az = Points(2).coord(3) - Points(1).coord(3)
    Bx = Points(3).coord(1) - Points(2).coord(1)
    By = Points(3).coord(2) - Points(2).coord(2)
    Bz = Points(3).coord(3) - Points(2).coord(3)
    m3Cross nx, ny, nz, Ax, Ay, Az, Bx, By, Bz
End Sub




' ***********************************************
' Compute the unit normal line segment for this
' polygon.
' ***********************************************
Sub UnitNormalSegment(x1 As Single, y1 As Single, z1 As Single, x2 As Single, y2 As Single, z2 As Single)
Dim i As Integer
Dim nx As Single
Dim ny As Single
Dim nz As Single

    UnitNormalVector nx, ny, nz

    x1 = 0
    y1 = 0
    z1 = 0
    For i = 1 To NumPts
        x1 = x1 + Points(i).coord(1)
        y1 = y1 + Points(i).coord(2)
        z1 = z1 + Points(i).coord(3)
    Next i
    x1 = x1 / NumPts
    y1 = y1 / NumPts
    z1 = z1 / NumPts

    x2 = x1 + nx
    y2 = y1 + ny
    z2 = z1 + nz
End Sub


' ***********************************************
' Compute the unit normal vector for this
' polygon.
' ***********************************************
Sub UnitNormalVector(nx As Single, ny As Single, nz As Single)
Dim D As Single

    NormalVector nx, ny, nz
    D = Sqr(nx * nx + ny * ny + nz * nz)
    nx = nx / D
    ny = ny / D
    nz = nz / D
End Sub





' ***********************************************
' Set or clear the IsCulled flag.
' ***********************************************
Property Let Culled(value As Boolean)
    IsCulled = value
End Property


' ***********************************************
' Return true if the polygon has been culled.
' ***********************************************
Property Get Culled() As Boolean
    Culled = IsCulled
End Property

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

' ************************************************
' Add one or more points to the polygon.
' ************************************************
Public Sub AddPoint(ParamArray coord() As Variant)
Dim num_pts As Integer
Dim i As Integer
Dim pt As Integer

    num_pts = (UBound(coord) + 1) \ 3
    ReDim Preserve Points(1 To NumPts + num_pts)

    pt = 0
    For i = 1 To num_pts
        Points(NumPts + i).coord(1) = coord(pt)
        Points(NumPts + i).coord(2) = coord(pt + 1)
        Points(NumPts + i).coord(3) = coord(pt + 2)
        Points(NumPts + i).coord(4) = 1#
        pt = pt + 3
    Next i

    NumPts = NumPts + num_pts
End Sub


' ************************************************
' Draw the object into a metafile.
' ************************************************
Public Sub MakeWMF(mhdc As Integer)
Dim pts() As POINTAPI
Dim pt As Integer
Dim status As Integer

    ' Don't draw if culled.
    If IsCulled Then Exit Sub

    ' Fill in the point array.
    ReDim pts(1 To NumPts)
    For pt = 1 To NumPts
        pts(pt).x = Points(pt).trans(1)
        pts(pt).y = Points(pt).trans(2)
    Next pt

    ' Draw the polygon.
    On Error Resume Next
    status = Polygon(mhdc, pts(1), NumPts)
End Sub

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

    For i = 1 To NumPts
        For j = 1 To 3
            Points(i).coord(j) = Points(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

    If IsCulled Then Exit Sub
    For i = 1 To NumPts
        m3ApplyFull Points(i).coord, M, Points(i).trans
    Next i
End Sub

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

    If IsCulled Then Exit Sub
    For i = 1 To NumPts
        m3Apply Points(i).coord, M, Points(i).trans
    Next i
End Sub


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

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

' ************************************************
' Write a polyline to a file using Write.
' Begin with "POLYGON" to identify this object.
' ************************************************
Public Sub FileWrite(filenum As Integer)
Dim i As Integer

    Write #filenum, "POLYGON", NumPts

    ' Write the points.
    For i = 1 To NumPts
        Write #filenum, Points(i).coord(1), Points(i).coord(2), Points(i).coord(3)
    Next i
End Sub

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

    ' Don't draw if culled.
    If IsCulled Then Exit Sub

    On Error Resume Next
    canvas.CurrentX = Points(NumPts).trans(1)
    canvas.CurrentY = Points(NumPts).trans(2)
    For pt = 1 To NumPts
        canvas.Line _
            -(Points(pt).trans(1), Points(pt).trans(2))
    Next pt
End Sub
' ***********************************************
' Cull if any points are behind the center of
' projection.
' ***********************************************
Public Sub ClipEye(r As Single)
Dim pt As Integer

    If IsCulled Then Exit Sub
    For pt = 1 To NumPts
        If Points(pt).trans(3) >= r Then Exit For
    Next pt
    If pt <= NumPts Then IsCulled = True
End Sub
' ***********************************************
' Perform backface removal.
' ***********************************************
Public Sub Cull(x As Single, y As Single, Z As Single)
Dim Ax As Single
Dim Ay As Single
Dim Az As Single
Dim nx As Single
Dim ny As Single
Dim nz As Single

    ' Compute a normal to the face.
    NormalVector nx, ny, nz

    ' Compute a vector from the center of
    ' projection to the face.
    Ax = Points(1).coord(1) - x
    Ay = Points(1).coord(2) - y
    Az = Points(1).coord(3) - Z

    ' See if the vectors meet at an angle < 90.
    IsCulled = (Ax * nx + Ay * ny + Az * nz > -0.0001)
End Sub

' ************************************************
' Read a polyline from a file using Input.
' Assume the "POLYGON" label has already been
' read.
' ************************************************
Public Sub FileInput(filenum As Integer)
Dim i As Integer

    Input #filenum, NumPts

    ' Allocate and read the points.
    ReDim Points(1 To NumPts)
    For i = 1 To NumPts
        Input #filenum, Points(i).coord(1), Points(i).coord(2), Points(i).coord(3)
        Points(i).coord(4) = 1#
    Next i
End Sub