Attribute VB_Name = "modDX"
'-------------------------------------------------------------------------------------
'
'  Project: Shooter
'  Date:    24/04/03
'  File:    modDX
'
'  Description
'   The Direct X Initialisation, Draw, Sound, and Input Code is in here
'   This routine also contains the main loop inside DX_Init which jumps to modMain
'-------------------------------------------------------------------------------------
Option Explicit

'This sets the screens display and the cooperative levels
Sub DX_SetDisplayCoopLevel(hdl As Long, sWidth As Long, sHeight As Long, sBPP As Long)
    'This one is for the Direct Sound
    Call dsMain.SetCooperativeLevel(hdl, DSSCL_PRIORITY)
    'This one is for Direct Draw
    Call ddMain.SetCooperativeLevel(hdl, DDSCL_FULLSCREEN Or DDSCL_EXCLUSIVE Or DDSCL_ALLOWMODEX)
    'This sets the display mode
    Call ddMain.SetDisplayMode(sWidth, sHeight, sBPP, 0, DDSDM_DEFAULT)
End Sub

'This restores everything to normal when the Program is exited
Sub DX_RestoreDisplayCoopLevel(hdl As Long)
    'This sets the Direct Sound Cooperative Level to normal
    Call dsMain.SetCooperativeLevel(hdl, DSSCL_NORMAL)
    'This sets the Direct Draw Cooperative Level to normal
    Call ddMain.SetCooperativeLevel(hdl, DDSCL_NORMAL)
    'This restores the users default Display Mode

    Call ddMain.RestoreDisplayMode
End Sub

'This is where everything comes together
Sub DX_Init()
    Dim hwCaps As DDCAPS
    Dim helCaps As DDCAPS

    'This tells the loop below that it is running
    Running = True

    On Error Resume Next
    'This creates the Direct Draw object
    Set ddMain = dxMain.DirectDrawCreate("")
    'This creates the Direct Sound object
    Set dsMain = dxMain.DirectSoundCreate("")
    
    'This call should set up the direct input for us...
    Set ddInput = dxMain.DirectInputCreate()
    Call CreateInput(frmMain.hWnd)
    
    'This calls the sub from above that sets the Display and the Cooperative Levels
    Call DX_SetDisplayCoopLevel(frmMain.hWnd, SCREEN_WIDTH, SCREEN_HEIGHT, SCREEN_BITDEPTH)
    'This calls a sub from modDD that creates the Primary Surface and the Backbuffer
    DD_CreatePrimBackBuf

    'This calls a sub from modDD that Creates Graphics from their Files
    DD_CreateGraphicsFromFile
    'This calls a sub from modDS that Creates Sounds from their Files
    DS_CreateSoundsFromFile

    'This calls a sub from modDS that Starts the Sound file and tells whether
    'it should be looped or not
    'Call DS_PlaySound(False)
        
    'Check for Gamma Ramp Support
    ddMain.GetCaps hwCaps, helCaps
    If (hwCaps.lCaps2 And DDCAPS2_PRIMARYGAMMA) = 0 Then
        MsgBox "Your system does not have Gamma Ramp Support", vbOKOnly, "No Gamma Support"
        End
    End If
    'Make a new gamma controler
    Set GammaControl = PrimBuf.GetDirectDrawGammaControl
    'Fill out the original gamma ramps
    GammaControl.GetGammaRamp DDSGR_DEFAULT, OriginalRamp
    
    'Set our initial colour values to zero
    nGammaRed = 0
    nGammaBlue = 0
    nGammaGreen = 0

End Sub

'This ends the app
Sub DX_EndIt()
    'This calls a sub from above that sets everything to normal
    Call DX_RestoreDisplayCoopLevel(frmMain.hWnd)
    DestroyInput
    DestroySound
    DestroyDraw
    Set dxMain = Nothing

