Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH13/SRC/OBJSPHR2.CLS

Text File | 1996-04-12 | 11.6 KB | 434 lines

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

Private Radius As Single
Private Center As Point3D

Private HitX As Single
Private HitY As Single
Private HitZ As Single

Private Kar As Single
Private Kag As Single
Private Kab As Single

Private Kdr As Single
Private Kdg As Single
Private Kdb As Single

Private SpecN As Single
Private Ks As Single

Private Krr As Single
Private Krg As Single
Private Krb As Single

Private Nt As Single
Private N1 As Single   ' Index of refraction outside the object.
Private N2 As Single   ' Index of refraction inside the object.
Private Ktr As Single
Private Ktg As Single
Private Ktb As Single

Private IsReflective As Boolean
Private IsTransparent As Boolean

' ************************************************
' Apply a transformation matrix to the sphere.
' ************************************************
Public Sub Apply(M() As Single)
    ' Transform the center.
    m3Apply Center.coord, M, Center.trans
End Sub
' ************************************************
' Return the red, green, and blue components of
' the surface at the hit position.
' ************************************************
Public Sub HitColor(depth As Integer, Objects As Collection, R As Integer, G As Integer, B 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 n_len As Single
Dim l_len As Single
Dim v_len As Single
Dim r_len As Single
Dim NdotL As Single
Dim RdotV As Single
Dim NdotV 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 r_ref As Single
Dim g_ref As Single
Dim b_ref As Single
Dim r1 As Integer
Dim g1 As Integer
Dim b1 As Integer
Dim mx As Single
Dim my As Single
Dim mz As Single
Dim LdotV As Single
Dim r_trd As Single
Dim g_trd As Single
Dim b_trd As Single
Dim r_tra As Single
Dim g_tra As Single
Dim b_tra As Single
Dim tx As Single
Dim ty As Single
Dim tz As Single
Dim n_ratio As Single
Dim cos2 As Single
Dim cos1 As Single
Dim cos_factor As Single
Dim NdotT As Single
Dim NdotT_Nt As Single
Dim hit_x As Single
Dim hit_y As Single
Dim hit_z As Single
Dim i As Integer
Dim dist As Single
Dim shadowed As Boolean
Dim rlng As Long
Dim glng As Long
Dim blng As Long

    hit_x = HitX
    hit_y = HitY
    hit_z = HitZ

    ' *******************************
    ' * Compute local contributions *
    ' *******************************

    ' Find the unit vector pointing toward the light.
    lx = LightSource.trans(1) - hit_x
    ly = LightSource.trans(2) - hit_y
    lz = LightSource.trans(3) - hit_z
    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.
    nx = hit_x - Center.trans(1)
    ny = hit_y - Center.trans(2)
    nz = hit_z - Center.trans(3)
    n_len = Sqr(nx * nx + ny * ny + nz * nz)
    nx = nx / n_len
    ny = ny / n_len
    nz = nz / n_len

    ' See if the light shines directly on the surface.
    For i = 1 To Objects.Count
        dist = Objects.Item(i).RayDistance( _
            LightSource.trans(1), _
            LightSource.trans(2), _
            LightSource.trans(3), _
            -lx, -ly, -lz)
        If dist < l_len - 0.1 Then Exit For
    Next i
    shadowed = (i <= Objects.Count)

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

    ' Find the vector V from the surface to the
    ' viewpoint.
    Vx = EyeX - hit_x
    Vy = EyeY - hit_y
    Vz = EyeZ - hit_z
    v_len = Sqr(Vx * Vx + Vy * Vy + Vz * Vz)
    Vx = Vx / v_len
    Vy = Vy / v_len
    Vz = Vz / v_len

    ' Calculate the part due to diffuse reflection.
    If shadowed Then NdotL = -1
    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 = Kdr * NdotL
        g_dif = Kdg * NdotL
        b_dif = Kdb * NdotL

        ' Calculate the part due to specular reflection.
        RdotV = rx * Vx + ry * Vy + rz * Vz
        If RdotV < 0 Then
            spec = 0
        Else
            spec = Ks * RdotV ^ SpecN
        End If
    End If

    ' Calculate the part due to ambient light.
    r_amb = LightIar * Kar
    g_amb = LightIag * Kag
    b_amb = LightIab * Kab

    ' **********************************
    ' * Compute reflected contribution *
    ' **********************************
    NdotV = nx * Vx + ny * Vy + nz * Vz
    r_ref = 0
    g_ref = 0
    b_ref = 0
    If IsReflective And depth > 1 Then
        ' Find vector M in the direction of reflection.
        mx = 2 * nx * NdotV - Vx
        my = 2 * ny * NdotV - Vy
        mz = 2 * nz * NdotV - Vz

        TraceRay depth - 1, hit_x, hit_y, hit_z, mx, my, mz, r1, g1, b1
        r_ref = Krr * r1
        g_ref = Krg * g1
        b_ref = Krb * b1
    End If

    ' **********************************
    ' * Compute refracted contribution *
    ' **********************************
    r_trd = 0
    g_trd = 0
    b_trd = 0
    r_tra = 0
    g_tra = 0
    b_tra = 0
    If IsTransparent Then
        ' Find the transmission vector T.
        If NdotV > 0 Then
            ' The ray is entering this object.
            cos1 = NdotV
        Else
            ' The ray is exiting this object.
            cos1 = -NdotV
        End If
        n_ratio = N1 / N2
        cos2 = Sqr(1 - (1 - cos1 * cos1) * n_ratio * n_ratio)
        cos_factor = cos2 - cos1 * n_ratio
        tx = -Vx * n_ratio - cos_factor * nx
        ty = -Vy * n_ratio - cos_factor * ny
        tz = -Vz * n_ratio - cos_factor * nz

        ' If LdotV < 0, the viewpoint and light are on
        ' opposite sides of the surface. In that case
        ' there is direct transmitted light and no
        ' specular reflection.
        '
        ' If LdotV > 0, the viewpoint and light are on
        ' the same side of the surface. Then there
        ' is specular reflection and no direct
        ' transmitted light.
        LdotV = lx * Vx + ly * Vy + lz * Vz

        ' Find the directly transmitted component.
        If LdotV < 0 Then
            NdotT = nx * tx + ny * ty + nz * tz
            NdotT_Nt = NdotT ^ Nt
            r_trd = Ktr * NdotT_Nt
            g_trd = Ktg * NdotT_Nt
            b_trd = Ktb * NdotT_Nt
        End If

        ' Find the indirectly transmitted component.
        If depth > 1 Then
            TraceRay depth - 1, hit_x, hit_y, hit_z, tx, ty, tz, r1, g1, b1
            r_tra = Ktr * r1
            g_tra = Ktg * g1
            b_tra = Ktb * b1
        End If
    End If

    ' See how intense to make the color.
    ' Some of the reflections may be close to
    ' the light source so these values can get big.
    rlng = r_amb + _
        LightIir / (l_len + LightKdist) * _
            (r_dif + spec) + _
        r_ref + r_tra + r_trd
    glng = g_amb + _
        LightIig / (l_len + LightKdist) * _
            (g_dif + spec) + _
        g_ref + g_tra + g_trd
    blng = b_amb + _
        LightIib / (l_len + LightKdist) * _
            (b_dif + spec) + _
        b_ref + b_tra + b_trd
    If rlng > 255 Then rlng = 255
    If glng > 255 Then glng = 255
    If blng > 255 Then blng = 255
    R = rlng
    G = glng
    B = blng
End Sub


' ************************************************
' Compute the distance from point (px, py, pz)
' along vector <vx, vy, vz> to the sphere.
'
' Save the point of intersection in
' (HitX, HitY, HitZ) for later use.
' ************************************************
Public Function RayDistance(px As Single, py As Single, pz As Single, Vx As Single, Vy As Single, Vz As Single) As Single
Dim A As Single
Dim B As Single
Dim C As Single
Dim Cx As Single
Dim Cy As Single
Dim Cz As Single
Dim B24AC As Single
Dim t1 As Single
Dim t2 As Single

    Cx = Center.trans(1)
    Cy = Center.trans(2)
    Cz = Center.trans(3)

    ' Get the coefficients for the quadratic.
    A = Vx * Vx + Vy * Vy + Vz * Vz
    B = 2 * Vx * (px - Cx) + _
        2 * Vy * (py - Cy) + _
        2 * Vz * (pz - Cz)
    C = Cx * Cx + Cy * Cy + Cz * Cz + _
        px * px + py * py + pz * pz - _
        2 * (Cx * px + Cy * py + Cz * pz) - _
        Radius * Radius

    ' Solve the quadratic A*t^2 + B*t + C = 0.
    B24AC = B * B - 4 * A * C
    If B24AC < 0 Then
        RayDistance = INFINITY
        Exit Function
    ElseIf B24AC = 0 Then
        t1 = -B / 2 / A
    Else
        B24AC = Sqr(B24AC)
        t1 = (-B + B24AC) / 2 / A
        t2 = (-B - B24AC) / 2 / A
        ' Use only positive t values.
        If t1 < 0.01 Then t1 = t2
        If t2 < 0.01 Then t2 = t1
        ' Use the smaller t value.
        If t1 > t2 Then t1 = t2
    End If

    ' If there is no positive t value, there's no
    ' intersection in this direction.
    If t1 < 0.01 Then
        RayDistance = INFINITY
        Exit Function
    End If

    ' Compute the actual hit location.
    HitX = px + t1 * Vx
    HitY = py + t1 * Vy
    HitZ = pz + t1 * Vz

    ' Compute the distance from (px, py, pz).
    A = px - HitX
    B = py - HitY
    C = pz - HitZ
    RayDistance = Sqr(A * A + B * B + C * C)
End Function

' ************************************************
' Set the center.
' ************************************************
Public Sub Initialize(R As Single, x As Single, y As Single, z As Single)
    Radius = R
    Center.coord(1) = x
    Center.coord(2) = y
    Center.coord(3) = z
    Center.coord(4) = 1
End Sub


' ************************************************
' Set N and Ks for specular reflection.
' ************************************************
Sub SetSpec(n As Single, s As Single)
    SpecN = n
    Ks = s
End Sub

' ************************************************
' Set constants for diffuse reflection.
' ************************************************
Sub SetKd(R As Single, G As Single, B As Single)
    Kdr = R
    Kdg = G
    Kdb = B
End Sub

' ************************************************
' Set constants for reflected light.
' ************************************************
Sub SetKr(R As Single, G As Single, B As Single)
    Krr = R
    Krg = G
    Krb = B
    IsReflective = (R > 0 Or G > 0 Or B > 0)
End Sub

' ************************************************
' Set constants for transmitted light.
' ************************************************
Sub SetKt(n As Single, n_1 As Single, n_2 As Single, R As Single, G As Single, B As Single)
    Nt = n
    N1 = n_1
    N2 = n_2
    Ktr = R
    Ktg = G
    Ktb = B
    IsTransparent = (R > 0 Or G > 0 Or B > 0)
End Sub

' ************************************************
' Set constants for ambient light.
' ************************************************
Sub SetKa(R As Single, G As Single, B As Single)
    Kar = R
    Kag = G
    Kab = B
End Sub


' ************************************************
' Initialize N1 and N2 to default values.
' ************************************************
Private Sub Class_Initialize()
    N1 = 1
    N2 = 1
End Sub