Initial commit: ROW Client source code

Game client codebase including:
- CharacterActionControl: Character and creature management
- GlobalScript: Network, items, skills, quests, utilities
- RYLClient: Main client application with GUI and event handlers
- Engine: 3D rendering engine (RYLGL)
- MemoryManager: Custom memory allocation
- Library: Third-party dependencies (DirectX, boost, etc.)
- Tools: Development utilities

🤖 Generated with [Claude Code](https://claude.com/claude-code)

Co-Authored-By: Claude <noreply@anthropic.com>
This commit is contained in:
2025-11-29 16:24:34 +09:00
commit e067522598
5135 changed files with 1745744 additions and 0 deletions

View File

@@ -0,0 +1,603 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "CParticle"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'-----------------------------------------------------------------------------
' Global data for the particles
'-----------------------------------------------------------------------------
Private Type CUSTOMVERTEX
v As D3DVECTOR
color As Long
tu As Single
tv As Single
End Type
Const D3DFVF_COLORVERTEX = (D3DFVF_XYZ Or D3DFVF_DIFFUSE Or D3DFVF_TEX1)
Private Type PARTICLE
m_bSpark As Boolean ' Spark? or real particle?
m_vPos As D3DVECTOR ' Current position
m_vVel As D3DVECTOR ' Current velocity
m_vPos0 As D3DVECTOR ' Initial Position
m_vVel0 As D3DVECTOR ' Initial Velocity
m_fTime0 As Single ' Time of creation
m_clrDiffuse As D3DCOLORVALUE ' Initial diffuse color
m_clrFade As D3DCOLORVALUE ' Faded diffuse color
m_fFade As Single ' Fade progression
iNext As Long ' Next particle in list
End Type
Dim m_Particles() As PARTICLE 'we leave 0 element unused to make code convenient
'so think of this as a 1 based array
Dim m_fRadius As Single
Dim m_MaxParticles As Long
Dim m_NumParticles As Long
Dim m_ParticlesLim As Long
Dim m_iFree As Long 'index of first free particle (0 = empty)
Dim m_iUsed As Long 'index of first particle in list (0 = empty)
Dim m_iLast As Long
'Geometry
Dim m_VertB As Direct3DVertexBuffer8
Dim m_IndxB As Direct3DIndexBuffer8
Dim m_Verts() As CUSTOMVERTEX
Dim m_binit As Boolean
'-----------------------------------------------------------------------------
' Name: Init
' Desc:
'-----------------------------------------------------------------------------
Sub Init(MaxParticles As Long, fRadius As Single)
m_fRadius = fRadius
m_MaxParticles = MaxParticles
m_NumParticles = 0
m_ParticlesLim = 1800
m_iFree = 0
m_iUsed = 0
Set m_VertB = Nothing
Set m_IndxB = Nothing
m_binit = True
ReDim m_Verts(MaxParticles * 6)
ReDim m_Particles(m_ParticlesLim)
End Sub
'-----------------------------------------------------------------------------
' Name: InitDeviceObjects
' Desc:
'-----------------------------------------------------------------------------
Sub InitDeviceObjects(dev As Direct3DDevice8)
Dim v As CUSTOMVERTEX
Dim j As Long, i As Long
Dim indices() As Integer
Dim indxbuffsize As Long
' Create the particle system's vertex buffer and index buffer.
' Each particle requires four vertices and 6 indices
Set m_VertB = dev.CreateVertexBuffer(4 * m_MaxParticles * Len(v), D3DUSAGE_SOFTWAREPROCESSING, D3DFVF_COLORVERTEX, D3DPOOL_MANAGED)
indxbuffsize = 6 * m_MaxParticles * 4 'each entry is 4 bytes (vb integer)
Set m_IndxB = dev.CreateIndexBuffer(indxbuffsize, D3DUSAGE_SOFTWAREPROCESSING, D3DFMT_INDEX16, D3DPOOL_MANAGED)
' Fill the index buffer
ReDim indices(6 * m_MaxParticles) 'we have 2 triangles per particle
j = 0
For i = 0 To m_MaxParticles - 1
indices(j) = 4 * i + 0: j = j + 1
indices(j) = 4 * i + 3: j = j + 1
indices(j) = 4 * i + 1: j = j + 1
indices(j) = 4 * i + 1: j = j + 1
indices(j) = 4 * i + 3: j = j + 1
indices(j) = 4 * i + 2: j = j + 1
Next
' Set the data on the d3d buffer
D3DIndexBuffer8SetData m_IndxB, 0, indxbuffsize, 0, indices(0)
End Sub
'-----------------------------------------------------------------------------
' Name: DeleteDeviceObjects
' Desc:
'-----------------------------------------------------------------------------
Sub DeleteDeviceObjects()
Set m_VertB = Nothing
Set m_IndxB = Nothing
End Sub
'-----------------------------------------------------------------------------
' Name: Class_Terminate
' Desc:
'-----------------------------------------------------------------------------
Private Sub Class_Terminate()
DeleteDeviceObjects
ReDim m_Particles(0)
End Sub
'-----------------------------------------------------------------------------
' Name:
' Desc:
'-----------------------------------------------------------------------------
Sub Update(fSecsPerFrame As Single, NumParticlesToEmit As Long, _
clrEmitColor As D3DCOLORVALUE, _
clrFadeColor As D3DCOLORVALUE, _
fEmitVel As Single, _
vPosition As D3DVECTOR)
If m_binit = False Then Exit Sub
Static fTime As Single
Dim i As Long
Dim iSpark As Long, inew As Long
Dim fRand1 As Single, fRand2 As Single
'advance simulation
fTime = fTime + fSecsPerFrame
Dim iCurrent As Long
Dim iPrevious As Long
iCurrent = m_iUsed
iPrevious = 0
'For each particle in the In Use list ...
'calculate its age and test if the particle is too old
Do While (iCurrent > 0)
With m_Particles(iCurrent)
Dim ft As Single
Dim fGravity As Single
'Calculate current lifetime
ft = fTime - .m_fTime0
'normal particle become sparks at the end of their
'life time and have different behaviour
'that we define here
If .m_bSpark Then
'sparks float higher and fade faster
fGravity = -5#
.m_fFade = .m_fFade - fSecsPerFrame * 2.25
Else
'other particles fall to ground faster but live longer
fGravity = -9.8
End If
'Our newposition computed from velocity and initial position
'pNew=pInit+t*velocity + accl * t * t
'the first terms
.m_vPos.x = .m_vVel0.x * ft + .m_vPos0.x
.m_vPos.y = .m_vVel0.y * ft + .m_vPos0.y
.m_vPos.z = .m_vVel0.z * ft + .m_vPos0.z
'we add gravity in for the accleration terms on y axis
.m_vPos.y = .m_vPos.y + (0.5 * fGravity) * (ft * ft)
'compute new Velocity given acceleartion
'vNew=vInit+t*vCurrent
.m_vVel.y = .m_vVel0.y + fGravity * ft
'clamp fading to zero
If (.m_fFade < 0#) Then .m_fFade = 0
'Normal particles die and turn into 5 sparks when they are
'above a certain height from the ground
'Sparks die when they fall below the surface
'We test here if any particle is dead
If (.m_vPos.y < m_fRadius) Then '
'if we have a normal particle
'lets turn it into 5 sparks
If (Not .m_bSpark) Then
For i = 0 To 4
'If there are particles in the free list, use them
If (m_iFree) Then
iSpark = m_iFree
m_iFree = m_Particles(m_iFree).iNext
'other wise get a new one
Else
If m_iLast >= m_ParticlesLim Then
' 'm_bReset = True
Exit For
End If
m_iLast = m_iLast + 1
iSpark = m_iLast
End If
'put this new particle on the used list
m_Particles(iSpark).iNext = m_iUsed
m_iUsed = iSpark
m_NumParticles = m_NumParticles + 1
'have the spark start out in the same position
'as where the normal particle is now
m_Particles(iSpark).m_bSpark = True
m_Particles(iSpark).m_vPos0 = .m_vPos
m_Particles(iSpark).m_vPos0.y = m_fRadius
fRand1 = Rnd(1) * g_pi * 2
fRand2 = Rnd(1) * g_pi * 0.25
'have the sparks velocity vere off from the normal particle
m_Particles(iSpark).m_vVel0.x = .m_vVel.x * 0.25 + Cos(fRand1) * Sin(fRand2)
m_Particles(iSpark).m_vVel0.z = .m_vVel.z * 0.25 + Sin(fRand1) * Sin(fRand2)
m_Particles(iSpark).m_vVel0.y = Cos(fRand2) * Rnd(1) * 1.5
'set the sparks current position = initial position
'set the sparks current velocitu = initial velocity
m_Particles(iSpark).m_vPos = .m_vPos0
m_Particles(iSpark).m_vVel = .m_vVel0
' set the initial color of the particle to be that of
'what it was as a normal particle
D3DXColorLerp m_Particles(iSpark).m_clrDiffuse, .m_clrFade, .m_clrDiffuse, .m_fFade
'set the spark to fade to blue
m_Particles(iSpark).m_clrFade = ColorValue4(0#, 0#, 0#, 1#)
'set its life time indicator to be newly created
m_Particles(iSpark).m_fFade = 1#
'save the time of creation
m_Particles(iSpark).m_fTime0 = fTime
Next
End If
' Kill the current particle
'remove it form used list
'put it on free list
If iPrevious > 0 Then
m_Particles(iPrevious).iNext = .iNext
Else
m_iUsed = .iNext
End If
Dim iTemp As Long
iTemp = .iNext
.iNext = m_iFree
m_iFree = iCurrent
iCurrent = iTemp
m_NumParticles = m_NumParticles - 1
Else
iPrevious = iCurrent
iCurrent = .iNext
End If
End With
Loop
' Emit new particles
Dim NumParticlesEmit As Long
NumParticlesEmit = m_NumParticles + NumParticlesToEmit
Do While (m_NumParticles < m_ParticlesLim And m_NumParticles < NumParticlesEmit)
' If there is a particle in the free list, use it
If (m_iFree) Then
inew = m_iFree
m_iFree = m_Particles(m_iFree).iNext
'other wise get an new one
Else
If m_iLast >= m_ParticlesLim Then
Exit Do
End If
m_iLast = m_iLast + 1
inew = m_iLast
End If
'put it on the used list
'put this new particle on the used list
m_Particles(inew).iNext = m_iUsed
m_iUsed = inew
m_NumParticles = m_NumParticles + 1
' Emit new particle
fRand1 = Rnd(1) * g_pi * 2
fRand2 = Rnd(1) * g_pi * 0.25
With m_Particles(inew)
.m_bSpark = False
D3DXVec3Add .m_vPos0, vPosition, vec3(0, m_fRadius, 0)
.m_vVel0.x = Cos(fRand1) * Sin(fRand2) * 2.5
.m_vVel0.z = Sin(fRand1) * Sin(fRand2) * 2.5
.m_vVel0.y = Cos(fRand2) * (Rnd(1) * fEmitVel)
.m_vPos = .m_vPos0
.m_vVel = .m_vVel0
.m_clrDiffuse = clrEmitColor
.m_clrFade = clrFadeColor
.m_fFade = 1
.m_fTime0 = fTime
End With
Loop
End Sub
'-----------------------------------------------------------------------------
' Name: Render()
' Desc: Renders the particle system using either pointsprites
'
'-----------------------------------------------------------------------------
Sub Render(dev As Direct3DDevice8)
Dim v As CUSTOMVERTEX
Dim iCurrent As Long, i As Long
With dev
Dim DWFloat0 As Long
Dim DWFloat1 As Long
Dim DWFloatp08 As Long
DWFloat0 = FtoDW(0)
DWFloat1 = FtoDW(1)
DWFloatp08 = FtoDW(0.08)
' Set the render states for using point sprites
.SetRenderState D3DRS_POINTSPRITE_ENABLE, 1 'True
.SetRenderState D3DRS_POINTSCALE_ENABLE, 1 'True
.SetRenderState D3DRS_POINTSIZE, DWFloatp08
.SetRenderState D3DRS_POINTSIZE_MIN, DWFloat0
.SetRenderState D3DRS_POINTSCALE_A, DWFloat0
.SetRenderState D3DRS_POINTSCALE_B, DWFloat0
.SetRenderState D3DRS_POINTSCALE_C, DWFloat1
' Set up the vertex buffer to be rendered
.SetStreamSource 0, m_VertB, Len(v)
.SetVertexShader D3DFVF_COLORVERTEX
End With
Dim NumParticlesToRender As Long
' Render each particle
iCurrent = m_iUsed
Dim vPos As D3DVECTOR, vVel As D3DVECTOR
Dim fLengthSq As Single, steps As Long
Do While (iCurrent <> 0)
With m_Particles(iCurrent)
vPos = .m_vPos
vVel = .m_vVel
fLengthSq = D3DXVec3LengthSq(vVel)
If (fLengthSq < 1#) Then
steps = 2
ElseIf (fLengthSq < 4#) Then
steps = 3
ElseIf (fLengthSq < 9#) Then
steps = 4
ElseIf (fLengthSq < 12.25) Then
steps = 5
ElseIf (fLengthSq < 16#) Then
steps = 6
ElseIf (fLengthSq < 20.25) Then
steps = 7
Else
steps = 8
End If
D3DXVec3Scale vVel, vVel, (-0.04 / steps)
Dim clrDiffuse As D3DCOLORVALUE
D3DXColorLerp clrDiffuse, .m_clrFade, .m_clrDiffuse, .m_fFade
Dim clrDiffuseLong As Long
clrDiffuseLong = D3DCOLORVALUEtoLONG(clrDiffuse)
Dim iVert As Long
' Render each particle a bunch of times to get a blurring effect
For i = 0 To steps - 1
m_Verts(iVert).v = vPos
m_Verts(iVert).color = clrDiffuseLong
NumParticlesToRender = NumParticlesToRender + 1
iVert = iVert + 1
If (NumParticlesToRender = m_MaxParticles) Then
' we have a full Vertex buffer
D3DVertexBuffer8SetData m_VertB, 0, Len(v) * m_MaxParticles, 0, m_Verts(0)
dev.DrawPrimitive D3DPT_POINTLIST, 0, NumParticlesToRender
NumParticlesToRender = 0
iVert = 0
End If
D3DXVec3Add vPos, vPos, vVel
Next
iCurrent = .iNext
End With
Loop
' Render any remaining particles
If (NumParticlesToRender <> 0) Then
D3DVertexBuffer8SetData m_VertB, 0, Len(v) * NumParticlesToRender, 0, m_Verts(0)
g_dev.DrawPrimitive D3DPT_POINTLIST, 0, NumParticlesToRender
End If
' Reset render states
g_dev.SetRenderState D3DRS_POINTSPRITE_ENABLE, 0 'False
g_dev.SetRenderState D3DRS_POINTSCALE_ENABLE, 0 'False
End Sub
'-----------------------------------------------------------------------------
' Name: RenderLights
' Desc:
'-----------------------------------------------------------------------------
Sub RenderLights(dev As Direct3DDevice8)
Dim vTL As D3DVECTOR, vBL As D3DVECTOR, vBR As D3DVECTOR, vTR As D3DVECTOR
Dim v As CUSTOMVERTEX
vTL = vec3(-1, 0, 1): vBL = vec3(-1, 0, -1)
vBR = vec3(1, 0, -1): vTR = vec3(1, 0, 1)
With dev
.SetStreamSource 0, m_VertB, Len(v)
.SetVertexShader D3DFVF_COLORVERTEX
.SetIndices m_IndxB, 0
End With
Dim iCurrent As Long
Dim NumParticlesToRender
Dim fY As Single
Dim fSize As Single
Dim clrDiffuse As D3DCOLORVALUE
Dim clrDiffuseTemp As D3DCOLORVALUE
Dim lngDiffuse As Long
Dim vPos As D3DVECTOR
Dim vTemp As D3DVECTOR
Dim j As Long
iCurrent = m_iUsed
Do While (iCurrent <> 0)
With m_Particles(iCurrent)
fY = .m_vPos.y
'if the particle is close to the ground we will add some lights effects
If (fY < 1) Then
'make sure particle cant go below ground
If (fY < 0) Then fY = 0
fSize = fY * 0.25 + m_fRadius
D3DXColorLerp clrDiffuse, .m_clrFade, .m_clrDiffuse, .m_fFade
D3DXColorScale clrDiffuseTemp, clrDiffuse, (1 - fY) * 0.5
lngDiffuse = D3DCOLORVALUEtoLONG(clrDiffuseTemp)
vPos = vec3(.m_vPos.x, 0#, .m_vPos.z)
D3DXVec3Scale vTemp, vTR, fSize
D3DXVec3Add m_Verts(j).v, vPos, vTemp
m_Verts(j).color = lngDiffuse
m_Verts(j).tu = 0: m_Verts(j).tv = 0
j = j + 1
D3DXVec3Scale vTemp, vBR, fSize
D3DXVec3Add m_Verts(j).v, vPos, vTemp
m_Verts(j).color = lngDiffuse
m_Verts(j).tu = 0: m_Verts(j).tv = 1
j = j + 1
D3DXVec3Scale vTemp, vBL, fSize
D3DXVec3Add m_Verts(j).v, vPos, vTemp
m_Verts(j).color = lngDiffuse
m_Verts(j).tu = 1: m_Verts(j).tv = 1
j = j + 1
D3DXVec3Scale vTemp, vTL, fSize
D3DXVec3Add m_Verts(j).v, vPos, vTemp
m_Verts(j).color = lngDiffuse
m_Verts(j).tu = 1: m_Verts(j).tv = 0
j = j + 1
NumParticlesToRender = NumParticlesToRender + 1
If (NumParticlesToRender = m_MaxParticles) Then
D3DVertexBuffer8SetData m_VertB, 0, Len(v) * 4 * NumParticlesToRender, 0, m_Verts(0)
dev.DrawIndexedPrimitive D3DPT_TRIANGLELIST, _
0, NumParticlesToRender * 4, _
0, NumParticlesToRender * 2
NumParticlesToRender = 0
j = 0
End If
End If
iCurrent = .iNext
End With
Loop
' Render remaining particles
If (NumParticlesToRender <> 0) Then
D3DVertexBuffer8SetData m_VertB, 0, Len(v) * 4 * NumParticlesToRender, 0, m_Verts(0)
dev.DrawIndexedPrimitive D3DPT_TRIANGLELIST, _
0, NumParticlesToRender * 4, _
0, NumParticlesToRender * 2
End If
End Sub

View File

@@ -0,0 +1,778 @@
VERSION 5.00
Begin VB.Form Form1
Caption = "Point Sprites"
ClientHeight = 4050
ClientLeft = 60
ClientTop = 345
ClientWidth = 5055
Icon = "PointSprites.frx":0000
LinkTopic = "Form1"
ScaleHeight = 270
ScaleMode = 3 'Pixel
ScaleWidth = 337
StartUpPosition = 3 'Windows Default
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: PointSprites.frm
' Content: Sample showing how to use point sprites to do particle effects
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Option Compare Text
Private Type CUSTOMVERTEX
v As D3DVECTOR
color As Long
tu As Single
tv As Single
End Type
Const D3DFVF_COLORVERTEX = (D3DFVF_XYZ Or D3DFVF_DIFFUSE Or D3DFVF_TEX1)
Const GROUND_GRIDSIZE = 8
Const GROUND_WIDTH = 256
Const GROUND_HEIGHT = 256
Const GROUND_TILE = 32
Const GROUND_COLOR = &HBBEEEEEE
Private Enum PARTICLE_COLORS
COLOR_WHITE = 0
COLOR_RED = 1
COLOR_GREEN = 2
COLOR_BLUE = 3
NUM_COLORS = 4
End Enum
Dim g_clrColor(4) As D3DCOLORVALUE
Dim g_clrColorFade(4) As D3DCOLORVALUE
Dim m_media As String
Dim m_ParticleSystem As CParticle
Dim m_ParticleTexture As Direct3DTexture8
Dim m_NumParticlesToEmit As Long
Dim m_bStaticParticle As Boolean
Dim m_nParticleColor As Long
Dim m_GroundTexture As Direct3DTexture8
Dim m_NumGroundVertices As Long
Dim m_NumGroundIndices As Long
Dim m_GroundIB As Direct3DIndexBuffer8
Dim m_GroundVB As Direct3DVertexBuffer8
Dim m_planeGround As D3DPLANE
Dim m_bDrawReflection As Boolean
Dim m_bCanDoAlphaBlend As Boolean
Dim m_bCanDoClipPlanes As Boolean
Dim m_bDrawHelp As Boolean
Dim m_matView As D3DMATRIX
Dim m_matOrientation As D3DMATRIX
Dim m_vPosition As D3DVECTOR
Dim m_vVelocity As D3DVECTOR
Dim m_fYaw As Single
Dim m_fYawVelocity As Single
Dim m_fPitch As Single
Dim m_fPitchVelocity As Single
Dim m_fElapsedTime As Single
Dim m_bKey(256) As Boolean
Dim g_fTime As Single
Dim g_fLastTime As Single
Dim m_grVerts() As CUSTOMVERTEX
Dim m_grVerts2() As CUSTOMVERTEX
Dim m_binit As Boolean
Dim m_bMinimized As Boolean
Dim m_bStopSim As Boolean
Const kMaxParticles = 128
Const kParticleRadius = 0.01
'-----------------------------------------------------------------------------
' Name: Form_KeyPress()
' Desc:
'-----------------------------------------------------------------------------
Private Sub Form_KeyPress(KeyAscii As Integer)
If Chr$(KeyAscii) = "r" Then m_bDrawReflection = Not m_bDrawReflection
End Sub
'-----------------------------------------------------------------------------
' Name: Form_Load()
' Desc:
'-----------------------------------------------------------------------------
Private Sub Form_Load()
Me.Show
DoEvents
'setup defaults
Init
' Initialize D3D
' Note: D3DUtil_Init will attempt to use D3D Hardware acceleartion.
' If it is not available it attempt to use the Software Reference Rasterizer.
' If all fail it will display a message box indicating so.
'
m_binit = D3DUtil_Init(Me.hwnd, True, 0, 0, D3DDEVTYPE_HAL, Me)
If Not (m_binit) Then End
' find Media and set media path
m_media = FindMediaDir("ground2.bmp")
D3DUtil_SetMediaPath m_media
' Set initial state
OneTimeSceneInit
' Load Mesh and textures from media
InitDeviceObjects
' Set device render states, lighting, camera
RestoreDeviceObjects
' Start Timer
DXUtil_Timer TIMER_start
' Start our timer
DXUtil_Timer TIMER_start
' Run the simulation forever
' See Form_Keydown for exit processing
Do While True
' Increment the simulation
FrameMove
' Render one image of the simulation
If Render Then
' Present the image to the screen
D3DUtil_PresentAll g_focushwnd
End If
' Allow for events to get processed
DoEvents
Loop
End Sub
'-----------------------------------------------------------------------------
' Name: Form_KeyDown()
' Desc: Process key messages for exit and change device
'-----------------------------------------------------------------------------
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
m_bKey(KeyCode) = True
Select Case KeyCode
Case vbKeyEscape
Unload Me
Case vbKeyF2
' Pause the timer
DXUtil_Timer TIMER_STOP
m_bStopSim = True
' Bring up the device selection dialog
' we pass in the form so the selection process
' can make calls into InitDeviceObjects
' and RestoreDeviceObjects
frmSelectDevice.SelectDevice Me
' Restart the timer
m_bStopSim = False
DXUtil_Timer TIMER_start
Case vbKeyReturn
' Check for Alt-Enter if not pressed exit
If Shift <> 4 Then Exit Sub
' stop simulation
DXUtil_Timer TIMER_STOP
m_bStopSim = True
' If we are windowed go fullscreen
' If we are fullscreen returned to windowed
If g_d3dpp.Windowed Then
D3DUtil_ResetFullscreen
Else
D3DUtil_ResetWindowed
End If
' Call Restore after ever mode change
' because calling reset looses state that needs to
' be reinitialized
RestoreDeviceObjects
' Restart simulation
DXUtil_Timer TIMER_STOP
m_bStopSim = False
End Select
End Sub
'-----------------------------------------------------------------------------
' Name: Form_KeyUp()
' Desc: Process key messages for exit and change device
'-----------------------------------------------------------------------------
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
m_bKey(KeyCode) = False
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
DXUtil_Timer (TIMER_STOP)
m_bStopSim = True
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
DXUtil_Timer (TIMER_start)
m_bStopSim = False
End Sub
'-----------------------------------------------------------------------------
' Name: Form_Resize()
' Desc: hadle resizing of the D3D backbuffer
'-----------------------------------------------------------------------------
Private Sub Form_Resize()
' If D3D is not initialized then exit
If Not m_binit Then Exit Sub
' If we are in a minimized state stop the timer and exit
If Me.WindowState = vbMinimized Then
DXUtil_Timer TIMER_STOP
m_bMinimized = True
m_bStopSim = True
Exit Sub
' If we just went from a minimized state to maximized
' restart the timer
Else
If m_bMinimized = True Then
DXUtil_Timer TIMER_start
m_bMinimized = False
m_bStopSim = False
End If
End If
' Dont let the window get too small
If Me.ScaleWidth < 10 Then
Me.width = Screen.TwipsPerPixelX * 10
Exit Sub
End If
If Me.ScaleHeight < 10 Then
Me.height = Screen.TwipsPerPixelY * 10
Exit Sub
End If
m_ParticleSystem.DeleteDeviceObjects
Set m_ParticleSystem = Nothing
Set m_ParticleSystem = New CParticle
'reset and resize our D3D backbuffer to the size of the window
D3DUtil_ResizeWindowed Me.hwnd
'All state get losts after a reset so we need to reinitialze it here
RestoreDeviceObjects
DXUtil_Timer TIMER_STOP
m_ParticleSystem.Init kMaxParticles, kParticleRadius
m_ParticleSystem.InitDeviceObjects g_dev
DXUtil_Timer TIMER_RESET
End Sub
'-----------------------------------------------------------------------------
' Name: Form_Unload()
' Desc:
'-----------------------------------------------------------------------------
Private Sub Form_Unload(Cancel As Integer)
DeleteDeviceObjects
End
End Sub
'-----------------------------------------------------------------------------
' Name: Init()
' Desc: Constructor
'-----------------------------------------------------------------------------
Sub Init()
Me.Caption = "PointSprites: Using particle effects"
Set m_ParticleSystem = New CParticle
m_ParticleSystem.Init kMaxParticles, kParticleRadius
Set m_ParticleTexture = Nothing
m_NumParticlesToEmit = 10
m_bStaticParticle = True
m_nParticleColor = COLOR_WHITE
Set m_GroundTexture = Nothing
m_NumGroundVertices = (GROUND_GRIDSIZE + 1) * (GROUND_GRIDSIZE + 1)
m_NumGroundIndices = (GROUND_GRIDSIZE * GROUND_GRIDSIZE) * 6
Set m_GroundVB = Nothing
Set m_GroundIB = Nothing
m_planeGround = D3DPLANE4(0, 1, 0, 0)
m_bDrawReflection = False
m_bCanDoAlphaBlend = False
m_bCanDoClipPlanes = False
m_bDrawHelp = False
m_vPosition = vec3(0, 3, -4)
m_vVelocity = vec3(0, 0, 0)
m_fYaw = 0
m_fYawVelocity = 0
m_fPitch = 0.5
m_fPitchVelocity = 0
g_clrColor(0) = ColorValue4(1, 1, 1, 1)
g_clrColor(1) = ColorValue4(1, 0.5, 0.5, 1)
g_clrColor(2) = ColorValue4(0.5, 1, 0.5, 1)
g_clrColor(3) = ColorValue4(0.125, 0.5, 1, 1)
g_clrColorFade(0) = ColorValue4(1, 0.25, 0.25, 1)
g_clrColorFade(1) = ColorValue4(1, 0.25, 0.25, 1)
g_clrColorFade(2) = ColorValue4(0.25, 0.75, 0.25, 1)
g_clrColorFade(3) = ColorValue4(0.125, 0.25, 0.75, 1)
End Sub
'-----------------------------------------------------------------------------
' Name: OneTimeSceneInit()
' Desc: Called during initial app startup, this function performs all the
' permanent initialization.
'-----------------------------------------------------------------------------
Sub OneTimeSceneInit()
D3DXMatrixTranslation m_matView, 0, 0, 10
D3DXMatrixTranslation m_matOrientation, 0, 0, 0
End Sub
'-----------------------------------------------------------------------------
' Name: FrameMove()
' Desc: Called once per frame, the call is the entry point for animating
' the scene.
'-----------------------------------------------------------------------------
Sub FrameMove()
If m_bStopSim = True Then Exit Sub
g_fTime = DXUtil_Timer(TIMER_GETAPPTIME) * 1.3
m_fElapsedTime = g_fTime - g_fLastTime
g_fLastTime = g_fTime
If m_fElapsedTime < 0 Then Exit Sub
' Slow things down for the REF device
If (g_devType = D3DDEVTYPE_REF) Then m_fElapsedTime = 0.05
Dim fSpeed As Single
Dim fAngularSpeed
fSpeed = 5 * m_fElapsedTime
fAngularSpeed = 1 * m_fElapsedTime
' Slowdown the camera movement
D3DXVec3Scale m_vVelocity, m_vVelocity, 0.9
m_fYawVelocity = m_fYawVelocity * 0.9
m_fPitchVelocity = m_fPitchVelocity * 0.9
' Process keyboard input
If (m_bKey(vbKeyRight)) Then m_vVelocity.x = m_vVelocity.x + fSpeed ' Slide Right
If (m_bKey(vbKeyLeft)) Then m_vVelocity.x = m_vVelocity.x - fSpeed ' Slide Left
If (m_bKey(vbKeyUp)) Then m_vVelocity.y = m_vVelocity.y + fSpeed ' Move up
If (m_bKey(vbKeyDown)) Then m_vVelocity.y = m_vVelocity.y - fSpeed ' Move down
If (m_bKey(vbKeyW)) Then m_vVelocity.z = m_vVelocity.z + fSpeed ' Move Forward
If (m_bKey(vbKeyS)) Then m_vVelocity.z = m_vVelocity.z - fSpeed ' Move Backward
If (m_bKey(vbKeyE)) Then m_fYawVelocity = m_fYawVelocity + fSpeed ' Yaw right
If (m_bKey(vbKeyQ)) Then m_fYawVelocity = m_fYawVelocity - fSpeed ' Yaw left
If (m_bKey(vbKeyZ)) Then m_fPitchVelocity = m_fPitchVelocity + fSpeed ' turn down
If (m_bKey(vbKeyA)) Then m_fPitchVelocity = m_fPitchVelocity - fSpeed ' turn up
If (m_bKey(vbKeyAdd)) Then
If (m_NumParticlesToEmit < 10) Then m_NumParticlesToEmit = m_NumParticlesToEmit + 1
End If
If (m_bKey(vbKeySubtract)) Then
If (m_NumParticlesToEmit > 0) Then m_NumParticlesToEmit = m_NumParticlesToEmit - 1
End If
' Update the position vector
Dim vT As D3DVECTOR, vTemp As D3DVECTOR
D3DXVec3Scale vTemp, m_vVelocity, fSpeed
D3DXVec3Add vT, vT, vTemp
D3DXVec3TransformNormal vT, vT, m_matOrientation
D3DXVec3Add m_vPosition, m_vPosition, vT
If (m_vPosition.y < 1) Then m_vPosition.y = 1
' Update the yaw-pitch-rotation vector
m_fYaw = m_fYaw + fAngularSpeed * m_fYawVelocity
m_fPitch = m_fPitch + fAngularSpeed * m_fPitchVelocity
If (m_fPitch < 0) Then m_fPitch = 0
If (m_fPitch > g_pi / 2) Then m_fPitch = g_pi / 2
Dim qR As D3DQUATERNION, det As Single
D3DXQuaternionRotationYawPitchRoll qR, m_fYaw, m_fPitch, 0
D3DXMatrixAffineTransformation m_matOrientation, 1.25, vec3(0, 0, 0), qR, m_vPosition
D3DXMatrixInverse m_matView, det, m_matOrientation
' Update particle system
If (m_bStaticParticle) Then
m_ParticleSystem.Update m_fElapsedTime, m_NumParticlesToEmit, _
g_clrColor(m_nParticleColor), _
g_clrColorFade(m_nParticleColor), 8, _
vec3(0, 0, 0)
Else
m_ParticleSystem.Update m_fElapsedTime, m_NumParticlesToEmit, _
g_clrColor(m_nParticleColor), _
g_clrColorFade(m_nParticleColor), 8, _
vec3(3 * Sin(g_fTime), 0, 3 * Cos(g_fTime))
End If
End Sub
'-----------------------------------------------------------------------------
' Name: Render()
' Desc: Called once per frame, the call is the entry point for 3d
' rendering. This function sets up render states, clears the
' viewport, and renders the scene.
'-----------------------------------------------------------------------------
Function Render() As Boolean
Dim v As CUSTOMVERTEX
Dim hr As Long
'See what state the device is in.
Render = False
hr = g_dev.TestCooperativeLevel
If hr = D3DERR_DEVICENOTRESET Then
g_dev.Reset g_d3dpp
RestoreDeviceObjects
End If
'dont bother rendering if we are not ready yet
If hr <> 0 Then Exit Function
Render = True
' Clear the backbuffer
D3DUtil_ClearAll &HFF&
With g_dev
.BeginScene
' Draw reflection of particles
If (m_bDrawReflection) Then
Dim matReflectedView As D3DMATRIX
D3DXMatrixReflect matReflectedView, m_planeGround
D3DXMatrixMultiply matReflectedView, matReflectedView, m_matView
.SetTransform D3DTS_VIEW, matReflectedView
'Dim clipplane As D3DCLIPPLANE
'LSet clipplane = m_planeGround
'.SetClipPlane 0, clipplane
.SetRenderState D3DRS_CLIPPLANEENABLE, D3DCLIPPLANE0
' Draw particles
.SetTexture 0, m_ParticleTexture
.SetRenderState D3DRS_ZWRITEENABLE, 0 'FALSE
.SetRenderState D3DRS_ALPHABLENDENABLE, 1 'TRUE
m_ParticleSystem.Render g_dev
.SetRenderState D3DRS_ALPHABLENDENABLE, 0 'False
.SetRenderState D3DRS_ZWRITEENABLE, 1 'True
.SetRenderState D3DRS_CLIPPLANEENABLE, 0 'FALSE
.SetRenderState D3DRS_ALPHABLENDENABLE, 1 'True
.SetRenderState D3DRS_SRCBLEND, D3DBLEND_SRCALPHA
.SetRenderState D3DRS_DESTBLEND, D3DBLEND_INVSRCALPHA
.SetTextureStageState 0, D3DTSS_ALPHAOP, D3DTOP_MODULATE
End If
.SetRenderState D3DRS_ALPHABLENDENABLE, 0 'False
.SetRenderState D3DRS_ZWRITEENABLE, 1 'True
.SetRenderState D3DRS_CLIPPLANEENABLE, 0 'FALSE
.SetRenderState D3DRS_ALPHABLENDENABLE, 1 '1 'True
.SetRenderState D3DRS_SRCBLEND, D3DBLEND_SRCALPHA
.SetRenderState D3DRS_DESTBLEND, D3DBLEND_INVSRCALPHA
.SetTextureStageState 0, D3DTSS_ALPHAOP, D3DTOP_MODULATE
' Draw ground
.SetTransform D3DTS_VIEW, m_matView
.SetTexture 0, m_GroundTexture
.SetVertexShader D3DFVF_COLORVERTEX
.SetStreamSource 0, m_GroundVB, Len(v)
.SetIndices m_GroundIB, 0
.DrawIndexedPrimitive D3DPT_TRIANGLELIST, _
0, m_NumGroundVertices, _
0, (m_NumGroundIndices / 3)
' Draw particles
.SetRenderState D3DRS_ALPHABLENDENABLE, 1 'True
.SetRenderState D3DRS_SRCBLEND, D3DBLEND_ONE
.SetRenderState D3DRS_DESTBLEND, D3DBLEND_ONE
.SetTextureStageState 0, D3DTSS_ALPHAOP, D3DTOP_SELECTARG1
.SetRenderState D3DRS_ZWRITEENABLE, 0 'False
.SetRenderState D3DRS_ZENABLE, 1 'TRUE
.SetTexture 0, m_ParticleTexture
.SetRenderState D3DRS_ZENABLE, 0 'False
.SetTexture 0, m_ParticleTexture
m_ParticleSystem.Render g_dev
.SetRenderState D3DRS_ALPHABLENDENABLE, 0 'False
.SetRenderState D3DRS_ZWRITEENABLE, 1 'True
.EndScene
End With
End Function
'-----------------------------------------------------------------------------
' Name: InitDeviceObjects()
' Desc: Initialize scene objects.
'-----------------------------------------------------------------------------
Function InitDeviceObjects() As Boolean
Dim i As Long
Dim v As CUSTOMVERTEX
Set m_GroundTexture = D3DUtil_CreateTexture(g_dev, "Ground2.bmp", D3DFMT_UNKNOWN)
Set m_ParticleTexture = D3DUtil_CreateTexture(g_dev, "Particle.bmp", D3DFMT_UNKNOWN)
' Check if we can do the reflection effect
m_bCanDoAlphaBlend = ((g_d3dCaps.SrcBlendCaps And D3DPBLENDCAPS_SRCALPHA) = D3DPBLENDCAPS_SRCALPHA) And _
((g_d3dCaps.DestBlendCaps And D3DPBLENDCAPS_INVSRCALPHA) = D3DPBLENDCAPS_INVSRCALPHA)
m_bCanDoClipPlanes = (g_d3dCaps.MaxUserClipPlanes >= 1)
' Note: all HW with Software Vertex Processing can do clipplanes
m_bCanDoClipPlanes = True
If (m_bCanDoAlphaBlend And m_bCanDoClipPlanes) Then m_bDrawReflection = True
' Create ground object
' Create vertex buffer for ground object
Set m_GroundVB = g_dev.CreateVertexBuffer(m_NumGroundVertices * Len(v), _
0, D3DFVF_COLORVERTEX, D3DPOOL_MANAGED)
' Fill vertex buffer
Dim zz As Long, xx As Long
ReDim m_grVerts(GROUND_GRIDSIZE * GROUND_GRIDSIZE * 6)
i = 0
For zz = 0 To GROUND_GRIDSIZE
For xx = 0 To GROUND_GRIDSIZE
m_grVerts(i).v.x = GROUND_WIDTH * ((xx / GROUND_GRIDSIZE) - 0.5)
m_grVerts(i).v.y = 0
m_grVerts(i).v.z = GROUND_HEIGHT * ((zz / GROUND_GRIDSIZE) - 0.5)
m_grVerts(i).color = GROUND_COLOR
m_grVerts(i).tu = xx * (GROUND_TILE / GROUND_GRIDSIZE)
m_grVerts(i).tv = zz * (GROUND_TILE / GROUND_GRIDSIZE)
i = i + 1
Next
Next
D3DVertexBuffer8SetData m_GroundVB, 0, Len(v) * (GROUND_GRIDSIZE + 1) * (GROUND_GRIDSIZE + 1), 0, m_grVerts(0)
Dim vtx As Long
Dim m_Indices() As Integer
ReDim m_Indices(m_NumGroundIndices * 4)
Dim z As Long, x As Long
' Create the index buffer
Set m_GroundIB = g_dev.CreateIndexBuffer(m_NumGroundIndices * 2, _
0, _
D3DFMT_INDEX16, D3DPOOL_MANAGED)
' Fill in indices
i = 0
For z = 0 To GROUND_GRIDSIZE - 1
For x = 0 To GROUND_GRIDSIZE - 1
vtx = x + z * (GROUND_GRIDSIZE + 1)
m_Indices(i) = vtx + 1: i = i + 1
m_Indices(i) = vtx + 0: i = i + 1
m_Indices(i) = vtx + 0 + (GROUND_GRIDSIZE + 1): i = i + 1
m_Indices(i) = vtx + 1: i = i + 1
m_Indices(i) = vtx + 0 + (GROUND_GRIDSIZE + 1): i = i + 1
m_Indices(i) = vtx + 1 + (GROUND_GRIDSIZE + 1): i = i + 1
Next
Next
D3DIndexBuffer8SetData m_GroundIB, 0, 2 * m_NumGroundIndices, 0, m_Indices(0)
' Initialize the particle system
m_ParticleSystem.InitDeviceObjects g_dev
InitDeviceObjects = True
End Function
'-----------------------------------------------------------------------------
' Name: VerifyDevice()
'-----------------------------------------------------------------------------
Function VerifyDevice(Behavior As Long, format As CONST_D3DFORMAT) As Boolean
' Make sure device can do ONE:ONE alphablending
If (0 = (g_d3dCaps.SrcBlendCaps And D3DPBLENDCAPS_ONE) = D3DPBLENDCAPS_ONE) Then Exit Function
If (0 = (g_d3dCaps.DestBlendCaps And D3DPBLENDCAPS_ONE) = D3DPBLENDCAPS_ONE) Then Exit Function
' We will run this app using software vertex processing
If (Behavior = D3DCREATE_HARDWARE_VERTEXPROCESSING) Then Exit Function
VerifyDevice = True
End Function
'-----------------------------------------------------------------------------
' Name: DeleteDeviceObjects()
' Desc: Called when the app is exitting, or the device is being changed,
' this function deletes any device dependant objects.
'-----------------------------------------------------------------------------
Sub DeleteDeviceObjects()
Set m_GroundTexture = Nothing
Set m_ParticleTexture = Nothing
Set m_GroundVB = Nothing
Set m_GroundIB = Nothing
If (m_ParticleSystem Is Nothing) Then Exit Sub
m_ParticleSystem.DeleteDeviceObjects
m_binit = False
End Sub
'-----------------------------------------------------------------------------
' Name: FinalCleanup()
' Desc: Called before the app exits, this function gives the app the chance
' to cleanup after itself.
'-----------------------------------------------------------------------------
Sub FinalCleanup()
Set m_GroundTexture = Nothing
Set m_ParticleTexture = Nothing
Set m_ParticleSystem = Nothing
End Sub
'-----------------------------------------------------------------------------
' Name: InvalidateDeviceObjects()
' Desc: Place code to release non managed objects here
'-----------------------------------------------------------------------------
Sub InvalidateDeviceObjects()
'all objects are managed in this sample
End Sub
'-----------------------------------------------------------------------------
' Name: RestoreDeviceObjects()
' Desc:
'-----------------------------------------------------------------------------
Sub RestoreDeviceObjects()
' Set the world matrix
Dim matWorld As D3DMATRIX
D3DXMatrixIdentity matWorld
g_dev.SetTransform D3DTS_WORLD, matWorld
' Set projection matrix
Dim matProj As D3DMATRIX
D3DXMatrixPerspectiveFovLH matProj, g_pi / 4, Me.ScaleHeight / Me.ScaleWidth, 0.1, 100
g_dev.SetTransform D3DTS_PROJECTION, matProj
' Set renderstates
With g_dev
Call .SetTextureStageState(0, D3DTSS_MINFILTER, D3DTEXF_LINEAR)
Call .SetTextureStageState(0, D3DTSS_MAGFILTER, D3DTEXF_LINEAR)
Call .SetTextureStageState(0, D3DTSS_MIPFILTER, D3DTEXF_LINEAR)
Call .SetTextureStageState(0, D3DTSS_COLOROP, D3DTOP_MODULATE)
Call .SetTextureStageState(0, D3DTSS_ALPHAOP, D3DTOP_SELECTARG1)
Call .SetTextureStageState(1, D3DTSS_COLOROP, D3DTOP_DISABLE)
Call .SetTextureStageState(1, D3DTSS_ALPHAOP, D3DTOP_DISABLE)
Call .SetRenderState(D3DRS_SRCBLEND, D3DBLEND_ONE)
Call .SetRenderState(D3DRS_DESTBLEND, D3DBLEND_ONE)
Call .SetRenderState(D3DRS_LIGHTING, 0) 'FALSE
Call .SetRenderState(D3DRS_CULLMODE, D3DCULL_CCW)
Call .SetRenderState(D3DRS_SHADEMODE, D3DSHADE_FLAT)
End With
End Sub

View File

@@ -0,0 +1,42 @@
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#stdole2.tlb#OLE Automation
Reference=*\G{E1211242-8E94-11D1-8808-00C04FC2C603}#1.0#0#dx8vb.dll#DirectX 8 for Visual Basic Type Library
Form=PointSprites.frm
Module=D3DUtil; ..\..\common\D3DUtil.bas
Class=CD3DMesh; ..\..\common\D3DMesh.cls
Class=CD3DFrame; ..\..\common\D3DFrame.cls
Class=CD3DAnimation; ..\..\common\D3DAnimation.cls
Class=CParticle; D3DParticle.cls
Module=MediaDir; ..\..\common\media.bas
Module=D3DInit; ..\..\common\D3DInit.bas
Form=..\..\common\SelectDevice.frm
Startup="Form1"
ExeName32="vb_PointSprites.exe"
Command32=""
Name="Project1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="Microsoft"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
[MS Transaction Server]
AutoRefresh=1

View File

@@ -0,0 +1,50 @@
//-----------------------------------------------------------------------------
// Name: PointSprites Direct3D Sample
//
// Copyright (C) 1999-2001 Microsoft Corporation. All rights reserved.
//-----------------------------------------------------------------------------
Description
===========
The PointSprites sample shows how to use the new Direct3D point sprites
feature. A point sprite is simply a forward-facing, textured quad that is
referenced only by (x,y,z) position coordinates. Point sprites are most
often used for particle systems and related effects.
Note that not all cards support all features for point sprites. For more
information on point sprites, refer to the DirectX SDK documentation.
Path
====
Source: DXSDK\Samples\Multimedia\VBSamples\Direct3D\PointSprites
Executable: DXSDK\Samples\Multimedia\VBSamples\Direct3D\Bin
User's Guide
============
The following keys are implemented.
<F2> Prompts user to select a new rendering device or display mode
<Alt+Enter> Toggles between fullscreen and windowed modes
<Esc> Exits the app.
Programming Notes
=================
Without Direct3D's support, point sprites can be implemented with four
vertices, that are oriented each frame towards the eyepoint (much like a
billboard). With Direct3D, though, you can refer to each point sprite by
just it's center position and a radius. This saves heavily on processor
computation time and on bandwidth uploading vertex information to the
graphics card.
In this sample, a particle system is implemented using point sprites. Each
particle is actually implemented using multiple alpha-blended point sprites,
giving the particle a motion-blur effect.
This sample makes use of common DirectX code (consisting of helper functions,
etc.) that is shared with other samples on the DirectX SDK. All common
classes and modules can be found in the following directory:
DXSDK\Samples\VBSamples\Multimedia\Common