'*******************************************************************************************
' program demonstrating making a virtual terrain in Rapidq DIRECT 3D by a bitmap file
' grey scale values. Overall scaling and rotation changed by clicking - all by
' QD3DFrame or MeshBuilder (QD3DMeshBuilder)
'JohnK please cite me if you include in other work
'******************************************************************************************
'
'
$TYPECHECK ON 'this will make you a better programmer in the end
$INCLUDE <RAPIDQ.INC>
$INCLUDE <RapidQ_D3D.INC> 'constants
DECLARE SUB DXInitialize(Sender AS QDXScreen) 'initalize Direct3D Retained mode interface
DECLARE SUB DXInitializeSurface(Sender AS QDXScreen)'initialize Direct Draw surface
DECLARE SUB RenderLoop
DECLARE SUB ToggleRotation (Button as integer, X as integer, Y as integer)
DECLARE SUB MakeRandomTerrMesh (TheMeshBuilder AS QD3DMeshBuilder)
DECLARE SUB Add_Height_Mesh
DECLARE SUB Load_HeightMap (TheMeshBuilder AS QD3DMeshBuilder)
DECLARE SUB Cancel_Load
DECLARE SUB LoadXModel
DECLARE SUB DelXModel
DECLARE SUB ScaleXModel
DECLARE SUB ScaleTheObject (Sender AS QBUTTON)
DECLARE SUB SetPerspectiveView
DECLARE SUB TogglePerspectiveView
DECLARE SUB Make_Sky_Floor_Clouds
DECLARE SUB Toggle_Terr
DECLARE SUB Toggle_Floor
DECLARE SUB Toggle_Sky_Box
DECLARE SUB Toggle_Cloud
DECLARE SUB Reload_Height_Map
DECLARE SUB Load_Background
DECLARE SUB Load_Terrain_Texture
DECLARE SUB Load_Floor_Texture
DECLARE SUB Load_Sky_Texture
DECLARE SUB Load_Cloud_Texture
DECLARE SUB Load_Xmodel_Texture
DECLARE SUB Model_Texture_Detail
DECLARE SUB Terr_Texture_Detail
DECLARE SUB MeshWhiteBackground
DECLARE SUB Set_Render_Shading(Sender AS QMENUITEM)
DECLARE SUB Turn_On_Fog
DECLARE SUB Change_Speed(TheKey AS WORD, Shift AS INTEGER)
DECLARE SUB Inc_Speed
DECLARE SUB Dec_Speed
DECLARE SUB Center_Terrain
DECLARE SUB Toggle_Flying
DECLARE SUB Toggle_Move_light
DECLARE SUB CloseApp
' ************** Constants *************************
CONST Max3DModels = 12 'allow up to 12 DirectX file (.x) models
' ************** RapidQ - Specific Objects *************************
DIM XmodelMesh(1 to Max3DModels)_
AS QD3DMeshBuilder 'models load on meshbuilder, can use this to attach to worldFrame
DIM XmodelFrame(1 to Max3DModels)_
AS QD3DFrame 'put the model on its own frame to move relative to WorldFrame
DIM XmodelCoord AS QD3DVector 'coordinates for the x model, position (x,y,z) orient (dx,dy,dz)
DIM WorldFrame AS QD3DFrame 'root (parent) frame all 3d objects moving together attached to this frame
DIM LightFrame AS QD3DFrame 'lights must be placed on a frame. Camera attached to a frame by RapidQ
DIM TerrMesh AS QD3DMeshBuilder 'mesh builder to create a mesh out of the face
DIM FloorMesh AS QD3DMeshBuilder 'build a flat plane on the floor
DIM CloudMesh AS QD3DMeshBuilder 'build a flat plane in the sky
DIM SkyBox AS QD3DMeshBuilder 'build a square box around the scene
DIM Terr_Texture AS QD3DTexture 'info for holding texture
DIM Sky_Texture AS QD3DTexture 'info for sky texture
DIM wrap AS QD3DWRAP 'object to hold texture wrapping information
DIM HeightMap AS QBITMAP 'bitmap with pixel values the determine the height of our scene
DIM XModelNum AS INTEGER: XModelNum = 0 'keep track of which model
DIM Mod_Scale AS DOUBLE 'Modify Scaling of x models, textures, etc.
DIM Max_X AS DOUBLE 'dimensions of scene mesh
DIM Min_X AS DOUBLE
DIM Max_Z AS DOUBLE
DIM Min_Z AS DOUBLE
DIM yScale AS DOUBLE 'scale terrain for height
DIM CeilingScale AS DOUBLE: CeilingScale = 1 'ceiling hieight of the sky relative to total terrain size
DIM Mid_X AS INTEGER
DIM Mid_Y AS INTEGER 'middle of the Screen
DIM Cam_Orient AS Q3DVector 'fix bug
DIM Cam_Pos AS Q3DVector
DIM Omega AS SINGLE: Omega = -3.1416'/2 'for camera rotation = pi/2 or 90 degrees
DIM Step_size AS INTEGER: Step_size = 1 'step size through terrain map (increase if using large bitmaps)
DIM CancelTerrLoad AS INTEGER: CancelTerrLoad = 0 'cancel loading the height map for terrain
DIM Terr_Steep AS SINGLE: Terr_Steep = 2.0 'steepness of Terrain relative to terrain width
DIM Psuedo_Color AS INTEGER: Psuedo_Color = 1 'toggle mesh face fake color
DIM Fly_On AS INTEGER: Fly_on = 0 'don't fly just yet
DIM The_Speed AS SINGLE : The_Speed = 1 'speed of translation motion
DIM RotAngl AS SINGLE : RotAngl = 0.02 'constant angle of rotation
DIM RotateIt AS INTEGER: RotateIt = 0 'toggle on/off rotation
DIM Shade_Quality AS INTEGER: Shade_Quality = D3DRMRENDER_GOURAUD
DIM Texture_Quality AS INTEGER: Texture_Quality = D3DRMTEXTURE_NEAREST 'default
CREATE Form AS QForm
Caption = "Direct 3D Example - click or move mouse"
Width = 640: Height = 480: Center
OnKeyDown = Change_Speed
OnClose = CloseApp
CREATE MainMenu AS QMAINMENU
CREATE FileMenu AS QMENUITEM '***** FILE MENUS ********
Caption = " &File"
CREATE OpenMapMnu AS QMENUITEM
Caption = " Load Height Map": OnClick = Reload_Height_Map
END CREATE
CREATE AddMapMnu AS QMENUITEM
Caption = " Add Height Map": Enabled = 0: OnClick = Add_Height_Mesh
END CREATE
CREATE AddXmodelMnu AS QMENUITEM
Caption = " Add .X Model": OnClick = LoadXModel
END CREATE
CREATE DelXmodelMnu AS QMENUITEM
Caption = " Delete last .X Model": OnClick = DelXModel
END CREATE
CREATE ScaleXmodelMnu1 AS QMENUITEM
Caption = " Scale .X Model": Enabled = 0: OnClick = ScaleXModel
END CREATE
CREATE ExitMnu AS QMENUITEM
Caption = " Exit": OnClick = CloseApp
END CREATE
END CREATE
CREATE TextureMenu AS QMENUITEM
Caption = " &Textures"
CREATE LoadTerrTexMnu AS QMENUITEM
Caption = " Load Terrain Texture Map": OnClick = Load_Terrain_Texture
END CREATE
CREATE TerrTexDetailMnu AS QMENUITEM
Caption = " Set Terrain Texture Detail": Enabled = 0: OnClick = Terr_Texture_Detail
END CREATE
CREATE LoadSkyTexMnu AS QMENUITEM
Caption = " Load Sky Texture Map": OnClick = Load_Sky_Texture
END CREATE
CREATE LoadFloorTexMnu AS QMENUITEM
Caption = " Load Floor Texture Map": OnClick = Load_Floor_Texture
END CREATE
CREATE LoadCloudTexMnu AS QMENUITEM
Caption = " Load Cloud Texture Map": Enabled = 0: OnClick = Load_Cloud_Texture
END CREATE
CREATE LoadXModelTexMnu AS QMENUITEM
Caption = " Load Model Texture Map": Enabled = 0: OnClick = Load_Xmodel_Texture
END CREATE
CREATE XModelTexDetailMnu AS QMENUITEM
Caption = " Set Model Texture Detail": Enabled = 0: OnClick = Model_Texture_Detail
END CREATE
CREATE DummyMnu00 AS QMENUITEM
Caption = "__________________________"
END CREATE
CREATE WhiteBckgrdTexMnu AS QMENUITEM
Caption = " Psuedo Color Terrain": Checked = 1:OnClick = MeshWhiteBackground
END CREATE
CREATE DummyMnu0 AS QMENUITEM
Caption = "__________________________"
END CREATE
CREATE LoadBackgrdMnu AS QMENUITEM
Caption = " Load Background Image": OnClick = Load_Background
END CREATE
END CREATE
CREATE ViewMenu AS QMENUITEM
Caption = " &View"
CREATE PhongMnu AS QMENUITEM
Caption = "Phong shading": Checked = 0: OnClick = Set_Render_Shading
END CREATE
CREATE GouradMnu AS QMENUITEM
Caption = "Gourad shading": Checked = 1: OnClick = Set_Render_Shading
END CREATE
CREATE FlatMnu AS QMENUITEM
Caption = "Flat shading": Checked = 0: OnClick = Set_Render_Shading
END CREATE
CREATE WireFrameMnu AS QMENUITEM
Caption = "Wireframe": Checked = 0: OnClick = Set_Render_Shading
END CREATE
CREATE PointsMnu AS QMENUITEM
Caption = "Points": Checked = 0: OnClick = Set_Render_Shading
END CREATE
CREATE DummyMnu1 AS QMENUITEM
Caption = "__________________________"
END CREATE
CREATE ScaleXmodelMnu2 AS QMENUITEM
Caption = " Scale .X Model": Enabled = 0: OnClick = ScaleXModel
END CREATE
CREATE DummyMnu2 AS QMENUITEM
Caption = "__________________________"
END CREATE
CREATE TerrOnMnu AS QMENUITEM
Caption = " Terrain": Checked = 1: OnClick = Toggle_Terr
END CREATE
CREATE FloorOnMnu AS QMENUITEM
Caption = " Floor": Checked = 1: OnClick = Toggle_Floor
END CREATE
CREATE SkyBoxOnMnu AS QMENUITEM
Caption = " Sky Box": Checked = 1: OnClick = Toggle_Sky_Box
END CREATE
CREATE CloudOnMnu AS QMENUITEM
Caption = " Clouds": Checked = 0: OnClick = Toggle_Cloud
END CREATE
CREATE DummyMnu3 AS QMENUITEM
Caption = "__________________________"
END CREATE
CREATE PerspectiveViewOnMnu AS QMENUITEM
Caption = " Set Perspective with Mouse": Checked = 0: OnClick = TogglePerspectiveView
END CREATE
CREATE DummyMnu4 AS QMENUITEM
Caption = "__________________________"
END CREATE
CREATE FogMnu AS QMENUITEM
Caption = " Fog": OnClick = Turn_On_Fog
END CREATE
END CREATE
CREATE SpeedMenu AS QMENUITEM
Caption = " &Animation"
CREATE FlyMnu AS QMENUITEM
Caption = "Mouse flies Camera F": Checked = Fly_On: OnClick = Toggle_Flying
END CREATE
CREATE MoveLightMnu AS QMENUITEM
Caption = "Mouse moves light L": Checked = 0: OnClick = Toggle_Move_Light
END CREATE
CREATE IncSpeedMnu AS QMENUITEM
Caption = "increase speed +": OnClick = Inc_Speed
END CREATE
CREATE DecSpeedMnu AS QMENUITEM
Caption = "decrease speed -": OnClick = Dec_Speed
END CREATE
CREATE CenterMeMnu AS QMENUITEM
Caption = "Center in viewport": OnClick = Center_Terrain
END CREATE
END CREATE
END CREATE
CREATE DXScreen AS QDXScreen 'really a direct draw surface?
Init(640,480)
Align = 5 'alClient - need this to center Direct Draw screen onto Form
BitCount = 32 '16,24 bits/pixel use 32 for alpha bending on fast 3d cards
Use3D = 1 'load Direct3D Retained mode
UseHardware = 1 '3D accelerated video cards are cheap, get one!!
OnInitialize = DXInitialize 'load your meshs/faces to the frames, set lights, camera
OnInitializeSurface = DXInitializeSurface 'screen is ready to be drawn
OnMouseDown = ToggleRotation 'mouse click stops/starts rotation
END CREATE
END CREATE
' generic form for scaling X models, and other objects
'---------------------------------------------------------
CREATE ScaleForm AS QFORM
BorderStyle=bsToolWindow
Width = 180: Height = 430
Left = 620: Top = 100
CREATE ScButton1 AS QBUTTON
Left = 65: Top = 25
Width = 107: Height = 35
OnClick = ScaleTheObject
END CREATE
CREATE ScButton2 AS QBUTTON
Left = 65: Top = 310
Width = 107: Height = 35
OnClick = ScaleTheObject
END CREATE
CREATE ScButton3 AS QBUTTON
Left = 75: Top = 150: Width = 80: Height = 50
OnClick = ScaleTheObject
END CREATE
CREATE ScaleScrollBar as QScrollbar
Kind=sbVertical
Kind = 1: Left = 26: Top = 12: Width = 25: Height = 361
PageSize=.5: SmallChange=1 : LargeChange = 20
Min = 1: Position = 50 'don't let a zero!, midway of default size
END CREATE
END CREATE
DIM DXTimer AS QDXTimer 'regularly update display
DXTimer.Enabled = 1
DXTimer.Interval = 0
DXTimer.OnTimer = RenderLoop
Form.ShowModal 'get the program running
'***********************************************************************
SUB DXInitialize(Sender AS QDXScreen)
DIM Ambient AS QD3DLight 'need at least one light this can be local sub-- we won't modify it
DIM Light AS QD3DLight 'will define as point ligth that gives rich illumination to see the walls
DIM Face AS QD3DFace 'can't modify so just declare it in sub that makes the face
DIM Face2 AS QD3DFace 'can't modify so just declare it in sub that makes the face
DIM x as double, y as double, z as double
Mid_X = Screen.Width/2
Mid_Y = Screen.Height/2
DXScreen.CreateFrame(WorldFrame) 'create the terrain frame, all other frames will be attached to it in heirarchy
DXScreen.CreateFrame(LightFrame) 'probably allocates memory, handles, etc
'' ********* First we create the lights ******************
DXScreen.CreateLightRGB(D3DRMLIGHT_AMBIENT, 0.4, 0.4, 0.6, Ambient) 'ambient is bluish grey
DXScreen.AddLight(Ambient) 'ambient light moves with root frame (and object since it is on root frame)
DXScreen.CreateLightRGB(D3DRMLIGHT_POINT, 0.6, 0.6, 0.4, Light) 'point light is yellowish, units 0-1,also depend on MeshBuilder.SetRGB(1, 1, 1)
LightFrame.AddLight(Light) 'attach light to frame to move the light!
LightFrame.SetPosition(-20, 20, 20) 'units are x,y,z
Reload_Height_Map 'Load up a terrain via bitmap
END SUB
SUB DXInitializeSurface(Sender AS QDXScreen)
DXScreen.SetRenderMode(D3DRMRENDERMODE_VIEWDEPENDENTSPECULAR)'OR D3DRMRENDERMODE_BLENDEDTRANSPARENCY OR D3DRMRENDERMODE_DISABLESORTEDALPHAZWRITE)' OR D3DRMRENDERMODE_VIEWDEPENDENTSPECULAR)
END SUB
SUB RenderLoop
DIM MouseX_Now AS SINGLE
DIM MouseY_Now AS SINGLE
DIM yLimiter AS SINGLE
MouseX_Now = Omega * (Screen.MouseX - Mid_X)/ Mid_X 'omega sets the sensitivity of the "stick"
MouseY_Now = Omega * (Screen.MouseY - Mid_Y)/ Mid_Y
Cam_Orient.dvx = COS(MouseX_Now) 'These vectors set the orientation of camera z-axis (-1 to 1)
Cam_Orient.dvy = SIN(MouseY_Now)' 'to set it along the default orientation you would have
Cam_Orient.dvz = SIN(MouseX_Now) 'x = 1, y = 0, z = 0
Cam_Orient.x = 0 'these three vectors set the camera's y-axis orientation
Cam_Orient.y = 1 'default is x = 0, y = 1, z = 0
Cam_Orient.z = 0
IF Fly_On THEN
Cam_Pos.x = Cam_Pos.x + (Cam_Orient.dvx * The_Speed/10) 'camera moves by orientation
Cam_Pos.z = Cam_Pos.z + (Cam_Orient.dvz * The_Speed/10)
Cam_Pos.y = Cam_Pos.y + (Cam_Orient.dvy * The_Speed/10)
IF Cam_Pos.y < 2 THEN Cam_Pos.y = 2 'dont go below floor, other limits
IF Cam_Pos.z < Min_Z THEN Cam_Pos.z = Min_Z + Step_size
'IF Cam_Pos.y > (yScale * 255) THEN Cam_Pos.y = (yScale * 255)
IF Cam_Pos.z > Max_Z THEN Cam_Pos.z = Max_Z - Step_size
yLimiter = yScale * (HeightMap.Pixel(Cam_Pos.x + Max_X, Cam_Pos.z + Max_Z) AND 255)
IF Cam_Pos.y < yLimiter THEN Cam_Pos.y = yLimiter + 10
DXScreen.SetCameraPosition(Cam_Pos.x, Cam_Pos.y, Cam_Pos.z)
DXScreen.SetCameraOrientation(Cam_Orient.dvx, Cam_Orient.dvy, Cam_Orient.dvz,_ 'x-axis vector
Cam_Orient.x, Cam_Orient.y, Cam_Orient.z) 'y-axis vector
END IF
IF MoveLightMnu.Checked THEN
LightFrame.SetPosition(MouseX_Now * Max_X, MouseY_Now * 3 * Max_X, 0)'MouseX_Now * Max_Z) 'frame with light on it translates
END IF
IF (XmodelNum > 0) THEN
XmodelFrame(XModelNum).SetPosition(Cam_Pos.x + 10, Cam_Pos.y, Cam_Pos.z)
XmodelFrame(XModelNum).SetOrientation(Cam_Orient.dvx, Cam_Orient.dvy, Cam_Orient.dvz,_ 'x-axis vector
Cam_Orient.x, Cam_Orient.y, Cam_Orient.z) 'y-axis vector
END IF
IF PerspectiveViewOnMnu.Checked THEN SetPerspectiveView
DXScreen.Move(1) ' This does the rotation if SetRotation angle <> 0
DXScreen.Render
DXScreen.ForceUpdate(0,0,50,50) ' Update FPS text only
DXScreen.TextOut(10,8,"FPS: "+STR$(DXTimer.FrameRate), &HFFFFFF, -1)
IF PerspectiveViewOnMnu.Checked THEN
DXScreen.TextOut(10,20,"Click Mouse to Stop Perspective", &HFFFFFF, -1)
END IF
' DXScreen.TextOut(10,32, STR$(Cam_Pos.y)+ " ", &HFFFFFF, -1) ' use to debug variables
' DXScreen.TextOut(10,46, STR$(Cam_Pos.z)+ " ", &HFFFFFF, -1) ' use to debug variables
DXScreen.Flip
END SUB
SUB ToggleRotation (Button as integer, X as integer, Y as integer)
IF PerspectiveViewOnMnu.Checked THEN
PerspectiveViewOnMnu.Checked = 0
ELSE
' WorldFrame.AddScale(D3DRMCOMBINE_AFTER, 0.5, 0.5, 0.5)
IF RotateIt THEN
WorldFrame.SetRotation(0, 0, 0, 0)
RotateIt= 0
ELSE
WorldFrame.SetRotation(0, 1, 0, RotAngl) ' rotate about y-axis, Angle of rotation is variable
RotateIt = 1
END IF
END IF
END SUB
SUB Load_HeightMap (TheMeshBuilder AS QD3DMeshBuilder)
DIM openDialog AS QOPENDIALOG 'open file dialog
DIM Xmap AS INTEGER: Xmap = 0 'coordinates of the height map
DIM Ymap AS INTEGER: Ymap = 0
DIM x AS DOUBLE
DIM y AS DOUBLE
DIM z AS DOUBLE 'coordinates of terrain
DIM fColor AS INTEGER 'representation of color
DIM hColor AS INTEGER
DIM Face AS QD3DFace 'holds the vertices of a single face
openDialog.Caption = "select a bitmap for terrain"
openDialog.filter = "*.bmp (bitmaps)|*.bmp"
IF openDialog.execute THEN
HeightMap.LoadFromFile (openDialog.filename)
ELSE
EXIT SUB
END IF
IF HeightMap.Empty THEN EXIT SUB 'no image loaded, bogus file
IF HeightMap.PixelFormat <3 THEN
ShowMessage "Height maps must be 8-bit images or higher" 'pformat 8, 15, 16, 24, 32 bit ok
EXIT SUB
END IF
CancelTerrLoad = 0 'let user break if too long
CREATE WaitForm AS QFORM
Parent = Form: Caption = "Calculating map ...": Width = 300: Height = 120: Center
CREATE CancelMyLoad AS QBUTTON
left = 120: top = 45: Caption = "Cancel": OnClick = Cancel_Load
END CREATE
CREATE Gauge AS QGauge
Height = 20: Top = 15: left = 20: Width = 250: max = HeightMap.Width
END CREATE
Show
END CREATE
' ***** Set the limits of the mesh ******
Max_X = HeightMap.Width/2: Min_X = - HeightMap.Width/2 '//center the terrain in our mesh
Max_Z = HeightMap.Height/2: Min_Z = -HeightMap.Height/2
yScale = (SQR(HeightMap.Width) * Terr_Steep)/ 255.0 '% of total width height
The_Speed = HeightMap.Width / 200 '//speed is 0.5% of size
FOR Xmap = 0 TO (HeightMap.Width - (2* Step_size)) STEP Step_size
FOR Ymap = 0 TO (HeightMap.Height - (2* Step_size)) STEP Step_size
IF (HeightMap.Pixel(Xmap, Ymap)) = (HeightMap.Pixel(Xmap + Step_size, Ymap)) = _
(HeightMap.Pixel(Xmap + Step_size, Ymap)) = (HeightMap.Pixel(Xmap + Step_size, Ymap+ Step_size)) THEN
'skip this face, its flat
ELSE
x = Xmap : z = Ymap
DXScreen.CreateFace(Face) '//must create each face/per 4 pixels
hColor = HeightMap.Pixel(Xmap, Ymap) AND 255 '//get red/grey intensity
y = hColor * yScale '// Get the (X, Y, Z) value for the bottom left vertex
Face.AddVertex(x - Max_X, y, z - Max_Z) '//vertex is each point of a face
x = Xmap : z = Ymap + Step_size '// Get the (x,y,z) values for the top left vertex
fColor = HeightMap.Pixel(Xmap, Ymap + Step_size) AND 255
y = fColor * yScale
Face.AddVertex(x - Max_X, y, z - Max_Z) '//vertex is each point of a face
IF fColor > hColor THEN hColor = fColor '//find the highest vertex for psuedo color
x = Xmap + Step_size: z = Ymap + Step_size '//top right vertex
fColor = HeightMap.Pixel(Xmap + Step_size, Ymap + Step_size) AND 255
y = fColor * yScale
Face.AddVertex(x - Max_X, y, z - Max_Z)
IF fColor > hColor THEN hColor = fColor '//find the highest vertex for psuedo color
x = Xmap + Step_size: z = Ymap '//bottom right vertex
fColor = HeightMap.Pixel(Xmap + Step_size, Ymap) AND 255
y = fColor * yScale
Face.AddVertex(x - Max_X, y, z - Max_Z)
IF fColor > hColor THEN hColor = fColor
IF Psuedo_Color THEN
SELECT CASE hColor '// Set the color value of the current vertice.
CASE IS > 145
Face.SetColorRGB (hColor, hColor, hColor) '//snow
CASE IS < 3
Face.SetColorRGB (0, 50, 230 ) '//water
CASE ELSE
Face.SetColorRGB (0, hColor, 0 ) '//grass
END SELECT
END IF
TheMeshBuilder.AddFace(Face) '//add this face to a mesh via meshbuilder
END IF
NEXT Ymap
Gauge.Position = Xmap
DOEVENTS
IF CancelTerrLoad THEN WaitForm.Close: EXIT SUB
NEXT Xmap
WaitForm.Close
END SUB
SUB Cancel_Load
CancelTerrLoad = 1
END SUB
SUB Make_Sky_Floor_Clouds
DIM Xmap AS SINGLE: Xmap = 0 'shifted coordinates of the height map
DIM Ymap AS SINGLE: Ymap = 0
DIM TheTop AS SINGLE
DIM CloudTop AS SINGLE
DIM Face AS QD3DFace
Xmap = -Min_X - Step_size
Ymap = -Min_Z - Step_size
TheTop = HeightMap.Width * CeilingScale '//higher than the mountain tops
DXScreen.CreateFace(Face)
Face.AddVertex(Xmap, 0, Min_Z): Face.AddVertex(Xmap, TheTop, Min_Z)
Face.AddVertex(Min_X, TheTop, Min_Z): Face.AddVertex(Min_X, 0, Min_Z) : 'front
IF Psuedo_Color THEN Face.SetColorRGB(15,20,165)
SkyBox.AddFace(Face)
DXScreen.CreateFace(Face)
Face.AddVertex(Xmap, 0, Ymap): Face.AddVertex(Xmap, TheTop, Ymap)
Face.AddVertex(Xmap, TheTop, Min_Z): Face.AddVertex(Xmap, 0, Min_Z) 'right
IF Psuedo_Color THEN Face.SetColorRGB(15,20,165)
SkyBox.AddFace(Face)
DXScreen.CreateFace(Face)
Face.AddVertex(Min_X, 0, Ymap): Face.AddVertex(Min_X, TheTop, Ymap)
Face.AddVertex(Xmap, TheTop, Ymap): Face.AddVertex(Xmap, 0, Ymap) 'back
IF Psuedo_Color THEN Face.SetColorRGB(15,20,165)
SkyBox.AddFace(Face)
DXScreen.CreateFace(Face)
Face.AddVertex(Min_X, 0, Min_Z): Face.AddVertex(Min_X, TheTop, Min_Z)
Face.AddVertex(Min_X, TheTop, Ymap): Face.AddVertex(Min_X, 0, Ymap): 'left
IF Psuedo_Color THEN Face.SetColorRGB(15,20,165)
SkyBox.AddFace(Face)
DXScreen.CreateFace(Face)
Face.AddVertex(Min_X, TheTop, Min_Z): Face.AddVertex(Xmap, TheTop, Min_Z)
Face.AddVertex(Xmap, TheTop, Ymap): Face.AddVertex(Min_X, TheTop, Ymap): 'ceiling
IF Psuedo_Color THEN Face.SetColorRGB(15,20,165)
SkyBox.AddFace(Face)
DXScreen.CreateFace(Face)
Face.AddVertex(Min_X, 0, Ymap): Face.AddVertex(Xmap, 0, Ymap)
Face.AddVertex(Xmap,0, Min_Z): Face.AddVertex(Min_X, 0, Min_Z) 'floor
IF Psuedo_Color THEN Face.SetColorRGB(0, 60, 200 ) '//water
FloorMesh.AddFace(Face)
CloudTop = TheTop * 0.8 '80% to the top
DXScreen.CreateFace(Face)
Face.AddVertex(Min_X, CloudTop, Ymap): Face.AddVertex(Xmap, CloudTop, Ymap)
Face.AddVertex(Xmap, CloudTop, Min_Z): Face.AddVertex(Min_X, CloudTop, Min_Z)
IF Psuedo_Color THEN Face.SetColorRGB(128, 128, 128) '//white
CloudMesh.AddFace(Face)
CloudTop = TheTop' * 0.8 + (TheTop * 0.1)
DXScreen.CreateFace(Face)
Face.AddVertex(Min_X, TheTop * .8, Min_Z): Face.AddVertex(Xmap,TheTop * .8, Min_Z)
Face.AddVertex(Xmap, TheTop * .8, Ymap): Face.AddVertex(Min_X, TheTop * .8, Ymap) 'two sided for visibility
IF Psuedo_Color THEN Face.SetColorRGB(128, 128, 128) '//white
CloudMesh.AddFace(Face)
CloudMesh.SetRGBA(1, 1, 1, 0.2) 'use alpha blending for transparent effect
WorldFrame.AddVisual(SkyBox) 'All objects added to the root frame (WorldFrame)
WorldFrame.AddVisual(FloorMesh) 'add Floor to frame, all will rotate/move together now
IF CloudOnMnu.Checked THEN WorldFrame.AddVisual(CloudMesh) 'add clouds only with user input
END SUB
SUB Turn_On_Fog
DIM TheFogColor AS LONG
TheFogColor = &HFFFFFF
IF WorldFrame.FogEnabled THEN
WorldFrame.FogEnabled = 0
FogMnu.Checked = 0
ELSE
WorldFrame.FogEnabled = 1
FogMnu.Checked = 1
WorldFrame.FogMode = D3DRMFOG_LINEAR 'also D3DRMFOG_EXPONENTIAL '
WorldFrame.FogColor = TheFogColor ' RGB(255,255,255) 'need to figure this out
WorldFrame.SetFogParams(Min_Z, Max_Z, 1.0)
END IF
END SUB
SUB Load_Terrain_Texture
DIM openDialog AS QOPENDIALOG
openDialog.Caption = "select a bitmap for texture"
openDialog.filter = "*.bmp (bitmaps)|*.bmp"
IF openDialog.execute THEN
TerrMesh.loadTexture(openDialog.fileName)
'//args-[1,2,3] wrap origin, [4,5,6] z-axis vector, [7,8,9] y-axis vector, [10,11] and [12,13] origin and scale factor of texture
' DXScreen.createWrap(D3DRMWRAP_SPHERE, _ 'alternative texture mapping
' Min_X, 0,Min_Z,_
' 0, 1, 0,_
' 0, 0, 1,_
' 0, 0, Max_X/4, Max_Z/4, wrap)
DXScreen.createWrap(D3DRMWRAP_FLAT, _
Min_X, 0,Min_Z,_
0, 1, 0,_
0, 0, 1,_
0, 0, 1/Max_X*2, 1/Max_Z*2, wrap)
wrap.apply(TerrMesh)
DXScreen.SetTextureQuality(Texture_Quality)
TerrTexDetailMnu.Enabled = 1
END IF
END SUB
SUB Load_Sky_Texture
DIM openDialog AS QOPENDIALOG
openDialog.Caption = "select a bitmap for sky"
openDialog.filter = "*.bmp (bitmaps)|*.bmp"
IF openDialog.execute THEN
SkyBox.loadTexture(openDialog.fileName)
DXScreen.createWrap(D3DRMWRAP_SPHERE, _ 'wraps around the box, disortion at the edges
0, 0, 0, _ 'origin is 0,0
0, 1, 0,_ 'the z-axis direction vector - texture projects down the z-azis
0, 0, 1,_ 'the up vector - the top of the texture points up the y-axis
0, 0, 1, CeilingScale * 1.75, wrap)
wrap.apply(SkyBox)
DXScreen.SetTextureQuality(Texture_Quality)
END IF
END SUB
SUB Load_Floor_Texture
DIM openDialog AS QOPENDIALOG
openDialog.Caption = "select a bitmap for Floor"
openDialog.filter = "*.bmp (bitmaps)|*.bmp"
IF openDialog.execute THEN
FloorMesh.loadTexture(openDialog.fileName)
'args-[1,2,3] wrap origin, [4,5,6] z-axis vector, [7,8,9] y-axis vector, [10,11] and [12,13] origin and scale factor of texture
DXScreen.createWrap(D3DRMWRAP_FLAT, _ 'flat scale width and height of the texture to width and height of object
Min_X, 0,Min_Z,_
0, 1, 0,_
0, 0, 1,_
0, 0, (1/(Max_X*2)), (1/(Max_Z*2)), wrap)
wrap.apply(FloorMesh)
DXScreen.SetTextureQuality(Texture_Quality)
END IF
END SUB
SUB Load_Cloud_Texture
DIM openDialog AS QOPENDIALOG
openDialog.Caption = "select a bitmap for Clouds"
openDialog.filter = "*.bmp (bitmaps)|*.bmp"
IF openDialog.execute THEN
CloudMesh.loadTexture(openDialog.fileName)
'args-[1,2,3] wrap origin, [4,5,6] z-axis vector, [7,8,9] y-axis vector, [10,11] and [12,13] origin and scale factor of texture
DXScreen.createWrap(D3DRMWRAP_FLAT, _ 'flat scale width and height of the texture to width and height of object
Min_X, 0,Min_Z,_
0, 1, 0,_
0, 0, 1,_
0, 0, (1/(Max_X*2)), (1/(Max_Z*2)), wrap)
wrap.apply(CloudMesh)
DXScreen.SetTextureQuality(Texture_Quality)
CloudMesh.SetRGBA(1, 1, 1, 0.1) 'use alpha blending for transparent effect
END IF
END SUB
SUB Load_Xmodel_Texture
DIM openDialog AS QOPENDIALOG
openDialog.Caption = "select a bitmap for X model"
openDialog.filter = "*.bmp (bitmaps)|*.bmp"
IF openDialog.execute THEN
XmodelMesh(XModelNum).loadTexture(openDialog.fileName)
'args-[1,2,3] wrap origin, [4,5,6] z-axis vector, [7,8,9] y-axis vector, [10,11] and [12,13] origin and scale factor of texture
DXScreen.createWrap(D3DRMWRAP_CHROME, _ 'flat scale width and height of the texture to width and height of object
Min_X, 0,Min_Z,_
0, 1, 0,_
0, 0, 1,_
0, 0, 1, 1, wrap)
wrap.apply(XmodelMesh(XModelNum))
XModelTexDetailMnu.Enabled = 1
END IF
END SUB
SUB Load_Background
DIM TheTexture AS QD3DTexture
DIM openDialog AS QOPENDIALOG
openDialog.Caption = "select a bitmap for texture"
openDialog.filter = "*.bmp (bitmaps)|*.bmp"
IF openDialog.execute THEN
DXScreen.LoadTexture(openDialog.filename, TheTexture)
DXScreen.SetBackgroundImage(TheTexture)
END IF
END SUB
SUB MeshWhiteBackground
IF Psuedo_Color = 1 THEN
Psuedo_Color = 0
WhiteBckgrdTexMnu.Checked = 0 'once you turn it off it is gone forever
WorldFrame.SetBackgroundRGB(1,1,1)
TerrMesh.SetRGBA(1,1,1,1)
SkyBox.SetRGBA(1,1,1,1)
FloorMesh.SetRGBA(1,1,1,1)
ELSE
Psuedo_Color = 1
WhiteBckgrdTexMnu.Checked = 1
ShowMessage("Changes affect next loaded mesh")
END IF
END SUB
SUB Reload_Height_Map
WorldFrame.DeleteVisual(TerrMesh) 'Delete the old meshes, if they exist
WorldFrame.DeleteVisual(SkyBox)
WorldFrame.DeleteVisual(FloorMesh)
WorldFrame.DeleteVisual(CloudMesh)
DXScreen.CreateFrame(WorldFrame) 'wipes out old frame if exists
DXScreen.CreateMeshBuilder(TerrMesh) 'must define them first
DXScreen.CreateMeshBuilder(SkyBox) 'before you can use them
DXScreen.CreateMeshBuilder(FloorMesh)
DXScreen.CreateMeshBuilder(CloudMesh)
Add_Height_Mesh 'in with the new
Make_Sky_Floor_Clouds 'enclose the terrain w/ box using the bitmap
Center_Terrain 'distance in each axis from origin, move the camera around instead of 3d object
END SUB
SUB Add_Height_Mesh
DXScreen.CreateMeshBuilder(TerrMesh) 'wipe out old meshes, already attached to a frame
Load_HeightMap(TerrMesh) 'make a mesh from a bitmap file
TerrMesh.SetQuality(Shade_Quality) 'highest Quality is D3DRMRENDER_PHONG, but not supported (yet..)
AddMapMnu.Enabled = 1 'allow superimposing of more terrains
WorldFrame.AddVisual(TerrMesh) 'add it to a frame to move, translate, etc.
END SUB
SUB Set_Render_Shading(Sender AS QMENUITEM)
DIM i as INTEGER
IF Sender.Caption = "Phong shading" THEN 'This isn't supported (yet..)
Shade_Quality = D3DRMRENDER_PHONG
PhongMnu.Checked = 1: GouradMnu.Checked = 0: FlatMnu.Checked = 0: WireFrameMnu.Checked = 0: PointsMnu.Checked = 0
END IF
IF Sender.Caption = "Gourad shading" THEN
Shade_Quality = D3DRMRENDER_GOURAUD
PhongMnu.Checked = 0: GouradMnu.Checked = 1: FlatMnu.Checked = 0: WireFrameMnu.Checked = 0: PointsMnu.Checked = 0
END IF
IF Sender.Caption = "Flat shading" THEN
Shade_Quality = D3DRMRENDER_FLAT
PhongMnu.Checked = 0: GouradMnu.Checked = 0: FlatMnu.Checked = 1: WireFrameMnu.Checked = 0: PointsMnu.Checked = 0
END IF
IF Sender.Caption = "Wireframe" THEN
Shade_Quality = D3DRMRENDER_WIREFRAME
PhongMnu.Checked = 0: GouradMnu.Checked = 0: FlatMnu.Checked = 0: WireFrameMnu.Checked = 1: PointsMnu.Checked = 0
END IF
IF Sender.Caption = "Points" THEN
Shade_Quality = D3DRMRENDER_POINTS
PhongMnu.Checked = 0: GouradMnu.Checked = 0: FlatMnu.Checked = 0: WireFrameMnu.Checked = 0: PointsMnu.Checked = 1
END IF
TerrMesh.SetQuality(Shade_Quality) 'highest rendering Quality is D3DRMRENDER_PHONG, but not supported
SkyBox.SetQuality(Shade_Quality)
FloorMesh.SetQuality(Shade_Quality)
IF XModelNum > 0 THEN
FOR i = 1 TO XModelNum
XmodelMesh(i).SetQuality(Shade_Quality) 'render shading
NEXT i
END IF
END SUB
SUB Change_Speed(TheKey AS WORD, Shift AS INTEGER)
SELECT CASE TheKey
CASE = 38, 107 'up arrow and "+"
Inc_Speed
' KILLMESSAGE Form.handle, WM_CHAR 'use to stop other controls from getting key
CASE 40, 109 'dn arrow "-"
Dec_Speed
' KILLMESSAGE Form.handle, WM_CHAR
CASE 70 'f key
Toggle_Flying
CASE 76 'l key
Toggle_Move_Light
CASE 49 '1
Texture_Quality = D3DRMTEXTURE_NEAREST
DXScreen.SetTextureQuality(Texture_Quality)
CASE 50
Texture_Quality = D3DRMTEXTURE_LINEAR
DXScreen.SetTextureQuality(Texture_Quality)
CASE 51
Texture_Quality = D3DRMTEXTURE_MIPNEAREST
DXScreen.SetTextureQuality(Texture_Quality)
CASE 52
Texture_Quality = D3DRMTEXTURE_MIPLINEAR
DXScreen.SetTextureQuality(Texture_Quality)
CASE 53
Texture_Quality = D3DRMTEXTURE_LINEARMIPNEAREST
DXScreen.SetTextureQuality(Texture_Quality)
CASE 54
Texture_Quality = D3DRMTEXTURE_LINEARMIPLINEAR
DXScreen.SetTextureQuality(Texture_Quality)
END SELECT
END SUB
SUB Inc_Speed
IF Fly_On = 0 THEN
INC (RotAngl, RotAngl/1.025)
WorldFrame.SetRotation(0, 1, 0, RotAngl)
END IF
IF Fly_On THEN INC (The_Speed, The_Speed/1.5)
IF Fly_On THEN INC (Omega, Omega * 0.2)
END SUB
SUB Dec_Speed
IF Fly_On = 0 THEN
DEC (RotAngl, RotAngl/1.025): IF RotAngl < 0.005 THEN RotAngl = 0.005
WorldFrame.SetRotation(0, 1, 0, RotAngl)
END IF
IF Fly_On THEN DEC (The_Speed, The_Speed/1.5): IF The_Speed < 0.01 THEN The_Speed = 0.01
IF Fly_On THEN DEC (Omega, Omega * 0.2): IF Omega < 0.005 THEN Omega = 0.005
END SUB
SUB Center_Terrain
Cam_Pos.x = Min_X - (0.1 * Min_X)
Cam_Pos.y = yScale * 30
Cam_Pos.z = 0
DXScreen.CameraLookAt(WorldFrame, D3DRMCONSTRAIN_Z) 'constrain the camera to look down z-axis
DXScreen.SetCameraPosition(Cam_Pos.x, Cam_Pos.y, Cam_Pos.z) 'x - axis into screen , y-up, z - left right
DXScreen.SetCameraOrientation(1, -.1, 0, 0, 1, 0) 'look a little down
WorldFrame.SetPosition(0,0,0) 'centered because Heightmap is centered
LightFrame.SetPosition(Min_X, 20, 0) 'units are x,y,z
' DXScreen.VIEW.SETFRONT(Min_X) 'front clipping plane
END SUB
SUB Toggle_Flying
IF Fly_On = 1 THEN Fly_On = 0 ELSE Fly_On = 1
FlyMnu.Checked = Fly_On
END SUB
SUB Toggle_Move_Light
IF MoveLightMnu.Checked = 1 THEN MoveLightMnu.Checked = 0 ELSE MoveLightMnu.Checked = 1
END SUB
SUB Toggle_Terr
IF TerrOnMnu.Checked THEN
TerrOnMnu.Checked = 0
WorldFrame.DeleteVisual(TerrMesh)
ELSE
TerrOnMnu.Checked = 1
WorldFrame.AddVisual(TerrMesh)
END IF
END SUB
SUB Toggle_Floor
IF FloorOnMnu.Checked THEN
FloorOnMnu.Checked = 0
WorldFrame.DeleteVisual(FloorMesh)
ELSE
FloorOnMnu.Checked = 1
WorldFrame.AddVisual(FloorMesh)
END IF
END SUB
SUB Toggle_Sky_Box
IF SkyBoxOnMnu.Checked THEN
SkyBoxOnMnu.Checked = 0
WorldFrame.DeleteVisual(SkyBox)
ELSE
SkyBoxOnMnu.Checked = 1
WorldFrame.AddVisual(SkyBox)
END IF
END SUB
SUB Toggle_Cloud
IF CloudOnMnu.Checked THEN
CloudOnMnu.Checked = 0
WorldFrame.DeleteVisual(CloudMesh)
ELSE
CloudOnMnu.Checked = 1
LoadCloudTexMnu.Enabled = 1
WorldFrame.AddVisual(CloudMesh)
END IF
END SUB
SUB CloseApp
DIM i AS INTEGER
WorldFrame.DeleteVisual(TerrMesh) 'just in case we need to free up resources
WorldFrame.DeleteVisual(SkyBox)
WorldFrame.DeleteVisual(FloorMesh)
IF XModelNum > 0 THEN
FOR i = 1 TO XModelNum
XmodelFrame(XModelNum).DeleteVisual(XmodelMesh(XModelNum))
NEXT i
END IF
Application.Terminate
END SUB
SUB DelXModel
IF XModelNum < 1 THEN
ShowMessage "No .X models loaded"
EXIT SUB
END IF
XmodelFrame(XModelNum).DeleteVisual(XmodelMesh(XModelNum)) 'deletes only the last loaded X model
' WorldFrame.DeleteVisual(XmodelMesh(XModelNum)) 'use if models move with world
DEC XModelNum
IF XModelNum = 0 THEN
ScaleXmodelMnu1.Enabled = 0
ScaleXmodelMnu2.Enabled = 0
LoadXModelTexMnu.Enabled = 0
XModelTexDetailMnu.Enabled = 0
END IF
END SUB
SUB LoadXModel
DIM ExtraFilter AS STRING 'allow to convert 3ds files
DIM ConvertedFileName AS STRING
ExtraFilter = ""
DIM openDialog AS QOPENDIALOG 'only if it resides in the same folder as this application
IF FILEEXISTS("CONV3DS.EXE") THEN ExtraFilter = "|3D Max files|*.3DS"
openDialog.filter = "*.x (X models)|*.x" + ExtraFilter
IF OpenDialog.Execute THEN
IF UCASE$(RIGHT$(OpenDialog.FileName,4)) = ".3DS" THEN 'got a .3ds file
ConvertedFileName = LEFT$(OpenDialog.FileName, (LEN(OpenDialog.FileName)-4))
ExtraFilter = "CONV3DS -m " + OpenDialog.FileName
SHELL(ExtraFilter) 'blocks execution
OpenDialog.FileName = ConvertedFileName + ".x"
END IF
INC XModelNum
ScaleXmodelMnu1.Enabled = 1
ScaleXmodelMnu2.Enabled = 1
DXScreen.CreateMeshBuilder(XmodelMesh(XModelNum)) 'allocate new pointers to Direct3D interface
XmodelMesh(XModelNum).Load(OpenDialog.fileName) 'only works for .x models saved as meshes
XmodelMesh(XModelNum).SetQuality(Shade_Quality) 'render shading
'XmodelMesh(XModelNum).SetRGBA(1, 1, 1, .2) 'Add color w/alphablending R, G, B, A - from 0 to 1.0
DXscreen.CreateFrame(XmodelFrame(XModelNum)) 'add this as an independent object on the world
'WorldFrame.addVisual(XmodelMesh(XModelNum)) 'use for all models move with the world
XmodelFrame(XModelNum).AddVisual(XmodelMesh(XModelNum)) 'ready to manipulate
LoadXModelTexMnu.Enabled = 1 'Now allow a texture to be loaded
END IF
END SUB
SUB ScaleXModel
IF XModelNum < 1 THEN
ShowMessage "No .X models loaded"
EXIT SUB
END IF
ScaleForm.Caption="Scale Model"
ScButton1.Caption = "Increase Size"
ScButton2.Caption = "Decrease Size"
ScButton3.Caption = "Update"
ScaleForm.Show
END SUB
SUB ScaleTheObject (Sender AS QBUTTON)
If Sender.Caption = "Decrease Size" THEN Mod_Scale = .9
If Sender.Caption = "Increase Size" THEN Mod_Scale = 1.1
If Sender.Caption = "Decrease Detail" THEN Mod_Scale = Mod_Scale * .8
If Sender.Caption = "Increase Detail" THEN Mod_Scale = Mod_Scale * 1.2
If Sender.Caption = "Update" THEN
Mod_Scale = 50# / ScaleScrollBar.Position 'convert upside down
IF Mod_Scale = 0.0 THEN Mod_Scale = 0.01
ScaleScrollBar.Position = 50 'reset
end if
SELECT CASE ScaleForm.Caption
CASE IS = "Scale Model"
XmodelMesh(XModelNum).Scale(Mod_Scale, Mod_Scale, Mod_Scale)
CASE IS = "Scale Model Texture"
DXScreen.createWrap(D3DRMWRAP_CHROME,0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, Mod_Scale, Mod_Scale, wrap)
wrap.apply(XmodelMesh(XModelNum))
CASE IS = "Scale Terrain Texture"
DXScreen.createWrap(D3DRMWRAP_FLAT, Min_X, 0,Min_Z, 0, 1, 0, 0, 0, 1, 0, 0, 1/Max_X*4 * Mod_Scale, 1/Max_Z*4* Mod_Scale, wrap)
wrap.apply(TerrMesh)
wrap.apply(FloorMesh)
END SELECT
END SUB
SUB Model_Texture_Detail
Mod_Scale = 1.0
ScaleForm.Caption= "Scale Model Texture"
ScButton1.Caption = "Increase Detail" 'allow different scaling methods by captions
ScButton2.Caption = "Decrease Detail"
ScButton3.Caption = "Update"
ScaleForm.Show
END SUB
SUB Terr_Texture_Detail
Mod_Scale = 1.0
ScaleForm.Caption= "Scale Terrain Texture"
ScButton1.Caption = "Increase Detail"
ScButton2.Caption = "Decrease Detail"
ScButton3.Caption = "Update"
ScaleForm.Show
END SUB
SUB TogglePerspectiveView
IF PerspectiveViewOnMnu.Checked THEN
PerspectiveViewOnMnu.Checked = 0
ELSE
PerspectiveViewOnMnu.Checked = 1
END IF
END SUB
SUB SetPerspectiveView
DIM x AS SINGLE
DIM y AS SINGLE
x = MouseX / Form.ClientHeight * 2: IF x < .01 THEN x = 0.01
y = MouseY / Form.ClientHeight * 2: IF x < .01 THEN x = 0.01
DXScreen.VIEW.SETPLANE(-1/x, 1/x, -y, y) 'this is an undocumented command, works great!
END SUB