End Sub
'This creates the Primary Surface and The Backbuffer
Sub DD_CreatePrimBackBuf()
    Dim ClipRect(1) As RECT
    With ClipRect(0)
        .Top = 0
        .Left = 0
        .Right = 800
        .Bottom = 600
    End With
    With ClipRect(1)
        .Top = 0
        .Left = 0
        .Right = 800
        .Bottom = 600
    End With

    'These are used to make the primary surface
    PrimBufDesc.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
    PrimBufDesc.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
    'This backbuffer count can be changed to 2 for triple buffering
    PrimBufDesc.lBackBufferCount = 1
    Set PrimBuf = ddMain.CreateSurface(PrimBufDesc)
    'Set Clipper = ddMain.CreateClipper(0)
    'Call Clipper.SetClipList(1, ClipRect())
    'Call PrimBuf.SetClipper(Clipper)
    
    'These are used to make the backbuffer
    Caps.lCaps = DDSCAPS_BACKBUFFER
    Set BackBuf = PrimBuf.GetAttachedSurface(Caps)
    Call BackBuf.GetSurfaceDesc(PrimBufDesc)
    'Call BackBuf.SetClipper(Clipper)
    If PrimBufDesc.ddpfPixelFormat.lGBitMask = &H3E0 Then
        VideoMode = 555
    Else
        VideoMode = 565
    End If
    PrimBuf.GetPixelFormat PixelFormat
    MaskToShiftValues PixelFormat.lRBitMask, RedShiftRight, RedShiftLeft
    MaskToShiftValues PixelFormat.lGBitMask, GreenShiftRight, GreenShiftLeft
    MaskToShiftValues PixelFormat.lBBitMask, BlueShiftRight, BlueShiftLeft

    'This sets the Fore color of the text at the top of the form
    Call BackBuf.SetForeColor(RGB(150, 0, 0))
    'Call BackBuf.SetFontBackColor(vbWhite)
    'This sets the font to be transparent.
    Call BackBuf.SetFontTransparency(True)

End Sub
Sub SetText(cColour As Long)
    Call BackBuf.SetForeColor(cColour)
End Sub
'Blits a rectangle from a surface to the backbuffer
Sub DD_BltFast(rTop As Long, rLeft As Long, rRight As Long, rBot As Long, Surface As DirectDrawSurface7, srcRect As RECT, destX As Long, destY As Long, Transparency As Long)
    Dim destRect    As RECT
    Dim nWidth      As Long
    Dim nHeight     As Long

    'this is used for the image sizing process
    srcRect.Top = rTop
    srcRect.Left = rLeft
    srcRect.Right = rRight
    srcRect.Bottom = rBot

    Select Case Transparency
        Case DX_BLIT
            'blit it with no transparency
            Call BackBuf.BltFast(destX, destY, Surface, srcRect, DDBLTFAST_DONOTWAIT)
        Case DX_BLITTRANS
            'blit it with transparency
            Call BackBuf.BltFast(destX, destY, Surface, srcRect, DDBLTFAST_DONOTWAIT Or DDBLTFAST_SRCCOLORKEY)
        Case DX_BLITCLIPTRANS
            'blit it with transparency and clipping
            If destX < 0 Then
                destRect.Left = 0
                srcRect.Left = srcRect.Left - destX
            Else
                destRect.Left = destX
            End If
            If destY < 0 Then
                destRect.Top = 0
                srcRect.Top = srcRect.Top - destY
            Else
                destRect.Top = destY
            End If
            nWidth = rRight - rLeft
            nHeight = rBot - rTop
            If destX + nWidth > 800 Then
                destRect.Right = 800
                srcRect.Right = srcRect.Left + 800 - destX
            Else
                destRect.Right = destX + nWidth
            End If
            If destY + nHeight > 600 Then
                destRect.Bottom = 600
                srcRect.Bottom = srcRect.Top + 600 - destY
            Else
                destRect.Bottom = destY + nHeight
            End If
            Call BackBuf.Blt(destRect, Surface, srcRect, DDBLT_DONOTWAIT Or DDBLT_KEYSRC)
        Case 3  'Alpha Channel Stuff?
            'Call BackBuf.BltFx(destRect, Surface, srcRect, DDBLTFAST_DONOTWAIT Or DDBLTFAST_SRCCOLORKEY, Null)
    End Select

