Action игра на basic

Option Explicit
 
Dim dx      As DirectX8                     ' Объект DirectX8
Dim dxs     As DirectSound8                 ' Объект DirectSound
Dim dl      As DirectSound3DListener8       ' Слушатель
Dim dp      As DirectSoundPrimaryBuffer8    ' Первичный буфер
Dim ds()    As DirectSoundSecondaryBuffer8  ' Вторичные буфера
Dim db()    As DirectSound3DBuffer8         ' 3D буфера
Dim dev     As Direct3DDevice8              ' Для визуализации ...
Dim d3d     As Direct3D8                    ' ...
Dim d3msh   As D3DXMesh                     ' ...
Dim d3pln   As D3DXMesh                     ' ...
 
Private Const CountSources = 3      ' Количество источников звука
 
' // Отключение/включение звука
Private Sub chkSound_Click(Index As Integer)
    ' Если стоит галочка, то
    If chkSound(Index).Value = vbChecked Then
        ' Проигрываем звук с зацикливанием по кругу
        ds(Index).Play DSBPLAY_LOOPING
    Else
        ' Иначе останавливаем
        ds(Index).Stop
    End If
    
End Sub
 
' // Процедура обрабтки нажатий клавиш
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim curPos  As D3DVECTOR    ' Текущая позиция слушателя
    Dim curOrt  As D3DVECTOR    ' Текущий вектор ориентации
    Dim curTop  As D3DVECTOR    ' Текущий вектор "макушки" слушателя
    Dim curLft  As D3DVECTOR    ' Вектор влево относительно ориентации слушателя
    
    ' Получаем позицию слушателя
    dl.GetPosition curPos
    ' Получаем ориентацию и направление вверх
    dl.GetOrientation curOrt, curTop
    ' С помощью векторного произведения находим препендикуляр к этим двум векторам, т.е. вектор влево
    D3DXVec3Cross curLft, curOrt, curTop
    
    ' Если нажата Shift/Ctrl
    If Shift Then
        ' Уменьшаем размер в 10 раз
        D3DXVec3Scale curOrt, curOrt, 0.1   ' вектора ориентации
        D3DXVec3Scale curLft, curLft, 0.1   ' вектора влево
        
    End If
    
    ' Получение кода нажатой клавиши
    Select Case KeyCode
    Case vbKeyW, vbKeyUp
        ' Вперед. Прибавляем к текущим координатам вектор ориентации
        D3DXVec3Add curPos, curPos, curOrt
    Case vbKeyA, vbKeyLeft
        ' Влево. Прибавляем к текущим координатам вектор влево
        D3DXVec3Add curPos, curPos, curLft
    Case vbKeyD, vbKeyRight
        ' Вправо. Вычитаем из текущих координат вектор влево
        D3DXVec3Subtract curPos, curPos, curLft
    Case vbKeyS, vbKeyDown
        ' Назад. Вычитаем из текущих координат ориентацию
        D3DXVec3Subtract curPos, curPos, curOrt
    End Select
    
    ' Устанавливаем измененную позицию
    dl.SetPosition curPos.X, curPos.Y, curPos.z, DS3D_IMMEDIATE
    ' Визуализация
    Render
    
End Sub
 
