Visual Basic Game Programming for Teens/VBGPFT.cdr/DirectX8/dx8vbsdk.exe/samples/multimedia/vbsamples/direct3d/vertexshader/vertexshader.frm

Visual Basic Form | 2000-10-09 | 17.4 KB | 427 lines

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Vertex Blend"
   ClientHeight    =   4485
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5640
   Icon            =   "vertexshader.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   299
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   376
   StartUpPosition =   3  'Windows Default
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  Copyright (C) 2000 Microsoft Corporation.  All Rights Reserved.
'  File:       VertexShader.frm
'  Content:    Example code showing how to use vertex shaders in D3D.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
' Scene
Dim m_VB As Direct3DVertexBuffer8
Dim m_IB As Direct3DIndexBuffer8
Dim m_NumVertices As Long
Dim m_NumIndices As Long
Dim m_Shader As Long
Dim m_Size As Long
' Transforms
Dim m_matPosition As D3DMATRIX
Dim m_matView As D3DMATRIX
Dim m_matProj As D3DMATRIX
'Navigation
Dim m_bKey(256) As Boolean
Dim m_fSpeed As Single
Dim m_fAngularSpeed As Single
Dim m_vVelocity As D3DVECTOR
Dim m_vAngularVelocity As D3DVECTOR
'Shader
Dim m_Decl(3) As Long
Dim m_ShaderArray() As Long
Dim m_bInit As Boolean                  ' Indicates that d3d has been initialized
Dim m_bMinimized As Boolean             ' Indicates that display window is minimized
'-----------------------------------------------------------------------------
' Name: Form_Load()
' Desc:
'-----------------------------------------------------------------------------
Private Sub Form_Load()
    Me.Show
    DoEvents
    'setup defaults
    Init
    ' Initialize D3D
    ' Note: D3DUtil_Init will attempt to use D3D Hardware acceleartion.
    ' If it is not available it attempt to use the Software Reference Rasterizer.
    ' If all fail it will display a message box indicating so.
    '
    m_bInit = D3DUtil_Init(Me.hwnd, True, 0, 0, D3DDEVTYPE_HAL, Me)
    If Not (m_bInit) Then End
    ' Create new D3D vertexbuffer objects and vertex shader
    InitDeviceObjects
    ' Sets the state for those objects and the current D3D device
    RestoreDeviceObjects
    ' Start our timer
    DXUtil_Timer TIMER_start
    ' Run the simulation forever
    ' See Form_Keydown for exit processing
    Do While True
        ' Increment the simulation
        FrameMove

        ' Render one image of the simulation
        Render

        ' Present the image to the screen
        D3DUtil_PresentAll g_focushwnd

        ' Allow for events to get processed
        DoEvents

    Loop
End Sub
'-----------------------------------------------------------------------------
' Name: Form_Unload()
' Desc:
'-----------------------------------------------------------------------------
Private Sub Form_Unload(Cancel As Integer)
    DeleteDeviceObjects
    End
End Sub
'-----------------------------------------------------------------------------
' Name: Init()
' Desc: Sets attributes for the app.
'-----------------------------------------------------------------------------
Sub Init()
    Me.Caption = "VertexShader"
    Set m_IB = Nothing
    Set m_VB = Nothing
    m_Size = 32
    m_NumIndices = (m_Size - 1) * (m_Size - 1) * 6
    m_NumVertices = m_Size * m_Size
    m_Shader = 0
    m_fSpeed = 5
    m_fAngularSpeed = 1
    m_vVelocity = vec3(0, 0, 0)
    m_vAngularVelocity = vec3(0, 0, 0)
    ' Setup the view matrix
    Dim veye As D3DVECTOR, vat As D3DVECTOR, vUp As D3DVECTOR
    veye = vec3(2, 3, 3)
    vat = vec3(0, 0, 0)
    vUp = vec3(0, 1, 0)
    D3DXMatrixLookAtRH m_matView, veye, vat, vUp
    ' Set the position matrix
    Dim det As Single
    D3DXMatrixInverse m_matPosition, det, m_matView