End Sub

'This creates the surfaces from their files
Sub DD_CreateSurfFromFile(FileName As String, Surface As DirectDrawSurface7, SurfDesc As DDSURFACEDESC2, Width As Long, Height As Long)

    'This is part of the creation process
    SurfDesc.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
    'This sets the surfaces description to an off screen plain
    SurfDesc.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
    'This sets the height of the surfaces description
    SurfDesc.lHeight = Height
    'This sets the width of the surfaces description
    SurfDesc.lWidth = Width

    'This sets the surface to the file with the above settings
    Set Surface = ddMain.CreateSurfaceFromFile(FileName, SurfDesc)

    'These are used for transparency during the blitting process
    Dim ColorKey As DDCOLORKEY
    'the transparent color will be black
    ColorKey.high = COLOUR_KEY
    ColorKey.low = COLOUR_KEY
    'This sets the surfaces color key to the color keys above
    Call Surface.SetColorKey(DDCKEY_SRCBLT, ColorKey)

End Sub

'This sub basically calls the above sub for easier transportation to the main initialization
'This makes it easier because I have multiple files I want in the application
Sub DD_CreateGraphicsFromFile()
    Call DD_CreateSurfFromFile(App.Path & "\Data\BG.bmp", BGSurf, BackBufDesc, SCREEN_WIDTH, SCREEN_HEIGHT)
    Call DD_CreateSurfFromFile(App.Path & "\Data\Title.bmp", TitleSurf, BackBufDesc, SCREEN_WIDTH, SCREEN_HEIGHT)
    Call DD_CreateSurfFromFile(App.Path & "\Data\Text.bmp", TextSurf, BackBufDesc, SCREEN_WIDTH, SCREEN_HEIGHT)
    Call DD_CreateSurfFromFile(App.Path & "\Data\Sprite004.bmp", Sprite4Surf, BackBufDesc, 640, 480)
    Call DD_CreateSurfFromFile(App.Path & "\Data\Sprite008.bmp", Sprite8Surf, BackBufDesc, 640, 480)
    Call DD_CreateSurfFromFile(App.Path & "\Data\Sprite016.bmp", Sprite16Surf, BackBufDesc, 640, 480)
    Call DD_CreateSurfFromFile(App.Path & "\Data\Sprite032.bmp", Sprite32Surf, BackBufDesc, 640, 480)
    Call DD_CreateSurfFromFile(App.Path & "\Data\Sprite064.bmp", Sprite64Surf, BackBufDesc, 640, 480)
    Call DD_CreateSurfFromFile(App.Path & "\Data\Sprite128.bmp", Sprite128Surf, BackBufDesc, 640, SPRITE127HEIGHT)
    Call DD_CreateSurfFromFile(App.Path & "\Data\Tile.bmp", TileSurf, BackBufDesc, 640, 480)
    Call DD_CreateSurfFromFile(App.Path & "\Data\Explosion.bmp", ExpSurf, BackBufDesc, 640, 480)
    
'Flash Graphics
    Call DD_CreateSurfFromFile(App.Path & "\Data\Sprite032.bmp", Sprite32SurfFlash, BackBufDesc, 640, 480)
    Call DD_CreateSurfFromFile(App.Path & "\Data\Sprite064.bmp", Sprite64SurfFlash, BackBufDesc, 640, 480)
    Call DD_CreateSurfFromFile(App.Path & "\Data\Sprite128.bmp", Sprite128SurfFlash, BackBufDesc, 640, SPRITE127HEIGHT)
    Call CreateFlash(32)
    Call CreateFlash(64)
    Call CreateFlash(128)