' // Процедура загрузки формы
Private Sub Form_Load()
    ' Создаем объект DirectX8
    Set dx = New DirectX8
    ' Создаем объект DirectSound
    Set dxs = dx.DirectSoundCreate(vbNullString)
    ' Настраиваем совместный доступ
    dxs.SetCooperativeLevel Me.hWnd, DSSCL_NORMAL
    ' Описатель буфера
    Dim bd  As DSBUFFERDESC
    ' Это первичный буфер и возможность контролировать положение и ориентацию в пространстве
    bd.lFlags = DSBCAPS_PRIMARYBUFFER Or DSBCAPS_CTRL3D
    ' Создаем первичный буфер
    Set dp = dxs.CreatePrimarySoundBuffer(bd)
    ' Получаем объект слушателя
    Set dl = dp.GetDirectSound3DListener()
    ' Для других буферов возможность контролировать положение и ориентацию в пространстве
    bd.lFlags = DSBCAPS_CTRL3D
    ' Задаем ориентацию вперед
    dl.SetOrientation 0, 0, 1, 0, 1, 0, DS3D_DEFERRED
    
    Dim i   As Long     ' Временная переменная
    Dim fil As Boolean  ' В IDE - загрузка из файла, в EXE из ресурсов
    
    ReDim ds(CountSources - 1)  ' Массив вторичных буферов (источников)
    ReDim db(CountSources - 1)  ' Массив 3D буферов
    
    Randomize
    
    For i = 0 To CountSources - 1
        
        Debug.Assert InIDE(fil)
        
        ' Загружаем из файла или из ресурса в зависимости от режима работы
        If fil Then
            Set ds(i) = dxs.CreateSoundBufferFromFile(Choose(i + 1, "Sound.wav", "Moto.wav", "Police.wav"), bd)
        Else
            Set ds(i) = dxs.CreateSoundBufferFromResource(App.EXEName & ".exe", Choose(i + 1, "#101", "#102", "#103"), bd)
        End If
        ' Получаем объект 3D буфера
        Set db(i) = ds(i).GetDirectSound3DBuffer()
        ' Задаем рандомную позицию
        db(i).SetPosition Rnd * 50 - 25, Rnd * 50, Rnd * 50 - 25, DS3D_DEFERRED
        ' Включаем воспроизведение
        ds(i).Play DSBPLAY_LOOPING
        
    Next
    ' Запуск просчета изменений
    dl.CommitDeferredSettings
    
    ' Для визуализации (не комментирую)
    ' //----//----//----//----//----//
    Dim pp  As D3DPRESENT_PARAMETERS
    Dim dm  As D3DDISPLAYMODE
    
    Set d3d = dx.Direct3DCreate()
    
    d3d.GetAdapterDisplayMode D3DADAPTER_DEFAULT, dm
    
    pp.BackBufferFormat = dm.Format
    pp.Windowed = 1
    pp.SwapEffect = D3DSWAPEFFECT_DISCARD
    pp.EnableAutoDepthStencil = 1
    pp.AutoDepthStencilFormat = D3DFMT_D16
    
    Set dev = d3d.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, pic.hWnd, D3DCREATE_HARDWARE_VERTEXPROCESSING, pp)
    
    Dim mtx As D3DMATRIX
    
    D3DXMatrixPerspectiveFovLH mtx, 3.14 / 180 * 80, pic.ScaleHeight / pic.ScaleWidth, 0.1, 200
    dev.SetTransform D3DTS_PROJECTION, mtx
    
    dev.SetRenderState D3DRS_ZENABLE, D3DZB_TRUE
    dev.SetRenderState D3DRS_LIGHTING, 1
    
    Dim d3      As D3DX8
    Dim dat()   As Byte
    
    Set d3 = New D3DX8
    Set d3msh = d3.CreateSphere(dev, 1, 16, 8, Nothing)
    Set d3pln = d3.CreatePolygon(dev, 100, 4, Nothing)
    
    Dim lth As D3DLIGHT8
    Dim mat As D3DMATERIAL8
    
    lth.Type = D3DLIGHT_POINT
    lth.diffuse = col(1, 1, 1)
    lth.Position = vec3(0, 100, -100)
    lth.Attenuation1 = 0.01
    lth.Range = 400
    
    dev.SetLight 0, lth
    dev.LightEnable 0, 1
    
    mat.diffuse = col(1, 1, 1)
    dev.SetMaterial mat
    ' //----//----//----//----//----//
    
End Sub
 