End Sub
'-----------------------------------------------------------------------------
' Name: FrameMove()
' Desc: Called once per frame, the call is the entry point for animating
'       the scene.
'-----------------------------------------------------------------------------
Sub FrameMove()
    Dim fSecsPerFrame As Single
    Dim fTime As Single
    Dim det As Single
    fSecsPerFrame = DXUtil_Timer(TIMER_GETELLAPSEDTIME)
    fTime = DXUtil_Timer(TIMER_GETAPPTIME)
    ' Process keyboard input
    Dim vT As D3DVECTOR, vR As D3DVECTOR
    vT = vec3(0, 0, 0)
    vR = vec3(0, 0, 0)
    If (m_bKey(vbKeyA) Or m_bKey(vbKeyNumpad1) Or m_bKey(vbKeyLeft)) Then vT.x = vT.x - 1  ' Slide Left
    If (m_bKey(vbKeyD) Or m_bKey(vbKeyNumpad3) Or m_bKey(vbKeyRight)) Then vT.x = vT.x + 1 ' Slide Right
    If (m_bKey(vbKeyDown)) Then vT.y = vT.y - 1                                      ' Slide Down
    If (m_bKey(vbKeyUp)) Then vT.y = vT.y + 1                                        ' Slide Up
    If (m_bKey(vbKeyW)) Then vT.z = vT.z - 2                                         ' Move Forward
    If (m_bKey(vbKeyS)) Then vT.z = vT.z + 2                                         ' Move Backward
    If (m_bKey(vbKeyNumpad8)) Then vR.x = vR.x - 1                                   ' Pitch Down
    If (m_bKey(vbKeyNumpad2)) Then vR.x = vR.x + 1                                   ' Pitch Up
    If (m_bKey(vbKeyE) Or m_bKey(vbKeyNumpad6)) Then vR.y = vR.y - 1                 ' Turn Right
    If (m_bKey(vbKeyQ) Or m_bKey(vbKeyNumpad4)) Then vR.y = vR.y + 1                 ' Turn Left
    If (m_bKey(vbKeyNumpad9)) Then vR.z = vR.z - 2                                   ' Roll CW
    If (m_bKey(vbKeyNumpad7)) Then vR.z = vR.z + 2                                   ' Roll CCW
    m_vVelocity.x = m_vVelocity.x * 0.9 + vT.x * 0.1
    m_vVelocity.y = m_vVelocity.y * 0.9 + vT.y * 0.1
    m_vVelocity.z = m_vVelocity.z * 0.9 + vT.z * 0.1
    m_vAngularVelocity.x = m_vAngularVelocity.x * 0.9 + vR.x * 0.1
    m_vAngularVelocity.y = m_vAngularVelocity.x * 0.9 + vR.y * 0.1
    m_vAngularVelocity.z = m_vAngularVelocity.x * 0.9 + vR.z * 0.1
    ' Update position and view matricies
    Dim matT As D3DMATRIX, matR As D3DMATRIX, qR As D3DQUATERNION
    D3DXVec3Scale vT, m_vVelocity, fSecsPerFrame * m_fSpeed
    D3DXVec3Scale vR, m_vAngularVelocity, fSecsPerFrame * m_fAngularSpeed
    D3DXMatrixTranslation matT, vT.x, vT.y, vT.z
    D3DXMatrixMultiply m_matPosition, matT, m_matPosition
    D3DXQuaternionRotationYawPitchRoll qR, vR.y, vR.x, vR.z
    D3DXMatrixRotationQuaternion matR, qR
    D3DXMatrixMultiply m_matPosition, matR, m_matPosition
    D3DXMatrixInverse m_matView, det, m_matPosition
    g_dev.SetTransform D3DTS_VIEW, m_matView
    ' Set up the vertex shader constants
    Dim mat As D3DMATRIX
    Dim vA As D3DVECTOR4, vD As D3DVECTOR4
    Dim vSin As D3DVECTOR4, vCos As D3DVECTOR4
    D3DXMatrixMultiply mat, m_matView, m_matProj
    D3DXMatrixTranspose mat, mat
    vA = vec4(Sin(fTime) * 15, 0, 0.5, 1)
    vD = vec4(g_pi, 1 / (2 * g_pi), 2 * g_pi, 0.05)
    ' Taylor series coefficients for sin and cos
    vSin = vec4(1, -1 / 6, 1 / 120, -1 / 5040)
    vCos = vec4(1, -1 / 2, 1 / 24, -1 / 720)
    g_dev.SetVertexShaderConstant 0, mat, 4
    g_dev.SetVertexShaderConstant 4, vA, 1
    g_dev.SetVertexShaderConstant 7, vD, 1
    g_dev.SetVertexShaderConstant 10, vSin, 1
    g_dev.SetVertexShaderConstant 11, vCos, 1