End Sub
'Tidy up all the surfaces and things used by DirectX - ddMain should be last
Sub DestroyDraw()

    Set PrimBuf = Nothing
    Set BackBuf = Nothing
    Set BGSurf = Nothing
    Set TitleSurf = Nothing
    Set TextSurf = Nothing
    Set Sprite4Surf = Nothing
    Set Sprite8Surf = Nothing
    Set Sprite16Surf = Nothing
    Set Sprite32Surf = Nothing
    Set Sprite32SurfFlash = Nothing
    Set Sprite64Surf = Nothing
    Set Sprite64SurfFlash = Nothing
    Set Sprite128Surf = Nothing
    Set Sprite128SurfFlash = Nothing
    Set TileSurf = Nothing
    Set ExpSurf = Nothing
    Set ddMain = Nothing
    
End Sub

Sub CreateInput(hdl As Long)

    'Check that we have set the ddInput up correctly
    'if ddinput is nothing then goto InitFailed
    
    'Get a pointer to the keyboard and mouse device objects
    Set Keyboard = ddInput.CreateDevice("GUID_SysKeyboard")
    'if keyboard is nothing then goto initfailed
    Set Mouse = ddInput.CreateDevice("guid_SysMouse")
    'if mouse is nothing then goto initfailed
    
    'Set the data formats to the commonly used keyboard and mouse
    Keyboard.SetCommonDataFormat DIFORMAT_KEYBOARD
    Mouse.SetCommonDataFormat DIFORMAT_MOUSE
    
    'Set the cooperative level
    Keyboard.SetCooperativeLevel hdl, DISCL_NONEXCLUSIVE Or DISCL_BACKGROUND
    Mouse.SetCooperativeLevel hdl, DISCL_EXCLUSIVE Or DISCL_FOREGROUND
    
    Keyboard.Acquire
    Mouse.Acquire
End Sub
Sub DestroyInput()
    Keyboard.Unacquire
    Mouse.Unacquire
    Set Keyboard = Nothing
    Set Mouse = Nothing
    Set ddInput = Nothing
End Sub
Sub MouseRefresh()
'Used to Refresh the mouse variables
    On Local Error Resume Next
'Get the current state of the mouse
    Mouse.GetDeviceStateMouse MouseState
    Return
    'If this fails then try to reaquire
    If Err.Number <> 0 Then Mouse.Acquire
    'If this also fails then exit subroutine
    If Err.Number <> 0 Then Exit Sub
    MousePosX = MousePosX + MouseState.x
    If MousePosX < 0 Then MousePosX = 0
    If MousePosX > SCREEN_WIDTH Then MousePosX = SCREEN_WIDTH
    MousePosY = MousePosY + MouseState.y
    If MousePosY < 0 Then MousePosY = 0
    If MousePosY > SCREEN_HEIGHT Then MousePosY = SCREEN_HEIGHT
    If MouseState.buttons(0) = 0 Then
        MouseBut = False
    Else
        MouseBut = True
    End If
    
'    Call DD_BltFast(0, 0, 50, 41, SpriteSurf, rSpriteSurf, MousePosX, MousePosY, DX_BLITTRANS)
    Exit Sub
ErrOut:
    MsgBox "Unable to acquire mouse input exclusively."
End Sub


'This is the sub that plays the sound
Sub DS_PlaySound(nSound As Long, Looping As Boolean)
    'If looping is set to true
    If Looping = True Then
        'rewind the sound to the beginning
        Call DBuffer.SetCurrentPosition(0)
        'play the sound and loop it
        Call DBuffer.Play(DSBPLAY_LOOPING)
    'If looping is set to false
    Else
        Select Case nSound
            Case SND_LASER
                'rewind the sound to the beginning
                Call DSoundLaser.SetCurrentPosition(0)
                'play the sound and don't loop it
                Call DSoundLaser.Play(DSBPLAY_DEFAULT)
            Case SND_GEM
                'rewind the sound to the beginning
                Call DSoundGem.SetCurrentPosition(0)
                'play the sound and don't loop it
                Call DSoundGem.Play(DSBPLAY_DEFAULT)
            Case SND_POWER
                'rewind the sound to the beginning
                Call DSoundPower.SetCurrentPosition(0)
                'play the sound and don't loop it
                Call DSoundPower.Play(DSBPLAY_DEFAULT)
            Case SND_EXPLODE
                'rewind the sound to the beginning
                Call DSoundExplode.SetCurrentPosition(0)
                'play the sound and don't loop it
                Call DSoundExplode.Play(DSBPLAY_DEFAULT)
        End Select
    End If