' // Визуализация
Private Sub Render()
    Dim idx As Long
    Dim v1  As D3DVECTOR
    Dim v2  As D3DVECTOR
    Dim v3  As D3DVECTOR
    Dim mtx As D3DMATRIX
    
    dev.Clear 0, ByVal 0, D3DCLEAR_ZBUFFER Or D3DCLEAR_TARGET, &HAFFFFF, 1, 0
 
    dev.BeginScene
 
    dev.SetVertexShader d3msh.GetFVF
    
    dl.GetPosition v1:      dl.GetOrientation v2, v3
    D3DXVec3Add v2, v1, v2
    D3DXMatrixLookAtLH mtx, v1, v2, v3
    dev.SetTransform D3DTS_VIEW, mtx
    
    D3DXMatrixTranslation mtx, 0, -3, 0
    dev.SetTransform D3DTS_WORLD, mtx
    D3DXMatrixRotationX mtx, -3.14 / 2
    dev.MultiplyTransform D3DTS_WORLD, mtx
    
    d3pln.DrawSubset 0
    
    For idx = 0 To CountSources - 1
        
        db(idx).GetPosition v1
        D3DXMatrixTranslation mtx, v1.X, v1.Y, v1.z
        dev.SetTransform D3DTS_WORLD, mtx
        d3msh.DrawSubset 0
        
    Next
    
    dev.EndScene
    
    dev.Present ByVal 0, ByVal 0, 0, ByVal 0
    
End Sub
 
' // Функция сздания векторов
Private Function vec3(ByVal X As Single, ByVal Y As Single, ByVal z As Single) As D3DVECTOR
    vec3.X = X: vec3.Y = Y: vec3.z = z
End Function
 
' // Функция создания цветов
Private Function col(r As Single, g As Single, b As Single) As D3DCOLORVALUE
    col.r = r
    col.g = g
    col.b = b
    col.a = 1
End Function
 
' // Процедура выгрузки формы
Private Sub Form_Unload(Cancel As Integer)
    Dim i   As Long
    ' Проход по всем буферам
    For i = 0 To CountSources - 1
        ' Остановка
        ds(i).Stop
        ' Удаление и очистка
        Set ds(i) = Nothing
        Set db(i) = Nothing
        
    Next
    
    Set dl = Nothing
    Set dp = Nothing
    
    Set dxs = Nothing
    Set dx = Nothing
    
End Sub
 
' // Процедура обработки мыши
Private Sub pic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Static ox  As Single, oy As Single
    Dim mtx As D3DMATRIX
    Dim qt1 As D3DQUATERNION
    Dim qt2 As D3DQUATERNION
    Dim v1  As D3DVECTOR
    Dim v2  As D3DVECTOR
    Dim v3  As D3DVECTOR
 
    ' При движении с зажатой левой кнопкой изменяем ориентацию
    If Button = vbLeftButton Then
            
        dl.GetOrientation v1, v2
        D3DXVec3Cross v3, v1, v2
        
        D3DXQuaternionRotationAxis qt1, v2, (X - ox) / 50
        D3DXQuaternionRotationAxis qt2, v3, -(Y - oy) / 50
        D3DXQuaternionMultiply qt1, qt1, qt2
        D3DXMatrixRotationQuaternion mtx, qt1
        
        D3DXVec3TransformCoord v1, v1, mtx
        D3DXVec3TransformCoord v2, v2, mtx
        dl.SetOrientation v1.X, v1.Y, v1.z, v2.X, v2.Y, v2.z, DS3D_IMMEDIATE
        
        Render
    ' При правой кнопке - наклон (направление вверх)
    ElseIf Button = vbRightButton Then
    
        dl.GetOrientation v1, v2
        
        D3DXQuaternionRotationAxis qt1, v1, (X - ox) / 50
        D3DXMatrixRotationQuaternion mtx, qt1
        
        D3DXVec3TransformCoord v1, v1, mtx
        D3DXVec3TransformCoord v2, v2, mtx
        dl.SetOrientation v1.X, v1.Y, v1.z, v2.X, v2.Y, v2.z, DS3D_IMMEDIATE
        
        Render
        
    End If
    
    ox = X: oy = Y
    
End Sub
 
Private Sub pic_Paint()
    Render
End Sub
 
Private Function InIDE(z As Boolean) As Boolean
    z = True: InIDE = z
End Function