End Sub
'-----------------------------------------------------------------------------
' Name: Render()
' Desc: Called once per frame, the call is the entry point for 3d
'       rendering. This function sets up render states, clears the
'       viewport, and renders the scene.
'-----------------------------------------------------------------------------
Sub Render()
    Dim v2 As D3DVECTOR2
    Dim hr As Long
    'See what state the device is in.
    hr = g_dev.TestCooperativeLevel
    If hr = D3DERR_DEVICENOTRESET Then
        g_dev.Reset g_d3dpp
        RestoreDeviceObjects
    End If
    'dont bother rendering if we are not ready yet
    If hr <> 0 Then Exit Sub
    'Clear the scene
    D3DUtil_ClearAll &HFF&
    With g_dev
        ' Begin the scene
        .BeginScene

        .SetVertexShader m_Shader
        .SetStreamSource 0, m_VB, Len(v2)
        .SetIndices m_IB, 0

        .DrawIndexedPrimitive D3DPT_TRIANGLELIST, 0, m_NumVertices, _
                                            0, m_NumIndices / 3
        ' End the scene.
        .EndScene
    End With
End Sub
'-----------------------------------------------------------------------------
' Name: RestoreDeviceObjects()
' Desc: Initialize scene objects.
'-----------------------------------------------------------------------------
Sub InitDeviceObjects()
    Dim Indices() As Integer    'Integer are 4 bytes wide in VB
    Dim Vertices() As D3DVECTOR2
    Dim v As D3DVECTOR2, x As Integer, y As Integer, i As Integer

    ' Fill in our index array with triangles indices to make a grid
    ReDim Indices(m_NumIndices)
    For y = 1 To m_Size - 1
        For x = 1 To m_Size - 1
            Indices(i) = (y - 1) * m_Size + (x - 1): i = i + 1
            Indices(i) = (y - 0) * m_Size + (x - 1): i = i + 1
            Indices(i) = (y - 1) * m_Size + (x - 0): i = i + 1
            Indices(i) = (y - 1) * m_Size + (x - 0): i = i + 1
            Indices(i) = (y - 0) * m_Size + (x - 1): i = i + 1
            Indices(i) = (y - 0) * m_Size + (x - 0): i = i + 1
        Next
    Next
    ' Create index buffer and copy the VB array into it
    Set m_IB = g_dev.CreateIndexBuffer(m_NumIndices * 2, 0, D3DFMT_INDEX16, D3DPOOL_MANAGED)
    D3DIndexBuffer8SetData m_IB, 0, m_NumIndices * 2, 0, Indices(0)
    i = 0

    'Fill our vertex array with the coordinates of our grid
    ReDim Vertices(m_NumVertices)
    For y = 0 To m_Size - 1
        For x = 0 To m_Size - 1
            Vertices(i) = vec2(((CSng(x) / CSng(m_Size - 1)) - 0.5) * g_pi, _
                            ((CSng(y) / CSng(m_Size - 1)) - 0.5) * g_pi)

            i = i + 1
        Next
    Next
    ' Create a vertex buffer and copy our vertex array into it
    Set m_VB = g_dev.CreateVertexBuffer(m_NumVertices * Len(v), 0, 0, D3DPOOL_MANAGED)
    D3DVertexBuffer8SetData m_VB, 0, m_NumVertices * Len(v), 0, Vertices(0)
    ' Create vertex shader
    Dim strVertexShaderPath As String
    Dim VShaderCode As D3DXBuffer
    m_Decl(0) = D3DVSD_STREAM(0)
    m_Decl(1) = D3DVSD_REG(D3DVSDE_POSITION, D3DVSDT_FLOAT2)
    m_Decl(2) = D3DVSD_END()

    ' Find the vertex shader file
    strVertexShaderPath = FindMediaDir("ripple.vsh") + "ripple.vsh"
    'Assemble the vertex shader from the file
    Set VShaderCode = g_d3dx.AssembleShaderFromFile(strVertexShaderPath, 0, "", Nothing)

    'Move VShader code into an array
    ReDim m_ShaderArray(VShaderCode.GetBufferSize() / 4)
    g_d3dx.BufferGetData VShaderCode, 0, 1, VShaderCode.GetBufferSize(), m_ShaderArray(0)
    Set VShaderCode = Nothing
End Sub
'-----------------------------------------------------------------------------
' Name: RestoreDeviceObjects()
' Desc: Initialize scene objects.
'-----------------------------------------------------------------------------
Sub RestoreDeviceObjects()
    Dim bufferdesc As D3DSURFACE_DESC
    g_dev.GetBackBuffer(0, D3DBACKBUFFER_TYPE_MONO).GetDesc bufferdesc
    ' Set up right handed projection matrix
    Dim fAspectRatio As Single
    fAspectRatio = bufferdesc.width / bufferdesc.height
    D3DXMatrixPerspectiveFovRH m_matProj, 60 * g_pi / 180, fAspectRatio, 0.1, 100
    g_dev.SetTransform D3DTS_PROJECTION, m_matProj
    ' Setup render states
    g_dev.SetRenderState D3DRS_LIGHTING, 0 'FALSE
    g_dev.SetRenderState D3DRS_CULLMODE, D3DCULL_NONE

    ' Create the vertex shader
    ' NOTE returns value in m_Shader
    g_dev.CreateVertexShader m_Decl(0), m_ShaderArray(0), m_Shader, 0