End Sub

'This creates a sound buffer from a file
Sub DS_CreateSoundBufFromFile()
    'this sets the buffer to the file you want in the program
    Set DSoundLaser = dsMain.CreateSoundBufferFromFile(App.Path & "\Data\LASER.WAV", DBufferDesc, WavFormat)
    Set DSoundGem = dsMain.CreateSoundBufferFromFile(App.Path & "\Data\HAMMER.WAV", DBufferDesc, WavFormat)
    Set DSoundPower = dsMain.CreateSoundBufferFromFile(App.Path & "\Data\CHIMES.WAV", DBufferDesc, WavFormat)
    Set DSoundExplode = dsMain.CreateSoundBufferFromFile(App.Path & "\Data\EXPLODE.WAV", DBufferDesc, WavFormat)
    Set DSoundBigExplode = dsMain.CreateSoundBufferFromFile(App.Path & "\Data\BPLODE.WAV", DBufferDesc, WavFormat)
End Sub

'This sub basically calls the above sub for easier transportation to the main initialization
'This would make it easier if you had multiple sound files you wanted in the application
Sub DS_CreateSoundsFromFile()
    Call DS_CreateSoundBufFromFile
End Sub
Sub DestroySound()
    Set DBuffer = Nothing
    Set dsMain = Nothing
End Sub

Sub FPS()
'Count the Frames Per Second
    If fpsTimer + 1000 <= dxMain.TickCount Then
        fpsTimer = dxMain.TickCount
        fpsCount = fpscounter + 1
        fpscounter = 0
    Else
        fpscounter = fpscounter + 1
    End If
    
    'Display FPS
    Call BackBuf.DrawText(0, 0, "FPS:" & fpsCount, False)

End Sub
Function ExModeActive() As Boolean
'This is used to text if we're still in the DirectX mode...
    Dim TestCoopRes As Long
    
    TestCoopRes = ddMain.TestCooperativeLevel
    If TestCoopRes = DD_OK Then
        ExModeActive = True
    Else
        ExModeActive = False
    End If
End Function

Sub SetGamma(nRed As Integer, nGreen As Integer, nBlue As Integer)

Dim i As Integer

    'Alter the gamma ramp to the percent given by comparing to original state
    'A value of zero ("0") for nRed, nGreen, or nBlue will result in the
    'gamma level being set back to the original levels. Anything ABOVE zero will
    'fade towards FULL colour, anything below zero will fade towards NO colour
    For i = 0 To 255
        If nRed < 0 Then GammaRamp.Red(i) = ConvToSignedValue(ConvToUnSignedValue(OriginalRamp.Red(i)) * (100 - Abs(nRed)) / 100)
        If nRed = 0 Then GammaRamp.Red(i) = OriginalRamp.Red(i)
        If nRed > 0 Then GammaRamp.Red(i) = ConvToSignedValue(65535 - ((65535 - ConvToUnSignedValue(OriginalRamp.Red(i))) * (100 - nRed) / 100))
        If nGreen < 0 Then GammaRamp.Green(i) = ConvToSignedValue(ConvToUnSignedValue(OriginalRamp.Green(i)) * (100 - Abs(nGreen)) / 100)
        If nGreen = 0 Then GammaRamp.Green(i) = OriginalRamp.Green(i)
        If nGreen > 0 Then GammaRamp.Green(i) = ConvToSignedValue(65535 - ((65535 - ConvToUnSignedValue(OriginalRamp.Green(i))) * (100 - nGreen) / 100))
        If nBlue < 0 Then GammaRamp.Blue(i) = ConvToSignedValue(ConvToUnSignedValue(OriginalRamp.Blue(i)) * (100 - Abs(nBlue)) / 100)
        If nBlue = 0 Then GammaRamp.Blue(i) = OriginalRamp.Blue(i)
        If nBlue > 0 Then GammaRamp.Blue(i) = ConvToSignedValue(65535 - ((65535 - ConvToUnSignedValue(OriginalRamp.Blue(i))) * (100 - nBlue) / 100))
    Next
    GammaControl.SetGammaRamp DDSGR_DEFAULT, GammaRamp

