'******************************************************************************************* ' 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