End Sub
'-----------------------------------------------------------------------------
' Name: InvalidateDeviceObjects()
' Desc:
'-----------------------------------------------------------------------------
Sub InvalidateDeviceObjects()
    On Local Error Resume Next
    g_dev.DeleteVertexShader m_Shader
End Sub
'-----------------------------------------------------------------------------
' Name: DeleteDeviceObjects()
' Desc: Called when the app is exitting, or the device is being changed,
'       this function deletes any device dependant objects.
'-----------------------------------------------------------------------------
Sub DeleteDeviceObjects()
    Set m_IB = Nothing
    Set m_VB = Nothing
    InvalidateDeviceObjects
    m_bInit = False
End Sub
'-----------------------------------------------------------------------------
' Name: FinalCleanup()
' Desc: Called before the app exits, this function gives the app the chance
'       to cleanup after itself.
'-----------------------------------------------------------------------------
Sub FinalCleanup()
End Sub
'-----------------------------------------------------------------------------
' Name: ConfirmDevice()
' Desc: Called during device intialization, this code checks the device
'       for some minimum set of capabilities
'-----------------------------------------------------------------------------
Function VerifyDevice(Behavior As Long, format As CONST_D3DFORMAT) As Boolean
    If (Behavior <> D3DCREATE_SOFTWARE_VERTEXPROCESSING) Then
        If (g_d3dCaps.VertexShaderVersion < D3DVS_VERSION(1, 0)) Then Exit Function
    End If
    VerifyDevice = True
End Function
'-----------------------------------------------------------------------------
' Name: Form_KeyDown()
' Desc: Process key messages for exit and change device
'-----------------------------------------------------------------------------
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
     Dim hr As Long

     m_bKey(KeyCode) = True
     Select Case KeyCode

        Case vbKeyEscape
            Unload Me

        Case vbKeyF2

            ' Pause the timer
            DXUtil_Timer TIMER_STOP

            ' Bring up the device selection dialog
            ' we pass in the form so the selection process
            ' can make calls into InitDeviceObjects
            ' and RestoreDeviceObjects
            frmSelectDevice.SelectDevice Me

            ' Restart the timer
            DXUtil_Timer TIMER_start

        Case vbKeyReturn

            ' Check for Alt-Enter if not pressed exit
            If Shift <> 4 Then Exit Sub

            ' If we are windowed go fullscreen
            ' If we are fullscreen returned to windowed
            If g_d3dpp.Windowed Then
                 hr = D3DUtil_ResetFullscreen
            Else
                 hr = D3DUtil_ResetWindowed
            End If

            If hr = D3DERR_DEVICELOST Then

                DeleteDeviceObjects

                m_bInit = D3DUtil_Init(Me.hwnd, True, 0, 0, D3DDEVTYPE_HAL, Me)
                If Not (m_bInit) Then End

                InitDeviceObjects
            End If

            ' Call Restore after ever mode change
            ' because calling reset looses state that needs to
            ' be reinitialized
            RestoreDeviceObjects

    End Select
End Sub
'-----------------------------------------------------------------------------
' Name: Form_Resize()
' Desc: hadle resizing of the D3D backbuffer
'-----------------------------------------------------------------------------
Private Sub Form_Resize()
    ' If D3D is not initialized then exit
    If Not m_bInit Then Exit Sub
    ' If we are in a minimized state stop the timer and exit
    If Me.WindowState = vbMinimized Then
        DXUtil_Timer TIMER_STOP
        m_bMinimized = True
        Exit Sub

    ' If we just went from a minimized state to maximized
    ' restart the timer
    Else
        If m_bMinimized = True Then
            DXUtil_Timer TIMER_start
            m_bMinimized = False
        End If
    End If
    ' Dont let the window get too small
    If Me.ScaleWidth < 10 Then
        Me.width = Screen.TwipsPerPixelX * 10
        Exit Sub
    End If
    If Me.ScaleHeight < 10 Then
        Me.height = Screen.TwipsPerPixelY * 10
        Exit Sub
    End If

    'reset and resize our D3D backbuffer to the size of the window
    D3DUtil_ResizeWindowed Me.hwnd
    'All state get losts after a reset so we need to reinitialze it here
    RestoreDeviceObjects
End Sub
'-----------------------------------------------------------------------------
' Name: Picture1_KeyUp
' Desc:
'-----------------------------------------------------------------------------
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    m_bKey(KeyCode) = False
End Sub