home *** CD-ROM | disk | FTP | other *** search
/ Microsoft DirectX SDK 7.0 / Dx7.bin / DXF / samples / multimedia / vbsamples / d3dim / src / fireworks / fireworkssample.bas < prev   
Encoding:
BASIC Source File  |  1999-08-03  |  12.7 KB  |  391 lines

  1. Attribute VB_Name = "FireWorksSample"
  2. '-----------------------------------------------------------------------------
  3. ' File: FireWorks.bas
  4. '
  5. ' Desc: Example code showing how to use particles to simulate a fireworks
  6. '       explosion.
  7. '
  8. '
  9. ' Copyright (c) 1997-1999 Microsoft Corporation. All rights reserved.
  10. '-----------------------------------------------------------------------------
  11. Const NUM_PARTICLES = 100
  12. Const RAND_MAX = &H7FFF
  13. '-----------------------------------------------------------------------------
  14. ' Name: Particle
  15. ' Desc: Data structure for each particle
  16. '-----------------------------------------------------------------------------
  17. Public Type Particle
  18.     vPosition As D3DVECTOR
  19.     vLaunchVelocity As D3DVECTOR
  20.     vInitialPosition As D3DVECTOR
  21.     vInitialVelocity As D3DVECTOR
  22.     r As Single
  23.     g As Single
  24.     b As Single
  25.     fLifeTime As Single
  26.     fMaturity As Single
  27.     wType As Long
  28.     fSize As Single
  29. End Type
  30.  
  31. Dim m_Particle(NUM_PARTICLES - 1) As Particle
  32. Dim m_Mesh(0 To 3) As D3DVERTEX
  33. Dim m_Background(0 To 3) As D3DTLVERTEX
  34. Dim m_fStartTimeKey As Single
  35. Dim TexturePool As New Collection
  36. Dim Texture1 As DirectDrawSurface7
  37. Dim Texture2 As DirectDrawSurface7
  38.     
  39. '-----------------------------------------------------------------------------
  40. ' Name: SetParticle()
  41. ' Desc: Helper function to initialize a particle
  42. '-----------------------------------------------------------------------------
  43. Public Function SetParticle(wType As Integer, fLifeTime As Single, _
  44.     vBasePosition As D3DVECTOR, vBaseVelocity As D3DVECTOR) As Particle
  45.     Dim V3D As D3DVECTOR
  46.     V3D = RVector(RND1, RND1, RND1)
  47.     DX.VectorNormalize V3D
  48.     With SetParticle
  49.         .vInitialVelocity = VScale(V3D, 15)
  50.         DX.VectorAdd .vInitialVelocity, .vInitialVelocity, vBaseVelocity
  51.         DX.VectorAdd .vInitialVelocity, .vInitialVelocity, RVector(RND1, RND1, RND1)
  52.         .vInitialPosition = vBasePosition
  53.         .vLaunchVelocity = vBaseVelocity
  54.         .r = 1
  55.         .g = 1
  56.         .b = 1
  57.         .fLifeTime = fLifeTime + fLifeTime * RND1 / 2
  58.         .fMaturity = 0
  59.         .fSize = 0.2
  60.         .wType = wType
  61.     End With
  62. End Function
  63.  
  64. '-----------------------------------------------------------------------------
  65. ' Name: Main()
  66. ' Desc: Core of the sample.
  67. '-----------------------------------------------------------------------------
  68.  
  69. Sub Main()
  70.     
  71.     m_bAppUseZBuffer = False
  72.     m_bShowStats = True
  73.     m_fnConfirmDevice = ConfirmDevice
  74.     m_fStartTimeKey = 0#
  75.   
  76.     InitDX
  77.     InitDeviceObjects
  78.     OneTimeSceneInit
  79.     Do Until MustExit        
  80.     on local error resume next
  81.         FrameMove Timer
  82.         Render
  83.         DoEvents
  84.     Loop
  85.     IM7Terminate
  86. End Sub
  87.  
  88. '-----------------------------------------------------------------------------
  89. ' Name: OneTimeSceneInit()
  90. ' Desc: Called during initial app startup, this subroutine performs all the
  91. '       permanent initialization.
  92. '-----------------------------------------------------------------------------
  93. Sub OneTimeSceneInit()
  94.     
  95. '   Initialize the array of particles
  96.     
  97.     Dim i As Long
  98.     For i = 0 To NUM_PARTICLES - 1
  99.         m_Particle(i) = SetParticle((i Mod 3), 4, RVector(0, 0, 0), _
  100.                                     RVector(0, 30, 0))
  101.     Next
  102.  
  103. '   Initializes vertices used to render the particles
  104.  
  105.     Dim vNorm As D3DVECTOR: vNorm = RVector(0, 0, -1) '1
  106.     m_Mesh(0) = RVertex(RVector(-1, -1, 1), vNorm, 0, 1)
  107.     m_Mesh(1) = RVertex(RVector(-1, 1, 1), vNorm, 0, 0)
  108.     m_Mesh(2) = RVertex(RVector(1, -1, 1), vNorm, 1, 1)
  109.     m_Mesh(3) = RVertex(RVector(1, 1, 1), vNorm, 1, 0)
  110.  
  111.     Dim desc As DDSURFACEDESC2
  112.     FireWorksForm.IMCanvas1.backSurface.GetSurfaceDesc desc
  113.     
  114. '   Initializes vertices used to render the background
  115.     
  116.     With FireWorksForm.IMCanvas1
  117.         DX.CreateD3DTLVertex 0, desc.lHeight, 0.99, 0.5, &HFFFFFFFF, 0, 0, 1, m_Background(0)
  118.         DX.CreateD3DTLVertex 0, 0, 0.99, 0.5, &HFFFFFFFF, 0, 0, 0, m_Background(1)
  119.         DX.CreateD3DTLVertex desc.lWidth, desc.lHeight, 0.99, 0.5, &HFFFFFFFF, 0, 1, 1, m_Background(2)
  120.         DX.CreateD3DTLVertex desc.lWidth, 0, 0.99, 0.5, &HFFFFFFFF, 0, 1, 0, m_Background(3)
  121.     End With
  122.     
  123. '   Load in textures
  124.     FindMediaDir "lake.bmp"
  125.     Set Texture1 = FireWorksForm.IMCanvas1.CreateTextureSurface("lake.bmp", 0, 0, 0)
  126.     Set Texture2 = FireWorksForm.IMCanvas1.CreateTextureSurface("firework.bmp", 0, 0, 0)
  127.     
  128. End Sub
  129.  
  130. '-----------------------------------------------------------------------------
  131. ' Name: FrameMove()
  132. ' Desc: Called once per frame, the call is the entry point for animating
  133. '       the scene.
  134. '-----------------------------------------------------------------------------
  135. Private Function FrameMove(fTimeKey As Single)
  136.  
  137.     Dim a0 As D3DVECTOR: a0 = RVector(0, -9.8, 0)
  138.     Dim t As Single: t = fTimeKey - m_fStartTimeKey
  139.     Dim k As Single: k = 1.8
  140.     Dim dwNumOldParticles As Long
  141.     Dim v0 As D3DVECTOR
  142.     Dim r0 As D3DVECTOR
  143.     Dim fDamping As Single
  144.     Dim st As Single
  145.     Dim vLaunchVelocity As D3DVECTOR
  146.  
  147. '   Store the particles positions
  148.  
  149.     fDamping = (1 - Exp(-k * t)) / (k * k)
  150.     
  151.     For i = 0 To NUM_PARTICLES - 1
  152.         If t < 0 Then ' Particle is in "launch" mode
  153.             
  154.             v0 = m_Particle(i).vLaunchVelocity
  155.             r0 = m_Particle(i).vInitialPosition
  156.             
  157.             m_Particle(i).vPosition = VAdd(r0, VScale(VScale(v0, t - RND1 / 10), 1.5))
  158.         
  159.         Else ' Particle is in "explode" mode
  160.  
  161.             v0 = m_Particle(i).vInitialVelocity
  162.             r0 = m_Particle(i).vInitialPosition
  163.             
  164.             m_Particle(i).vPosition = VAdd(r0, VAdd(VScale(VScale(a0, t), k), VScale(VAdd(VScale(v0, k), a0), fDamping)))
  165.             m_Particle(i).fMaturity = t / m_Particle(i).fLifeTime
  166.             st = m_Particle(i).fMaturity + 0.5
  167.             m_Particle(i).r = Exp(-0.5 * st * st)
  168.             m_Particle(i).g = Exp(-1.8 * st * st)
  169.             m_Particle(i).b = Exp(-2# * st * st)
  170.             m_Particle(i).fSize = Exp(-1# * st * st)
  171.             If m_Particle(i).fMaturity > 1 Then
  172.                 dwNumOldParticles = dwNumOldParticles + 1
  173.             End If
  174.         End If
  175.     Next
  176.     If NUM_PARTICLES = dwNumOldParticles Then
  177.         m_fStartTimeKey = fTimeKey + 1#
  178.         vLaunchVelocity = RVector(40 * Rnd, 30, 0)
  179.         For i = 0 To NUM_PARTICLES - 1
  180.             m_Particle(i) = SetParticle((i Mod 3), 4#, RVector(0, 0, 0), _
  181.                                         vLaunchVelocity)
  182.         Next
  183.     End If
  184. End Function
  185.  
  186.  
  187. '-----------------------------------------------------------------------------
  188. ' Name: Render()
  189. ' Desc: Called once per frame, the call is the entry point for 3d
  190. '       rendering. This subroutine sets up render states, clears the
  191. '       viewport, and renders the scene.
  192. '-----------------------------------------------------------------------------
  193. Private Sub Render()
  194.  
  195.     Dim fRestore As Boolean
  196.     
  197.     fRestore = False
  198.     While FireWorksForm.IMCanvas1.DirectDraw.TestCooperativeLevel <> DD_OK
  199.         DoEvents
  200.         fRestore = True
  201.     Wend
  202.     If fRestore Then
  203.         FireWorksForm.IMCanvas1.DirectDraw.RestoreAllSurfaces
  204.         OneTimeSceneInit
  205.     End If
  206. '   Clear the backbuffer
  207.     FireWorksForm.IMCanvas1.ClearBackSurface
  208.     
  209. '   Begin the scene
  210.     d3ddev.BeginScene
  211.     
  212. '   Draw the background
  213.     d3ddev.SetTexture 0, Texture1 'TexturePool.Item(1) ' GetTexture("c:\images\lake.bmp")
  214.     d3ddev.DrawPrimitive D3DPT_TRIANGLESTRIP, D3DFVF_TLVERTEX, _
  215.                             m_Background(0), 4, 0
  216.  
  217. '   Render the particles
  218.     RenderParticles
  219.  
  220. '   End the scene.
  221.     d3ddev.EndScene
  222.     
  223. '   Update the screen
  224.     FireWorksForm.IMCanvas1.Update
  225.     DoEvents
  226. End Sub
  227.  
  228. '-----------------------------------------------------------------------------
  229. ' Name: RenderParticles()
  230. ' Desc: Draws the system of particles
  231. '-----------------------------------------------------------------------------
  232. Private Sub RenderParticles()
  233.  
  234.     Dim mtrl As D3DMATERIAL7
  235.     Dim i As Long
  236.     Dim matWorld As D3DMATRIX
  237.     Dim matWorld2 As D3DMATRIX
  238.     
  239. '    Turn on alpha blending for the particles
  240.  
  241.     d3ddev.SetTexture 0, Texture2
  242.     d3ddev.SetRenderState D3DRENDERSTATE_ALPHABLENDENABLE, True
  243.     
  244.     For i = 0 To NUM_PARTICLES - 1
  245.     
  246.     LSet matWorld = matWorld2
  247.  
  248.         If m_Particle(i).fMaturity < 1 Then
  249.             
  250.             mtrl.emissive.r = m_Particle(i).r
  251.             mtrl.emissive.g = m_Particle(i).g
  252.             mtrl.emissive.b = m_Particle(i).b
  253.             
  254.             d3ddev.SetMaterial mtrl
  255.     
  256.     '       Translate and scale the world matrix for each particle
  257.             
  258.             matWorld.rc11 = m_Particle(i).fSize
  259.             matWorld.rc22 = m_Particle(i).fSize
  260.             TranslateMatrix matWorld, m_Particle(i).vPosition
  261.     
  262.     '       Set the new world transform and render the particle
  263.             
  264.             d3ddev.SetTransform D3DTRANSFORMSTATE_WORLD, matWorld
  265.             d3ddev.DrawPrimitive D3DPT_TRIANGLESTRIP, D3DFVF_VERTEX, _
  266.                                     m_Mesh(0), 4, D3DDP_DEFAULT
  267.         End If
  268.     Next
  269.     
  270. '   Restore the material and states
  271.     
  272.     mtrl.emissive.r = 1
  273.     mtrl.emissive.g = 1
  274.     mtrl.emissive.b = 1
  275.     d3ddev.SetMaterial mtrl
  276.     
  277.     d3ddev.SetRenderState D3DRENDERSTATE_ALPHABLENDENABLE, False
  278.  
  279. End Sub
  280.  
  281. '-----------------------------------------------------------------------------
  282. ' Name: InitDeviceObjects()
  283. ' Desc: Initialize scene objects
  284. '-----------------------------------------------------------------------------
  285. Public Sub InitDeviceObjects()
  286.  
  287.  
  288.  
  289.           Dim lProp As D3DLIGHT7
  290.           Dim c As D3DCOLORVALUE
  291.           
  292.           With FireWorksForm.IMCanvas1
  293.               Set DDraw = .DirectDraw
  294.               Set DDSFront = .screenSurface
  295.               Set DDSBack = .backSurface
  296.               Set D3D = .Direct3d
  297.               Set d3ddev = .Direct3DDevice
  298.           End With
  299.           
  300.           With DX
  301.               .IdentityMatrix MatWorld1
  302.               .IdentityMatrix matView1
  303.               .IdentityMatrix matProj1
  304.               .ViewMatrix matView1, RVector(0, -20, -32), RVector(0, 0, 400), RVector(0, 1, 0), 0
  305.               .ProjectionMatrix matProj1, 1, 100, 1.57
  306.           End With
  307.   
  308.           d3ddev.SetTransform D3DTRANSFORMSTATE_WORLD, MatWorld1
  309.           d3ddev.SetTransform D3DTRANSFORMSTATE_VIEW, matView1
  310.           d3ddev.SetTransform D3DTRANSFORMSTATE_PROJECTION, matProj1
  311.   
  312.           With ViewPort1
  313.               .lHeight = FireWorksForm.IMCanvas1.Height
  314.               .lWidth = FireWorksForm.IMCanvas1.Width
  315.               .minz = 0#
  316.               .maxz = 1#
  317.           End With
  318.           DX.GetWindowRect FireWorksForm.hWnd, RWDestRect
  319.   
  320.           With c
  321.               .a = 1
  322.               .r = 1
  323.               .g = 1
  324.               .b = 1
  325.           End With
  326.           With lProp
  327.               .dltType = D3DLIGHT_POINT
  328.               .Ambient = c
  329.               .diffuse = c
  330.               .specular = c
  331.               .position.y = 100
  332.           End With
  333.           d3ddev.SetLight 0, lProp
  334.           d3ddev.LightEnable 0, True
  335.   
  336.           With c
  337.               .a = 1
  338.               .r = 1
  339.               .g = 1
  340.               .b = 1
  341.           End With
  342.   
  343.           Material1.Ambient = c
  344.           Material1.diffuse = c
  345.           Material1.emissive = c
  346.           Material1.power = 1
  347.           d3ddev.SetMaterial Material1
  348.  
  349. '    Set any appropiate state
  350.     
  351.           d3ddev.SetRenderState D3DRENDERSTATE_AMBIENT, &HFFFFFFFF
  352.           d3ddev.SetRenderState D3DRENDERSTATE_SRCBLEND, D3DBLEND_ONE
  353.           d3ddev.SetRenderState D3DRENDERSTATE_DESTBLEND, D3DBLEND_ONE
  354.           d3ddev.SetRenderState D3DRENDERSTATE_DITHERENABLE, True
  355.           d3ddev.SetRenderState D3DRENDERSTATE_SPECULARENABLE, False
  356.           d3ddev.SetRenderState D3DRENDERSTATE_ZENABLE, False
  357.           d3ddev.SetTextureStageState 0, D3DTSS_COLORARG1, D3DTA_TEXTURE
  358.           d3ddev.SetTextureStageState 0, D3DTSS_COLORARG2, D3DTA_DIFFUSE
  359.           d3ddev.SetTextureStageState 0, D3DTSS_COLOROP, D3DTOP_MODULATE
  360.           d3ddev.SetTextureStageState 0, D3DTSS_MINFILTER, D3DTFN_LINEAR
  361.           d3ddev.SetTextureStageState 0, D3DTSS_MAGFILTER, D3DTFG_LINEAR
  362.   
  363. End Sub
  364.  
  365. Sub FindMediaDir(sFile As String)
  366.     On Local Error Resume Next
  367.     If Dir$(sFile) <> "" Then Exit Sub
  368.     If Mid$(App.Path, 2, 1) = ":" Then
  369.         ChDrive Mid$(App.Path, 1, 1)
  370.     End If
  371.     ChDir App.Path
  372.     If Dir$(sFile) = "" Then
  373.         ChDir "..\media"
  374.     End If
  375.     If Dir$(sFile) = "" Then
  376.         ChDir "..\..\media"
  377.     End If
  378. End Sub
  379.  
  380. Public Function RND1() As Double
  381.     RND1 = (Rnd - Rnd) / 2
  382. End Function
  383.  
  384. Public Function RND2() As Double
  385.     RND2 = Rnd
  386. End Function
  387.  
  388.  
  389.  
  390.  
  391.