End Sub

Sub CreateFlash(nSurface As Long)
'This routine goes through a 640x480 surface pixel by pixel change all that are not black
' to red!
'Slow bad method of getting a sprite to flash
    Dim rLock   As RECT
    Dim ddsdLock As DDSURFACEDESC2
    Dim xLoop   As Long
    Dim yLoop   As Long
    Dim Colour  As Long
    
    rLock.Right = 640
    rLock.Bottom = 480
    Colour = CreateRGB(CLng(255), CLng(0), CLng(0))

'Lock the surface so that we can access it...
    Select Case nSurface
        Case 32
            Sprite32SurfFlash.Lock rLock, ddsdLock, DDLOCK_WAIT, 0
        Case 64
            Sprite64SurfFlash.Lock rLock, ddsdLock, DDLOCK_WAIT, 0
        Case 128
            rLock.Bottom = SPRITE127HEIGHT
            Sprite128SurfFlash.Lock rLock, ddsdLock, DDLOCK_WAIT, 0
    End Select
    
'Scan through every pixel on the surface
    For xLoop = 0 To rLock.Right
        For yLoop = 0 To rLock.Bottom
        
            Select Case nSurface
                Case 32
                    If (Sprite32SurfFlash.GetLockedPixel(xLoop, yLoop) > COLOUR_KEY) Then
                        Sprite32SurfFlash.SetLockedPixel xLoop, yLoop, Colour
                    End If
                Case 64
                    If (Sprite64SurfFlash.GetLockedPixel(xLoop, yLoop) > COLOUR_KEY) Then
                        Sprite64SurfFlash.SetLockedPixel xLoop, yLoop, Colour
                    End If
                Case 128
                    If (Sprite128SurfFlash.GetLockedPixel(xLoop, yLoop) > COLOUR_KEY) Then
                        Sprite128SurfFlash.SetLockedPixel xLoop, yLoop, Colour
                    End If
            End Select
            
        Next yLoop
    Next xLoop

'All work is now done, unlock the surface
    Select Case nSurface
        Case 32
            Sprite32SurfFlash.Unlock rLock
        Case 64
            Sprite64SurfFlash.Unlock rLock
        Case 128
            Sprite128SurfFlash.Unlock rLock
    End Select

End Sub
Function CreateRGB(Red As Long, Green As Long, Blue As Long) As Long
    CreateRGB = (Red \ RedShiftRight) * RedShiftLeft + (Green \ GreenShiftRight) * GreenShiftLeft + (Blue \ BlueShiftRight) * BlueShiftLeft
End Function
Private Sub MaskToShiftValues(ByVal Mask As Long, ShiftRight As Long, ShiftLeft As Long)
    Dim ZeroBitCount    As Long
    Dim OneBitCount     As Long
    ' Count zero bits
    ZeroBitCount = 0
    Do While (Mask And 1) = 0
        ZeroBitCount = ZeroBitCount + 1
        Mask = Mask \ 2 ' Shift right
    Loop
    ' Count one bits
    OneBitCount = 0
    Do While (Mask And 1) = 1
        OneBitCount = OneBitCount + 1
        Mask = Mask \ 2 ' Shift right
    Loop
    ' Shift right 8-OneBitCount bits
    ShiftRight = 2 ^ (8 - OneBitCount)
    ' Shift left ZeroBitCount bits
    ShiftLeft = 2 ^ ZeroBitCount
End Sub

