TMcubeX: Visual Basic Version


'*****************************************************************************
'                                                                            *
'  TMcubeX.frm                                                               *
'                                                                            *
'  This program is similar to the TMcube example, but it shows how to create *
'  a native, DirectDraw, or Direct3D program from the same source code.      *
'                                                                            *
'  Use the FGWinD.bas module file if creating a DirectX program, or use the  *
'  FGWin.bas module file if creating a native program.                       *
'                                                                            *
'  Requires Visual Basic 5.0 or later.                                       *
'                                                                            *
'*****************************************************************************
Const RENDER_STATE = FG_PERSPECTIVE_TM + FG_ZBUFFER + FG_ZCLIP
' set DIRECTX to
'   True if creating a DirectDraw or Direct3D program (use module FGWinD.bas)
'   False if creating a native Win32 program (use module FGWin.bas)
#Const DIRECTX = True
' define the flag bits for fg_ddsetup()
' specify FG_DX_FLIP for a Direct3D application
' specify FG_DX_RENDER_HW or FG_DX_RENDER_SW for a Direct3D application
' specify FG_DX_ZBUFFER only if FG_ZBUFFER is defined in RENDER_STATE
#If DIRECTX Then
Const DIRECTX_FLAGS = FG_DX_FLIP + FG_DX_RENDER_HW + FG_DX_ZBUFFER
#End If
Const vbWidth = 640
Const vbHeight = 480
Const vbDepth = 16
Const tmWidth = 64
Private Type Point3D
   X As Double
   Y As Double
   Z As Double
End Type
Option Base 1
Dim hPal As Long
Dim hVB As Long
Dim hZB As Long
Dim hTM(6) As Long
Dim AppIsActive As Boolean
Dim AppIsRunning As Boolean
Dim xAngle As Long, yAngle As Long, zAngle As Long
Dim xWorld As Double, yWorld As Double, zWorld As Double
' six faces of a 40x40x40 cube, defined in object coordinates
Dim Faces(4, 6) As Point3D
' texture map array
Dim Texture(tmWidth * tmWidth * (vbDepth / 8), 6) As Byte
' coordinates defining source polygon vertices within the texture map array
Dim tmSource(8) As Long
Public Sub ActivateApp(ByVal wParam As Long)
   AppIsActive = (wParam <> 0)
   If AppIsActive Then
      WindowState = vbMaximized
      #If DIRECTX Then
      Call fg_ddrestore
      #End If
      Call CheckForMovement(True)
   Else
      WindowState = vbMinimized
      #If DIRECTX Then
      Call fg_gdiflip
      #End If
   End If
End Sub
Private Sub Form_Activate()
   Call fg_realize(hPal)
