Columns: Visual Basic Version


'*****************************************************************************
'                                                                            *
'  Columns.frm                                                               *
'                                                                            *
'  This program draws a grid of columns in 3D world space. It demonstrates   *
'  polygon culling and Fastgraph's incremental POV functions.                *
'                                                                            *
'*****************************************************************************
Const vbWidth = 600
Const vbHeight = 400
Const InfoHeight = 80
Const WinWidth = vbWidth
Const WinHeight = (vbHeight + InfoHeight)
Option Base 1
Dim hPal As Long
Dim hVB As Long
Dim hZB As Long
Dim AppIsRunning As Boolean
' six faces of a 2x2x10 column, defined in object coordinates
Dim ColumnData(12, 6) As Double
Private Sub Form_Activate()
   Call fg_realize(hPal)
   Refresh
End Sub
Private Sub Form_Load()
   ' set up the device context and logical palette
   ScaleMode = 3
   Call fg_setdc(hDC)
   hPal = fg_defpal()
   Call fg_realize(hPal)
   ' initialize the virtual buffer environment
   Call fg_vbinit
   Call fg_vbdepth(fg_colors())
   ' create and open the virtual buffer
   hVB = fg_vballoc(vbWidth, vbHeight)
   Call fg_vbopen(hVB)
   Call fg_vbcolors
   ' create and open the z-buffer
   hZB = fg_zballoc(vbWidth, vbHeight)
   Call fg_zbopen(hZB)
   ' define 3D viewport, render state, and initial POV
   Call fg_3Dviewport(0, vbWidth - 1, 0, vbHeight - 1, 1#)
   Call fg_3Drenderstate(FG_ZBUFFER + FG_ZCLIP)
   Call fg_3Dlookat(10#, 20#, 100#, 0#, 20#, 0#)
   ' direct strings to the active virtual buffer
   Call fg_fontdc(fg_getdc())
   ' make the client area equal to the required size
   Left = 0
   Top = 0
   Width = (WinWidth + 8) * 15
   Height = (WinHeight + 27) * 15
   Call InitGlobals
   Visible = True
   AppIsRunning = True
   While AppIsRunning
      DoEvents
      Call CheckForMotion
   Wend
End Sub
Private Sub Form_Paint()
   Call DrawColumns
End Sub
Private Sub Form_Unload(Cancel As Integer)
   AppIsRunning = False
   Call fg_vbclose
   Call fg_zbfree(hZB)
   Call fg_vbfree(hVB)
   Call fg_vbfin
End Sub
'*****************************************************************************
'                                                                            *
'  CheckForMotion()                                                          *
'                                                                            *
'  The CheckForMotion() function checks for key presses that control the     *
'  viewer's position and orientation, and if required redraws the scene at   *
'  its new POV. It is called from the WinMain() message loop when there are  *
'  no messages waiting.                                                      *
'                                                                            *
'*****************************************************************************
Private Sub CheckForMotion()
   Dim ShiftKey As Boolean
   ' check if either shift key is pressed
   ShiftKey = (fg_kbtest(42) = 1) Or (fg_kbtest(54) = 1)
   If fg_kbtest(71) = 1 Then      ' Home
      Call fg_3Dmoveup(5#)
      Call DrawColumns
   ElseIf fg_kbtest(72) = 1 Then  ' Up arrow
      Call fg_3Dmoveforward(5#)
      Call DrawColumns
   ElseIf fg_kbtest(73) = 1 Then  ' PgUp
      Call fg_3Drotateup(100)
      Call DrawColumns
   ElseIf fg_kbtest(75) = 1 Then  ' Left arrow
      If (ShiftKey) Then
         Call fg_3Dmoveright(-5#)
      Else
         Call fg_3Drotateright(-100)
      End If
      Call DrawColumns
   ElseIf fg_kbtest(77) = 1 Then  ' Right arrow
      If (ShiftKey) Then
         Call fg_3Dmoveright(5#)
      Else
         Call fg_3Drotateright(100)
      End If
      Call DrawColumns
   ElseIf fg_kbtest(79) = 1 Then  ' End
      Call fg_3Dmoveup(-5#)
      Call DrawColumns
   ElseIf fg_kbtest(80) = 1 Then  ' Down arrow
      Call fg_3Dmoveforward(-5#)
      Call DrawColumns
   ElseIf fg_kbtest(81) = 1 Then  ' PgDn
      Call fg_3Drotateup(-100)
      Call DrawColumns
   End If
End Sub
'*****************************************************************************
'                                                                            *
'  DrawColumns()                                                             *
'                                                                            *
'  Draws each of the six cube faces in 3D world space.                       *
'                                                                            *
'*****************************************************************************
Private Sub DrawColumns()
   Dim nColor(6) As Long
   Dim Row, Col As Long
   Dim I As Long
   ' prepare for the new frame
   Call fg_zbframe
   Call fg_setcolor(-1)
   Call fg_fillpage
   ' create the six encoded color values
   nColor(1) = fg_maprgb(254, 219, 164)
   nColor(2) = fg_maprgb(243, 194, 117)
   nColor(3) = fg_maprgb(226, 172, 86)
   nColor(4) = fg_maprgb(203, 150, 67)
   nColor(5) = fg_maprgb(123, 98, 59)
   nColor(6) = fg_maprgb(166, 125, 60)
   ' 50x50x6 = 15000 polygons per frame
   For Row = -500 To 480 Step 20
      For Col = -500 To 480 Step 20
         If fg_3Dbehindviewer(CDbl(Row), 0#, CDbl(Col), -1#) = 0 Then
            Call fg_3Dmoveobject(CDbl(Row), 0#, CDbl(Col))
            ' draw all the faces
            For I = 1 To 6
               ' set the color
               Call fg_setcolor(nColor(I))
               ' draw the face
               Call fg_3Dpolygonobject(ColumnData(1, I), 4)
            Next I
         End If
      Next Col
   Next Row
   ' display the scene
   Call fg_vbpaste(0, vbWidth - 1, 0, vbHeight - 1, 0, vbHeight - 1)
   ' display the 3D information at the bottom of the window
   Call UpdateInfo
End Sub
'*****************************************************************************
'                                                                            *
'  UpdateInfo()                                                              *
'                                                                            *
'  Displays the information at the bottom of the window.                     *
'                                                                            *
'*****************************************************************************
Private Sub UpdateInfo()
   Dim x As Double, y As Double, Z As Double
   Dim xDir As Double, yDir As Double, zDir As Double
   Dim MessageText As String
   ' get current position and direction
   Call fg_3Dgetpov(x, y, Z, xDir, yDir, zDir)
   ' clear an area to write on
   Call fg_setcolorrgb(0, 0, 140)
   Call fg_rect(0, 249, 0, InfoHeight - 1)
   Call fg_setcolorrgb(0, 140, 0)
   Call fg_rect(250, vbWidth - 1, 0, InfoHeight - 1)
   Call fg_setcolor(-1)
   ' print current position and unit vector
   Call fg_move(20, 32)
   MessageText = "x = " + Format(x, "###0.00") + "  xDir = " + Format(xDir, "###0.00")
   Call fg_print(MessageText, Len(MessageText))
   Call fg_move(20, 46)
   MessageText = "y = " + Format(y, "###0.00") + "  yDir = " + Format(yDir, "###0.00")
   Call fg_print(MessageText, Len(MessageText))
   Call fg_move(20, 60)
   MessageText = "z = " + Format(Z, "###0.00") + "  zDir = " + Format(zDir, "###0.00")
   Call fg_print(MessageText, Len(MessageText))
   ' print instructions
   Call fg_move(270, 18)
   MessageText = "Up    = move forward   Home = move up"
   Call fg_print(MessageText, Len(MessageText))
   Call fg_move(270, 32)
   MessageText = "Down  = move back      End  = move down"
   Call fg_print(MessageText, Len(MessageText))
   Call fg_move(270, 46)
   MessageText = "Left  = turn left      PgUp = look up"
   Call fg_print(MessageText, Len(MessageText))
   Call fg_move(270, 60)
   MessageText = "Right = turn right     PgDn = look down"
   Call fg_print(MessageText, Len(MessageText))
   Call fg_move(290, 74)
   MessageText = "Shift+Left/Right = move left/right"
   Call fg_print(MessageText, Len(MessageText))
   Call fg_vbpaste(0, vbWidth - 1, 0, InfoHeight - 1, 0, WinHeight - 1)
End Sub
'*****************************************************************************
'                                                                            *
'  InitGlobals()                                                             *
'                                                                            *
'  Initialize global variables and arrays. Called from Form_Load().          *
'                                                                            *
'*****************************************************************************
Private Sub InitGlobals()
   ' top
   ColumnData(1, 1) = -1#: ColumnData(2, 1) = 10#: ColumnData(3, 1) = 1#
   ColumnData(4, 1) = 1#: ColumnData(5, 1) = 10#: ColumnData(6, 1) = 1#
   ColumnData(7, 1) = 1#: ColumnData(8, 1) = 10#: ColumnData(9, 1) = -1#
   ColumnData(10, 1) = -1#: ColumnData(11, 1) = 10#: ColumnData(12, 1) = -1#
   ' front
   ColumnData(1, 2) = -1#: ColumnData(2, 2) = 10#: ColumnData(3, 2) = -1#
   ColumnData(4, 2) = 1#: ColumnData(5, 2) = 10#: ColumnData(6, 2) = -1#
   ColumnData(7, 2) = 1#: ColumnData(8, 2) = 0#: ColumnData(9, 2) = -1#
   ColumnData(10, 2) = -1#: ColumnData(11, 2) = 0#: ColumnData(12, 2) = -1#
   ' left
   ColumnData(1, 3) = -1#: ColumnData(2, 3) = 10#: ColumnData(3, 3) = 1#
   ColumnData(4, 3) = -1#: ColumnData(5, 3) = 10#: ColumnData(6, 3) = -1#
   ColumnData(7, 3) = -1#: ColumnData(8, 3) = 0#: ColumnData(9, 3) = -1#
   ColumnData(10, 3) = -1#: ColumnData(11, 3) = 0#: ColumnData(12, 3) = 1#
   ' right
   ColumnData(1, 4) = 1#: ColumnData(2, 4) = 10#: ColumnData(3, 4) = -1#
   ColumnData(4, 4) = 1#: ColumnData(5, 4) = 10#: ColumnData(6, 4) = 1#
   ColumnData(7, 4) = 1#: ColumnData(8, 4) = 0#: ColumnData(9, 4) = 1#
   ColumnData(10, 4) = 1#: ColumnData(11, 4) = 0#: ColumnData(12, 4) = -1#
   ' bottom
   ColumnData(1, 5) = -1#: ColumnData(2, 5) = 0#: ColumnData(3, 5) = -1#
   ColumnData(4, 5) = 1#: ColumnData(5, 5) = 0#: ColumnData(6, 5) = -1#
   ColumnData(7, 5) = 1#: ColumnData(8, 5) = 0#: ColumnData(9, 5) = 1#
   ColumnData(10, 5) = -1#: ColumnData(11, 5) = 0#: ColumnData(12, 5) = 1#
   ' back
   ColumnData(1, 6) = 1#: ColumnData(2, 6) = 10#: ColumnData(3, 6) = 1#
   ColumnData(4, 6) = -1#: ColumnData(5, 6) = 10#: ColumnData(6, 6) = 1#
   ColumnData(7, 6) = -1#: ColumnData(8, 6) = 0#: ColumnData(9, 6) = 1#
   ColumnData(10, 6) = 1#: ColumnData(11, 6) = 0#: ColumnData(12, 6) = 1#
End Sub

<< Prev

Next >>

Contents
Fastgraph Home Page

 

copyright 2001 Ted Gruber Software, Inc.