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
|