End Sub
Private Sub Form_Load()
   Dim I As Long
   ScaleMode = 3
   Visible = True
   #If DIRECTX Then
   Call fg_ddsetup(vbWidth, vbHeight, vbDepth, DIRECTX_FLAGS)
   #Else
   Call fg_modeset(vbWidth, vbHeight, fg_colors(), 1)
   WindowState = vbMaximized
   #End If
   Call fg_setdc(hDC)
   hPal = fg_defpal()
   Call fg_realize(hPal)
   Call fg_vbinit
   Call fg_vbdepth(vbDepth)
   #If DIRECTX Then
   hVB = 0
   #Else
   hVB = fg_vballoc(vbWidth, vbHeight)
   #End If
   Call fg_vbopen(hVB)
   Call fg_vbcolors
   hZB = fg_zballoc(vbWidth, vbHeight)
   Call fg_zbopen(hZB)
   ' define 3D viewport, clipping planes, and initial render state
   Call fg_3Dviewport(0, vbWidth - 1, 0, vbHeight - 1, 0.5)
   Call fg_3Dsetzclip(40#, 1000#)
   Call fg_3Drenderstate(RENDER_STATE)
   ' obtain the six texture maps from the CUBE.PCX file
   Call fg_tminit(6)
   Call fg_showpcx(App.Path & "\CUBE.PCX", FG_AT_XY + FG_KEEPCOLORS)
   Call fg_move(0, tmWidth - 1)
   For I = 1 To 6
      #If vbDepth = 8 Then
      Call fg_getimage(Texture(1, I), tmWidth, tmWidth)
      Call fg_invert(Texture(1, I), tmWidth, tmWidth)
      #Else
      Call fg_getdcb(Texture(1, I), tmWidth, tmWidth)
      Call fg_invdcb(Texture(1, I), tmWidth, tmWidth)
      #End If
      hTM(I) = fg_tmdefine(Texture(1, I), tmWidth, tmWidth)
      Call fg_moverel(tmWidth, 0)
   Next
   xAngle = 0
   yAngle = 0
   zAngle = 0
   xWorld = 0#
   yWorld = 0#
   zWorld = 100#
   Call InitGlobals
   AppIsActive = True
   AppIsRunning = True
   Call HookWindowProc(hWnd)
   Call CheckForMovement(True)
   While AppIsRunning
      DoEvents
      If AppIsActive Then Call CheckForMovement(False)
   Wend
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
   If KeyCode = vbKeyEscape Or KeyCode = vbKeyF12 Then Unload Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
   AppIsRunning = False
   AppIsActive = False
   Call UnHookWindowProc(hWnd)
   Call fg_vbclose
   Call fg_tmfree(-1)
   Call fg_zbfree(hZB)
   #If DIRECTX Then
   Call fg_vbfin
   #Else
   Call fg_vbfree(hVB)
   Call fg_vbfin
   Call fg_modeset(0, 0, 0, 0)
   #End If
End Sub
'*****************************************************************************
'                                                                            *
'  CheckForMovement()                                                        *
'                                                                            *
'  The CheckForMovement() function checks for key presses that control the   *
'  cube's movement, and if required redraws the cube at its new position and *
'  orientation. It is called from the message loop in Form_Load().           *
'                                                                            *
'  The Redraw parameter controls when CheckForMovement() redraws the cube.   *
'  If False, the cube is redrawn only if its position or orientation has     *
'  changed since the last call. If True, the cube is redrawn no matter what. *
'                                                                            *
'*****************************************************************************
Private Sub CheckForMovement(Redraw As Boolean)
   Dim ShiftKey As Boolean
   ' check if either shift key is pressed
   ShiftKey = (fg_kbtest(42) = 1) Or (fg_kbtest(54) = 1)
   ' + and - move cube along the z axis (+ is toward viewer, - is
   ' away from viewer), restricting movement beyond z=40
   If fg_kbtest(74) = 1 Then
      zWorld = zWorld + 3#
      Redraw = True
   ElseIf fg_kbtest(78) = 1 Then
      zWorld = zWorld - 3#
      Redraw = True
   ' left and right arrow keys move cube along x axis
   ElseIf fg_kbtest(75) = 1 Then
      xWorld = xWorld - 3#
      Redraw = True
   ElseIf fg_kbtest(77) = 1 Then
      xWorld = xWorld + 3#
      Redraw = True
   ' up and down arrow keys move cube along y axis
   ElseIf fg_kbtest(72) = 1 Then
      yWorld = yWorld + 3#
      Redraw = True
   ElseIf fg_kbtest(80) = 1 Then
      yWorld = yWorld - 3#
      Redraw = True
   ' x rotates counterclockwise around x axis, X rotates clockwise
   ElseIf fg_kbtest(45) = 1 Then
      If ShiftKey Then
         xAngle = xAngle + 6
         If xAngle >= 360 Then xAngle = xAngle - 360
      Else
         xAngle = xAngle - 6
         If xAngle < 0 Then xAngle = xAngle + 360
      End If
      Redraw = True
   ' y rotates counterclockwise around y axis, Y rotates clockwise
   ElseIf fg_kbtest(21) = 1 Then
      If ShiftKey Then
         yAngle = yAngle + 6
         If yAngle >= 360 Then yAngle = yAngle - 360
      Else
         yAngle = yAngle - 6
         If yAngle < 0 Then yAngle = yAngle + 360
      End If
      Redraw = True
   ' z rotates counterclockwise around z axis, Z rotates clockwise
   ElseIf fg_kbtest(44) = 1 Then
      If ShiftKey Then
         zAngle = zAngle + 6
         If zAngle >= 360 Then zAngle = zAngle - 360
      Else
         zAngle = zAngle - 6
         If zAngle < 0 Then zAngle = zAngle + 360
      End If
      Redraw = True
   End If
   ' if the cube's position or orientation changed, redraw the cube
   If Redraw Then
      #If DIRECTX Then
      ' tell Direct3D we're about to start a new frame
      Call fg_ddframe(0)
      #End If
      ' prepare the z-buffer for the next frame
      Call fg_zbframe
      ' erase the previous frame from the virtual buffer
      Call fg_setcolor(-1)
      Call fg_fillpage
      ' define the cube's new position and rotation in 3D world space
      Call fg_3Dsetobject(xWorld, yWorld, zWorld, xAngle * 10, yAngle * 10, zAngle * 10)
      ' draw the cube
      Call DrawCube
      #If DIRECTX Then
      ' tell Direct3D we're finished with this frame
      Call fg_ddframe(1)
      #End If
      ' display what we just drew
      Call ShowCube
   End If
End Sub
'*****************************************************************************
'                                                                            *
'  DrawCube()                                                                *
'                                                                            *
'  Draws each of the six cube faces in 3D world space.                       *
'                                                                            *
'*****************************************************************************
Private Sub DrawCube()
   Dim I As Long
   For I = 1 To 6
      Call fg_tmselect(hTM(I))
      Call fg_3Dtexturemapobject(Faces(1, I).X, tmSource(1), 4)
   Next
End Sub
'*****************************************************************************
'                                                                            *
'  ShowCube()                                                                *
'                                                                            *
'  Performs a blit or flip to make the cube visible.                         *
'                                                                            *
'*****************************************************************************
Private Sub ShowCube()
   #If DIRECTX Then
   Call fg_ddflip
   #Else
   Call fg_vbpaste(0, vbWidth - 1, 0, vbHeight - 1, 0, vbHeight - 1)
   #End If
End Sub
'*****************************************************************************
'                                                                            *
'  InitGlobals()                                                             *
'                                                                            *
'  Initialize global variables and arrays. Called from Form_Load().          *
'                                                                            *
'*****************************************************************************
Private Sub InitGlobals()
   Faces(1, 1).X = 20#: Faces(1, 1).Y = -20#: Faces(1, 1).Z = -20#
   Faces(2, 1).X = -20#: Faces(2, 1).Y = -20#: Faces(2, 1).Z = -20#
   Faces(3, 1).X = -20#: Faces(3, 1).Y = 20#: Faces(3, 1).Z = -20#
   Faces(4, 1).X = 20#: Faces(4, 1).Y = 20#: Faces(4, 1).Z = -20#
   Faces(1, 2).X = -20#: Faces(1, 2).Y = -20#: Faces(1, 2).Z = -20#
   Faces(2, 2).X = -20#: Faces(2, 2).Y = -20#: Faces(2, 2).Z = 20#
   Faces(3, 2).X = -20#: Faces(3, 2).Y = 20#: Faces(3, 2).Z = 20#
   Faces(4, 2).X = -20#: Faces(4, 2).Y = 20#: Faces(4, 2).Z = -20#
   Faces(1, 3).X = 20#: Faces(1, 3).Y = 20#: Faces(1, 3).Z = 20#
   Faces(2, 3).X = -20#: Faces(2, 3).Y = 20#: Faces(2, 3).Z = 20#
   Faces(3, 3).X = -20#: Faces(3, 3).Y = -20#: Faces(3, 3).Z = 20#
   Faces(4, 3).X = 20#: Faces(4, 3).Y = -20#: Faces(4, 3).Z = 20#
   Faces(1, 4).X = 20#: Faces(1, 4).Y = -20#: Faces(1, 4).Z = 20#
   Faces(2, 4).X = 20#: Faces(2, 4).Y = -20#: Faces(2, 4).Z = -20#
   Faces(3, 4).X = 20#: Faces(3, 4).Y = 20#: Faces(3, 4).Z = -20#
   Faces(4, 4).X = 20#: Faces(4, 4).Y = 20#: Faces(4, 4).Z = 20#
   Faces(1, 5).X = 20#: Faces(1, 5).Y = -20#: Faces(1, 5).Z = 20#
   Faces(2, 5).X = -20#: Faces(2, 5).Y = -20#: Faces(2, 5).Z = 20#
   Faces(3, 5).X = -20#: Faces(3, 5).Y = -20#: Faces(3, 5).Z = -20#
   Faces(4, 5).X = 20#: Faces(4, 5).Y = -20#: Faces(4, 5).Z = -20#
   Faces(1, 6).X = 20#: Faces(1, 6).Y = 20#: Faces(1, 6).Z = -20#
   Faces(2, 6).X = -20#: Faces(2, 6).Y = 20#: Faces(2, 6).Z = -20#
   Faces(3, 6).X = -20#: Faces(3, 6).Y = 20#: Faces(3, 6).Z = 20#
   Faces(4, 6).X = 20#: Faces(4, 6).Y = 20#: Faces(4, 6).Z = 20#
   tmSource(1) = tmWidth - 1: tmSource(2) = tmWidth - 1
   tmSource(3) = 0: tmSource(4) = tmWidth - 1
   tmSource(5) = 0: tmSource(6) = 0
   tmSource(7) = tmWidth - 1: tmSource(8) = 0
End Sub

<< Prev

Next >>

Contents
Fastgraph Home Page

 

copyright 2001 Ted Gruber Software, Inc.